diff --git a/Makefile b/Makefile index fb2f88236..ccd177289 100644 --- a/Makefile +++ b/Makefile @@ -24,8 +24,7 @@ include $(ROOT_DIR)/makefiles/c_backend.mk test tests quick_test test_one \ calc_dir info_c calc_o dgfip_c_backend compile_dgfip_c_backend \ backend_tests test_dgfip_c_backend \ - clean_backend clean_backend_c clean_backend_exe clean_backend_tmp clean_backend_res clean_backend_all \ - test_java_backend + clean_backend clean_backend_c clean_backend_exe clean_backend_tmp clean_backend_res clean_backend_all FORCE: @@ -33,19 +32,10 @@ FORCE: default: FORCE build -test_java_backend: FORCE build - @echo "\033[0;31mWarning: Java backend not supported\033[0m" -#ifeq ($(OPTIMIZE), 0) -# @echo "\033[0;31mWarning, non-optimized Java files cannot be executed for now (too many constants for the JVM)\033[0m" -#else -#endif -# $(MAKE) -C examples/java/ run_tests - -all: FORCE quick_test tests test_dgfip_c_backend test_java_backend +all: FORCE quick_test tests test_dgfip_c_backend clean: FORCE $(call make_in,$(DGFIP_DIR),clean_backend_all) -# $(MAKE) -C examples/java clean rm -f doc/doc.html dune clean diff --git a/README.md b/README.md index 713419d11..197ca7426 100644 --- a/README.md +++ b/README.md @@ -74,26 +74,6 @@ The interpreter and the C backend in `examples/dgfip_c/` should be usable straig as the C compiler was installed for Opam. Mlang results are tested on GCC and Clang, the latter being preferred if available. -The Java backend in `examples/java/` requires Java development environment. -The generated code targets Java 7, and could be used with OpenJDK 1.7 or more. -However, the test harness code requires Java 8, so to use the automated backend tests, we ask for -OpenJDK 1.8 or more. - -For Debian-based distributions, you can try: - - sudo apt install default-jdk - -For Red Hat-based distributions, depending on your version: - - sudo yum install java-1.8.0-openjdk-devel - -or - - sudo yum install java-11-openjdk-devel - -NB : if you are using JDK 1.8, in order to cross-compile the generated code to 1.7, you would also need JDK 1.7 -installed in order to provide the correct version of the base classes. - ## Usage Mlang also need an M file to know how to run the "liquidations multiples" @@ -131,8 +111,7 @@ their internal tooling. The `--run_test` and `--run_all_tests` options ease the testing process of the interpreter (with or without optimizations) and report test errors in a convenient format. -Mlang backends are also tested using the same `FIP` format, see for instance -`examples/java/backend_test`. +Mlang backends are also tested using the same `FIP` format. When running `--run_all_tests`, you can enable code coverage instrumentation with the `--code_coverage` option. Another interesting option is `--precision`, diff --git a/UpdateMlangDeps.sh b/UpdateMlangDeps.sh deleted file mode 100755 index 9d2e534c9..000000000 --- a/UpdateMlangDeps.sh +++ /dev/null @@ -1,20 +0,0 @@ -#!/usr/bin/env bash - -set -e -x - -cd $(dirname $(readlink -f $0)) - -echo Mise à jour des fichiers issus du dépôt mlang-deps - -mkdir -p mlang-deps - -cd mlang-deps - -git clone --branch master https://forge.dgfip.finances.rie.gouv.fr/dgfip/si-1e/firsth/ir/calculette/mlang-deps - -rm -fr mlang-deps/.git - -cp -fr mlang-deps/* ./ - -rm -fr mlang-deps - diff --git a/examples/README.md b/examples/README.md index b13b9e345..90e4f35f1 100644 --- a/examples/README.md +++ b/examples/README.md @@ -10,9 +10,7 @@ code. To know more about using a particular Mlang backend, please read the dedicated `README.md` inside the correct folder: -* [C](c/README.md) -* [Java](java/README.md) -* [Python](python/README.md) +* [C](dgfip_c/README.md) ### Configuring the generated file diff --git a/examples/dgfip_c/ml_primitif/ml_driver/common.ml b/examples/dgfip_c/ml_primitif/ml_driver/common.ml index 9208c9fa0..0717303c3 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/common.ml +++ b/examples/dgfip_c/ml_primitif/ml_driver/common.ml @@ -15,13 +15,6 @@ type type_ = Reel | Booleen | Date type domaine = Indefini | Contexte | Famille | Revenu | RevenuCorr | Variation | Penalite -external init_errs : unit -> unit = "ml_init_errs" -external get_err_list : unit -> string list = "ml_get_err_list" -external free_errs : unit -> unit = "ml_free_errs" - -let get_errs () = - List.fold_left (fun res e -> StrSet.add e res) StrSet.empty (get_err_list ()) - module Var = struct type t = { @@ -301,3 +294,11 @@ module TGV = struct ) var_list end + +external init_errs : TGV.t -> unit = "ml_init_errs" +external get_err_list : TGV.t -> string list = "ml_get_err_list" +external free_errs : TGV.t -> unit = "ml_free_errs" + +let get_errs tgv = + List.fold_left (fun res e -> StrSet.add e res) StrSet.empty (get_err_list tgv) + diff --git a/examples/dgfip_c/ml_primitif/ml_driver/irdata.c b/examples/dgfip_c/ml_primitif/ml_driver/irdata.c index ece4ebfc0..2631daf89 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/irdata.c +++ b/examples/dgfip_c/ml_primitif/ml_driver/irdata.c @@ -32,13 +32,18 @@ T_irdata * IRDATA_new_irdata(void) if ((irdata = (T_irdata *)malloc(sizeof(T_irdata))) == NULL) { return NULL; } -#ifndef FLG_COMPACT irdata->saisie = NULL; - irdata->def_saisie = NULL; irdata->calculee = NULL; - irdata->def_calculee = NULL; irdata->base = NULL; + irdata->tmps = NULL; + irdata->ref = NULL; + irdata->def_saisie = NULL; + irdata->def_calculee = NULL; irdata->def_base = NULL; + irdata->def_tmps = NULL; + irdata->def_ref = NULL; + irdata->info_tmps = NULL; + irdata->info_ref = NULL; if (alloc_tab(&irdata->saisie, &irdata->def_saisie, TAILLE_SAISIE) == FALSE) { IRDATA_delete_irdata(irdata); return NULL; @@ -51,14 +56,46 @@ T_irdata * IRDATA_new_irdata(void) IRDATA_delete_irdata(irdata); return NULL; } -#ifdef FLG_MULTITHREAD + if (alloc_tab(&irdata->tmps, &irdata->def_tmps, TAILLE_TMP_VARS) == FALSE) { + IRDATA_delete_irdata(irdata); + return NULL; + } + irdata->ref = (double **)malloc(TAILLE_REFS * (sizeof (double *))); + if (irdata->ref == NULL) { + IRDATA_delete_irdata(irdata); + return NULL; + } + irdata->def_ref = (char **)malloc(TAILLE_REFS * (sizeof (char *))); + if (irdata->def_ref == NULL) { + IRDATA_delete_irdata(irdata); + return NULL; + } + irdata->info_tmps = (T_varinfo *)malloc(TAILLE_TMP_VARS * (sizeof (T_varinfo))); + if (irdata->info_tmps == NULL) { + IRDATA_delete_irdata(irdata); + return NULL; + } + irdata->info_ref = (T_varinfo **)malloc(TAILLE_REFS * (sizeof (T_varinfo *))); + if (irdata->info_ref == NULL) { + IRDATA_delete_irdata(irdata); + return NULL; + } + irdata->tmps_org = 0; + irdata->ref_org = 0; irdata->discords = NULL; irdata->tas_discord = NULL; irdata->p_discord = &irdata->discords; - irdata->nb_bloquantes = 0; - irdata->max_bloquantes = 0; -#endif /* FLG_MULTITHREAD */ -#endif /* !FLG_COMPACT */ + irdata->nb_bloqs = 0; + irdata->max_bloqs = 4; + irdata->sz_err_finalise = 0; + irdata->err_finalise = NULL; + irdata->nb_err_finalise = 0; + irdata->sz_err_sortie = 0; + irdata->err_sortie = NULL; + irdata->nb_err_sortie = 0; + irdata->sz_err_archive = 0; + irdata->err_archive = NULL; + irdata->nb_err_archive = 0; irdata->ctx_pr_out.indent = 0; irdata->ctx_pr_out.is_newline = 1; irdata->ctx_pr_err.indent = 0; @@ -70,22 +107,24 @@ T_irdata * IRDATA_new_irdata(void) void IRDATA_delete_irdata(T_irdata *irdata) { if (irdata != NULL) { -#ifndef FLG_COMPACT if (irdata->saisie != NULL) free(irdata->saisie); if (irdata->calculee != NULL) free(irdata->calculee); if (irdata->base != NULL) free(irdata->base); + if (irdata->tmps != NULL) free(irdata->tmps); + if (irdata->ref != NULL) free(irdata->ref); if (irdata->def_saisie != NULL) free(irdata->def_saisie); if (irdata->def_calculee != NULL) free(irdata->def_calculee); if (irdata->def_base != NULL) free(irdata->def_base); -#endif /* FLG_COMPACT */ -#ifdef FLG_MULTITHREAD + if (irdata->def_tmps != NULL) free(irdata->def_tmps); + if (irdata->def_ref != NULL) free(irdata->def_ref); + if (irdata->info_tmps != NULL) free(irdata->info_tmps); + if (irdata->info_ref != NULL) free(irdata->info_ref); IRDATA_reset_erreur(irdata); while (irdata->tas_discord != NULL) { *(irdata->p_discord) = irdata->tas_discord; irdata->tas_discord = (irdata->tas_discord)->suivant; free(*irdata->p_discord); } -#endif /* FLG_MULTITHREAD */ free(irdata); } } @@ -98,25 +137,15 @@ static void reset_tab(double *p_double, char *p_char, int nb) void IRDATA_reset_irdata(T_irdata *irdata) { -#ifdef FLG_COMPACT - reset_tab(irdata->valeurs, irdata->defs, TAILLE_TOTALE); -#else reset_tab(irdata->saisie, irdata->def_saisie, TAILLE_SAISIE); reset_tab(irdata->calculee, irdata->def_calculee, TAILLE_CALCULEE); reset_tab(irdata->base, irdata->def_base, TAILLE_BASE); -#endif /* FLG_COMPACT */ -#ifdef FLG_MULTITHREAD IRDATA_reset_erreur(irdata); -#endif /* FLG_MULTITHREAD */ } void IRDATA_reset_base(T_irdata *irdata) { -#ifdef FLG_COMPACT - reset_tab(irdata->valeurs + TAILLE_SAISIE + TAILLE_CALCULEE, irdata->defs + TAILLE_SAISIE + TAILLE_CALCULEE, TAILLE_BASE); -#else reset_tab(irdata->base, irdata->def_base, TAILLE_BASE); -#endif /* FLG_COMPACT */ } void IRDATA_reset_light(irdata) @@ -128,11 +157,7 @@ reset_tab(irdata->calculee, irdata->def_calculee, TAILLE_CALCULEE) ; void IRDATA_reset_calculee(T_irdata *irdata) { -#ifdef FLG_COMPACT - reset_tab(irdata->valeurs + TAILLE_SAISIE, irdata->defs + TAILLE_SAISIE, TAILLE_CALCULEE); -#else reset_tab(irdata->calculee, irdata->def_calculee, TAILLE_CALCULEE); -#endif /* FLG_COMPACT */ } void IRDATA_recopie_irdata(irdata_src, irdata_dst) @@ -149,23 +174,16 @@ memcpy(irdata_dst->def_base, irdata_src->def_base, TAILLE_BASE) ; void IRDATA_reset_erreur(T_irdata *irdata) { -#ifdef FLG_MULTITHREAD *irdata->p_discord = irdata->tas_discord; irdata->tas_discord = irdata->discords; irdata->discords = 0; irdata->p_discord = &irdata->discords; - irdata->nb_bloquantes = 0; -#endif /* FLG_MULTITHREAD */ + irdata->nb_bloqs = 0; } void IRDATA_range_base(T_irdata *irdata, T_var_irdata p_desc, double valeur) { T_desc_var *desc = (T_desc_var *)p_desc; -#ifdef FLG_COMPACT - int indice = desc->indice; - irdata->defs[indice] = 1; - irdata->valeurs[indice] = valeur; -#else int indice = desc->indice & INDICE_VAL; switch (desc->indice & EST_MASQUE) { case EST_SAISIE: @@ -181,25 +199,18 @@ void IRDATA_range_base(T_irdata *irdata, T_var_irdata p_desc, double valeur) irdata->base[indice] = valeur; break; } -#endif /* FLG_COMPACT */ } void IRDATA_efface(T_irdata *irdata, T_var_irdata p_desc) { T_desc_var *desc = (T_desc_var *)p_desc; int indice = 0; -#ifdef FLG_COMPACT - indice = desc->indice; - irdata->valeurs[indice] = 0; - irdata->defs[indice] = 0; -#else indice = desc->indice & INDICE_VAL; if ((desc->indice & EST_MASQUE) != EST_SAISIE) { return; } irdata->saisie[indice] = 0; irdata->def_saisie[indice] = 0; -#endif /* FLG_COMPACT */ return; } @@ -207,10 +218,6 @@ double * IRDATA_extrait_special(T_irdata *irdata, T_var_irdata p_desc) { T_desc_var *desc = (T_desc_var *)p_desc; double *res = NULL; -#ifdef FLG_COMPACT - int indice = desc->indice; - res = (irdata->defs[indice] == 0) ? NULL : &irdata->valeurs[indice]; -#else int indice = desc->indice & INDICE_VAL; switch (desc->indice & EST_MASQUE) { case EST_SAISIE: @@ -226,7 +233,6 @@ double * IRDATA_extrait_special(T_irdata *irdata, T_var_irdata p_desc) res = NULL; break; } -#endif /* FLG_COMPACT */ return res; } @@ -234,10 +240,6 @@ double * IRDATA_extrait_tableau(T_irdata *irdata, T_var_irdata p_desc, int ind) { T_desc_var *desc = (T_desc_var *)p_desc; double *res = NULL; -#ifdef FLG_COMPACT - int indice = desc->indice + ind; - res = (irdata->defs[indice] == 0) ? NULL : &irdata->valeurs[indice]; -#else int indice = (desc->indice & INDICE_VAL) + ind; switch (desc->indice & EST_MASQUE) { case EST_SAISIE: @@ -253,22 +255,11 @@ double * IRDATA_extrait_tableau(T_irdata *irdata, T_var_irdata p_desc, int ind) res = NULL; break; } -#endif /* FLG_COMPACT */ return res; } /* Gestion des erreurs */ -int sz_err_finalise = 0; -char **err_finalise = NULL; -int nb_err_finalise = 0; -int sz_err_sortie = 0; -char **err_sortie = NULL; -int nb_err_sortie = 0; -int sz_err_archive = 0; -char **err_archive = NULL; -int nb_err_archive = 0; - /* * # ajouter_espace(sz, tab, nb) # * @@ -297,7 +288,6 @@ void ajouter_espace(int *sz, char ***tab, int nb) { void finalise_erreur(irdata) T_irdata *irdata; { -#ifdef FLG_MULTITHREAD int i = 0; int trouve = 0; T_discord *pDisco = irdata->discords; @@ -312,55 +302,23 @@ T_irdata *irdata; if (! trouve) { ajouter_espace(&irdata->sz_err_archive, &irdata->err_archive, irdata->nb_err_archive); irdata->err_archive[irdata->nb_err_archive] = pDisco->erreur->nom; - nb_err_archive++; + irdata->nb_err_archive++; ajouter_espace(&irdata->sz_err_finalise, &irdata->err_finalise, irdata->nb_err_finalise); irdata->err_finalise[irdata->nb_err_finalise] = pDisco->erreur->nom; - nb_err_finalise++; + irdata->nb_err_finalise++; } pDisco = pDisco->suivant; } -#else - int i = 0; - int trouve = 0; - T_discord *pDisco = discords; - nb_err_finalise = 0; - while (pDisco != NULL) { - trouve = 0; - for (i = 0; i < nb_err_archive && ! trouve; i++) { - if (strcmp(pDisco->erreur->nom, err_archive[i]) == 0) { - trouve = 1; - } - } - if (! trouve) { - ajouter_espace(&sz_err_archive, &err_archive, nb_err_archive); - err_archive[nb_err_archive] = pDisco->erreur->nom; - nb_err_archive++; - ajouter_espace(&sz_err_finalise, &err_finalise, nb_err_finalise); - err_finalise[nb_err_finalise] = pDisco->erreur->nom; - nb_err_finalise++; - } - pDisco = pDisco->suivant; - } -#endif /* FLG_MULTITHREAD */ } void exporte_erreur(irdata) T_irdata *irdata; { -#ifdef FLG_MULTITHREAD int i; for (i = 0; i < irdata->sz_err_finalise && irdata->err_finalise[i] != NULL; i++) { ajouter_espace(&irdata->sz_err_sortie, &irdata->err_sortie, irdata->nb_err_sortie); irdata->err_sortie[irdata->nb_err_sortie] = irdata->err_finalise[i]; irdata->nb_err_sortie++; } -#else - int i; - for (i = 0; i < sz_err_finalise && err_finalise[i] != NULL; i++) { - ajouter_espace(&sz_err_sortie, &err_sortie, nb_err_sortie); - err_sortie[nb_err_sortie] = err_finalise[i]; - nb_err_sortie++; - } -#endif /* FLG_MULTITHREAD */ } diff --git a/examples/dgfip_c/ml_primitif/ml_driver/main.ml b/examples/dgfip_c/ml_primitif/ml_driver/main.ml index 89e86ad28..46340d4b0 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/main.ml +++ b/examples/dgfip_c/ml_primitif/ml_driver/main.ml @@ -154,13 +154,13 @@ let run_test test_file annee_exec flag_no_bin_compare = TGV.set_int tgv "IND_TRAIT" 4 (* = primitif *); TGV.set_int tgv "ANCSDED" annee_exec; (* instead of execution date *) - init_errs (); + init_errs tgv; let err = M.enchainement_primitif tgv in M.export_errs tgv; M.dump_raw_tgv_in out tgv err; - let res_ok = check_result tgv (get_errs ()) res_prim ctl_prim in - + let res_ok = check_result tgv (get_errs tgv) res_prim ctl_prim in + free_errs tgv; match flag_no_bin_compare with | true -> if res_ok then 0 else 1 | false -> @@ -225,11 +225,8 @@ let main () = let () = Printexc.record_backtrace true; try - let res = main () in - free_errs (); - exit res + exit (main ()) with e -> Printf.eprintf "%s\n" (Printexc.to_string e); Printexc.print_backtrace stderr; - free_errs (); exit 30 diff --git a/examples/dgfip_c/ml_primitif/ml_driver/stubs.c b/examples/dgfip_c/ml_primitif/ml_driver/stubs.c index ff717ad47..5b249194e 100644 --- a/examples/dgfip_c/ml_primitif/ml_driver/stubs.c +++ b/examples/dgfip_c/ml_primitif/ml_driver/stubs.c @@ -612,22 +612,23 @@ cherche_var( } CAMLprim value -ml_init_errs(value unit) +ml_init_errs(value mlTgv) { - CAMLparam1(unit); - for (int i = 0; i < sz_err_finalise; i++) { - err_finalise[i] = NULL; + CAMLparam1(mlTgv); + T_irdata *tgv = Tgv_val(mlTgv); + for (int i = 0; i < tgv->sz_err_finalise; i++) { + tgv->err_finalise[i] = NULL; } - nb_err_finalise = 0; - for (int i = 0; i < sz_err_sortie; i++) { - err_sortie[i] = NULL; + tgv->nb_err_finalise = 0; + for (int i = 0; i < tgv->sz_err_sortie; i++) { + tgv->err_sortie[i] = NULL; } - nb_err_sortie = 0; - for (int i = 0; i < sz_err_archive; i++) { - err_archive[i] = NULL; + tgv->nb_err_sortie = 0; + for (int i = 0; i < tgv->sz_err_archive; i++) { + tgv->err_archive[i] = NULL; } - nb_err_archive = 0; - CAMLreturn(unit); + tgv->nb_err_archive = 0; + CAMLreturn(Val_unit); } CAMLprim value @@ -640,14 +641,15 @@ ml_export_errs(value mlTgv) } CAMLprim value -ml_get_err_list(value unit) +ml_get_err_list(value mlTgv) { - CAMLparam1(unit); + CAMLparam1(mlTgv); CAMLlocal2(res, cons); res = Val_emptylist; - for (int i = 0; i < nb_err_sortie; ++i) { + T_irdata *tgv = Tgv_val(mlTgv); + for (int i = 0; i < tgv->nb_err_sortie; ++i) { cons = caml_alloc_small(2, Tag_cons); - Field(cons, 0) = caml_copy_string(err_sortie[i]); + Field(cons, 0) = caml_copy_string(tgv->err_sortie[i]); Field(cons, 1) = res; res = cons; } @@ -655,19 +657,20 @@ ml_get_err_list(value unit) } CAMLprim value -ml_free_errs(value unit) +ml_free_errs(value mlTgv) { - CAMLparam1(unit); - if (err_finalise != NULL) { - free(err_finalise); + CAMLparam1(mlTgv); + T_irdata *tgv = Tgv_val(mlTgv); + if (tgv->err_finalise != NULL) { + free(tgv->err_finalise); } - if (err_sortie != NULL) { - free(err_sortie); + if (tgv->err_sortie != NULL) { + free(tgv->err_sortie); } - if (err_archive != NULL) { - free(err_archive); + if (tgv->err_archive != NULL) { + free(tgv->err_archive); } - CAMLreturn(unit); + CAMLreturn(Val_unit); } CAMLprim value diff --git a/examples/java/.gitignore b/examples/java/.gitignore deleted file mode 100644 index be24f4f56..000000000 --- a/examples/java/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -Ir_*.java -*.class \ No newline at end of file diff --git a/examples/java/Makefile b/examples/java/Makefile deleted file mode 100644 index 5251029f6..000000000 --- a/examples/java/Makefile +++ /dev/null @@ -1,68 +0,0 @@ -ifeq ($(MAKELEVEL), 0) - include ../../Makefile.include -endif - -MLANG_JAVA_OPTS=\ - --mpp_file=$(MPP_FILE) \ - --mpp_function=$(MPP_FUNCTION) - -MLANG=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(MLANG_JAVA_OPTS) - -# Check Java compiler version : -# - if < 8 : backend won't compile due to TestHarness, period. -# - if = 8 : calculator code prefers JRE 7 base class rt.jar to be compiled targetting Java 7, so we try to find it. -# - if > 8 : calculator code is cross-compiled to Java 7, test code is cross-compiled to Java 8. -JAVAC8=$(shell javac -version 2>&1|grep -q "javac 1.8"; printf $$?) -ifeq ($(JAVAC8),0) - # Default path is debian-based OpenJDK 7 package path, overridable by environment variables. - JAVA7_PATH?=/usr/lib/jvm/java-7-openjdk-amd64 - # if path exists, use it as bootclasspath - ifeq (test -d $(JAVA7_PATH),0) - BOOTCLASSPATH=-bootclasspath $(JAVA7_PATH)/jre/lib/rt.jar - # Otherwise we default to empty bootclasspath, meaning javac will use its own version of base class (JRE 8). - else - $(warning Warning: Java 7 path not found) - endif - # JDK 8 specific cross-compilation option: -source and optional -bootclasspath. -target defaults to the value of -source - JAVACOPT_CALC=-source 7 $(BOOTCLASSPATH) - JAVACOPT_TEST= -else - # JDK9+ cross-compilation options. From version 9, reference base classes for older JRE are provided. - JAVACOPT_CALC=--release 7 - JAVACOPT_TEST=--release 8 -endif - -.DEFAULT_GOAL := backend_tests/target/TestHarness.class - -clean: - rm -f src/com/mlang/Ir_*.java target/com/mlang/*.class backend_tests/target/com/mlang/*.class - -################################################## -# Generating and running Java files from Mlang -################################################## - -.PRECIOUS: src/com/mlang/Ir_%.java -src/com/mlang/Ir_%.java: ../../m_specs/%.m_spec - $(MLANG) \ - --backend java --output $@ \ - --function_spec $^ \ - $(SOURCE_FILES) \ - $(SOURCE_EXT_FILES) - -target: - mkdir -p $@ - -backend_tests/target: - mkdir -p $@ - -target/com/mlang/Ir_%.class: src/com/mlang/Ir_%.java | target -ifeq ($(JAVAC8),0) - @echo "Cross-compiling Java 7 sources with JDK 8, using JAVA7_PATH=$(JAVA7_PATH) if present. Feel free to override it." -endif - javac -J-Xss10m -J-Xmx4096m $(JAVACOPT_CALC) -d target -cp src src/com/mlang/*.java - -backend_tests/target/TestHarness.class: target/com/mlang/Ir_tests_2020.class | backend_tests/target - javac $(JAVACOPT_TEST) -cp "backend_tests/src/:target" -d backend_tests/target backend_tests/src/com/mlang/TestHarness.java - -run_tests: backend_tests/target/TestHarness.class - java -cp "target:backend_tests/target" com.mlang.TestHarness $(TESTS_DIR) diff --git a/examples/java/README.md b/examples/java/README.md deleted file mode 100644 index 58f379a85..000000000 --- a/examples/java/README.md +++ /dev/null @@ -1,79 +0,0 @@ -## Using Mlang with Java - -Mlang is able to compile the official source code of the French income tax -computation to Java. You can use these files in your Java application to calculate tax. -This file is a guide on this file usage. - -**Warning:** Mlang produces Java code for `JDK 7` and above, older -versions of Java are not supported. - -### Generating the Java file - -You have to invoke Mlang for that, with something like: - -``` -mlang --display_time --debug \ # Prints debug information - --mpp_file=path/to/mlang/.mpp \ # is the year when the income was received - --mpp_function=compute_double_liquidation_pvro \ # this function is the one computing the taxes - --optimize \ # optimize the output, otherwise the generated file is very large - --backend java --output .java \ # outputs a Java file - --function_spec .m_spec \ # configuration (see above) - -``` - -### Using the generated Java file - -The generated Java file provides one method, `calculateTax`, taking as an -argument a `Map` whose keys are the input variables declared in the `.m_spec` -file. The method is overloaded with a version that also takes an `int` representing the max number -of anomalies before the program exits. By default, the program will exit on the first anomaly. - -The function returns a `Map` of the output variables. -Caution: The elements of this `Map` may be undefined, in which their propery `undefined` is set to true. - -### Helper Java classes - -- `MValue`: Represents a variable used during calculation, either as input, output or an intermediate value. -Contains a `value` and a boolean `undefined`. - -- `MCalculation`: Internal class that carries the state of calculation during it's lifetime. - -- `MError`: Represents an anomaly of any level that may occur during tax calculation. - -- `MException`: Exception class, thrown if the max number of top level anomalies has been reached. -This class includes a list of all the anomalies that occurred up until that point. - -- `MOutput`: Final return value of a calculation if `MException` was not thrown, contains an `outputValues` -field of `Map` with the key being the name of the variable. It also contains -a `calculationVariables` field of `List` containing the anomalies that occurred during calculation. - -- `MValue`: Base calculation variable type that has two properties : `value` and `undefined` - -Please see Javadoc in classes for more information - -### Using the Makefile in this folder - -The Makefile in this folder contains rules for generating Java files from -`.m_specs` in the `m_specs/` folder of this repository, using the 2020 code from -`ir_calcul` and the canonical `.mpp` file for 2020 income tax. To use it, -simply invoke: - - make src/com/mlang/Ir_.java - -`make` will re-generate this file at each modification of the `.m_spec` file, -otherwise use `-B` to force re-generation. - -If you have an error about unknown variables, then it probably means the -example you're trying to build depends on a different year of the tax code. -To get it working, invoke the command by setting the year to another year: - - YEAR= make ir_.java - -### Testing the correctness of the Mlang backend - -The `backend_tests` folder contains a small utility that compares the output -of running the Java against the expected output for a test base. - -To launch the tests, simply invoke from this folder: - - make run_tests diff --git a/examples/java/backend_tests/src/com/mlang/TestHarness.java b/examples/java/backend_tests/src/com/mlang/TestHarness.java deleted file mode 100644 index 33ceca26c..000000000 --- a/examples/java/backend_tests/src/com/mlang/TestHarness.java +++ /dev/null @@ -1,275 +0,0 @@ -/* Copyright (C) 2021 Inria, contributor: James Barnes - - 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 . */ - -package com.mlang; - -import java.io.IOException; -import java.nio.file.Files; -import java.nio.file.Path; -import java.nio.file.Paths; -import java.util.ArrayList; -import java.util.HashMap; -import java.util.List; -import java.util.Map; -import java.util.Map.Entry; -import java.util.stream.Collectors; -import java.util.stream.IntStream; - -public class TestHarness { - - private static final String SEPERATOR = "/"; - - public static void main(String[] args) throws Exception { - - if (args.length != 1) { - System.err.println("Expected one command-line argument, the tests directory"); - return; - } - - String testDirString = args[0]; - - Path testsDir = Paths.get(testDirString); - - System.out.println(testsDir); - - if (!Files.exists(testsDir) || !Files.isDirectory(testsDir)) { - System.err.println("Tests directory does not exist or is not a directory"); - return; - } - - Map> errorTestMap = new HashMap<>(); - - runTests(testsDir, errorTestMap); - } - - private static void runTests(Path testsDir, Map> errorTestMap) { - try { - List testsData = Files.list(testsDir).map(TestHarness::parseTest).collect(Collectors.toList()); - analyzeTestResults(testsData); - } catch (IOException ex) { - System.err.println(ex.getMessage()); - return; - } - } - - private static void analyzeTestResults(List testsData) { - Map> errorTestMap = findTestErrors(testsData); - displayTestErrorsExit(errorTestMap); - } - - private static void displayTestErrorsExit(Map> errorTestMap) { - if (!errorTestMap.isEmpty()) { - for (Entry> entry : errorTestMap.entrySet()) { - System.err.println("Error with test " + entry.getKey()); - for (String error : entry.getValue()) { - System.err.println(error); - } - } - System.exit(-1); - } - } - - private static Map> findTestErrors(List testsData) { - Map> errorTestMap = new HashMap<>(); - for (TestData test : testsData) { - Map realOutputs = Ir_tests_2020.calculateTax(test.getInputVariables()).getOutputValues(); - List errorsWithVars = extractTestErrorsFromData(test, realOutputs); - - if (!errorsWithVars.isEmpty()) { - errorTestMap.put(test.getTestName(), errorsWithVars); - } - } - return errorTestMap; - } - - private static List extractTestErrorsFromData(TestData test, Map realOutputs) { - List errorsWithVars = new ArrayList<>(); - test.getExceptedVariables().forEach((name, value) -> { - if (!(realOutputs.get(name).getValue() == value.getValue())) { - errorsWithVars.add("Code " + name + ", expected: " + value + ", got: " + realOutputs.get(name)); - } - }); - return errorsWithVars; - } - - private static TestData parseTest(Path test) { - TestData td = new TestData(test.toString()); - - System.out.println("Test case : " + test); - try { - List lines = Files.readAllLines(test); - - TestPosition tp = new TestPosition(); - - IntStream.range(0, lines.size()).forEach(pos -> { - String line = lines.get(pos); - switch (line) { - case "#ENTREES-PRIMITIF": - tp.setEntreesPrimitif(pos); - break; - case "#CONTROLES-PRIMITIF": - tp.setControlesPrimitif(pos); - break; - case "#RESULTATS-PRIMITIF": - tp.setResultatsPrimtifs(pos); - break; - case "#ENTREES-CORRECTIF": - tp.setEntreesCorrectif(pos); - break; - case "#CONTROLES-CORRECTIF": - tp.setControlesCorrectif(pos); - break; - case "#RESULTATS-CORRECTIF": - tp.setResultatsCorrectifs(pos); - break; - } - }); - - lines.subList(tp.getEntreesPrimitif() + 1, tp.getControlesPrimitif()).stream().forEach(variableLine -> { - addInputVariableToTestData(variableLine, td); - }); - - lines.subList(tp.getResultatsPrimtifs() + 1, tp.getEntreesCorrectif()).stream().forEach(variableLine -> { - addExpectedVariableToTestData(variableLine, td); - }); - - } catch (IOException | NumberFormatException e) { - e.printStackTrace(); - } - - return td; - } - - private static void addInputVariableToTestData(String variableLine, TestData td) { - Variable var = createVariable(variableLine); - td.addInputVariable(var.getCode(), new MValue(var.getValue(), false)); - } - - private static void addExpectedVariableToTestData(String variableLine, TestData td) { - Variable var = createVariable(variableLine); - td.addExpectedVariable(var.getCode(), new MValue(var.getValue(), false)); - } - - private static Variable createVariable(String variableLine) { - String[] variableLineArray = variableLine.split(SEPERATOR); - String code = variableLineArray[0]; - double value = Double.parseDouble(variableLineArray[1]); - return new Variable(code, value); - } -} - -class TestData { - private final String testName; - private final Map inputVariables = new HashMap<>(); - private final Map expectedVariables = new HashMap<>(); - - public TestData(String name) { - this.testName = name; - } - - public void addInputVariable(String code, MValue value) { - inputVariables.put(code, value); - } - - public void addExpectedVariable(String code, MValue value) { - expectedVariables.put(code, value); - } - - public Map getInputVariables() { - return inputVariables; - } - - public Map getExceptedVariables() { - return expectedVariables; - } - - public String getTestName() { - return this.testName; - } -} - -class Variable { - private final String code; - private final double value; - - public Variable(String code, double value) { - this.code = code; - this.value = value; - } - - public String getCode() { - return code; - } - - public double getValue() { - return value; - } -} - -class TestPosition { - private int entreesPrimitif; - private int controlesPrimitif; - private int resultatsPrimtifs; - - private int entreesCorrectif; - private int controlesCorrectif; - private int resultatsCorrectifs; - - public int getEntreesPrimitif() { - return entreesPrimitif; - } - - public void setEntreesPrimitif(int entreesPrimitif) { - this.entreesPrimitif = entreesPrimitif; - } - - public int getControlesPrimitif() { - return controlesPrimitif; - } - - public void setControlesPrimitif(int controlesPrimitif) { - this.controlesPrimitif = controlesPrimitif; - } - - public int getResultatsPrimtifs() { - return resultatsPrimtifs; - } - - public void setResultatsPrimtifs(int resultatsPrimtifs) { - this.resultatsPrimtifs = resultatsPrimtifs; - } - - public int getEntreesCorrectif() { - return entreesCorrectif; - } - - public void setEntreesCorrectif(int entreesCorrectif) { - this.entreesCorrectif = entreesCorrectif; - } - - public int getControlesCorrectif() { - return controlesCorrectif; - } - - public void setControlesCorrectif(int controlesCorrectif) { - this.controlesCorrectif = controlesCorrectif; - } - - public int getResultatsCorrectifs() { - return resultatsCorrectifs; - } - - public void setResultatsCorrectifs(int resultatsCorrectifs) { - this.resultatsCorrectifs = resultatsCorrectifs; - } -} diff --git a/examples/java/src/com/mlang/MCalculation.java b/examples/java/src/com/mlang/MCalculation.java deleted file mode 100644 index 8111dc11d..000000000 --- a/examples/java/src/com/mlang/MCalculation.java +++ /dev/null @@ -1,58 +0,0 @@ -/* Copyright (C) 2021 Inria, contributor: James Barnes - - 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 . */ - -package com.mlang; - -import java.util.HashMap; -import java.util.List; -import java.util.Map; - -class MCalculation { - - private final MValue[] calculationVariables; - private final MValue[] localVariables; - private final Map> tableVariables = new HashMap<>(); - private final int maxAnomalies; - private int currentAnomalies = 0; - - MCalculation(MValue[] calculationVariables, MValue[] localVariables, int maxAnomalies) { - this.calculationVariables = calculationVariables; - this.maxAnomalies = maxAnomalies; - this.localVariables = localVariables; - } - - MValue[] getCalculationVariables() { - return calculationVariables; - } - - MValue[] getLocalVariables() { - return localVariables; - } - - Map> getTableVariables() { - return tableVariables; - } - - int getMaxAnomalies() { - return maxAnomalies; - } - - int getCurrentAnomalies() { - return currentAnomalies; - } - - void setCurrentAnomalies(int currentAnomalies) { - this.currentAnomalies = currentAnomalies; - } - -} diff --git a/examples/java/src/com/mlang/MError.java b/examples/java/src/com/mlang/MError.java deleted file mode 100644 index 395a274bc..000000000 --- a/examples/java/src/com/mlang/MError.java +++ /dev/null @@ -1,58 +0,0 @@ -/* Copyright (C) 2021 Inria, contributor: James Barnes - - 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 . */ - -package com.mlang; - -public class MError { - - private final String name; - private final String kind; - private final String majorCode; - private final String minorCode; - private final String description; - private final String alias; - - MError(String name, String kind, String majorCode, String minorCode, String description, String alias) { - this.name = name; - this.kind = kind; - this.majorCode = majorCode; - this.minorCode = minorCode; - this.description = description; - this.alias = alias; - } - - public String getName() { - return name; - } - - public String getKind() { - return kind; - } - - public String getMajorCode() { - return majorCode; - } - - public String getMinorCode() { - return minorCode; - } - - public String getDescription() { - return description; - } - - public String getAlias() { - return alias; - } - -} diff --git a/examples/java/src/com/mlang/MException.java b/examples/java/src/com/mlang/MException.java deleted file mode 100644 index 5171b2719..000000000 --- a/examples/java/src/com/mlang/MException.java +++ /dev/null @@ -1,31 +0,0 @@ -/* Copyright (C) 2021 Inria, contributor: James Barnes - - 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 . */ - -package com.mlang; - -import java.util.List; - -public class MException extends RuntimeException { - - private final List calculationErrors; - private static final String MESSAGE = "Max number of anomalies occurred before end of calculation"; - - MException(List calculationErrors){ - super(MESSAGE); - this.calculationErrors = calculationErrors; - } - - public List getCalculationErrors() { - return calculationErrors; - } -} diff --git a/examples/java/src/com/mlang/MOutput.java b/examples/java/src/com/mlang/MOutput.java deleted file mode 100644 index 363df1f98..000000000 --- a/examples/java/src/com/mlang/MOutput.java +++ /dev/null @@ -1,37 +0,0 @@ -/* Copyright (C) 2021 Inria, contributor: James Barnes - - 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 . */ - -package com.mlang; - -import java.util.List; -import java.util.Map; - -public class MOutput { - - private final Map outputValues; - private final List calculationErrors; - - MOutput(Map outputValues, List calculationErrors) { - this.outputValues = outputValues; - this.calculationErrors = calculationErrors; - } - - public Map getOutputValues() { - return outputValues; - } - - public List getCalculationErrors() { - return calculationErrors; - } - -} diff --git a/examples/java/src/com/mlang/MValue.java b/examples/java/src/com/mlang/MValue.java deleted file mode 100644 index 79fe1022a..000000000 --- a/examples/java/src/com/mlang/MValue.java +++ /dev/null @@ -1,325 +0,0 @@ -/* Copyright (C) 2021 Inria, contributor: James Barnes - - 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 . */ - -package com.mlang; - -/** - * MValue is the representation of a variable used during a tax calculation, - * either as input, output or an intermediate value. - */ -public class MValue { - - static final MValue mUndefined = new MValue(0., true); - static final MValue zero = new MValue(0., false); - static final MValue one = new MValue(1., false); - - private final double value; - private final boolean undefined; - - MValue(double value, boolean isDefined) { - this.value = value; - this.undefined = isDefined; - } - - /** - * Create an MValue with a double value, by default MValues are created as - * defined - * - * @param value the value to be used with this variable - */ - public MValue(double value) { - this.value = value; - this.undefined = false; - } - - /** - * Getter for value Field - * - * @return the double value of the MValue - */ - public double getValue() { - return this.value; - } - - /** - * Getter for undefined field - * - * @return boolean, whether the value has been defined during calculation - */ - public boolean isUndefined() { - return this.undefined; - } - - private static MValue boolToMValue(boolean b) { - return b ? one : zero; - } - - static MValue mGreaterThan(MValue x, MValue y) { - if (x.isUndefined() || y.isUndefined()) { - return mUndefined; - } - return boolToMValue(x.getValue() > y.getValue()); - } - - static MValue mGreaterThanEqual(MValue x, MValue y) { - if (x.isUndefined() || y.isUndefined()) { - return mUndefined; - } - return boolToMValue(x.getValue() >= y.getValue()); - } - - static MValue mLessThan(MValue x, MValue y) { - if (x.isUndefined() || y.isUndefined()) { - return mUndefined; - } - return boolToMValue(x.getValue() < y.getValue()); - } - - static MValue mLessThanEqual(MValue x, MValue y) { - if (x.isUndefined() || y.isUndefined()) { - return mUndefined; - } - return boolToMValue(x.getValue() <= y.getValue()); - } - - static MValue mEqual(MValue x, MValue y) { - if (x.isUndefined() || y.isUndefined()) { - return mUndefined; - } - return boolToMValue(x.getValue() == y.getValue()); - } - - static MValue mNotEqual(MValue x, MValue y) { - if (x.isUndefined() || y.isUndefined()) { - return mUndefined; - } - return boolToMValue(x.getValue() != y.getValue()); - } - - static MValue mAnd(MValue x, MValue y) { - if (x.isUndefined() || y.isUndefined()) { - return mUndefined; - } - return boolToMValue(x.getValue() != 0 && y.getValue() != 0); - } - - static MValue mOr(MValue x, MValue y) { - if (x.isUndefined() && y.isUndefined()) { - return mUndefined; - } - return boolToMValue(x.getValue() != 0 || y.getValue() != 0); - } - - static MValue mAdd(MValue x, MValue y) { - - if (x.isUndefined() && y.isUndefined()) { - return mUndefined; - } - - return new MValue(x.getValue() + y.getValue()); - } - - static MValue mSubtract(MValue x, MValue y) { - if (x.isUndefined() && y.isUndefined()) { - return mUndefined; - } - - return new MValue(x.getValue() - y.getValue()); - } - - static MValue mMultiply(MValue x, MValue y) { - if (x.isUndefined() || y.isUndefined()) { - return mUndefined; - } - return new MValue(x.getValue() * y.getValue()); - } - - static MValue mDivide(MValue x, MValue y) { - - if (x.isUndefined() || y.isUndefined()) { - return mUndefined; - } - - double denominateur = y.getValue(); - - if (denominateur == 0) { - return zero; - } - - return new MValue(x.getValue() / denominateur); - } - - static MValue m_round(MValue x) { - if (x.isUndefined()) { - return mUndefined; - } - double dValue = x.getValue(); - double valueToRound = dValue + (dValue < 0 ? -0.50005 : 0.50005); - return new MValue((double) (int) (valueToRound)); - } - - static MValue m_null(MValue x) { - if (x.isUndefined()) { - return mUndefined; - } - else if (x.getValue() == 0) { - return one; - } - else { - return zero; - } - } - - static MValue m_floor(MValue x) { - if (x.isUndefined()) { - return mUndefined; - } - double valueToFloor = x.getValue() + 0.000001; - return new MValue(Math.floor(valueToFloor)); - } - - static MValue m_abs(MValue x) { - if (x.isUndefined()) { - return mUndefined; - } - return new MValue(Math.abs(x.getValue())); - } - - static MValue m_cond(MValue cond, MValue trueVal, MValue falseVal) { - if (cond.isUndefined()) { - return mUndefined; - } else if (cond.getValue() != 0) { - return trueVal; - } else { - return falseVal; - } - } - - static MValue m_max(MValue x, MValue y) { - - if (x.isUndefined() && y.isUndefined()) { - return mUndefined; - } - - return new MValue(Math.max(x.getValue(), y.getValue())); - } - - static MValue m_min(MValue x, MValue y) { - - if (x.isUndefined() && y.isUndefined()) { - return mUndefined; - } - - return new MValue(Math.min(x.getValue(), y.getValue())); - } - - static MValue mNeg(MValue x) { - if (x.isUndefined()) { - return mUndefined; - } - return new MValue(-x.getValue()); - } - - static MValue mPresent(MValue value) { - return value.isUndefined() ? zero : one; - } - - static MValue mNot(MValue value) { - if (value.isUndefined()) { - return mUndefined; - } - return value.getValue() == 0 ? one : zero; - } - - static MValue m_multimax(MValue boundMValue, MValue[] array, int position) { - if (boundMValue.isUndefined()) { - throw new RuntimeException("Multimax bound undefined!"); - } - - int bound = (int)Math.floor(boundMValue.getValue()); - - MValue max = array[position]; - for (int i = 0; i <= bound; i++) { - MValue challenger = array[position + i]; - if (challenger.getValue() > max.getValue() || max.isUndefined()) { - max = challenger; - } - } - return max; - } - - static boolean m_is_defined_true(MValue x) { - if (x.isUndefined()) { - return false; - } else { - return x.getValue() != 0; - } - } - - static boolean m_is_defined_false(MValue x) { - if (x.isUndefined()) { - return false; - } else { - return x.getValue() == 0; - } - } - - static MValue m_array_index(MValue[] array, int tableStart, MValue index, int size) { - if (index.isUndefined()) { - return mUndefined; - } - - int indexInteger = (int)Math.floor(index.getValue()); - - if (indexInteger < 0) { - return zero; - } else if (indexInteger >= size) { - return mUndefined; - } else { - return array[tableStart + indexInteger]; - } - - } - - /** - * Compare two MValues based on their value alone taking into account a - * threshold of precision (e.g. 0.001). This threshold is useful as comparing - * floats with the == operator can lead to false negatives, especially with - * large numbers - * - * @param toCompare MValue to be compared with current MValue - * @param withThreshold double representing threshold - * @return boolean true if MValues are equal - */ - public boolean equalsWithThreshold(MValue toCompare, double withThreshold) { - return Math.abs(this.getValue() - toCompare.getValue()) < withThreshold; - } - - /** - * Compare two MValues based on their value and definedness, beware that - * comparaison of float values is done with == operator - * - * @param o Java Object to be compared with current MValue - * @return boolean true if objects are equal - */ - @Override - public boolean equals(Object o) { - return o != null && o instanceof MValue && ((MValue) o).getValue() == this.getValue() - && ((MValue) o).isUndefined() == this.isUndefined(); - } - - @Override - public String toString() { - return "Value: " + this.getValue() + " undefined: " + this.isUndefined(); - } -} diff --git a/m_ext/2019/cibles.m b/m_ext/2019/cibles.m index 94f72a849..d23029833 100644 --- a/m_ext/2019/cibles.m +++ b/m_ext/2019/cibles.m @@ -236,7 +236,7 @@ si nb_anomalies() = 0 alors application : iliad; iterer : variable ITBASE -: categorie calculee base * +: categorie calculee base : dans ( ITBASE = indefini; ) @@ -245,7 +245,7 @@ si nb_anomalies() = 0 alors application : iliad; iterer : variable ITCAL -: categorie calculee, calculee restituee +: categorie calculee : dans ( ITCAL = indefini; ) diff --git a/m_ext/2020/cibles.m b/m_ext/2020/cibles.m index 63cbb6a1f..29d1ef76c 100644 --- a/m_ext/2020/cibles.m +++ b/m_ext/2020/cibles.m @@ -236,7 +236,7 @@ si nb_anomalies() = 0 alors application : iliad; iterer : variable ITBASE -: categorie calculee base * +: categorie calculee base : dans ( ITBASE = indefini; ) @@ -245,7 +245,7 @@ si nb_anomalies() = 0 alors application : iliad; iterer : variable ITCAL -: categorie calculee, calculee restituee +: categorie calculee : dans ( ITCAL = indefini; ) diff --git a/m_ext/2021/cibles.m b/m_ext/2021/cibles.m index 611c168fd..0562620bb 100644 --- a/m_ext/2021/cibles.m +++ b/m_ext/2021/cibles.m @@ -243,7 +243,7 @@ si nb_anomalies() = 0 alors application : iliad; iterer : variable ITBASE -: categorie calculee base * +: categorie calculee base : dans ( ITBASE = indefini; ) @@ -252,7 +252,7 @@ si nb_anomalies() = 0 alors application : iliad; iterer : variable ITCAL -: categorie calculee, calculee restituee +: categorie calculee : dans ( ITCAL = indefini; ) diff --git a/m_ext/2022/cibles.m b/m_ext/2022/cibles.m index efcd96d70..4448b011c 100644 --- a/m_ext/2022/cibles.m +++ b/m_ext/2022/cibles.m @@ -289,7 +289,7 @@ et nb_categorie(*) = nb_categorie(saisie famille) + nb_categorie(saisie contexte calculer cible trace_in; iterer : variable ITBASE -: categorie calculee base * +: categorie calculee base : dans ( ITBASE = indefini; ) @@ -302,7 +302,7 @@ et nb_categorie(*) = nb_categorie(saisie famille) + nb_categorie(saisie contexte calculer cible trace_in; iterer : variable ITCAL -: categorie calculee, calculee restituee +: categorie calculee : dans ( ITCAL = indefini; ) @@ -334,13 +334,11 @@ et nb_categorie(*) = nb_categorie(saisie famille) + nb_categorie(saisie contexte application: iliad; #afficher_erreur "effacer_avfisc_1[\n"; calculer cible trace_in; -VARTMP1 = 0; iterer : variable REV_AV : categorie saisie revenu, saisie revenu corrective : avec attribut(REV_AV, avfisc) = 1 et present(REV_AV) : dans ( - VARTMP1 = 1; REV_AV = indefini; ) calculer cible trace_out; @@ -348,9 +346,10 @@ et nb_categorie(*) = nb_categorie(saisie famille) + nb_categorie(saisie contexte cible est_code_supp_avfisc: application: iliad; +argument: EXISTE_CODE_SUPP; #afficher_erreur "est_code_supp_avfisc[\n"; calculer cible trace_in; -VARTMP1 = 0; +EXISTE_CODE_SUPP = 0; #si # present(COD7QD) ou present(COD7QB) ou present(COD7QC) # ou present(RFORDI) ou present(RFROBOR) ou present(RFDORD) @@ -360,14 +359,14 @@ et nb_categorie(*) = nb_categorie(saisie famille) + nb_categorie(saisie contexte # ou present(PINELQP_A) ou present(COD7QS_A) ou present(PINELQN_A) # ou present(PINELQO_A) #alors -# VARTMP1 = 1; +# EXISTE_CODE_SUPP = 1; #sinon iterer : variable REV_AV : categorie saisie revenu, saisie revenu corrective : avec attribut(REV_AV, avfisc) = 2 et present(REV_AV) : dans ( - VARTMP1 = 1; + EXISTE_CODE_SUPP = 1; ) #finsi calculer cible trace_out; @@ -375,19 +374,21 @@ et nb_categorie(*) = nb_categorie(saisie famille) + nb_categorie(saisie contexte cible calcule_avfiscal: application: iliad; -variable temporaire: EXISTE_AVFISC, SAUV_IAD11, SAUV_INE, SAUV_IRE, SAUV_ART1731BIS, SAUV_PREM8_11; +variable temporaire: + EXISTE_AVFISC, EXISTE_CODE_SUPP, + SAUV_IAD11, SAUV_INE, SAUV_IRE, SAUV_ART1731BIS, SAUV_PREM8_11; #afficher_erreur "calcule_avfiscal[\n"; calculer cible trace_in; EXISTE_AVFISC = 0; iterer : variable REV_AV : categorie saisie revenu, saisie revenu corrective - : avec attribut(REV_AV, avfisc) dans (1, 2) et present(REV_AV) +: avec attribut(REV_AV, avfisc) dans (1, 2) et present(REV_AV) : dans ( EXISTE_AVFISC = 1; ) -calculer cible est_code_supp_avfisc; -si VARTMP1 = 0 alors +calculer cible est_code_supp_avfisc : avec EXISTE_CODE_SUPP; +si EXISTE_CODE_SUPP = 0 alors EXISTE_AVFISC = 1; finsi si EXISTE_AVFISC = 1 alors @@ -462,43 +463,45 @@ si CMAJ dans (8, 11) alors cible est_calcul_acomptes: application: iliad; +argument: EXISTE_ACOMPTES; #afficher_erreur "est_calcul_acomptes[\n"; calculer cible trace_in; -VARTMP1 = 0; +EXISTE_ACOMPTES = 0; iterer : variable REV_AC : categorie saisie revenu, saisie revenu corrective : avec attribut(REV_AC, acompte) = 0 et present(REV_AC) : dans ( - VARTMP1 = 1; + EXISTE_ACOMPTES = 1; ) calculer cible trace_out; #afficher_erreur "]est_calcul_acomptes\n"; cible est_calcul_avfisc: application: iliad; +argument: EXISTE_AVFISC; #afficher_erreur "est_calcul_avfisc[\n"; calculer cible trace_in; -VARTMP1 = 0; +EXISTE_AVFISC = 0; iterer : variable REV_AV : categorie saisie revenu, saisie revenu corrective : avec attribut(REV_AV, avfisc) = 1 et present(REV_AV) : dans ( - VARTMP1 = 1; + EXISTE_AVFISC = 1; ) -si VARTMP1 = 0 alors - calculer cible est_code_supp_avfisc; +si EXISTE_AVFISC = 0 alors + calculer cible est_code_supp_avfisc : avec EXISTE_AVFISC; finsi calculer cible trace_out; #afficher_erreur "]est_calcul_avfisc\n"; cible traite_double_liquidation3: application: iliad; -variable temporaire: P_EST_CALCUL_ACOMPTES, CALCUL_ACOMPTES, CALCUL_AVFISC, SAUV_IRANT; +argument: P_EST_CALCUL_ACOMPTES; +variable temporaire: CALCUL_ACOMPTES, CALCUL_AVFISC, SAUV_IRANT; #afficher_erreur "traite_double_liquidation3[\n"; calculer cible trace_in; -P_EST_CALCUL_ACOMPTES = VARTMP1; FLAG_ACO = 0; V_NEGACO = 0; V_AVFISCOPBIS = 0; @@ -507,10 +510,8 @@ si CMAJ dans (8, 11) alors PREM8_11 = 0; calculer cible article_1731_bis; finsi -calculer cible est_calcul_acomptes; -CALCUL_ACOMPTES = VARTMP1; -calculer cible est_calcul_avfisc; -CALCUL_AVFISC = VARTMP1; +calculer cible est_calcul_acomptes : avec CALCUL_ACOMPTES; +calculer cible est_calcul_avfisc : avec CALCUL_AVFISC; si CALCUL_AVFISC = 1 alors SAUV_IRANT = IRANT + 0 ; IRANT = indefini; @@ -564,20 +565,26 @@ si CMAJ dans (8, 11) alors calculer cible trace_out; #afficher_erreur "]traite_double_liquidation3\n"; +cible abs_flag: +application: iliad; +argument: VAR, ABS, FLAG; +si present(VAR) alors + FLAG = (VAR < 0); + ABS = abs(VAR); + VAR = ABS; +finsi + cible traite_double_liquidation_exit_taxe: application: iliad; +variable temporaire: CALCULER_ACOMPTES; #afficher_erreur "traite_double_liquidation_exit_taxe[\n"; calculer cible trace_in; si present(PVIMPOS) ou present(CODRWB) alors FLAG_3WBNEG = 0; FLAG_EXIT = 1; - VARTMP1 = 0; - calculer cible traite_double_liquidation3; - si present(NAPTIR) alors - FLAG_3WBNEG = (NAPTIR < 0); - V_NAPTIR3WB = abs(NAPTIR); - NAPTIR = V_NAPTIR3WB; - finsi + CALCULER_ACOMPTES = 0; + calculer cible traite_double_liquidation3 : avec CALCULER_ACOMPTES; + calculer cible abs_flag : avec NAPTIR, V_NAPTIR3WB, FLAG_3WBNEG; si present(IHAUTREVT) alors V_CHR3WB = IHAUTREVT; finsi @@ -589,13 +596,9 @@ si present(IAD11) alors si present(PVSURSI) ou present(CODRWA) alors FLAG_3WANEG = 0; FLAG_EXIT = 2; - VARTMP1 = 0; - calculer cible traite_double_liquidation3; - si present(NAPTIR) alors - FLAG_3WANEG = (NAPTIR < 0); - V_NAPTIR3WA = abs(NAPTIR); - NAPTIR = V_NAPTIR3WA; - finsi + CALCULER_ACOMPTES = 0; + calculer cible traite_double_liquidation3 : avec CALCULER_ACOMPTES; + calculer cible abs_flag : avec NAPTIR, V_NAPTIR3WA, FLAG_3WANEG; si present(IHAUTREVT) alors V_CHR3WA = IHAUTREVT; finsi @@ -605,8 +608,8 @@ si present(IAD11) alors FLAG_EXIT = 0; finsi FLAG_BAREM = 1; -VARTMP1 = 1; -calculer cible traite_double_liquidation3; +CALCULER_ACOMPTES = 1; +calculer cible traite_double_liquidation3 : avec CALCULER_ACOMPTES; si present(RASTXFOYER) alors V_BARTXFOYER = RASTXFOYER; finsi @@ -624,17 +627,13 @@ si present(INDTAZ) alors # leve_erreur A000; finsi finsi -si present(IITAZIR) alors - FLAG_BARIITANEG = (IITAZIR < 0); - V_BARIITAZIR = abs(IITAZIR); - IITAZIR = V_BARIITAZIR; -finsi +calculer cible abs_flag : avec IITAZIR, V_BARIITAZIR, FLAG_BARIITANEG; si present(IRTOTAL) alors V_BARIRTOTAL = IRTOTAL; finsi FLAG_BAREM = 0; -VARTMP1 = 1; -calculer cible traite_double_liquidation3; +CALCULER_ACOMPTES = 1; +calculer cible traite_double_liquidation3 : avec CALCULER_ACOMPTES; calculer cible trace_out; #afficher_erreur "]traite_double_liquidation_exit_taxe\n"; @@ -751,6 +750,7 @@ ou present(MOISAN_ISF) cible enchaine_calcul: application: iliad; +# variable temporaire: CALCULER_ACOMPTES; si V_IND_TRAIT = 4 alors # primitif calculer cible effacer_base_etc; calculer cible traite_double_liquidation_2; @@ -762,51 +762,52 @@ ou present(MOISAN_ISF) sinon V_ACO_MTAP = 0; V_NEGACO = 0; -# VARTMP1 = si (present(FLAGDERNIE)) alors (1) sinon (0) finsi; -# calculer cible traite_double_liquidation3; +# CALCULER_ACOMPTES = si (present(FLAGDERNIE)) alors (1) sinon (0) finsi; +# calculer cible traite_double_liquidation3 : avec CALCULER_ACOMPTES; calculer cible traite_double_liquidation_pvro; finsi +cible exporte_si_non_bloquantes: +application: iliad; +si nb_discordances() + nb_informatives() > 0 alors + exporte_erreurs; +finsi + cible enchainement_primitif: application: iliad; +variable temporaire: EXPORTE_ERREUR; #afficher_erreur "traite_double_liquidation2[\n"; calculer cible trace_in; calculer cible ir_verif_saisie_isf; finalise_erreurs; -si nb_anomalies() > 0 alors - exporte_erreurs; -sinon_si nb_discordances() + nb_informatives() = 0 alors +EXPORTE_ERREUR = 1; +quand nb_anomalies() = 0 faire + EXPORTE_ERREUR = 0; +puis_quand nb_discordances() + nb_informatives() = 0 faire calculer cible ir_verif_contexte; finalise_erreurs; - si nb_anomalies() = 0 alors - si nb_discordances() + nb_informatives() > 0 alors - exporte_erreurs; - finsi - calculer cible ir_verif_famille; - finalise_erreurs; - si nb_anomalies() = 0 alors - si nb_discordances() + nb_informatives() > 0 alors - exporte_erreurs; - finsi - calculer cible ir_verif_revenu; - finalise_erreurs; - si nb_anomalies() > 0 alors - exporte_erreurs; - sinon - si nb_discordances() + nb_informatives() > 0 alors - exporte_erreurs; - finsi - calculer cible ir_calcul_primitif_isf; - finalise_erreurs; - calculer cible enchaine_calcul; - finalise_erreurs; - si nb_discordances() + nb_informatives() > 0 alors - exporte_erreurs; - finsi - finsi - finsi + EXPORTE_ERREUR = 0; +puis_quand nb_anomalies() = 0 faire + calculer cible exporte_si_non_bloquantes; + calculer cible ir_verif_famille; + finalise_erreurs; +puis_quand nb_anomalies() = 0 faire + EXPORTE_ERREUR = 1; +puis_quand nb_discordances() + nb_informatives() = 0 faire + calculer cible ir_verif_revenu; + finalise_erreurs; +puis_quand nb_anomalies() = 0 faire + calculer cible exporte_si_non_bloquantes; + calculer cible ir_calcul_primitif_isf; + finalise_erreurs; + calculer cible enchaine_calcul; + finalise_erreurs; + calculer cible exporte_si_non_bloquantes; +sinon_faire + si EXPORTE_ERREUR = 1 alors + exporte_erreurs; finsi -finsi +finquand calculer cible trace_out; #afficher_erreur "]traite_double_liquidation2\n"; @@ -817,8 +818,3 @@ si nb_discordances() + nb_informatives() > 0 alors V_IND_TRAIT = 4; # primitif calculer cible enchainement_primitif; -#{ - - - -}# diff --git a/makefiles/variables.mk b/makefiles/variables.mk index 52a483a4d..9e5ceef2a 100644 --- a/makefiles/variables.mk +++ b/makefiles/variables.mk @@ -7,7 +7,6 @@ ################################################## GCC=gcc -JAVA_HOME?=/usr/lib/jvm/java MUSL_HOME?=/usr/local/musl ################################################## diff --git a/mlang-deps b/mlang-deps index b76fbd822..014039664 160000 --- a/mlang-deps +++ b/mlang-deps @@ -1 +1 @@ -Subproject commit b76fbd8220f2d575a1d918d2199068ba5ee8203e +Subproject commit 0140396648e7fc488c1f67fd43a08ebea4264a37 diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index 4f3e62f1e..93e2fc34d 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -14,8 +14,8 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -open Bir module D = DecoupledExpr +module VID = Dgfip_varid let str_escape str = let l = String.length str in @@ -48,97 +48,164 @@ let fresh_c_local = incr c; s -let rec generate_c_expr (e : expression Pos.marked) - (var_indexes : Dgfip_varid.var_id_map) : D.expression_composition = - match Pos.unmark e with - | Comparison (op, e1, e2) -> - let se1 = generate_c_expr e1 var_indexes in - let se2 = generate_c_expr e2 var_indexes in - let safe_def = - match (Pos.unmark op, Pos.unmark e2) with - | Mast.Gt, Mir.(Literal (Undefined | Float 0.)) -> - (* hack to catch positive test in M *) true - | _ -> false +let rec generate_c_expr (e : Mir.expression Pos.marked) : + D.expression_composition = + let comparison op se1 se2 = + let safe_def = false in + let set_vars = se1.D.set_vars @ se2.D.set_vars in + let def_test = D.dand se1.D.def_test se2.D.def_test in + let value_comp = + let op = + let open Com in + match Pos.unmark op with + | Gt -> ">" + | Gte -> ">=" + | Lt -> "<" + | Lte -> "<=" + | Eq -> "==" + | Neq -> "!=" in - let def_test = D.dand se1.def_test se2.def_test in - let value_comp = - let op = + D.comp op se1.value_comp se2.value_comp + in + D.build_transitive_composition ~safe_def { set_vars; def_test; value_comp } + in + let binop op se1 se2 = + match Pos.unmark op with + | _ -> + let set_vars = se1.D.set_vars @ se2.D.set_vars in + let def_test = match Pos.unmark op with - | Mast.Gt -> ">" - | Mast.Gte -> ">=" - | Mast.Lt -> "<" - | Mast.Lte -> "<=" - | Mast.Eq -> "==" - | Mast.Neq -> "!=" + | Com.And | Com.Mul | Com.Div -> D.dand se1.def_test se2.def_test + | Com.Or | Com.Add | Com.Sub -> D.dor se1.def_test se2.def_test in - D.comp op se1.value_comp se2.value_comp - in - D.build_transitive_composition ~safe_def { def_test; value_comp } - | Binop ((Mast.Div, _), e1, e2) -> - let se1 = generate_c_expr e1 var_indexes in - let se2 = generate_c_expr e2 var_indexes in - let def_test = D.dand se1.def_test se2.def_test in - let value_comp = - D.ite se2.value_comp (D.div se1.value_comp se2.value_comp) (D.lit 0.) + let op e1 e2 = + match Pos.unmark op with + | Com.And -> D.dand e1 e2 + | Com.Or -> D.dor e1 e2 + | Com.Add -> D.plus e1 e2 + | Com.Sub -> D.sub e1 e2 + | Com.Mul -> D.mult e1 e2 + | Com.Div -> D.ite e2 (D.div e1 e2) (D.lit 0.) + in + let value_comp = op se1.value_comp se2.value_comp in + D.build_transitive_composition ~safe_def:true + { set_vars; def_test; value_comp } + in + let unop op se = + let set_vars = se.D.set_vars in + let def_test = se.def_test in + let op, safe_def = + match op with Com.Not -> (D.dnot, false) | Com.Minus -> (D.minus, true) + in + let value_comp = op se.value_comp in + D.build_transitive_composition ~safe_def { set_vars; def_test; value_comp } + in + match Pos.unmark e with + | Com.TestInSet (positive, e0, values) -> + let se0 = generate_c_expr e0 in + let ldef, lval = D.locals_from_m () in + let sle0 = + { + D.set_vars = []; + D.def_test = D.local_var ldef; + D.value_comp = D.local_var lval; + } in - D.build_transitive_composition ~safe_def:true { def_test; value_comp } - | Binop (op, e1, e2) -> - let se1 = generate_c_expr e1 var_indexes in - let se2 = generate_c_expr e2 var_indexes in - let def_test = - match Pos.unmark op with - | Mast.And | Mast.Mul -> D.dand se1.def_test se2.def_test - | Mast.Or | Mast.Add | Mast.Sub -> D.dor se1.def_test se2.def_test - | Mast.Div -> assert false - (* see above *) + let declare_local constr = + D.let_local ldef se0.def_test (D.let_local lval se0.value_comp constr) in - let op e1 e2 = - match Pos.unmark op with - | Mast.And -> D.dand e1 e2 - | Mast.Or -> D.dor e1 e2 - | Mast.Add -> D.plus e1 e2 - | Mast.Sub -> D.sub e1 e2 - | Mast.Mul -> D.mult e1 e2 - | Mast.Div -> assert false - (* see above *) + let or_chain = + List.fold_left + (fun or_chain set_value -> + let equal_test = + match set_value with + | Com.VarValue set_var -> + let s_set_var = + let v = Pos.unmark set_var in + let def_test = D.m_var v None Def in + let value_comp = D.m_var v None Val in + D.{ set_vars = []; def_test; value_comp } + in + comparison (Com.Eq, Pos.no_pos) sle0 s_set_var + | Com.FloatValue i -> + let s_i = + { + D.set_vars = []; + D.def_test = D.dtrue; + D.value_comp = D.lit (Pos.unmark i); + } + in + comparison (Com.Eq, Pos.no_pos) sle0 s_i + | Com.Interval (bn, en) -> + let s_bn = + let bn' = float_of_int (Pos.unmark bn) in + D.{ set_vars = []; def_test = dtrue; value_comp = lit bn' } + in + let s_en = + let en' = float_of_int (Pos.unmark en) in + D.{ set_vars = []; def_test = dtrue; value_comp = lit en' } + in + binop (Com.And, Pos.no_pos) + (comparison (Com.Gte, Pos.no_pos) sle0 s_bn) + (comparison (Com.Lte, Pos.no_pos) sle0 s_en) + in + binop (Com.Or, Pos.no_pos) or_chain equal_test) + D.{ set_vars = []; def_test = dfalse; value_comp = lit 0. } + values in - let value_comp = op se1.value_comp se2.value_comp in - D.build_transitive_composition ~safe_def:true { def_test; value_comp } + let se = if positive then or_chain else unop Com.Not or_chain in + { + D.set_vars = se0.set_vars; + D.def_test = declare_local se.def_test; + D.value_comp = declare_local se.value_comp; + } + | Comparison (op, e1, e2) -> + let se1 = generate_c_expr e1 in + let se2 = generate_c_expr e2 in + comparison op se1 se2 + | Binop (op, e1, e2) -> + let se1 = generate_c_expr e1 in + let se2 = generate_c_expr e2 in + binop op se1 se2 | Unop (op, e) -> - let se = generate_c_expr e var_indexes in - let def_test = se.def_test in - let op, safe_def = - match op with - | Mast.Not -> (D.dnot, false) - | Mast.Minus -> (D.minus, true) - in - let value_comp = op se.value_comp in - D.build_transitive_composition ~safe_def { def_test; value_comp } + let se = generate_c_expr e in + unop op se | Index (var, e) -> - let idx = generate_c_expr e var_indexes in - let size = - Option.get (Bir.var_to_mir (Pos.unmark var)).Mir.Variable.is_table + let index = fresh_c_local "index" in + let def_index = Pp.spr "def_%s" index in + let val_index = Pp.spr "val_%s" index in + let idx = generate_c_expr e in + let size = VID.gen_size (Pos.unmark var) in + let set_vars = + idx.D.set_vars + @ [ + (D.Def, def_index, idx.def_test); (D.Val, val_index, idx.value_comp); + ] in - let idx_var = D.new_local () in let def_test = - D.let_local idx_var idx.value_comp - (D.dand - (D.dand idx.def_test - (D.comp "<" (D.local_var idx_var) (D.lit (float_of_int size)))) - (D.access (Pos.unmark var) Def (D.local_var idx_var))) + D.dand + (D.dand (D.dinstr def_index) + (D.comp "<" (D.dinstr val_index) (D.dinstr size))) + (D.access (Pos.unmark var) Def (D.dinstr val_index)) in let value_comp = - D.let_local idx_var idx.value_comp - (D.ite - (D.comp "<" (D.local_var idx_var) (D.lit 0.)) - (D.lit 0.) - (D.access (Pos.unmark var) Val (D.local_var idx_var))) + D.ite + (D.comp "<" (D.dinstr val_index) (D.lit 0.)) + (D.lit 0.) + (D.access (Pos.unmark var) Val (D.dinstr val_index)) + in + D.build_transitive_composition { set_vars; def_test; value_comp } + | Conditional (c, t, f_opt) -> + let cond = generate_c_expr c in + let thenval = generate_c_expr t in + let elseval = + match f_opt with + | None -> D.{ set_vars = []; def_test = dfalse; value_comp = lit 0. } + | Some f -> generate_c_expr f + in + let set_vars = + cond.D.set_vars @ thenval.D.set_vars @ elseval.D.set_vars in - D.build_transitive_composition { def_test; value_comp } - | Conditional (c, t, f) -> - let cond = generate_c_expr c var_indexes in - let thenval = generate_c_expr t var_indexes in - let elseval = generate_c_expr f var_indexes in let def_test = D.dand cond.def_test (D.ite cond.value_comp thenval.def_test elseval.def_test) @@ -146,292 +213,352 @@ let rec generate_c_expr (e : expression Pos.marked) let value_comp = D.ite cond.value_comp thenval.value_comp elseval.value_comp in - D.build_transitive_composition { def_test; value_comp } - | FunctionCall (Supzero, [ arg ]) -> - let se = generate_c_expr arg var_indexes in + D.build_transitive_composition { set_vars; def_test; value_comp } + | FuncCall ((Supzero, _), [ arg ]) -> + let se = generate_c_expr arg in + let set_vars = se.D.set_vars in let cond = D.dand se.def_test (D.comp ">=" se.value_comp (D.lit 0.0)) in let def_test = D.ite cond D.dfalse se.def_test in let value_comp = D.ite cond (D.lit 0.0) se.value_comp in - D.build_transitive_composition { def_test; value_comp } - | FunctionCall (PresentFunc, [ arg ]) -> - let se = generate_c_expr arg var_indexes in + D.build_transitive_composition { set_vars; def_test; value_comp } + | FuncCall ((PresentFunc, _), [ arg ]) -> + let se = generate_c_expr arg in + let set_vars = se.D.set_vars in let def_test = D.dtrue in let value_comp = se.def_test in - D.build_transitive_composition ~safe_def:true { def_test; value_comp } - | FunctionCall (NullFunc, [ arg ]) -> - let se = generate_c_expr arg var_indexes in + D.build_transitive_composition ~safe_def:true + { set_vars; def_test; value_comp } + | FuncCall ((NullFunc, _), [ arg ]) -> + let se = generate_c_expr arg in + let set_vars = se.D.set_vars in let def_test = se.def_test in let value_comp = D.dand def_test (D.comp "==" se.value_comp (D.lit 0.0)) in - D.build_transitive_composition ~safe_def:true { def_test; value_comp } - | FunctionCall (ArrFunc, [ arg ]) -> - let se = generate_c_expr arg var_indexes in + D.build_transitive_composition ~safe_def:true + { set_vars; def_test; value_comp } + | FuncCall ((ArrFunc, _), [ arg ]) -> + let se = generate_c_expr arg in + let set_vars = se.D.set_vars in let def_test = se.def_test in let value_comp = D.dfun "my_arr" [ se.value_comp ] in (* Here we boldly assume that rounding value of `undef` will give zero, given the invariant. Pretty sure that not true, in case of doubt, turn `safe_def` to false *) - D.build_transitive_composition ~safe_def:true { def_test; value_comp } - | FunctionCall (InfFunc, [ arg ]) -> - let se = generate_c_expr arg var_indexes in + D.build_transitive_composition ~safe_def:true + { set_vars; def_test; value_comp } + | FuncCall ((InfFunc, _), [ arg ]) -> + let se = generate_c_expr arg in + let set_vars = se.D.set_vars in let def_test = se.def_test in let value_comp = D.dfun "my_floor" [ se.value_comp ] in (* same as above *) - D.build_transitive_composition ~safe_def:true { def_test; value_comp } - | FunctionCall (AbsFunc, [ arg ]) -> - let se = generate_c_expr arg var_indexes in + D.build_transitive_composition ~safe_def:true + { set_vars; def_test; value_comp } + | FuncCall ((AbsFunc, _), [ arg ]) -> + let se = generate_c_expr arg in + let set_vars = se.D.set_vars in let def_test = se.def_test in let value_comp = D.dfun "fabs" [ se.value_comp ] in - D.build_transitive_composition ~safe_def:true { def_test; value_comp } - | FunctionCall (MaxFunc, [ e1; e2 ]) -> - let se1 = generate_c_expr e1 var_indexes in - let se2 = generate_c_expr e2 var_indexes in + D.build_transitive_composition ~safe_def:true + { set_vars; def_test; value_comp } + | FuncCall ((MaxFunc, _), [ e1; e2 ]) -> + let se1 = generate_c_expr e1 in + let se2 = generate_c_expr e2 in + let set_vars = se1.D.set_vars @ se2.D.set_vars in let def_test = D.dor se1.def_test se2.def_test in let value_comp = D.dfun "max" [ se1.value_comp; se2.value_comp ] in - D.build_transitive_composition ~safe_def:true { def_test; value_comp } - | FunctionCall (MinFunc, [ e1; e2 ]) -> - let se1 = generate_c_expr e1 var_indexes in - let se2 = generate_c_expr e2 var_indexes in + D.build_transitive_composition ~safe_def:true + { set_vars; def_test; value_comp } + | FuncCall ((MinFunc, _), [ e1; e2 ]) -> + let se1 = generate_c_expr e1 in + let se2 = generate_c_expr e2 in + let set_vars = se1.D.set_vars @ se2.D.set_vars in let def_test = D.dor se1.def_test se2.def_test in let value_comp = D.dfun "min" [ se1.value_comp; se2.value_comp ] in - D.build_transitive_composition ~safe_def:true { def_test; value_comp } - | FunctionCall (Multimax, [ e1; (Var v2, _) ]) -> - let bound = generate_c_expr e1 var_indexes in + D.build_transitive_composition ~safe_def:true + { set_vars; def_test; value_comp } + | FuncCall ((Multimax, _), [ e1; (Var v2, _) ]) -> + let bound = generate_c_expr e1 in + let set_vars = bound.D.set_vars in let def_test = D.dfun "multimax_def" [ bound.value_comp; D.m_var v2 PassPointer Def ] in let value_comp = D.dfun "multimax" [ bound.value_comp; D.m_var v2 PassPointer Val ] in - D.build_transitive_composition { def_test; value_comp } - | FunctionCall _ -> assert false (* should not happen *) - | Literal (Float f) -> { def_test = D.dtrue; value_comp = D.lit f } - | Literal Undefined -> { def_test = D.dfalse; value_comp = D.lit 0. } - | Var var -> - { def_test = D.m_var var None Def; value_comp = D.m_var var None Val } - | LocalVar lvar -> - let ldef, lval = D.locals_from_m lvar in - { def_test = D.local_var ldef; value_comp = D.local_var lval } - | LocalLet (lvar, e1, e2) -> - let se1 = generate_c_expr e1 var_indexes in - let se2 = generate_c_expr e2 var_indexes in - let ldef, lval = D.locals_from_m lvar in - let declare_local constr = - D.let_local ldef se1.def_test (D.let_local lval se1.value_comp constr) + D.build_transitive_composition { set_vars; def_test; value_comp } + | FuncCall ((Func fn, _), args) -> + let res = fresh_c_local "result" in + let def_res = Pp.spr "def_%s" res in + let val_res = Pp.spr "val_%s" res in + let def_res_ptr = Pp.spr "&%s" def_res in + let val_res_ptr = Pp.spr "&%s" val_res in + let set_vars, arg_exprs = + let rec aux (set_vars, arg_exprs) = function + | [] -> (List.rev set_vars, List.rev arg_exprs) + | a :: la -> + let e = generate_c_expr a in + let set_vars = List.rev e.set_vars @ set_vars in + let arg_exprs = e.value_comp :: e.def_test :: arg_exprs in + aux (set_vars, arg_exprs) la + in + aux ([], []) args + in + let d_fun = + D.dfun fn + ([ + D.dlow_level "irdata"; + D.dlow_level def_res_ptr; + D.dlow_level val_res_ptr; + ] + @ arg_exprs) + in + let set_vars = + set_vars + @ [ (D.Def, def_res, d_fun); (D.Val, val_res, D.dlow_level val_res) ] in + let def_test = D.dinstr def_res in + let value_comp = D.dinstr val_res in + D.build_transitive_composition { set_vars; def_test; value_comp } + | FuncCall _ -> assert false (* should not happen *) + | Literal (Float f) -> + { set_vars = []; def_test = D.dtrue; value_comp = D.lit f } + | Literal Undefined -> + { set_vars = []; def_test = D.dfalse; value_comp = D.lit 0. } + | Var var -> { - def_test = declare_local se2.def_test; - value_comp = declare_local se2.value_comp; + set_vars = []; + def_test = D.m_var var None Def; + value_comp = D.m_var var None Val; } - | Attribut (_v, var, a) -> - let ptr, var_cat_data = - match Mir.VariableMap.find var.mir_var var_indexes with - | Dgfip_varid.VarIterate (t, _, vcd) -> (t, vcd) - | _ -> assert false - in - let id_str = var_cat_data.Mir.id_str in + | Attribut (var, a) -> + let ptr = VID.gen_info_ptr (Pos.unmark var) in let def_test = D.dinstr - (Format.sprintf "attribut_%s_def(%s, \"%s\")" id_str ptr - (Pos.unmark a)) + (Format.sprintf "attribut_%s_def((T_varinfo *)%s)" (Pos.unmark a) ptr) in let value_comp = D.dinstr - (Format.sprintf "attribut_%s(%s, \"%s\")" id_str ptr (Pos.unmark a)) + (Format.sprintf "attribut_%s((T_varinfo *)%s)" (Pos.unmark a) ptr) in - D.build_transitive_composition { def_test; value_comp } + D.build_transitive_composition { set_vars = []; def_test; value_comp } | Size var -> - let ptr = - match Mir.VariableMap.find var.mir_var var_indexes with - | Dgfip_varid.VarIterate (t, _, _) -> t - | _ -> assert false - in + let ptr = VID.gen_info_ptr (Pos.unmark var) in let def_test = D.dinstr "1.0" in let value_comp = D.dinstr (Format.sprintf "(%s->size)" ptr) in - D.build_transitive_composition { def_test; value_comp } + D.build_transitive_composition { set_vars = []; def_test; value_comp } | NbAnomalies -> let def_test = D.dinstr "1.0" in let value_comp = D.dinstr "nb_anomalies(irdata)" in - D.build_transitive_composition { def_test; value_comp } + D.build_transitive_composition { set_vars = []; def_test; value_comp } | NbDiscordances -> let def_test = D.dinstr "1.0" in let value_comp = D.dinstr "nb_discordances(irdata)" in - D.build_transitive_composition { def_test; value_comp } + D.build_transitive_composition { set_vars = []; def_test; value_comp } | NbInformatives -> let def_test = D.dinstr "1.0" in let value_comp = D.dinstr "nb_informatives(irdata)" in - D.build_transitive_composition { def_test; value_comp } + D.build_transitive_composition { set_vars = []; def_test; value_comp } | NbBloquantes -> let def_test = D.dinstr "1.0" in let value_comp = D.dinstr "nb_bloquantes(irdata)" in - D.build_transitive_composition { def_test; value_comp } + D.build_transitive_composition { set_vars = []; def_test; value_comp } | NbCategory _ -> assert false + | FuncCallLoop _ | Loop _ -> assert false -let generate_m_assign (dgfip_flags : Dgfip_options.flags) - (var_indexes : Dgfip_varid.var_id_map) (var : variable) (offset : D.offset) - (oc : Format.formatter) (se : D.expression_composition) : unit = - let def_var = D.generate_variable ~def_flag:true var_indexes offset var in - let val_var = D.generate_variable var_indexes offset var in - let locals, def, value = D.build_expression se in +let generate_m_assign (dgfip_flags : Dgfip_options.flags) (var : Com.Var.t) + (offset : D.offset) (oc : Format.formatter) (se : D.expression_composition) + : unit = + let pr form = Format.fprintf oc form in + let def_var = D.generate_variable ~def_flag:true offset var in + let val_var = D.generate_variable offset var in + let locals, set, def, value = D.build_expression se in if D.is_always_true def then - Format.fprintf oc "%a%a@,@[{@,%a@,@]}" D.format_local_declarations - locals - (D.format_assign dgfip_flags var_indexes def_var) + pr "%a%a%a@;@[{@;%a@]@;}" D.format_local_declarations locals + (D.format_set_vars dgfip_flags) + set + (D.format_assign dgfip_flags def_var) def - (D.format_assign dgfip_flags var_indexes val_var) + (D.format_assign dgfip_flags val_var) value else - Format.fprintf oc "%a%a@,@[if(%s){@;%a@]@,}@,else %s = 0.;" + pr "%a%a%a@,@[if(%s){@;%a@]@,}@,else %s = 0.;" D.format_local_declarations locals - (D.format_assign dgfip_flags var_indexes def_var) + (D.format_set_vars dgfip_flags) + set + (D.format_assign dgfip_flags def_var) def def_var - (D.format_assign dgfip_flags var_indexes val_var) + (D.format_assign dgfip_flags val_var) value val_var; (* If the trace flag is set, we print the value of all non-temp variables *) - let var = Bir.var_to_mir var in - if dgfip_flags.flg_trace && not var.Mir.Variable.is_temp then - Format.fprintf oc "@;aff2(\"%s\", irdata, %s);" - (Pos.unmark var.Mir.Variable.name) - (Dgfip_varid.gen_access_pos_from_start var_indexes var) + if dgfip_flags.flg_trace && not (Com.Var.is_temp var) then + pr "@;aff2(\"%s\", irdata, %s);" + (Pos.unmark var.Com.Var.name) + (VID.gen_pos_from_start var) -let generate_var_def (dgfip_flags : Dgfip_options.flags) - (var_indexes : Dgfip_varid.var_id_map) (var : variable) (def : variable_def) - (fmt : Format.formatter) : unit = - match def with - | SimpleVar e -> - let se = generate_c_expr e var_indexes in - if var.Bir.mir_var.Mir.is_it then ( - let pr form = Format.fprintf fmt form in - pr "@[{"; +let generate_var_def (dgfip_flags : Dgfip_options.flags) (var : Com.Var.t) + (vidx_opt : Mir.expression Pos.marked option) + (vexpr : Mir.expression Pos.marked) (fmt : Format.formatter) : unit = + let pr form = Format.fprintf fmt form in + match vidx_opt with + | None -> + let se = generate_c_expr vexpr in + if Com.Var.is_ref var then ( + pr "@[{@;"; let idx = fresh_c_local "idxPROUT" in pr "@;int %s;" idx; - pr "@;@[for(%s = 0; %s < %s; %s++) {" idx idx - (Dgfip_varid.gen_size var_indexes var.Bir.mir_var) + pr "@;@[for(%s = 0; %s < %s; %s++) {" idx idx (VID.gen_size var) idx; - pr "@;%a" - (generate_m_assign dgfip_flags var_indexes var (GetValueExpr idx)) - se; + pr "@;%a" (generate_m_assign dgfip_flags var (GetValueExpr idx)) se; pr "@]@;}"; pr "@]@;}@;") - else generate_m_assign dgfip_flags var_indexes var None fmt se - | TableVar (_, IndexTable es) -> - Mir.IndexMap.iter - (fun i v -> - let sv = generate_c_expr v var_indexes in - Format.fprintf fmt "@[{@,%a@]}@," - (generate_m_assign dgfip_flags var_indexes var (GetValueConst i)) - sv) - es - | TableVar (_size, IndexGeneric (v, e)) -> - (* TODO: boundary checks *) - let sv = generate_c_expr e var_indexes in - Format.fprintf fmt "if(%s)@[{%a@]@;}" - (D.generate_variable var_indexes None ~def_flag:true v) - (generate_m_assign dgfip_flags var_indexes var (GetValueVar v)) - sv - | InputVar -> assert false + else generate_m_assign dgfip_flags var None fmt se + | Some ei -> + pr "@[{@;"; + let idx_val = fresh_c_local "mpp_idx" in + let idx_def = idx_val ^ "_d" in + let locals_idx, set_idx, def_idx, value_idx = + D.build_expression @@ generate_c_expr ei + in + pr "char %s;@;long %s;@;%a%a%a@;%a@;" idx_def idx_val + D.format_local_declarations locals_idx + (D.format_set_vars dgfip_flags) + set_idx + (D.format_assign dgfip_flags idx_def) + def_idx + (D.format_assign dgfip_flags idx_val) + value_idx; + let size = VID.gen_size var in + pr "@[if(%s && 0 <= %s && %s < %s){@;%a@]@;}" idx_def idx_val idx_val + size + (generate_m_assign dgfip_flags var (GetValueExpr idx_val)) + (generate_c_expr vexpr); + pr "@]@;}@;" -let rec generate_stmt (dgfip_flags : Dgfip_options.flags) (program : program) - (var_indexes : Dgfip_varid.var_id_map) (oc : Format.formatter) (stmt : stmt) - = +let rec generate_stmt (dgfip_flags : Dgfip_options.flags) + (program : Mir.program) (oc : Format.formatter) (stmt : Mir.m_instruction) = match Pos.unmark stmt with - | SAssign (var, vdata) -> - Format.fprintf oc "@[{@,"; - generate_var_def dgfip_flags var_indexes var vdata oc; - Format.fprintf oc "@]@,}" - | SConditional (cond, iftrue, iffalse) -> + | Affectation (SingleFormula (m_var, vidx_opt, vexpr), _) -> + Format.fprintf oc "@[{@;"; + generate_var_def dgfip_flags (Pos.unmark m_var) vidx_opt vexpr oc; + Format.fprintf oc "@]@;}@;" + | Affectation _ -> assert false + | IfThenElse (cond, iftrue, iffalse) -> Format.fprintf oc "@[{@,"; let cond_val = fresh_c_local "mpp_cond" in let cond_def = cond_val ^ "_d" in - let locals, def, value = - D.build_expression - @@ generate_c_expr (Pos.same_pos_as cond stmt) var_indexes + let locals, set, def, value = + D.build_expression @@ generate_c_expr cond in - Format.fprintf oc "char %s;@;double %s;@;%a%a@;%a" cond_def cond_val + Format.fprintf oc "char %s;@;double %s;@;%a%a%a@;%a@;" cond_def cond_val D.format_local_declarations locals - (D.format_assign dgfip_flags var_indexes cond_def) + (D.format_set_vars dgfip_flags) + set + (D.format_assign dgfip_flags cond_def) def - (D.format_assign dgfip_flags var_indexes cond_val) + (D.format_assign dgfip_flags cond_val) value; - Format.fprintf oc "@[if(%s && %s){@,%a@]@,}" cond_def cond_val - (generate_stmts dgfip_flags program var_indexes) + Format.fprintf oc "@[if(%s && %s) {@,%a@]@,}" cond_def cond_val + (generate_stmts dgfip_flags program) iftrue; if iffalse <> [] then - Format.fprintf oc "@[else if(%s){@,%a@]@,}" cond_def - (generate_stmts dgfip_flags program var_indexes) + Format.fprintf oc "@[else if(%s){@,%a@]@,}" cond_def + (generate_stmts dgfip_flags program) iffalse; - Format.fprintf oc "@]@,}" - | SVerifBlock stmts -> + Format.fprintf oc "@]@,}@;" + | WhenDoElse (wdl, ed) -> + let pr fmt_str = Format.fprintf oc fmt_str in + let goto_label = fresh_c_local "when_do_block" in + let fin_label = fresh_c_local "when_do_end" in + let cond_val = fresh_c_local "when_do_cond" in + let cond_def = cond_val ^ "_d" in + pr "@[{@;"; + pr "char %s;@;" cond_def; + pr "double %s;@;" cond_val; + let rec aux = function + | (expr, dl, _) :: l -> + let locals, set, def, value = + D.build_expression @@ generate_c_expr expr + in + pr "@[{@;"; + pr "%a@;" D.format_local_declarations locals; + pr "%a@;" (D.format_set_vars dgfip_flags) set; + pr "%a@;" (D.format_assign dgfip_flags cond_def) def; + pr "%a@;" (D.format_assign dgfip_flags cond_val) value; + pr "@[if(%s) {@;" cond_def; + pr "if (! %s) goto %s;@;" cond_val goto_label; + pr "%a@]@;" (generate_stmts dgfip_flags program) dl; + pr "}@;"; + pr "@]@;}@;"; + aux l + | [] -> () + in + aux wdl; + pr "goto %s;@;" fin_label; + pr "%s:@;" goto_label; + pr "%a@;" (generate_stmts dgfip_flags program) (Pos.unmark ed); + pr "%s:{}@]@;" fin_label; + pr "}@;" + | VerifBlock stmts -> let goto_label = fresh_c_local "verif_block" in let pr fmt = Format.fprintf oc fmt in - pr "@[{@\n"; - pr "#ifdef FLG_MULTITHREAD@\n"; - pr " if (setjmp(irdata->jmp_bloq) != 0) {@\n"; - pr " goto %s;@\n" goto_label; - pr " }@\n"; - pr "#else@\n"; - pr " if (setjmp(jmp_bloq) != 0) {@\n"; - pr " goto %s;@\n" goto_label; - pr " }@\n"; - pr "#endif@\n"; - pr "%a@\n" (generate_stmts dgfip_flags program var_indexes) stmts; - pr "%s:;@]@\n}@\n" goto_label - | SRovCall r -> - let rov = ROVMap.find r program.rules_and_verifs in - generate_rov_function_header ~definition:false oc rov - | SFunctionCall (f, _) -> Format.fprintf oc "%s(irdata);" f - | SPrint (std, args) -> + pr "@[{@;"; + pr " if (setjmp(irdata->jmp_bloq) != 0) {@;"; + pr " goto %s;@;" goto_label; + pr " }@;"; + pr "%a@;" (generate_stmts dgfip_flags program) stmts; + pr "%s:;@]@;}" goto_label + | Print (std, args) -> let print_std, pr_ctx = match std with - | Mast.StdOut -> ("stdout", "&(irdata->ctx_pr_out)") - | Mast.StdErr -> ("stderr", "&(irdata->ctx_pr_err)") + | StdOut -> ("stdout", "&(irdata->ctx_pr_out)") + | StdErr -> ("stderr", "&(irdata->ctx_pr_err)") in let print_val = fresh_c_local "mpp_print" in let print_def = print_val ^ "_d" in Format.fprintf oc "@[{@,char %s;@;double %s;@;" print_def print_val; List.iter - (function - | Mir.PrintString s -> + (fun (arg : Com.Var.t Com.print_arg Pos.marked) -> + match Pos.unmark arg with + | PrintString s -> Format.fprintf oc "print_string(%s, %s, \"%s\");@;" print_std pr_ctx (str_escape s) - | Mir.PrintName (_, var) -> begin - match Mir.VariableMap.find var var_indexes with - | Dgfip_varid.VarIterate (t, _, _) -> - Format.fprintf oc "print_string(%s, %s, %s->name);@;" - print_std pr_ctx t - | _ -> assert false - end - | Mir.PrintAlias (_, var) -> begin - match Mir.VariableMap.find var var_indexes with - | Dgfip_varid.VarIterate (t, _, _) -> - Format.fprintf oc "print_string(%s, %s, %s->alias);@;" - print_std pr_ctx t - | _ -> assert false - end - | Mir.PrintIndent e -> - let locals, def, value = - D.build_expression @@ generate_c_expr e var_indexes + | PrintName (var, _) -> + let ptr = VID.gen_info_ptr var in + Format.fprintf oc "print_string(%s, %s, %s->name);@;" print_std + pr_ctx ptr + | PrintAlias (var, _) -> + let ptr = VID.gen_info_ptr var in + Format.fprintf oc "print_string(%s, %s, %s->alias);@;" print_std + pr_ctx ptr + | PrintIndent e -> + let locals, set, def, value = + D.build_expression @@ generate_c_expr e in - Format.fprintf oc "@[{%a%a@;%a@;@]}@;" + Format.fprintf oc "@[{%a%a%a@;%a@;@]}@;" D.format_local_declarations locals - (D.format_assign dgfip_flags var_indexes print_def) + (D.format_set_vars dgfip_flags) + set + (D.format_assign dgfip_flags print_def) def - (D.format_assign dgfip_flags var_indexes print_val) + (D.format_assign dgfip_flags print_val) value; Format.fprintf oc "@[if(%s){@;" print_def; Format.fprintf oc "set_print_indent(%s, %s, %s);@]@;" print_std pr_ctx print_val; Format.fprintf oc "}@;" - | Mir.PrintExpr (e, min, max) -> - let locals, def, value = - D.build_expression @@ generate_c_expr e var_indexes + | PrintExpr (e, min, max) -> + let locals, set, def, value = + D.build_expression @@ generate_c_expr e in - Format.fprintf oc "@[{%a%a@;%a@;@]}@;" + Format.fprintf oc "@[{%a%a%a@;%a@;@]}@;" D.format_local_declarations locals - (D.format_assign dgfip_flags var_indexes print_def) + (D.format_set_vars dgfip_flags) + set + (D.format_assign dgfip_flags print_def) def - (D.format_assign dgfip_flags var_indexes print_val) + (D.format_assign dgfip_flags print_val) value; Format.fprintf oc "@[if(%s){@;" print_def; Format.fprintf oc "print_double(%s, %s, %s, %d, %d);@]@;" @@ -441,306 +568,259 @@ let rec generate_stmt (dgfip_flags : Dgfip_options.flags) (program : program) print_std pr_ctx) args; Format.fprintf oc "@]@;}@;" - | SIterate (var, vcs, expr, stmts) -> + | ComputeTarget ((tn, _), targs) -> + let pr fmt = Format.fprintf oc fmt in + ignore + (List.fold_left + (fun n ((v : Com.Var.t), _) -> + let ref_idx = Format.sprintf "irdata->ref_org + %d" n in + let ref_info = Format.sprintf "irdata->info_ref[%s]" ref_idx in + let v_info_p = VID.gen_info_ptr v in + pr "%s = %s;@;" ref_info v_info_p; + let ref_def = Format.sprintf "irdata->def_ref[%s]" ref_idx in + let v_def_p = VID.gen_def_ptr v in + pr "%s = %s;@;" ref_def v_def_p; + let ref_val = Format.sprintf "irdata->ref[%s]" ref_idx in + let v_val_p = VID.gen_val_ptr v in + pr "%s = %s;@;" ref_val v_val_p; + n + 1) + 0 targs); + Format.fprintf oc "%s(irdata);" tn + | Iterate (m_var, vars, var_params, stmts) -> + let pr fmt = Format.fprintf oc fmt in let it_name = fresh_c_local "iterate" in - Mir.CatVarSet.iter - (fun vc -> - let vcd = - Mir.CatVarMap.find vc program.mir_program.Mir.program_var_categories - in - let var_indexes = - Mir.VariableMap.add var.mir_var - (Dgfip_varid.VarIterate ("tab_" ^ it_name, vcd.Mir.loc, vcd)) - var_indexes - in - Format.fprintf oc "@[{@;"; - Format.fprintf oc - "T_varinfo_%s *tab_%s = varinfo_%s;@;int nb_%s = 0;@;" - vcd.Mir.id_str it_name vcd.Mir.id_str it_name; - Format.fprintf oc "@[while (nb_%s < NB_%s) {@;" it_name - vcd.Mir.id_str; - let cond_val = "cond_" ^ it_name in - let cond_def = cond_val ^ "_d" in - let locals, def, value = - D.build_expression - @@ generate_c_expr (Pos.same_pos_as expr stmt) var_indexes - in - Format.fprintf oc "char %s;@;double %s;@;@[{@;%a%a@;%a@]@;}@;" - cond_def cond_val D.format_local_declarations locals - (D.format_assign dgfip_flags var_indexes cond_def) - def - (D.format_assign dgfip_flags var_indexes cond_val) - value; - Format.fprintf oc "@[if(%s && %s){@;%a@]@;}@;" cond_def - cond_val - (generate_stmts dgfip_flags program var_indexes) - stmts; - Format.fprintf oc "tab_%s++;@;nb_%s++;@;" it_name it_name; - Format.fprintf oc "@]}@;"; - Format.fprintf oc "@]}@;") - vcs - | SRestore (vars, var_params, stmts) -> - Format.fprintf oc "@[{@;"; + let var = Pos.unmark m_var in + let ref_info = VID.gen_info_ptr var in + let ref_def = VID.gen_def_ptr var in + let ref_val = VID.gen_val_ptr var in + List.iter + (fun (v, _) -> + pr "@[{@;"; + let v_info_p = VID.gen_info_ptr v in + pr "%s = %s;@;" ref_info v_info_p; + let v_def_p = VID.gen_def_ptr v in + pr "%s = %s;@;" ref_def v_def_p; + let v_val_p = VID.gen_val_ptr v in + pr "%s = %s;@;" ref_val v_val_p; + pr "%a@;" (generate_stmts dgfip_flags program) stmts; + pr "@]@;}@;") + vars; + List.iter + (fun (vcs, expr) -> + Com.CatVar.Map.iter + (fun vc _ -> + let vcd = Com.CatVar.Map.find vc program.program_var_categories in + let ref_tab = VID.gen_tab vcd.loc in + let cond_val = "cond_" ^ it_name in + let cond_def = cond_val ^ "_d" in + let locals, set, def, value = + D.build_expression @@ generate_c_expr expr + in + pr "@[{@;"; + pr "T_varinfo_%s *tab_%s = varinfo_%s;@;" vcd.id_str it_name + vcd.id_str; + pr "int nb_%s = 0;@;" it_name; + pr "@[while (nb_%s < NB_%s) {@;" it_name vcd.id_str; + pr "char %s;@;" cond_def; + pr "double %s;@;" cond_val; + pr "%s = (T_varinfo *)tab_%s;@;" ref_info it_name; + pr "%s = &(D%s[%s->idx]);@;" ref_def ref_tab ref_info; + pr "%s = &(%s[%s->idx]);@;" ref_val ref_tab ref_info; + pr "@[{@;"; + pr "%a" D.format_local_declarations locals; + pr "%a" (D.format_set_vars dgfip_flags) set; + pr "%a@;" (D.format_assign dgfip_flags cond_def) def; + pr "%a" (D.format_assign dgfip_flags cond_val) value; + pr "@]@;"; + pr "}@;"; + pr "@[if(%s && %s){@;" cond_def cond_val; + pr "%a@]@;" (generate_stmts dgfip_flags program) stmts; + pr "}@;"; + pr "tab_%s++;@;" it_name; + pr "nb_%s++;" it_name; + pr "@]@;}"; + pr "@]@;}@;") + vcs) + var_params + | Restore (vars, var_params, stmts) -> + let pr fmt = Format.fprintf oc fmt in + pr "@[{@;"; let rest_name = fresh_c_local "restore" in - Format.fprintf oc "T_env_sauvegarde *%s = NULL;@;" rest_name; - Bir.VariableSet.iter - (fun v -> - Format.fprintf oc "env_sauvegarder(&%s, %s, %s, %s);@;" rest_name - (Dgfip_varid.gen_access_def_pointer var_indexes v.mir_var) - (Dgfip_varid.gen_access_pointer var_indexes v.mir_var) - (Dgfip_varid.gen_size var_indexes v.mir_var)) + pr "T_env_sauvegarde *%s = NULL;@;" rest_name; + List.iter + (fun m_v -> + let v = Pos.unmark m_v in + pr "env_sauvegarder(&%s, %s, %s, %s);@;" rest_name (VID.gen_def_ptr v) + (VID.gen_val_ptr v) (VID.gen_size v)) vars; List.iter - (fun (var, vcs, expr) -> + (fun (m_var, vcs, expr) -> + let var = Pos.unmark m_var in let it_name = fresh_c_local "iterate" in - Mir.CatVarSet.iter - (fun vc -> - let vcd = - Mir.CatVarMap.find vc - program.mir_program.Mir.program_var_categories - in - let var_indexes = - Mir.VariableMap.add var.mir_var - (Dgfip_varid.VarIterate ("tab_" ^ it_name, vcd.Mir.loc, vcd)) - var_indexes - in - Format.fprintf oc "@[{@;"; - Format.fprintf oc - "T_varinfo_%s *tab_%s = varinfo_%s;@;int nb_%s = 0;@;" - vcd.Mir.id_str it_name vcd.Mir.id_str it_name; - Format.fprintf oc "@[while (nb_%s < NB_%s) {@;" it_name - vcd.Mir.id_str; + Com.CatVar.Map.iter + (fun vc _ -> + let vcd = Com.CatVar.Map.find vc program.program_var_categories in + let ref_tab = VID.gen_tab vcd.loc in + let ref_info = VID.gen_info_ptr var in + let ref_def = VID.gen_def_ptr var in + let ref_val = VID.gen_val_ptr var in let cond_val = "cond_" ^ it_name in let cond_def = cond_val ^ "_d" in - let locals, def, value = - D.build_expression - @@ generate_c_expr (Pos.same_pos_as expr stmt) var_indexes + let locals, set, def, value = + D.build_expression @@ generate_c_expr expr in - Format.fprintf oc - "char %s;@;double %s;@;@[{@;%a%a@;%a@]@;}@;" cond_def - cond_val D.format_local_declarations locals - (D.format_assign dgfip_flags var_indexes cond_def) - def - (D.format_assign dgfip_flags var_indexes cond_val) - value; - Format.fprintf oc "@[if(%s && %s){@;" cond_def cond_val; - Format.fprintf oc "env_sauvegarder(&%s, %s, %s, %s);@;" rest_name - (Dgfip_varid.gen_access_def_pointer var_indexes var.mir_var) - (Dgfip_varid.gen_access_pointer var_indexes var.mir_var) - (Dgfip_varid.gen_size var_indexes var.mir_var); - Format.fprintf oc "@]@;}@;"; - Format.fprintf oc "tab_%s++;@;nb_%s++;@;" it_name it_name; - Format.fprintf oc "@]}@;"; - Format.fprintf oc "@]}@;") + pr "@[{@;"; + pr "T_varinfo_%s *tab_%s = varinfo_%s;@;" vcd.id_str it_name + vcd.id_str; + pr "int nb_%s = 0;@;" it_name; + pr "@[while (nb_%s < NB_%s) {@;" it_name vcd.id_str; + pr "char %s;@;" cond_def; + pr "double %s;@;" cond_val; + pr "%s = (T_varinfo *)tab_%s;@;" ref_info it_name; + pr "%s = &(D%s[%s->idx]);@;" ref_def ref_tab ref_info; + pr "%s = &(%s[%s->idx]);@;" ref_val ref_tab ref_info; + pr "@[{@;"; + pr "%a" D.format_local_declarations locals; + pr "%a" (D.format_set_vars dgfip_flags) set; + pr "%a@;" (D.format_assign dgfip_flags cond_def) def; + pr "%a" (D.format_assign dgfip_flags cond_val) value; + pr "@]@;"; + pr "}@;"; + pr "@[if(%s && %s){@;" cond_def cond_val; + pr "env_sauvegarder(&%s, %s, %s, %s);" rest_name + (VID.gen_def_ptr var) (VID.gen_val_ptr var) (VID.gen_size var); + pr "@]@;"; + pr "}@;"; + pr "tab_%s++;@;" it_name; + pr "nb_%s++;" it_name; + pr "@]@;}"; + pr "@]@;}@;") vcs) var_params; - Format.fprintf oc "%a@;" - (generate_stmts dgfip_flags program var_indexes) - stmts; - Format.fprintf oc "env_restaurer(&%s);@;" rest_name; - Format.fprintf oc "@]}@;" - | SRaiseError (err, var_opt) -> - let err_name = Pos.unmark err.Mir.Error.name in + pr "%a@;" (generate_stmts dgfip_flags program) stmts; + pr "env_restaurer(&%s);@;" rest_name; + pr "@]}@;" + | RaiseError (m_err, var_opt) -> + let err = Pos.unmark m_err in + let err_name = Pos.unmark err.Com.Error.name in let code = match var_opt with - | Some var -> Format.sprintf "\"%s\"" var + | Some var -> Format.sprintf "\"%s\"" (Pos.unmark var) | None -> "NULL" in Format.fprintf oc "add_erreur(irdata, &erreur_%s, %s);@;" err_name code - | SCleanErrors -> Format.fprintf oc "nettoie_erreur(irdata);@;" - | SExportErrors -> Format.fprintf oc "exporte_erreur(irdata);@;" - | SFinalizeErrors -> Format.fprintf oc "finalise_erreur(irdata);@;" + | CleanErrors -> Format.fprintf oc "nettoie_erreur(irdata);@;" + | ExportErrors -> Format.fprintf oc "exporte_erreur(irdata);@;" + | FinalizeErrors -> Format.fprintf oc "finalise_erreur(irdata);@;" + | ComputeDomain _ | ComputeChaining _ | ComputeVerifs _ -> assert false -and generate_stmts (dgfip_flags : Dgfip_options.flags) (program : program) - (var_indexes : Dgfip_varid.var_id_map) (oc : Format.formatter) - (stmts : stmt list) = +and generate_stmts (dgfip_flags : Dgfip_options.flags) (program : Mir.program) + (oc : Format.formatter) (stmts : Mir.m_instruction list) = Format.fprintf oc "@["; - Format.pp_print_list (generate_stmt dgfip_flags program var_indexes) oc stmts; + Format.pp_print_list (generate_stmt dgfip_flags program) oc stmts; Format.fprintf oc "@]" -and generate_rov_function_header ~(definition : bool) (oc : Format.formatter) - (rov : rule_or_verif) = - let arg_type = if definition then "T_irdata *" else "" in - let tname, ret_type = - match rov.rov_code with - | Rule _ -> ("regle", "int ") - | Verif _ -> ("verif", "void ") - in - let ret_type = if definition then ret_type else "" in - Format.fprintf oc "%s%s_%s(%sirdata)%s" ret_type tname - (Pos.unmark rov.rov_name) arg_type - (if definition then "" else ";") +let generate_var_tmp_decls (oc : Format.formatter) (tf : Mir.target_data) = + let pr fmt = Format.fprintf oc fmt in + if tf.target_sz_tmps > 0 then ( + pr "@[{"; + pr "@;int i;"; + pr "@;T_varinfo *info;"; + pr "@;@[for (i = 0; i < %d; i++) {" tf.target_sz_tmps; + pr "@;irdata->def_tmps[irdata->tmps_org + i] = 0;"; + pr "@;irdata->tmps[irdata->tmps_org + i] = 0.0;"; + pr "@]@;}"; + pr "@;irdata->tmps_org = irdata->tmps_org + %d;" tf.target_sz_tmps; + StrMap.iter + (fun vn (var, _, sz_opt) -> + let loc_str = + Format.sprintf "irdata->tmps_org + (%d)" (Com.Var.loc_int var) + in + pr "@;info = &(irdata->info_tmps[%s]);" loc_str; + pr "@;info->name = \"%s\";" vn; + pr "@;info->alias = \"\";"; + pr "@;info->idx = %s;" loc_str; + (match sz_opt with + | None -> pr "@;info->size = 1;" + | Some i -> pr "@;info->size = %d;" i); + pr "@;info->cat = ID_TMP_VARS;"; + pr "@;info->loc_cat = EST_TEMPORAIRE;") + tf.target_tmp_vars; + pr "@]@;}"); + if tf.target_nb_refs > 0 then + pr "@;irdata->ref_org = irdata->ref_org + %d;" tf.target_nb_refs; + pr "@;" -let generate_rov_function (dgfip_flags : Dgfip_options.flags) - (program : program) (var_indexes : Dgfip_varid.var_id_map) - (oc : Format.formatter) (rov : rule_or_verif) = - let decl, ret = - let noprint _ _ = () in - match rov.rov_code with - | Rule _ -> (noprint, fun fmt () -> Format.fprintf fmt "@,return 0;") - | Verif _ -> - ((fun fmt () -> Format.fprintf fmt "register char cond;@;"), noprint) +let generate_function_prototype (add_semicolon : bool) (oc : Format.formatter) + (fd : Mir.target_data) = + let fn = Pos.unmark fd.target_name in + let pp_args fmt args = + List.iteri + (fun i _ -> Pp.fpr fmt ", char def_arg%d, double val_arg%d" i i) + args in - Format.fprintf oc "@[%a{@,%a%a%a@]@,}" - (generate_rov_function_header ~definition:true) - rov decl () - (generate_stmts (dgfip_flags : Dgfip_options.flags) program var_indexes) - (Bir.rule_or_verif_as_statements rov) - ret () - -let generate_rov_functions (dgfip_flags : Dgfip_options.flags) - (program : program) (var_indexes : Dgfip_varid.var_id_map) - (oc : Format.formatter) (rovs : rule_or_verif list) = - Format.fprintf oc "@["; - Format.pp_print_list ~pp_sep:Format.pp_print_cut - (generate_rov_function - (dgfip_flags : Dgfip_options.flags) - program var_indexes) - oc rovs; - Format.fprintf oc "@]" - -let generate_target_prototype (add_semicolon : bool) (return_type : bool) - (oc : Format.formatter) (function_name : string) = - let ret_type = if return_type then "struct S_discord *" else "void" in - Format.fprintf oc "%s %s(T_irdata* irdata)%s" ret_type function_name + Format.fprintf oc + "int %s(T_irdata* irdata, char *def_res, double *val_res%a)%s" fn pp_args + fd.Mir.target_args (if add_semicolon then ";" else "") -let generate_var_tmp_decls (oc : Format.formatter) - (tmp_vars : (Bir.variable * Pos.t * int option) StrMap.t) = - StrMap.iter - (fun vn (_, _, size) -> - let sz = match size with Some i -> i | None -> 1 in - Format.fprintf oc "char %s_def[%d];@,double %s_val[%d];@," vn sz vn sz) - tmp_vars; - if not (StrMap.is_empty tmp_vars) then Format.fprintf oc "@,"; - StrMap.iter - (fun vn (_, _, size) -> - match size with - | Some 1 | None -> - Format.fprintf oc "%s_def[0] = 0;@,%s_val[0] = 0.0;@," vn vn - | Some i -> - Format.fprintf oc "@[{@;"; - Format.fprintf oc "int i;@;"; - Format.fprintf oc "for (i = 0; i < %d; i++) {@;" i; - Format.fprintf oc "%s_def[i] = 0;@,%s_val[i] = 0.0;@," vn vn; - Format.fprintf oc "@]@;}@;"; - Format.fprintf oc "@]@;}@;") - tmp_vars; - if not (StrMap.is_empty tmp_vars) then Format.fprintf oc "@," - -let generate_target (dgfip_flags : Dgfip_options.flags) (program : Bir.program) - (var_indexes : Dgfip_varid.var_id_map) (oc : Format.formatter) - ((f, ret_type) : Bir.function_name * bool) = - let { tmp_vars; stmts; is_verif; _ } = Mir.TargetMap.find f program.targets in - Format.fprintf oc "@[%a{@,%a%s@\n%a%s@\n%s@]@,}@," - (generate_target_prototype false is_verif) - f generate_var_tmp_decls tmp_vars - (if dgfip_flags.flg_trace then "aff1(\"debut " ^ f ^ "\\n\") ;" else "") - (generate_stmts dgfip_flags program var_indexes) - stmts - (if dgfip_flags.flg_trace then "aff1(\"fin " ^ f ^ "\\n\") ;" else "") - (if ret_type then - {| -#ifdef FLG_MULTITHREAD - return irdata->discords; -#else - return discords; -#endif -|} - else "") +let generate_function (dgfip_flags : Dgfip_options.flags) + (program : Mir.program) (oc : Format.formatter) (fn : string) = + let pr fmt = Format.fprintf oc fmt in + let fd = Com.TargetMap.find fn program.program_functions in + pr "@[%a{@;" (generate_function_prototype false) fd; + pr "%a@;" generate_var_tmp_decls fd; + if dgfip_flags.flg_trace then pr "aff1(\"debut %s\\n\");@;" fn; + pr "%a@;" (generate_stmts dgfip_flags program) fd.target_prog; + if dgfip_flags.flg_trace then pr "aff1(\"fin %s\\n\");@;" fn; + pr "@;"; + if fd.target_nb_refs > 0 then + pr "irdata->ref_org = irdata->ref_org - %d;@;" fd.target_nb_refs; + if fd.target_sz_tmps > 0 then + pr "irdata->tmps_org = irdata->tmps_org - %d;@;" fd.target_sz_tmps; + pr "return 1;@]@;}@\n@\n" -let generate_targets (dgfip_flags : Dgfip_options.flags) (program : Bir.program) - (filemap : (out_channel * Format.formatter) StrMap.t) - (var_indexes : Dgfip_varid.var_id_map) = - let targets = Mir.TargetMap.bindings program.Bir.targets in +let generate_functions (dgfip_flags : Dgfip_options.flags) + (program : Mir.program) + (filemap : (out_channel * Format.formatter) StrMap.t) = + let functions = Com.TargetMap.bindings program.program_functions in List.iter - (fun (name, { is_verif; file; _ }) -> - let file_str = match file with Some s -> s | None -> "" in + (fun (name, Mir.{ target_file; _ }) -> + let file_str = match target_file with Some s -> s | None -> "" in let _, fmt = StrMap.find file_str filemap in - generate_target - (dgfip_flags : Dgfip_options.flags) - program var_indexes fmt (name, is_verif)) - targets + generate_function (dgfip_flags : Dgfip_options.flags) program fmt name) + functions -let generate_mpp_function_prototype (add_semicolon : bool) (return_type : bool) - (oc : Format.formatter) (function_name : Bir.function_name) = - let ret_type = if return_type then "struct S_discord *" else "void" in - Format.fprintf oc "%s %s(T_irdata* irdata)%s" ret_type function_name +let generate_target_prototype (add_semicolon : bool) (oc : Format.formatter) + (function_name : string) = + Format.fprintf oc "struct S_discord * %s(T_irdata* irdata)%s" function_name (if add_semicolon then ";" else "") -let generate_mpp_function (dgfip_flags : Dgfip_options.flags) - (program : Bir.program) (var_indexes : Dgfip_varid.var_id_map) - (oc : Format.formatter) ((f, ret_type) : Bir.function_name * bool) = - let { mppf_stmts; mppf_is_verif } = - Bir.FunctionMap.find f program.mpp_functions - in - Format.fprintf oc "@[%a{@,%a%s@]@,}@," - (generate_mpp_function_prototype false mppf_is_verif) - f - (generate_stmts dgfip_flags program var_indexes) - mppf_stmts - (if ret_type then - {| -#ifdef FLG_MULTITHREAD - return irdata->discords; -#else - return discords; -#endif -|} - else "") +let generate_target (dgfip_flags : Dgfip_options.flags) (program : Mir.program) + (oc : Format.formatter) (f : string) = + let pr fmt = Format.fprintf oc fmt in + let tf = Com.TargetMap.find f program.program_targets in + pr "@[%a{@;" (generate_target_prototype false) f; + pr "%a@;" generate_var_tmp_decls tf; + if dgfip_flags.flg_trace then pr "aff1(\"debut %s\\n\");@;" f; + pr "%a@;" (generate_stmts dgfip_flags program) tf.target_prog; + if dgfip_flags.flg_trace then pr "aff1(\"fin %s\\n\");@;" f; + pr "@;"; + if tf.target_nb_refs > 0 then + pr "irdata->ref_org = irdata->ref_org - %d;@;" tf.target_nb_refs; + if tf.target_sz_tmps > 0 then + pr "irdata->tmps_org = irdata->tmps_org - %d;@;" tf.target_sz_tmps; + pr "return irdata->discords;@]@;}@\n@\n" -let generate_mpp_functions (dgfip_flags : Dgfip_options.flags) - (program : Bir.program) (oc : Format.formatter) - (var_indexes : Dgfip_varid.var_id_map) = - let funcs = Bir.FunctionMap.bindings program.Bir.mpp_functions in +let generate_targets (dgfip_flags : Dgfip_options.flags) (program : Mir.program) + (filemap : (out_channel * Format.formatter) StrMap.t) = + let targets = Com.TargetMap.bindings program.program_targets in List.iter - (fun (fname, { mppf_is_verif; _ }) -> - generate_mpp_function - (dgfip_flags : Dgfip_options.flags) - program var_indexes oc (fname, mppf_is_verif)) - funcs - -let generate_rovs_files (dgfip_flags : Dgfip_options.flags) (program : program) - (folder : string) (vm : Dgfip_varid.var_id_map) = - let default_file = "default" in - let filemap = - ROVMap.fold - (fun _rov_id rov filemap -> - let file = - let pos = Pos.get_position rov.rov_name in - if pos = Pos.no_pos then default_file - else - (Pos.get_file pos |> Filename.basename |> Filename.remove_extension) - ^ ".c" - in - let filerovs = - match StrMap.find_opt file filemap with None -> [] | Some fr -> fr - in - StrMap.add file (rov :: filerovs) filemap) - program.rules_and_verifs StrMap.empty - in - StrMap.fold - (fun file rovs orphan -> - if String.equal file default_file then rovs @ orphan - else - let oc = open_out (Filename.concat folder file) in - let fmt = Format.formatter_of_out_channel oc in - Format.fprintf fmt - {| -#include -#include -#include "var.h" - -#ifndef FLG_MULTITHREAD -#define add_erreur(a,b,c) add_erreur(b,c) -#endif - -|}; - generate_rov_functions dgfip_flags program vm fmt rovs; - Format.fprintf fmt "@\n@."; - close_out oc; - orphan) - filemap [] + (fun (name, Mir.{ target_file; _ }) -> + let file_str = match target_file with Some s -> s | None -> "" in + let _, fmt = StrMap.find file_str filemap in + generate_target (dgfip_flags : Dgfip_options.flags) program fmt name) + targets let generate_implem_header oc msg = Format.fprintf oc {| @@ -754,25 +834,20 @@ let generate_implem_header oc msg = |} msg -let generate_c_program (dgfip_flags : Dgfip_options.flags) (program : program) - (filename : string) (vm : Dgfip_varid.var_id_map) : unit = +let generate_c_program (dgfip_flags : Dgfip_options.flags) + (program : Mir.program) (filename : string) : unit = if Filename.extension filename <> ".c" then Errors.raise_error (Format.asprintf "Output file should have a .c extension (currently %s)" filename); let folder = Filename.dirname filename in - let orphan_rovs = generate_rovs_files dgfip_flags program folder vm in let _oc = open_out filename in let oc = Format.formatter_of_out_channel _oc in - Format.fprintf oc "%a%a%a@\n@." generate_implem_header Prelude.message - (generate_rov_functions dgfip_flags program vm) - orphan_rovs - (generate_mpp_functions dgfip_flags program) - vm; + Format.fprintf oc "%a@\n@." generate_implem_header Prelude.message; let filemap = - Mir.TargetMap.fold - (fun _ t filemap -> - let file_str = match t.Bir.file with Some s -> s | None -> "" in + Com.TargetMap.fold + (fun _ (t : Mir.target_data) filemap -> + let file_str = match t.target_file with Some s -> s | None -> "" in let update = function | Some fmt -> Some fmt | None -> @@ -783,10 +858,11 @@ let generate_c_program (dgfip_flags : Dgfip_options.flags) (program : program) Some (oc, fmt) in StrMap.update file_str update filemap) - program.Bir.targets - (StrMap.singleton "" (_oc, oc)) + program.program_targets + (StrMap.one "" (_oc, oc)) in - generate_targets dgfip_flags program filemap vm; + generate_functions dgfip_flags program filemap; + generate_targets dgfip_flags program filemap; StrMap.iter (fun _ (oc, fmt) -> Format.fprintf fmt "\n@?"; diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.mli b/src/mlang/backend_compilers/bir_to_dgfip_c.mli index 7671022cc..6a6fa57d6 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.mli +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.mli @@ -21,8 +21,4 @@ of the output, is built in {!DecoupledExpr}. *) val generate_c_program : - Dgfip_options.flags -> - Bir.program -> - (* filename *) string -> - Dgfip_varid.var_id_map -> - unit + Dgfip_options.flags -> Mir.program -> (* filename *) string -> unit diff --git a/src/mlang/backend_compilers/bir_to_java.ml b/src/mlang/backend_compilers/bir_to_java.ml deleted file mode 100644 index 170d49ef6..000000000 --- a/src/mlang/backend_compilers/bir_to_java.ml +++ /dev/null @@ -1,453 +0,0 @@ -(* Copyright (C) 2021 Inria, contributor: James Barnes - - - 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 Bir - -let java_imports : string = - {| -package com.mlang; - -import java.util.ArrayList; -import java.util.HashMap; -import java.util.Map; -import java.util.List; - -import static com.mlang.MValue.*; -|} - -let none_value = "MValue.mUndefined" - -let generate_comp_op (op : Mast.comp_op) : string = - match op with - | Mast.Gt -> "mGreaterThan" - | Mast.Gte -> "mGreaterThanEqual" - | Mast.Lt -> "mLessThan" - | Mast.Lte -> "mLessThanEqual" - | Mast.Eq -> "mEqual" - | Mast.Neq -> "mNotEqual" - -let generate_binop (op : Mast.binop) : string = - match op with - | Mast.And -> "mAnd" - | Mast.Or -> "mOr" - | Mast.Add -> "mAdd" - | Mast.Sub -> "mSubtract" - | Mast.Mul -> "mMultiply" - | Mast.Div -> "mDivide" - -let generate_unop (op : Mast.unop) : string = - match op with Mast.Not -> "mNot" | Mast.Minus -> "mNeg" - -let generate_var_name (var : variable) : string = - let v = Pos.unmark (Bir.var_to_mir var).Mir.Variable.name in - String.uppercase_ascii v - -let format_var_name (fmt : Format.formatter) (var : variable) : unit = - Format.fprintf fmt "%s" (generate_var_name var) - -let generate_name (v : variable) : string = - let v = Bir.var_to_mir v in - match v.alias with Some v -> v | None -> Pos.unmark v.Mir.Variable.name - -let print_double_cut oc () = Format.fprintf oc "@,@," - -let get_var_pos (var : variable) : int = var.Bir.offset - -let get_tgv_position (var : variable) : string = - Format.asprintf "tgv[%d /* %s */]" (get_var_pos var) (generate_var_name var) - -let rec generate_java_expr (e : expression Pos.marked) : - string * (Mir.LocalVariable.t * expression Pos.marked) list = - match Pos.unmark e with - | Comparison (op, e1, e2) -> - let se1, s1 = generate_java_expr e1 in - let se2, s2 = generate_java_expr e2 in - let se3, s3 = - ( Format.asprintf "%s(%s, %s)" (generate_comp_op (Pos.unmark op)) se1 se2, - s1 @ s2 ) - in - (se3, s3) - | Binop (op, e1, e2) -> - let se1, s1 = generate_java_expr e1 in - let se2, s2 = generate_java_expr e2 in - let se3, s3 = - ( Format.asprintf "%s(%s, %s)" (generate_binop (Pos.unmark op)) se1 se2, - s1 @ s2 ) - in - (se3, s3) - | Unop (op, e) -> - let se, s = generate_java_expr e in - let se2, s2 = (Format.asprintf "%s(%s)" (generate_unop op) se, s) in - (se2, s2) - | Index (var, e) -> - let se, s = generate_java_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 - let se2, s2 = - ( Format.asprintf "m_array_index(tgv, %d ,%s, %d)" - (get_var_pos unmarked_var) se size, - s ) - in - (se2, s2) - | Conditional (e1, e2, e3) -> - let se1, s1 = generate_java_expr e1 in - let se2, s2 = generate_java_expr e2 in - let se3, s3 = generate_java_expr e3 in - let se4, s4 = - (Format.asprintf "m_cond(%s, %s, %s)" se1 se2 se3, s1 @ s2 @ s3) - in - (se4, s4) - | FunctionCall (PresentFunc, [ arg ]) -> - let se, s = generate_java_expr arg in - let se2, s2 = (Format.asprintf "mPresent(%s)" se, s) in - (se2, s2) - | FunctionCall (NullFunc, [ arg ]) -> - let se, s = generate_java_expr arg in - let se2, s2 = (Format.asprintf "m_null(%s)" se, s) in - (se2, s2) - | FunctionCall (ArrFunc, [ arg ]) -> - let se, s = generate_java_expr arg in - let se2, s2 = (Format.asprintf "m_round(%s)" se, s) in - (se2, s2) - | FunctionCall (InfFunc, [ arg ]) -> - let se, s = generate_java_expr arg in - let se2, s2 = (Format.asprintf "m_floor(%s)" se, s) in - (se2, s2) - | FunctionCall (AbsFunc, [ arg ]) -> - let se, s = generate_java_expr arg in - let se2, s2 = (Format.asprintf "m_abs(%s)" se, s) in - (se2, s2) - | FunctionCall (MaxFunc, [ e1; e2 ]) -> - let se1, s1 = generate_java_expr e1 in - let se2, s2 = generate_java_expr e2 in - let se3, s3 = (Format.asprintf "m_max(%s, %s)" se1 se2, s1 @ s2) in - (se3, s3) - | FunctionCall (MinFunc, [ e1; e2 ]) -> - let se1, s1 = generate_java_expr e1 in - let se2, s2 = generate_java_expr e2 in - let se3, s3 = (Format.asprintf "m_min(%s, %s)" se1 se2, s1 @ s2) in - (se3, s3) - | FunctionCall (Multimax, [ e1; (Var v2, _) ]) -> - let se1, s1 = generate_java_expr e1 in - let se2, s2 = - (Format.asprintf "m_multimax(%s, tgv, %d)" se1 (get_var_pos v2), []) - in - (se2, s1 @ s2) - | FunctionCall _ -> assert false (* should not happen *) - | Literal (Float f) -> ( - match f with - | 0. -> (Format.asprintf "MValue.zero", []) - | 1. -> (Format.asprintf "MValue.one", []) - | _ -> (Format.asprintf "new MValue(%s)" (string_of_float f), [])) - | Literal Undefined -> (Format.asprintf "%s" none_value, []) - | Var var -> (get_tgv_position var, []) - | LocalVar lvar -> - (Format.asprintf "localVariables[%d]" lvar.Mir.LocalVariable.id, []) - | LocalLet (lvar, e1, e2) -> - let _, s1 = generate_java_expr e1 in - let se2, s2 = generate_java_expr e2 in - let se3, s3 = (Format.asprintf "%s" se2, s1 @ ((lvar, e1) :: s2)) in - (se3, s3) - | Attribut _ | Size _ | NbAnomalies | NbDiscordances | NbInformatives - | NbBloquantes -> - Errors.raise_spanned_error "not yet implemented !!!" (Pos.get_position e) - | NbCategory _ -> assert false - -let format_local_vars_defs (oc : Format.formatter) - (defs : (Mir.LocalVariable.t * expression Pos.marked) list) = - Format.pp_print_list - (fun fmt (lvar, expr) -> - let se, _ = generate_java_expr expr in - Format.fprintf fmt "localVariables[%d] = %s;" lvar.Mir.LocalVariable.id se) - oc defs - -let generate_var_def (var : variable) (def : variable_def) - (oc : Format.formatter) = - match def with - | SimpleVar e -> - let se, defs = generate_java_expr e in - Format.fprintf oc "%a%s = %s;" format_local_vars_defs defs - (get_tgv_position var) se - | TableVar (_, IndexTable es) -> - Format.fprintf oc "%a" - (fun fmt -> - Mir.IndexMap.iter (fun i v -> - let sv, defs = generate_java_expr v in - Format.fprintf fmt "%atgv[%d /* %a */] = %s;" - format_local_vars_defs defs - (get_var_pos var |> ( + ) i) - format_var_name var sv)) - es - | TableVar (_size, IndexGeneric (v, e)) -> - let se, s = generate_java_expr e in - Format.fprintf oc - "if(!%s.isUndefined())@[{@ %atgv[%d/* %a */ + \ - (int)%s.getValue()] = %s;@] }@," - (get_tgv_position v) format_local_vars_defs s (get_var_pos var) - format_var_name var (get_tgv_position v) se - | InputVar -> assert false - -let generate_input_handling (oc : Format.formatter) (_split_threshold : int) = - let input_methods_count = ref 0 in - let print_input fmt var = - Format.fprintf fmt - "%s = inputVariables.get(\"%s\") != null ? inputVariables.get(\"%s\") : \ - MValue.mUndefined;" - (get_tgv_position var) (generate_name var) (generate_name var) - in - let _print_method fmt inputs = - Format.fprintf fmt - "@[private static void loadInputVariables_%d(MapinputVariables, MValue[] tgv) {@,\ - %a@]@,\ - }@," - !input_methods_count - (Format.pp_print_list print_input) - inputs; - input_methods_count := !input_methods_count + 1 - in - let load_calls = List.init !input_methods_count (fun i -> i) in - let print_call oc i = - Format.fprintf oc "loadInputVariables_%d(inputVariables, tgv);" i - in - Format.fprintf oc - "@,\ - @[static void loadInputVariables(Map \ - inputVariables, MValue[] tgv) {@,\ - %a@]@,\ - }" - (Format.pp_print_list print_call) - load_calls - -let fresh_cond_counter = ref 0 - -let generate_rov_header (oc : Format.formatter) (rov : rule_or_verif) = - let tname = match rov.rov_code with Rule _ -> "rule" | Verif _ -> "verif" in - Format.fprintf oc "Rule.m_%s_%s(mCalculation, calculationErrors);" tname - (Pos.unmark rov.rov_name) - -let rec generate_stmts (program : program) (oc : Format.formatter) - (stmts : stmt list) = - Format.pp_print_list (generate_stmt program) oc stmts - -and generate_stmt (program : program) (oc : Format.formatter) (stmt : stmt) : - unit = - match Pos.unmark stmt with - | SRovCall r -> - let rov = ROVMap.find r program.rules_and_verifs in - generate_rov_header oc rov - | SAssign (var, vdata) -> generate_var_def var vdata oc - | SConditional (cond, 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_%d" fname (Pos.get_start_line pos) - (Pos.get_start_column pos) (Pos.get_end_line pos) - (Pos.get_end_column pos) !fresh_cond_counter - in - fresh_cond_counter := !fresh_cond_counter + 1; - Format.fprintf oc - "MValue %s = %s;@,@[if (m_is_defined_true(%s)) {@,%a@]@,}" - cond_name - (let s, _ = generate_java_expr (Pos.same_pos_as cond stmt) in - s) - cond_name (generate_stmts program) tt; - Format.fprintf oc " @[if (m_is_defined_false(%s)) {@,%a@]@,}" - cond_name (generate_stmts program) ff - | SVerifBlock s -> generate_stmts program oc s - | SFunctionCall (f, _) -> - Format.fprintf oc "MppFunction.%s(mCalculation, calculationErrors);" f - | SPrint (std, args) -> - let print_std = - match std with - | Mast.StdOut -> "System.out" - | Mast.StdErr -> "System.err" - in - List.iter - (function - | Mir.PrintString s -> - Format.fprintf oc "%s(\"%%s\", %s);@," print_std s - | Mir.PrintName ((_, pos), _) | Mir.PrintAlias ((_, pos), _) -> - Errors.raise_spanned_error "not implemented yet !!!" pos - | Mir.PrintIndent _e -> - Errors.raise_spanned_error "not implemented yet !!!" - (Pos.get_position stmt) - | Mir.PrintExpr (e, _, _) -> - Format.fprintf oc "cond = %s;@,%s(\"%%s\", cond.toString());@," - (fst (generate_java_expr e)) - print_std) - args - | SIterate _ -> - Errors.raise_spanned_error "iterators not implemented in Java" - (Pos.get_position stmt) - | SRestore _ -> - Errors.raise_spanned_error "restorators not implemented in Java" - (Pos.get_position stmt) - | SRaiseError _ | SCleanErrors | SExportErrors | SFinalizeErrors -> - Errors.raise_spanned_error "errors not implemented in Java" - (Pos.get_position stmt) - -let generate_return (oc : Format.formatter) (_x : 'a) = - let returned_variables = [] in - let print_outputs oc returned_variables = - Format.pp_print_list - (fun oc var -> - Format.fprintf oc "outputVariables.put(\"%a\",%s);" format_var_name var - (get_tgv_position var)) - oc returned_variables - in - Format.fprintf oc - "@[private static Map loadOutputVariables(MValue[] \ - tgv) {@,\ - Map outputVariables = new HashMap<>();@,\ - @,\ - %a@,\ - return outputVariables;@]@,\ - }" - print_outputs returned_variables - -let generate_rov_method (program : program) (oc : Format.formatter) - (rov : rule_or_verif) = - let tname, stmts = - match rov.rov_code with - | Rule stmts -> ("rule", stmts) - | Verif stmt -> ("verif", [ stmt ]) - in - Format.fprintf oc - "@[static void m_%s_%s(MCalculation mCalculation, List \ - calculationErrors) {@,\ - MValue cond = MValue.mUndefined;@,\ - MValue[] tgv = mCalculation.getCalculationVariables();@,\ - MValue[] localVariables = mCalculation.getLocalVariables();@,\ - Map> tableVariables = \ - mCalculation.getTableVariables();@,\ - %a@]@,\ - }" - tname (Pos.unmark rov.rov_name) (generate_stmts program) stmts - -let generate_rov_methods (oc : Format.formatter) (program : program) : unit = - let rovs = ROVMap.bindings program.rules_and_verifs in - let _, rovs = List.split rovs in - Format.pp_print_list ~pp_sep:print_double_cut - (generate_rov_method program) - oc rovs - -let generate_calculateTax_method (calculation_vars_len : int) - (program : program) (locals_size : int) (oc : Format.formatter) () = - Format.fprintf oc - "@[/**@,\ - * Main calculation method for determining tax @,\ - * @param inputVariables Map of variables to be used for calculation, the \ - key is the variable name and the value is the variable value@,\ - * @return Map of variables returned after calculation, the key is the \ - variable name and the value is the variable value@,\ - */@,\ - @[public static MOutput calculateTax(Map \ - inputVariables) {@,\ - return calculateTax(inputVariables, 0);@]@,\ - }%a@[public static MOutput calculateTax(Map \ - inputVariables, int maxAnomalies) {@,\ - MValue cond = MValue.mUndefined;@,\ - List calculationErrors = new ArrayList<>();@,\ - MValue[] tgv = new MValue[%d];@,\ - MValue[] localVariables = new MValue[%d];@,\ - MCalculation mCalculation = new MCalculation(tgv, localVariables, \ - maxAnomalies);%a@[for (int i = 0; i < localVariables.length; i++) \ - {@,\ - localVariables[i] = mUndefined;@]@,\ - }%a@[for (int i = 0; i < tgv.length; i++) {@,\ - tgv[i] = mUndefined;@]@,\ - }%aInputHandler.loadInputVariables(inputVariables, \ - mCalculation.getCalculationVariables());@,\ - %a@,\ - Map outputVariables = \ - loadOutputVariables(mCalculation.getCalculationVariables());@,\ - return new MOutput(outputVariables, calculationErrors);@]@,\ - }@]@,\ - @," - print_double_cut () calculation_vars_len locals_size print_double_cut () - print_double_cut () print_double_cut () (generate_stmts program) - (Bir.main_statements program) - -let generate_mpp_function (program : program) (oc : Format.formatter) - (f : function_name) = - let { mppf_stmts; _ } = FunctionMap.find f program.mpp_functions in - Format.fprintf oc - "@[static void %s(MCalculation mCalculation, List \ - calculationErrors) {@,\ - MValue cond = MValue.mUndefined;@,\ - MValue[] tgv = mCalculation.getCalculationVariables();@,\ - MValue[] localVariables = mCalculation.getLocalVariables();@,\ - Map> tableVariables = \ - mCalculation.getTableVariables();@,\ - %a@]@,\ - }" - f (generate_stmts program) mppf_stmts - -let generate_mpp_functions (oc : Format.formatter) (program : program) = - let functions = FunctionMap.bindings program.Bir.mpp_functions in - let function_names, _ = List.split functions in - Format.pp_print_list ~pp_sep:print_double_cut - (generate_mpp_function program) - oc function_names - -let generate_main_class (program : program) (var_table_size : int) - (locals_size : int) (fmt : Format.formatter) (filename : string) = - let class_name = - String.split_on_char '.' filename |> List.hd |> String.split_on_char '/' - |> fun list -> List.nth list (List.length list - 1) - in - Format.fprintf fmt - "@[// %s@,\ - %s@,\ - /**@,\ - * Main class containing calculation logic@,\ - */@,\ - @[public class %s {@,\ - @,\ - %a%a@]@]@,\ - }" - Prelude.message java_imports class_name - (generate_calculateTax_method var_table_size program locals_size) - () generate_return [] - -let generate_java_program (program : program) - (filename : string) : unit = - let split_treshold = 100 in - let _oc = open_out filename 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 - let program = Bir.squish_statements program split_treshold "java_rule_" in - Format.fprintf oc - "@[%a%a\ - @[class InputHandler {@,%a@]@,}%a\ - @[class MppFunction {@,%a@]@,}%a\ - @[class Rule {@,%a@]@,}@]@." - (generate_main_class program var_table_size locals_size) filename - print_double_cut () - generate_input_handling split_treshold - print_double_cut () - generate_mpp_functions program - print_double_cut () - generate_rov_methods program; - close_out _oc[@@ocamlformat "disable"] diff --git a/src/mlang/backend_compilers/bir_to_java.mli b/src/mlang/backend_compilers/bir_to_java.mli deleted file mode 100644 index 3f1680258..000000000 --- a/src/mlang/backend_compilers/bir_to_java.mli +++ /dev/null @@ -1,17 +0,0 @@ -(* Copyright (C) 2021 Inria, contributor: James Barnes - - - 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 generate_java_program : Bir.program -> string -> unit diff --git a/src/mlang/backend_compilers/decoupledExpr.ml b/src/mlang/backend_compilers/decoupledExpr.ml index 7c7d11d7a..6a970e3a8 100644 --- a/src/mlang/backend_compilers/decoupledExpr.ml +++ b/src/mlang/backend_compilers/decoupledExpr.ml @@ -1,42 +1,42 @@ +module VID = Dgfip_varid + type offset = | GetValueConst of int | GetValueExpr of string - | GetValueVar of Bir.variable + | GetValueVar of Com.Var.t | PassPointer | None -let rec generate_variable (vm : Dgfip_varid.var_id_map) (offset : offset) - ?(def_flag = false) ?(trace_flag = false) (var : Bir.variable) : string = - let mvar = Bir.var_to_mir var in +let rec generate_variable (offset : offset) ?(def_flag = false) + ?(trace_flag = false) (var : Com.Var.t) : string = try match offset with | PassPointer -> - if def_flag then Dgfip_varid.gen_access_def_pointer vm mvar - else Dgfip_varid.gen_access_pointer vm mvar + if def_flag then VID.gen_def_ptr var else VID.gen_val_ptr var | _ -> let offset = match offset with | None -> "" - | GetValueVar offset -> " + (int)" ^ generate_variable vm None offset + | GetValueVar offset -> " + (int)" ^ generate_variable None offset | GetValueConst offset -> " + " ^ string_of_int offset | GetValueExpr offset -> Format.sprintf " + (%s)" offset | PassPointer -> assert false in - if def_flag then Dgfip_varid.gen_access_def vm mvar offset + if def_flag then VID.gen_def var offset else - let access_val = Dgfip_varid.gen_access_val vm mvar offset in + let access_val = VID.gen_val var offset in (* When the trace flag is present, we print the value of the non-temporary variable being used *) - if trace_flag && not mvar.Mir.Variable.is_temp then - let vn = Pos.unmark mvar.Mir.Variable.name in - let pos_tgv = Dgfip_varid.gen_access_pos_from_start vm mvar in + if trace_flag && not (Com.Var.is_temp var) then + let vn = Pos.unmark var.Com.Var.name in + let pos_tgv = VID.gen_pos_from_start var in Format.asprintf "(aff3(\"%s\",irdata, %s), %s)" vn pos_tgv access_val else access_val with Not_found -> Errors.raise_error (Format.asprintf "Variable %s not found in TGV" - (Pos.unmark mvar.Mir.Variable.name)) + (Pos.unmark var.Com.Var.name)) type local_var = | Anon (* inlined sub-expression, not intended for reuse *) @@ -68,17 +68,22 @@ and expr = | Dunop of string * expr | Dbinop of string * expr * expr | Dfun of string * expr list - | Daccess of Bir.variable * dflag * expr + | Daccess of Com.Var.t * dflag * expr | Dite of expr * expr * expr | Dinstr of string + | DlowLevel of string -and expr_var = Local of stack_slot | M of Bir.variable * offset * dflag +and expr_var = Local of stack_slot | M of Com.Var.t * offset * dflag and t = expr * dflag * local_vars and constr = local_stacks -> local_vars -> t -type expression_composition = { def_test : constr; value_comp : constr } +type expression_composition = { + set_vars : (dflag * string * constr) list; + def_test : constr; + value_comp : constr; +} type stack_position = Not_to_stack | Must_be_pushed | On_top of dflag @@ -131,6 +136,7 @@ let rec expr_position (expr : expr) (st : local_stacks) = (* Needed to bumb the stack to avoid erasing subexpressions *) | _, _ -> Not_to_stack (* Either already stored, or duplicatable *) end + | DlowLevel _ -> Not_to_stack | _ -> Must_be_pushed (* allocate to local variable if necessary *) @@ -176,9 +182,16 @@ let push (stacks : local_stacks) (ctx : local_vars) (constr : constr) = (** smart constructors *) -let locals_from_m (lvar : Mir.local_variable) = - ( Refered (-(2 * lvar.Mir.LocalVariable.id)), - Refered (-((2 * lvar.Mir.LocalVariable.id) + 1)) ) +let locals_from_m = + let counter = ref 0 in + let fresh_id () = + let v = !counter in + counter := !counter + 1; + v + in + fun () -> + let lvar_id = fresh_id () in + (Refered (-(2 * lvar_id)), Refered (-((2 * lvar_id) + 1))) let new_local : unit -> local_var = let c = ref 0 in @@ -199,7 +212,7 @@ let dfalse _stacks _lv : t = (Dfalse, Def, []) let lit (f : float) _stacks _lv : t = (Dlit f, Val, []) -let m_var (v : Bir.variable) (offset : offset) (df : dflag) _stacks _lv : t = +let m_var (v : Com.Var.t) (offset : offset) (df : dflag) _stacks _lv : t = (Dvar (M (v, offset, df)), df, []) let local_var (lvar : local_var) (stacks : local_stacks) (ctx : local_vars) : t @@ -306,13 +319,13 @@ let comp op (e1 : constr) (e2 : constr) (stacks : local_stacks) (ctx : local_vars) : t = let stacks', lv1, e1 = push_with_kind stacks ctx Val e1 in let _, lv2, e2 = push_with_kind stacks' ctx Val e2 in - let comp (o : Mast.comp_op) = + let comp (o : Com.comp_op) = match (e1, e2) with | Dlit f1, Dlit f2 -> if - Bir_interpreter.FloatDefInterp.compare_numbers o - (Bir_number.RegularFloatNumber.of_float f1) - (Bir_number.RegularFloatNumber.of_float f2) + Mir_interpreter.FloatDefInterp.compare_numbers o + (Mir_number.RegularFloatNumber.of_float f1) + (Mir_number.RegularFloatNumber.of_float f2) then Dtrue else Dfalse | Dvar v1, Dvar v2 -> @@ -321,12 +334,12 @@ let comp op (e1 : constr) (e2 : constr) (stacks : local_stacks) in let e = match op with - | "==" -> comp Mast.Eq - | "!=" -> comp Mast.Neq - | "<=" -> comp Mast.Lte - | "<" -> comp Mast.Lt - | ">=" -> comp Mast.Gte - | ">" -> comp Mast.Gt + | "==" -> comp Com.Eq + | "!=" -> comp Com.Neq + | "<=" -> comp Com.Lte + | "<" -> comp Com.Lt + | ">=" -> comp Com.Gte + | ">" -> comp Com.Gt | _ -> assert false in (e, Def, lv2 @ lv1) @@ -346,8 +359,11 @@ let dfun (f : string) (args : constr list) (stacks : local_stacks) let dinstr (i : string) (_stacks : local_stacks) (_ctx : local_vars) : t = (Dinstr i, Val, []) -let access (var : Bir.variable) (df : dflag) (e : constr) - (stacks : local_stacks) (ctx : local_vars) : t = +let dlow_level (i : string) (_stacks : local_stacks) (_ctx : local_vars) : t = + (DlowLevel i, Val, []) + +let access (var : Com.Var.t) (df : dflag) (e : constr) (stacks : local_stacks) + (ctx : local_vars) : t = let _, lv, e = push_with_kind stacks ctx Val e in (Daccess (var, df, e), df, lv) @@ -385,24 +401,33 @@ let it0 (c : constr) (t : constr) (stacks : local_stacks) (ctx : local_vars) : t | _ -> (Dite (c, t, e), tkind, lvt @ lvc) let build_transitive_composition ?(safe_def = false) - ({ def_test; value_comp } : expression_composition) : expression_composition - = + ({ set_vars; def_test; value_comp } : expression_composition) : + expression_composition = (* `safe_def` can be set on call when we are sure that `value_comp` will always happen to be zero when `def_test` ends up false. E.g. arithmetic operation have such semantic property (funny question is what's the causality ?). This allows to remove a check to the definition flag when we compute the value, avoiding a lot of unnecessary code. *) let value_comp = if safe_def then value_comp else it0 def_test value_comp in - { def_test; value_comp } + { set_vars; def_test; value_comp } type local_decls = int * int (* in practice, stacks sizes *) (* evaluate a complete (AKA, context free) expression. Not to be used for further construction. *) -let build_expression (expr_comp : expression_composition) : local_decls * t * t - = +let build_expression (expr_comp : expression_composition) : + local_decls * (dflag * string * t) list * t * t = let empty_stacks = { def_top = 0; val_top = 0; var_substs = [] } in let empty_locals = [] in + let set_tests = + List.map + (fun (kd, vn, constr) -> + (kd, vn, collapse_constr empty_stacks empty_locals constr)) + expr_comp.set_vars + in + let set_locals = + List.concat (List.map (fun (_, _, (_, _, locals)) -> locals) set_tests) + in let ((_, _, def_locals) as def_test) = collapse_constr empty_stacks empty_locals expr_comp.def_test in @@ -416,27 +441,25 @@ let build_expression (expr_comp : expression_composition) : local_decls * t * t | Def -> (max slot.depth def_s, val_s) | Val -> (def_s, max slot.depth val_s)) (-1, -1) - (def_locals @ value_locals) + (set_locals @ def_locals @ value_locals) in - (stacks_size, def_test, value_comp) + (stacks_size, set_tests, def_test, value_comp) let format_slot fmt ({ kind; depth } : stack_slot) = let kind = match kind with Def -> "int" | Val -> "real" in Format.fprintf fmt "%s%d" kind depth -let format_expr_var (dgfip_flags : Dgfip_options.flags) - (vm : Dgfip_varid.var_id_map) fmt (ev : expr_var) = +let format_expr_var (dgfip_flags : Dgfip_options.flags) fmt (ev : expr_var) = match ev with | Local slot -> format_slot fmt slot | M (var, offset, df) -> let def_flag = df = Def in Format.fprintf fmt "%s" - (generate_variable ~trace_flag:dgfip_flags.flg_trace vm offset ~def_flag + (generate_variable ~trace_flag:dgfip_flags.flg_trace offset ~def_flag var) -let rec format_dexpr (dgfip_flags : Dgfip_options.flags) - (vm : Dgfip_varid.var_id_map) fmt (de : expr) = - let format_dexpr = format_dexpr dgfip_flags vm in +let rec format_dexpr (dgfip_flags : Dgfip_options.flags) fmt (de : expr) = + let format_dexpr = format_dexpr dgfip_flags in match de with | Dtrue -> Format.fprintf fmt "1" | Dfalse -> Format.fprintf fmt "0" @@ -448,7 +471,7 @@ let rec format_dexpr (dgfip_flags : Dgfip_options.flags) | _ -> (* Print literal floats as precisely as possible *) Format.fprintf fmt "%#.19g" f) - | Dvar evar -> format_expr_var dgfip_flags vm fmt evar + | Dvar evar -> format_expr_var dgfip_flags fmt evar | Dand (de1, de2) -> Format.fprintf fmt "@[(%a@ && %a@])" format_dexpr de1 format_dexpr de2 @@ -486,11 +509,11 @@ let rec format_dexpr (dgfip_flags : Dgfip_options.flags) ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") format_dexpr) des - | Dinstr instr -> Format.fprintf fmt "%s" instr + | Dinstr instr | DlowLevel instr -> Format.fprintf fmt "%s" instr | Daccess (var, dflag, de) -> Format.fprintf fmt "(%s[(int)%a])" (generate_variable ~def_flag:(dflag = Def) - ~trace_flag:dgfip_flags.flg_trace vm PassPointer var) + ~trace_flag:dgfip_flags.flg_trace PassPointer var) format_dexpr de | Dite (dec, det, dee) -> Format.fprintf fmt "@[(%a ?@ %a@ : %a@])" format_dexpr dec @@ -506,21 +529,28 @@ let rec format_local_declarations fmt format_local_declarations fmt (def_stk_size, val_stk_size - 1)) else () -let format_local_vars_defs (dgfip_flags : Dgfip_options.flags) - (vm : Dgfip_varid.var_id_map) fmt (lv : local_vars) = +let format_local_vars_defs (dgfip_flags : Dgfip_options.flags) fmt + (lv : local_vars) = let lv = List.rev lv in let format_one_assign fmt (_, { slot; subexpr }) = Format.fprintf fmt "@[%a =@ %a;@]@," format_slot slot - (format_dexpr dgfip_flags vm) - subexpr + (format_dexpr dgfip_flags) subexpr in List.iter (format_one_assign fmt) lv -let format_assign (dgfip_flags : Dgfip_options.flags) - (var_indexes : Dgfip_varid.var_id_map) (var : string) fmt +let format_assign (dgfip_flags : Dgfip_options.flags) (var : string) fmt ((e, _kind, lv) : t) = Format.fprintf fmt "%a@[%s =@ %a;@]" - (format_local_vars_defs dgfip_flags var_indexes) - lv var - (format_dexpr dgfip_flags var_indexes) - e + (format_local_vars_defs dgfip_flags) + lv var (format_dexpr dgfip_flags) e + +let format_set_vars (dgfip_flags : Dgfip_options.flags) fmt + (set_vars : (dflag * string * t) list) = + List.iter + (fun ((kd, vn, _expr) : dflag * string * t) -> + Pp.fpr fmt "%s %s;@;" (match kd with Def -> "char" | Val -> "double") vn) + set_vars; + List.iter + (fun ((_kd, vn, expr) : dflag * string * t) -> + Pp.fpr fmt "%a@;" (format_assign dgfip_flags vn) expr) + set_vars diff --git a/src/mlang/backend_compilers/decoupledExpr.mli b/src/mlang/backend_compilers/decoupledExpr.mli index 4904bf5e8..d76f679b3 100644 --- a/src/mlang/backend_compilers/decoupledExpr.mli +++ b/src/mlang/backend_compilers/decoupledExpr.mli @@ -1,17 +1,12 @@ type offset = | GetValueConst of int | GetValueExpr of string - | GetValueVar of Bir.variable + | GetValueVar of Com.Var.t | PassPointer | None val generate_variable : - Dgfip_varid.var_id_map -> - offset -> - ?def_flag:bool -> - ?trace_flag:bool -> - Bir.variable -> - string + offset -> ?def_flag:bool -> ?trace_flag:bool -> Com.Var.t -> string type dflag = Def | Val @@ -33,7 +28,7 @@ type dflag = Def | Val type local_var (** Variable local to the computed expression *) -val locals_from_m : Mir.LocalVariable.t -> local_var * local_var +val locals_from_m : unit -> local_var * local_var (** Return a couple of local variable from a MIR one, for defineness and valuation in this order. *) @@ -67,7 +62,7 @@ val dfalse : constr val lit : float -> constr (** Float literal *) -val m_var : Bir.variable -> offset -> dflag -> constr +val m_var : Com.Var.t -> offset -> dflag -> constr (** Value from TGV. [m_var v off df] represents an access to the TGV variable [v] with [df] to read defineness or valuation. [off] is the access type for M array, and should be [None] most of the time. For array access, see @@ -114,7 +109,10 @@ val dfun : string -> constr list -> constr val dinstr : string -> constr (** Direct instruction *) -val access : Bir.variable -> dflag -> constr -> constr +val dlow_level : string -> constr +(** Direct instruction, not pushed *) + +val access : Com.Var.t -> dflag -> constr -> constr (** Arbitrary access to M TGV variable. Either defineness of valuation *) val ite : constr -> constr -> constr -> constr @@ -126,7 +124,11 @@ val ite : constr -> constr -> constr -> constr (** While {!constr} is the expression language for decoupled values, the following represents complete and optimized expressions for M computations *) -type expression_composition = { def_test : constr; value_comp : constr } +type expression_composition = { + set_vars : (dflag * string * constr) list; + def_test : constr; + value_comp : constr; +} (** Representation of an M computation in construction. [def_test] for the defineness flag, and [value_comp] for the actual valuation. *) @@ -148,15 +150,14 @@ val is_always_true : t -> bool type local_decls (** Representation of local variables existing in an expression *) -val build_expression : expression_composition -> local_decls * t * t +val build_expression : + expression_composition -> local_decls * (dflag * string * t) list * t * t (** Crush {!constr} values into closed expressions {!t} *) val format_local_declarations : Format.formatter -> local_decls -> unit val format_assign : - Dgfip_options.flags -> - Dgfip_varid.var_id_map -> - string -> - Format.formatter -> - t -> - unit + Dgfip_options.flags -> string -> Format.formatter -> t -> unit + +val format_set_vars : + Dgfip_options.flags -> Format.formatter -> (dflag * string * t) list -> unit diff --git a/src/mlang/backend_compilers/dgfip_gen_files.ml b/src/mlang/backend_compilers/dgfip_gen_files.ml index d09965b00..398300547 100644 --- a/src/mlang/backend_compilers/dgfip_gen_files.ml +++ b/src/mlang/backend_compilers/dgfip_gen_files.ml @@ -14,32 +14,6 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -let ascii_to_ebcdic = - [| - 0; 1; 2; 3; 55; 45; 46; 47; 22; 5; 37; 11; 12; 13; 14; 15; - 16; 17; 18; 19; 60; 61; 50; 38; 24; 25; 63; 39; 28; 29; 30; 31; - 64; 79; 127; 123; 91; 108; 80; 125; 77; 93; 92; 78; 107; 96; 75; 97; - 240; 241; 242; 243; 244; 245; 246; 247; 248; 249; 122; 94; 76; 126; 110; 111; - 124; 193; 194; 195; 196; 197; 198; 199; 200; 201; 209; 210; 211; 212; 213; 214; - 215; 216; 217; 226; 227; 228; 229; 230; 231; 232; 233; 74; 224; 90; 95; 109; - 121; 129; 130; 131; 132; 133; 134; 135; 136; 137; 145; 146; 147; 148; 149; 150; - 151; 152; 153; 162; 163; 164; 165; 166; 167; 168; 169; 192; 106; 208; 161; - |][@@ocamlformat "disable"] - -let ebcdic_compare (str1 : string) str2 = - let rec ebcdic_compare_aux i = - if String.length str1 <= i || String.length str2 <= i then - Stdlib.compare (String.length str1) (String.length str2) - else - let r = - Stdlib.compare - ascii_to_ebcdic.(Char.code str1.[i]) - ascii_to_ebcdic.(Char.code str2.[i]) - in - if r <> 0 then r else ebcdic_compare_aux (i + 1) - in - ebcdic_compare_aux 0 - (* Various flags used to control wicch data to put in each variable array *) type gen_opt = { with_verif : bool; @@ -94,34 +68,6 @@ type gen_type = | Debug of int (* can be of any subtype *) -let default_flags = - Dgfip_options. - { - nom_application = ""; - annee_revenu = 0; - flg_correctif = true; - flg_iliad = false; - flg_pro = false; - flg_cfir = false; - flg_gcos = false; - flg_tri_ebcdic = false; - flg_multithread = false; - flg_short = false; - flg_register = false; - flg_optim_min_max = false; - flg_extraction = false; - flg_genere_libelle_restituee = false; - flg_controle_separe = false; - flg_controle_immediat = false; - flg_overlays = false; - flg_colors = false; - flg_ticket = false; - flg_trace = false; - flg_debug = false; - nb_debug_c = 0; - xflg = false; - } - let is_input st = match st with Base | Computed -> false | _ -> true let is_computed st = match st with Base | Computed -> true | _ -> false @@ -239,21 +185,25 @@ let get_attr a attributes = let get_name name alias_opt = match alias_opt with Some alias -> alias | _ -> name -let sort_vars_by_alias vars is_ebcdic = - let compare_func = if is_ebcdic then ebcdic_compare else String.compare in +let sort_vars_by_alias is_ebcdic vars = + let compare_name = + if is_ebcdic then Strings.compare_ebcdic else Strings.compare_default + in List.fast_sort (fun (_, _, _, _, name1, alias_opt1, _, _, _, _) (_, _, _, _, name2, alias_opt2, _, _, _, _) -> let var_name1 = get_name name1 alias_opt1 in let var_name2 = get_name name2 alias_opt2 in - compare_func var_name1 var_name2) + compare_name var_name1 var_name2) vars -let sort_vars_by_name vars is_ebcdic = - let compare_func = if is_ebcdic then ebcdic_compare else String.compare in +let sort_vars_by_name is_ebcdic vars = + let compare_name = + if is_ebcdic then Strings.compare_ebcdic else Strings.compare_default + in List.fast_sort (fun (_, _, _, _, name1, _, _, _, _, _) (_, _, _, _, name2, _, _, _, _, _) -> - compare_func name1 name2) + compare_name name1 name2) vars (* Retrieve all the variables, sorted by alias, and compute their IDs *) @@ -324,7 +274,7 @@ let get_vars prog is_ebcdic = [] prog in - let vars = sort_vars_by_name vars is_ebcdic in + let vars = sort_vars_by_name is_ebcdic vars in let idx = new_idx () in @@ -358,7 +308,7 @@ let get_vars prog is_ebcdic = vars in - let vars = sort_vars_by_alias vars is_ebcdic in + let vars = sort_vars_by_alias is_ebcdic vars in let idx = new_idx () in @@ -390,8 +340,8 @@ let get_vars prog is_ebcdic = (* Retrieve the variables for the debug array; variables with aliases are duplicated *) -let get_vars_debug vars is_ebcdic = - sort_vars_by_name +let get_vars_debug is_ebcdic vars = + sort_vars_by_name is_ebcdic (List.fold_left (fun vars var -> let ( tvar, @@ -421,7 +371,6 @@ let get_vars_debug vars is_ebcdic = :: var :: vars | None -> var :: vars) [] vars) - is_ebcdic (* Split a list in approximately equal chunks into a list of lists *) let split_list lst cnt = @@ -447,10 +396,8 @@ let split_list lst cnt = (* Print a variable's description *) let gen_var fmt req_type opt ~idx ~name ~tvar ~is_output ~typ_opt ~attributes ~desc ~alias_opt = - let open Mast in let var_name = if opt.with_alias then get_name name alias_opt else name in - (* TODO if flg_compact is used, then handle flat representation of TGV *) let kind, is_input = match (tvar : var_subtype) with | Computed -> ("EST_CALCULEE", false) @@ -458,11 +405,11 @@ let gen_var fmt req_type opt ~idx ~name ~tvar ~is_output ~typ_opt ~attributes | _ -> ("EST_SAISIE", true) in - let typ = match typ_opt with None -> Real | Some ct -> Pos.unmark ct in + let typ = match typ_opt with None -> Com.Real | Some ct -> Pos.unmark ct in Format.fprintf fmt " { \"%s\", %s | %d" var_name kind idx; if opt.with_type_donnee then - Format.fprintf fmt ", %a" Format_mast.format_value_typ typ; + Format.fprintf fmt ", %a" Com.format_value_typ typ; if opt.with_verif then if is_input && false then Format.fprintf fmt ", err_%s" name (* Note: no alias *) @@ -518,7 +465,7 @@ let var_matches req_type var_type is_output = | Debug _i -> true (* Print the specified variable table *) -let gen_table fmt (flags : Dgfip_options.flags) vars req_type opt = +let gen_table fmt is_ebcdic vars req_type opt = Format.fprintf fmt {|/****** LICENCE CECIL *****/ #include "compir.h" @@ -530,11 +477,9 @@ let gen_table fmt (flags : Dgfip_options.flags) vars req_type opt = (* TODO there should be individual var verification functions here, but they do not seem to be used (for all kind of input vars as well as output vars and debug tables) *) - let is_ebcdic = flags.flg_tri_ebcdic in let vars = - if opt.with_alias then - if is_ebcdic then sort_vars_by_alias vars is_ebcdic else vars - else sort_vars_by_name vars is_ebcdic + if opt.with_alias then sort_vars_by_alias is_ebcdic vars + else sort_vars_by_name is_ebcdic vars in let table_name = req_type_name req_type in let table_NAME = String.uppercase_ascii table_name in @@ -582,8 +527,8 @@ let gen_table fmt (flags : Dgfip_options.flags) vars req_type opt = Format.fprintf fmt "};\n" -let gen_desc fmt vars ~alias_only is_ebcdic = - let vars = sort_vars_by_name vars is_ebcdic in +let gen_desc fmt is_ebcdic vars ~alias_only = + let vars = sort_vars_by_name is_ebcdic vars in Format.fprintf fmt {|/****** LICENCE CECIL *****/ @@ -631,6 +576,7 @@ let gen_desc fmt vars ~alias_only is_ebcdic = desc_verif) although it does not seem to be used anymore *) let gen_table_output fmt flags vars = + let is_ebcdic = flags.Dgfip_options.flg_tri_ebcdic in let opt = { with_verif = false; @@ -653,10 +599,10 @@ let gen_table_output fmt flags vars = with_primrest = true; } in - - gen_table fmt flags vars Output opt + gen_table fmt is_ebcdic vars Output opt let gen_table_context fmt flags vars = + let is_ebcdic = flags.Dgfip_options.flg_tri_ebcdic in let opt = { with_verif = true; @@ -679,10 +625,10 @@ let gen_table_context fmt flags vars = with_primrest = false; } in - - gen_table fmt flags vars (Input (Some Context)) opt + gen_table fmt is_ebcdic vars (Input (Some Context)) opt let gen_table_family fmt flags vars = + let is_ebcdic = flags.Dgfip_options.flg_tri_ebcdic in let opt = { with_verif = true; @@ -705,10 +651,10 @@ let gen_table_family fmt flags vars = with_primrest = false; } in - - gen_table fmt flags vars (Input (Some Family)) opt + gen_table fmt is_ebcdic vars (Input (Some Family)) opt let gen_table_income fmt flags vars = + let is_ebcdic = flags.Dgfip_options.flg_tri_ebcdic in let opt = { with_verif = true; @@ -731,10 +677,10 @@ let gen_table_income fmt flags vars = with_primrest = false; } in - - gen_table fmt flags vars (Input (Some Income)) opt + gen_table fmt is_ebcdic vars (Input (Some Income)) opt let gen_table_corrincome fmt flags vars = + let is_ebcdic = flags.Dgfip_options.flg_tri_ebcdic in let opt = { with_verif = true; @@ -757,10 +703,10 @@ let gen_table_corrincome fmt flags vars = with_primrest = false; } in - - gen_table fmt flags vars (Input (Some CorrIncome)) opt + gen_table fmt is_ebcdic vars (Input (Some CorrIncome)) opt let gen_table_variation fmt flags vars = + let is_ebcdic = flags.Dgfip_options.flg_tri_ebcdic in let opt = { with_verif = true; @@ -783,10 +729,10 @@ let gen_table_variation fmt flags vars = with_primrest = false; } in - - gen_table fmt flags vars (Input (Some Variation)) opt + gen_table fmt is_ebcdic vars (Input (Some Variation)) opt let gen_table_penality fmt flags vars = + let is_ebcdic = flags.Dgfip_options.flg_tri_ebcdic in let opt = { with_verif = true; @@ -809,9 +755,10 @@ let gen_table_penality fmt flags vars = with_primrest = false; } in - gen_table fmt flags vars (Input (Some Penality)) opt + gen_table fmt is_ebcdic vars (Input (Some Penality)) opt let gen_table_debug fmt flags vars i = + let is_ebcdic = flags.Dgfip_options.flg_tri_ebcdic in let opt = { with_verif = true; @@ -834,74 +781,82 @@ let gen_table_debug fmt flags vars i = with_primrest = false; } in - gen_table fmt flags vars (Debug i) opt + gen_table fmt is_ebcdic vars (Debug i) opt -let gen_table_varinfo fmt var_dict cat Mir.{ id_int; id_str; attributs; _ } - stats = +let gen_table_varinfo fmt var_dict cat + Com.CatVar.{ id_int; id_str; attributs; _ } stats = Format.fprintf fmt "T_varinfo_%s varinfo_%s[NB_%s + 1] = {\n" id_str id_str id_str; let nb = StrMap.fold (fun _ (var, idx, size) nb -> - match var.Mir.cats with - | Some c when Mir.compare_cat_variable c cat = 0 -> - Format.fprintf fmt " { \"%s\", \"%s\", %d, %d, %d" - (Pos.unmark var.Mir.name) - (match var.Mir.alias with Some s -> s | None -> "") - idx size id_int; - let attr_map = - List.fold_left - (fun res (an, al) -> - let vn = Pos.unmark an in - let vl = Pos.unmark al in - StrMap.add vn vl res) - StrMap.empty var.Mir.attributes - in - StrMap.iter (fun _ av -> Format.fprintf fmt ", %d" av) attr_map; - Format.fprintf fmt " },\n"; - nb + 1 - | _ -> nb) + if Com.CatVar.compare (Com.Var.cat var) cat = 0 then ( + let loc_cat = + match (Com.Var.loc_tgv var).loc_cat with + | Com.CatVar.LocComputed -> "EST_CALCULEE" + | Com.CatVar.LocBase -> "EST_BASE" + | Com.CatVar.LocInput -> "EST_SAISIE" + in + Format.fprintf fmt " { \"%s\", \"%s\", %d, %d, %d, %s" + (Com.Var.name_str var) (Com.Var.alias_str var) idx size id_int + loc_cat; + StrMap.iter + (fun _ av -> Format.fprintf fmt ", %d" (Pos.unmark av)) + (Com.Var.attrs var); + Format.fprintf fmt " },\n"; + nb + 1) + else nb) var_dict 0 in Format.fprintf fmt " NULL\n};\n\n"; let attr_set = StrMap.fold (fun an _ res -> StrSet.add an res) attributs StrSet.empty in - Mir.CatVarMap.add cat (id_str, id_int, nb, attr_set) stats + Com.CatVar.Map.add cat (id_str, id_int, nb, attr_set) stats -let gen_table_varinfos fmt cprog vars = +let gen_table_varinfos fmt (cprog : Mir.program) vars = Format.fprintf fmt {|/****** LICENCE CECIL *****/ #include "mlang.h" |}; - Mir.CatVarMap.iter - (fun _ Mir.{ id_str; attributs; _ } -> - Format.fprintf fmt - "char attribut_%s_def(T_varinfo_%s *vi, char *attr) {\n" id_str id_str; - StrMap.iter - (fun attr _ -> - Format.fprintf fmt " if (strcmp(attr, \"%s\") == 0) return 1;\n" attr) - attributs; + let attrs = + Com.CatVar.Map.fold + (fun _ Com.CatVar.{ attributs; _ } res -> + StrMap.fold (fun attr _ res -> StrSet.add attr res) attributs res) + cprog.program_var_categories StrSet.empty + in + StrSet.iter + (fun attr -> + Format.fprintf fmt "char attribut_%s_def(T_varinfo *vi) {\n" attr; + Format.fprintf fmt " switch (vi->cat) {\n"; + Com.CatVar.Map.iter + (fun _ Com.CatVar.{ id_str; attributs; _ } -> + if StrMap.mem attr attributs then + Format.fprintf fmt " case ID_%s: return 1;\n" id_str) + cprog.program_var_categories; + Format.fprintf fmt " }\n"; Format.fprintf fmt " return 0;\n"; Format.fprintf fmt "}\n\n"; - Format.fprintf fmt "double attribut_%s(T_varinfo_%s *vi, char *attr) {\n" - id_str id_str; - StrMap.iter - (fun attr _ -> - Format.fprintf fmt " if (strcmp(attr, \"%s\") == 0) return vi->%s;\n" - attr attr) - attributs; + Format.fprintf fmt "double attribut_%s(T_varinfo *vi) {\n" attr; + Format.fprintf fmt " switch (vi->cat) {\n"; + Com.CatVar.Map.iter + (fun _ Com.CatVar.{ id_str; attributs; _ } -> + if StrMap.mem attr attributs then ( + Format.fprintf fmt " case ID_%s:\n" id_str; + Format.fprintf fmt " return ((T_varinfo_%s *)vi)->attr_%s;\n" + id_str attr)) + cprog.program_var_categories; + Format.fprintf fmt " }\n"; Format.fprintf fmt " return 0.0;\n"; Format.fprintf fmt "}\n\n") - cprog.Bir.mir_program.program_var_categories; + attrs; + let var_dict = - Mir.VariableDict.fold - (fun var dict -> - match var.Mir.cats with - | Some _ -> StrMap.add (Pos.unmark var.Mir.name) (var, -1, -1) dict - | None -> dict) - cprog.Bir.mir_program.program_vars StrMap.empty + StrMap.fold + (fun _ var dict -> + StrMap.add (Pos.unmark var.Com.Var.name) (var, -1, -1) dict) + cprog.program_vars StrMap.empty in let var_dict = List.fold_left @@ -921,12 +876,23 @@ let gen_table_varinfos fmt cprog vars = dict) var_dict vars in - Mir.CatVarMap.fold + Com.CatVar.Map.fold (gen_table_varinfo fmt var_dict) - cprog.Bir.mir_program.program_var_categories Mir.CatVarMap.empty + cprog.program_var_categories Com.CatVar.Map.empty + +let gen_decl_varinfos fmt (cprog : Mir.program) stats = + Format.fprintf fmt + {|typedef struct S_varinfo { + char *name; + char *alias; + int idx; + int size; + int cat; + int loc_cat; +} T_varinfo; -let gen_decl_varinfos fmt stats = - Mir.CatVarMap.iter +|}; + Com.CatVar.Map.iter (fun _ (id_str, _, _, attr_set) -> Format.fprintf fmt {|typedef struct S_varinfo_%s { @@ -935,39 +901,45 @@ let gen_decl_varinfos fmt stats = int idx; int size; int cat; + int loc_cat; |} id_str; - StrSet.iter (fun an -> Format.fprintf fmt " int %s;\n" an) attr_set; + StrSet.iter (fun an -> Format.fprintf fmt " int attr_%s;\n" an) attr_set; Format.fprintf fmt "} T_varinfo_%s;\n\n" id_str) stats; Format.fprintf fmt "\n"; - Mir.CatVarMap.iter + Com.CatVar.Map.iter (fun _ (id_str, _, _, _) -> Format.fprintf fmt "extern T_varinfo_%s varinfo_%s[];\n" id_str id_str) stats; Format.fprintf fmt "\n"; - Mir.CatVarMap.iter + Com.CatVar.Map.iter (fun _ (id_str, _, nb, _) -> Format.fprintf fmt "#define NB_%s %d\n" id_str nb) stats; Format.fprintf fmt "\n"; - Mir.CatVarMap.iter - (fun _ (id_str, id_int, _, _) -> - Format.fprintf fmt "#define ID_%s %d\n" id_str id_int) - stats; - Format.fprintf fmt "\n"; - Mir.CatVarMap.iter - (fun _ (id_str, _, _, _) -> - Format.fprintf fmt - "extern char attribut_%s_def(T_varinfo_%s *vi, char *attr);\n" id_str - id_str; - Format.fprintf fmt - "extern double attribut_%s(T_varinfo_%s *vi, char *attr);\n" id_str - id_str) - stats + let id_tmp = + Com.CatVar.Map.fold + (fun _ (id_str, id_int, _, _) id_tmp -> + Format.fprintf fmt "#define ID_%s %d\n" id_str id_int; + max (id_int + 1) id_tmp) + stats (-1) + in + Format.fprintf fmt "#define ID_TMP_VARS %d\n" id_tmp; + + let attrs = + Com.CatVar.Map.fold + (fun _ Com.CatVar.{ attributs; _ } res -> + StrMap.fold (fun attr _ res -> StrSet.add attr res) attributs res) + cprog.program_var_categories StrSet.empty + in + StrSet.iter + (fun attr -> + Format.fprintf fmt "\nextern char attribut_%s_def(T_varinfo *vi);\n" attr; + Format.fprintf fmt "extern double attribut_%s(T_varinfo *vi);\n" attr) + attrs -let is_valid_app al = - List.exists (fun a -> String.equal (Pos.unmark a) "iliad") al +let is_valid_app apps = StrMap.mem "iliad" apps (* Retrieve rules, verifications, errors and chainings from a program *) let get_rules_verif_etc prog = @@ -980,7 +952,7 @@ let get_rules_verif_etc prog = match Pos.unmark item with | Rule r -> let rules, chainings = - if is_valid_app r.rule_applications then + if is_valid_app r.rule_apps then ( Pos.unmark r.rule_number :: rules, match r.rule_chaining with | None -> chainings @@ -990,7 +962,7 @@ let get_rules_verif_etc prog = (rules, verifs, errors, chainings) | Verification v -> let verifs = - if is_valid_app v.verif_applications then + if is_valid_app v.verif_apps then fst @@ List.fold_left (fun (verifs, vn) _vc -> (vn :: verifs, vn + 1)) @@ -1359,7 +1331,7 @@ let gen_erreurs_c fmt flags errors = end (* Print #defines corresponding to generation options *) -let gen_conf_h fmt flags vars = +let gen_conf_h fmt (cprog : Mir.program) flags = let open Dgfip_options in Format.fprintf fmt {|/****** LICENCE CECIL *****/ @@ -1374,9 +1346,7 @@ let gen_conf_h fmt flags vars = if flags.flg_cfir then Format.fprintf fmt "#define FLG_CFIR\n"; if flags.flg_gcos then Format.fprintf fmt "#define FLG_GCOS\n"; if flags.flg_tri_ebcdic then Format.fprintf fmt "#define FLG_TRI_EBCDIC\n"; - if flags.flg_multithread then Format.fprintf fmt "#define FLG_MULTITHREAD\n"; (* flag is not used *) - (*if flags.flg_compact then Format.fprintf fmt "#define FLG_COMPACT\n"; *) if flags.flg_short then Format.fprintf fmt "#define FLG_SHORT\n"; if flags.flg_register then Format.fprintf fmt "#define FLG_REGISTER\n"; (* flag is not used *) @@ -1400,10 +1370,15 @@ let gen_conf_h fmt flags vars = if flags.flg_debug then Format.fprintf fmt "#define FLG_DEBUG\n"; Format.fprintf fmt "#define NB_DEBUG_C %d\n" flags.nb_debug_c; Format.fprintf fmt "#define EPSILON %f\n" !Cli.comparison_error_margin; - - let nb_saisie = count vars (Input None) in - let nb_calculee = count vars (Computed (Some Computed)) in - let nb_base = count vars (Computed (Some Base)) in + let count loc = + StrMap.fold + (fun _ var nb -> + nb + if Com.Var.cat_var_loc var = Some loc then Com.Var.size var else 0) + cprog.program_vars 0 + in + let nb_saisie = count Com.CatVar.LocInput in + let nb_calculee = count Com.CatVar.LocComputed in + let nb_base = count Com.CatVar.LocBase in let nb_vars = nb_saisie + nb_calculee + nb_base in Format.fprintf fmt "#define NB_VARS %d\n" nb_vars; Format.fprintf fmt {| @@ -1443,24 +1418,6 @@ struct S_print_context { typedef struct S_print_context T_print_context; -#ifdef FLG_COMPACT - -struct S_irdata { - double valeurs[NB_VARS]; - char defs[NB_VARS]; - T_print_context ctx_pr_out; - T_print_context ctx_pr_err; -}; - -#define S_ irdata->valeurs -#define C_ irdata->valeurs -#define B_ irdata->valeurs -#define DS_ irdata->defs -#define DC_ irdata->defs -#define DB_ irdata->defs - -#else - typedef void *T_var_irdata; struct S_erreur @@ -1488,19 +1445,35 @@ struct S_irdata double *saisie; double *calculee; double *base; + double *tmps; + double **ref; char *def_saisie; char *def_calculee; char *def_base; -#ifdef FLG_MULTITHREAD + char *def_tmps; + char **def_ref; + T_varinfo *info_tmps; + T_varinfo **info_ref; + int tmps_org; + int ref_org; T_discord *discords; T_discord *tas_discord; T_discord **p_discord; int nb_anos; - int nb_dicos; + int nb_discos; int nb_infos; - int nb_bloqus; + int nb_bloqs; + int max_bloqs; jmp_buf jmp_bloq; -#endif /* FLG_MULTITHREAD */ + int sz_err_finalise; + char **err_finalise; + int nb_err_finalise; + int sz_err_sortie; + char **err_sortie; + int nb_err_sortie; + int sz_err_archive; + char **err_archive; + int nb_err_archive; T_print_context ctx_pr_out; T_print_context ctx_pr_err; }; @@ -1510,17 +1483,24 @@ typedef struct S_irdata T_irdata; #define S_ irdata->saisie #define C_ irdata->calculee #define B_ irdata->base +/*#define T_ irdata->tmps*/ +/*#define R_ irdata->ref*/ #define DS_ irdata->def_saisie #define DC_ irdata->def_calculee #define DB_ irdata->def_base - -#define EST_SAISIE 0x0000 -#define EST_CALCULEE 0x4000 -#define EST_BASE 0x8000 -#define EST_MASQUE 0xc000 -#define INDICE_VAL 0x3fff - -#endif /* FLG_COMPACT */ +/*#define DT_ irdata->def_tmps*/ +/*#define DR_ irdata->def_ref*/ +/*#define IT_ irdata->info_tmps*/ +/*#define IR_ irdata->info_ref*/ + +#define EST_SAISIE 0x00000 +#define EST_CALCULEE 0x04000 +#define EST_BASE 0x08000 +#define EST_TEMPORAIRE 0x10000 +#define EST_ARGUMENT 0x20000 +#define EST_RESULTAT 0x40000 +#define EST_MASQUE 0x3c000 +#define INDICE_VAL 0x03fff #define RESTITUEE 5 #define RESTITUEE_P 6 @@ -1556,10 +1536,16 @@ extern int modulo_def(int, int); extern double modulo(double, double); |} -let gen_lib fmt flags vars rules verifs chainings errors = - let taille_saisie = count vars (Input None) in - let taille_calculee = count vars (Computed (Some Computed)) in - let taille_base = count vars (Computed (Some Base)) in +let gen_lib fmt (cprog : Mir.program) flags rules verifs chainings errors = + let count loc = + StrMap.fold + (fun _ var nb -> + nb + if Com.Var.cat_var_loc var = Some loc then Com.Var.size var else 0) + cprog.program_vars 0 + in + let taille_saisie = count Com.CatVar.LocInput in + let taille_calculee = count Com.CatVar.LocComputed in + let taille_base = count Com.CatVar.LocBase in let taille_totale = taille_saisie + taille_calculee + taille_base in let nb_ench = StrSet.cardinal chainings in let nb_err = List.length errors in @@ -1567,8 +1553,7 @@ let gen_lib fmt flags vars rules verifs chainings errors = let nb_verif = List.length verifs in Format.fprintf fmt - {| -#define TAILLE_SAISIE %d + {|#define TAILLE_SAISIE %d #define TAILLE_CALCULEE %d #define TAILLE_BASE %d #define TAILLE_TOTALE %d @@ -1577,6 +1562,12 @@ let gen_lib fmt flags vars rules verifs chainings errors = |} taille_saisie taille_calculee taille_base taille_totale nb_ench; + Format.fprintf fmt {|#define TAILLE_TMP_VARS %d +#define TAILLE_REFS %d + +|} + cprog.program_stats.sz_all_tmps cprog.program_stats.nb_all_refs; + Format.fprintf fmt {|#define ANOMALIE 1 #define DISCORDANCE 2 @@ -1638,37 +1629,32 @@ extern int nb_bloquantes(T_irdata *irdata); extern void nettoie_erreur _PROTS((T_irdata *irdata )); extern void finalise_erreur _PROTS((T_irdata *irdata )); extern void exporte_erreur _PROTS((T_irdata *irdata )); -#ifdef FLG_MULTITHREAD extern void init_erreur(T_irdata *irdata); -#else -extern void init_erreur(void); -#endif /* FLG_MULTITHREAD */ |} -let gen_decl_targets fmt cprog = - Format.fprintf fmt - {|#ifndef FLG_MULTITHREAD -extern T_discord *discords; -extern T_discord *tas_discord; -extern T_discord **p_discord; -extern int nb_anos; -extern int nb_discos; -extern int nb_infos; -extern int nb_bloqs; -extern jmp_buf jmp_bloq; -#endif - -|}; - - let targets = Mir.TargetMap.bindings cprog.Bir.targets in +let gen_decl_functions fmt (cprog : Mir.program) = + let functions = Com.TargetMap.bindings cprog.program_functions in + let pp_args fmt args = + List.iteri + (fun i _ -> Pp.fpr fmt ", char def_arg%d, double val_arg%d" i i) + args + in + Format.fprintf fmt "@[%a@]@," + (Format.pp_print_list (fun fmt (fn, fd) -> + Format.fprintf fmt + "extern int %s(T_irdata* irdata, char *def_res, double *val_res%a);" + fn pp_args fd.Mir.target_args)) + functions + +let gen_decl_targets fmt (cprog : Mir.program) = + let targets = Com.TargetMap.bindings cprog.program_targets in Format.fprintf fmt "@[%a@]@," (Format.pp_print_list (fun fmt (name, _) -> Format.fprintf fmt "extern struct S_discord *%s(T_irdata* irdata);" name)) targets -let gen_mlang_h fmt cprog flags vars stats_varinfos rules verifs chainings - errors = +let gen_mlang_h fmt cprog flags stats_varinfos rules verifs chainings errors = let pr = Format.fprintf fmt in pr "/****** LICENCE CECIL *****/\n\n"; pr "#ifndef _MLANG_H_\n"; @@ -1687,17 +1673,18 @@ let gen_mlang_h fmt cprog flags vars stats_varinfos rules verifs chainings pr "\n"; gen_annee fmt flags; pr "\n"; + gen_decl_varinfos fmt cprog stats_varinfos; + pr "\n"; gen_const fmt; pr "\n"; (* The debug functions need T_irdata to be defined so we put them after *) gen_dbg fmt; pr "\n"; - gen_decl_varinfos fmt stats_varinfos; + gen_lib fmt cprog flags rules verifs chainings errors; pr "\n"; - gen_lib fmt flags vars rules verifs chainings errors; + gen_decl_functions fmt cprog; pr "\n"; gen_decl_targets fmt cprog; - pr "\n"; pr "#endif /* _MLANG_H_ */\n\n" let gen_mlang_c fmt = @@ -1769,10 +1756,8 @@ static void add_erreur_code(T_erreur *erreur, const char *code) { } } -#ifdef FLG_MULTITHREAD - void init_erreur(T_irdata *irdata) { -// IRDATA_reset_erreur(irdata); +/* IRDATA_reset_erreur(irdata); */ *irdata->p_discord = irdata->tas_discord; irdata->tas_discord = irdata->discords; irdata->discords = 0; @@ -1781,6 +1766,7 @@ void init_erreur(T_irdata *irdata) { irdata->nb_discos = 0; irdata->nb_infos = 0; irdata->nb_bloqs = 0; + irdata->max_bloqs = 4; } void add_erreur(T_irdata *irdata, T_erreur *erreur, char *code) { @@ -1805,8 +1791,8 @@ void add_erreur(T_irdata *irdata, T_erreur *erreur, char *code) { if (erreur->type == INFORMATIVE) irdata->nb_infos++; if (strcmp(erreur->isisf, "N") == 0 && erreur->type == ANOMALIE) { - irdata->nb_bloqus++; - if (irdata->nb_bloqus >= 4) { + irdata->nb_bloqs++; + if (irdata->nb_bloqs >= irdata->max_bloqs) { longjmp(irdata->jmp_bloq, 1); } } @@ -1827,98 +1813,9 @@ int nb_informatives(T_irdata *irdata) { } int nb_bloquantes(T_irdata *irdata) { - return irdata->nb_bloqus; -} - -#else - -T_discord *discords = 0; -T_discord *tas_discord = 0; -T_discord **p_discord = &discords; -int nb_anos = 0; -int nb_discos = 0; -int nb_infos = 0; -int nb_bloqus = 0; -jmp_buf jmp_bloq; - - -void init_erreur(void) { - *p_discord = tas_discord; - tas_discord = discords; - discords = 0; - p_discord = &discords; - nb_anos = 0; - nb_discos = 0; - nb_infos = 0; - nb_bloqus = 0; -} - -void add_erreur(T_irdata *irdata, T_erreur *erreur, char *code) { - T_discord *new_discord = NULL; - - if (tas_discord == 0) { - new_discord = (T_discord *)malloc(sizeof(T_discord)); - } else { - new_discord = tas_discord; - tas_discord = new_discord->suivant; - } - - add_erreur_code(erreur, code); - - new_discord->erreur = erreur; - new_discord->suivant = 0; - *p_discord = new_discord; - p_discord = &new_discord->suivant; - - if (erreur->type == ANOMALIE) nb_anos++; - if (erreur->type == DISCORDANCE) nb_discos++; - if (erreur->type == INFORMATIVE) nb_infos++; - - if (strcmp(erreur->isisf, "N") == 0 && erreur->type == ANOMALIE) { - nb_bloqus++; - if (nb_bloqus >= 4) { - longjmp(jmp_bloq, 1); - } - } -} - -void free_erreur() { - T_discord *temp_discords = discords; - T_discord *dd = NULL; - char *debut = NULL; - int i = 0; - - while (temp_discords != NULL) { - dd = temp_discords; - temp_discords = temp_discords->suivant; - if (dd->erreur->message != NULL) { - debut = strstr(dd->erreur->message, " (("); - if (debut != NULL) { - free(dd->erreur->message); - } - dd->erreur->message = NULL; - } - } -} - -int nb_anomalies(T_irdata *irdata) { - return nb_anos; -} - -int nb_discordances(T_irdata *irdata) { - return nb_discos; -} - -int nb_informatives(T_irdata *irdata) { - return nb_infos; -} - -int nb_bloquantes(T_irdata *irdata) { - return nb_bloqus; + return irdata->nb_bloqs; } -#endif /* FLG_MULTITHREAD */ - #ifdef FLG_TRACE int niv_trace = 3; @@ -1963,10 +1860,6 @@ void aff_val(const char *nom, const T_irdata *irdata, int indice, int niv, const #endif /* FLG_COLORS */ expr = 0; } -#ifdef FLG_COMPACT - valeur = irdata->valeurs[indice + expr]; - def = irdata->defs[indice + expr]; -#else switch (indice & EST_MASQUE) { case EST_SAISIE: valeur = irdata->saisie[(indice & INDICE_VAL) + expr]; @@ -1980,8 +1873,11 @@ void aff_val(const char *nom, const T_irdata *irdata, int indice, int niv, const valeur = irdata->base[(indice & INDICE_VAL) + expr]; def = irdata->def_base[(indice & INDICE_VAL) + expr]; break; + case EST_TEMPORAIRE: + valeur = irdata->tmps[irdata->tmps_org - (indice & INDICE_VAL) + expr]; + def = irdata->def_tmps[irdata->tmps_org - (indice & INDICE_VAL) + expr]; + break; } -#endif /* FLG_COMPACT */ if (is_tab) { if (def == 0) { if (valeur != 0) { @@ -2201,72 +2097,10 @@ void print_double(FILE *std, T_print_context *pr_ctx, double f, int pmin, int pm void nettoie_erreur(irdata) T_irdata *irdata; { -#ifdef FLG_MULTITHREAD init_erreur(irdata); -#else - init_erreur(); -#endif /* FLG_MULTITHREAD */ } |} -(* Generate a map from variables to array indices *) -let extract_var_ids (cprog : Bir.program) vars = - let open Mir in - (* let open Dgfip_varid in *) - let pvars = cprog.mir_program.program_vars in - let add vn v vm = - let vs = - match StrMap.find_opt vn vm with - | None -> VariableSet.empty - | Some vs -> vs - in - StrMap.add (Pos.unmark v.Variable.name) (VariableSet.add v vs) vm - in - (* Build a map from variable names to all their definitions (with different - ids) *) - let vars_map = - VariableDict.fold - (fun v vm -> - let vm = add (Pos.unmark v.Variable.name) v vm in - match v.Variable.alias with Some a -> add a v vm | None -> vm) - pvars StrMap.empty - in - let process_var ~alias - ( tvar, - idx1, - _idx2, - _idxo_opt, - name, - alias_opt, - _desc, - _typ_opt, - _attributes, - _size ) = - let vid = - match (tvar : var_subtype) with - | Computed -> Dgfip_varid.VarComputed idx1 - | Base -> VarBase idx1 - | _ -> VarInput idx1 - in - let name = - if alias then match alias_opt with Some alias -> alias | None -> name - else name - in - (name, vid) - in - (* Build a map from variable definitions (with different ids) to their array - indices *) - List.fold_left - (fun vm vd -> - let name, vid = process_var ~alias:false vd in - let vs = - try StrMap.find name vars_map - with Not_found -> - Errors.raise_error (Format.asprintf "Variable %s is undeclared" name) - in - VariableSet.fold (fun v vm -> VariableMap.add v vid vm) vs vm) - VariableMap.empty vars - let open_file filename = let oc = open_out filename in let fmt = Format.formatter_of_out_channel oc in @@ -2274,7 +2108,7 @@ let open_file filename = (* Generate the auxiliary files AND return the map of variables names to TGV ids *) -let generate_auxiliary_files flags prog cprog : Dgfip_varid.var_id_map = +let generate_auxiliary_files flags prog (cprog : Mir.program) : unit = let folder = Filename.dirname !Cli.output_file in let vars = get_vars prog Dgfip_options.(flags.flg_tri_ebcdic) in @@ -2311,7 +2145,7 @@ let generate_auxiliary_files flags prog cprog : Dgfip_varid.var_id_map = let stats_varinfos = gen_table_varinfos fmt cprog vars in close_out oc; - let vars_debug = get_vars_debug vars Dgfip_options.(flags.flg_tri_ebcdic) in + let vars_debug = get_vars_debug Dgfip_options.(flags.flg_tri_ebcdic) vars in let vars_debug_split = split_list vars_debug flags.nb_debug_c in let _ = if flags.nb_debug_c > 0 then @@ -2330,15 +2164,15 @@ let generate_auxiliary_files flags prog cprog : Dgfip_varid.var_id_map = in let oc, fmt = open_file (Filename.concat folder "compir_desc.h") in - gen_desc fmt vars ~alias_only:true Dgfip_options.(flags.flg_tri_ebcdic); + gen_desc fmt Dgfip_options.(flags.flg_tri_ebcdic) vars ~alias_only:true; close_out oc; let oc, fmt = open_file (Filename.concat folder "compir_desc_inv.h") in - gen_desc fmt vars ~alias_only:false Dgfip_options.(flags.flg_tri_ebcdic); + gen_desc fmt Dgfip_options.(flags.flg_tri_ebcdic) vars ~alias_only:false; close_out oc; let rules, verifs, errors, chainings = get_rules_verif_etc prog in - let prefix = cprog.Bir.mir_program.Mir.program_safe_prefix in + let prefix = cprog.program_safe_prefix in let oc, fmt = open_file (Filename.concat folder "compir_tableg.c") in gen_table_call fmt flags vars_debug prefix rules chainings errors; @@ -2357,15 +2191,13 @@ let generate_auxiliary_files flags prog cprog : Dgfip_varid.var_id_map = close_out oc; let oc, fmt = open_file (Filename.concat folder "conf.h") in - gen_conf_h fmt flags vars; + gen_conf_h fmt cprog flags; close_out oc; let oc, fmt = open_file (Filename.concat folder "mlang.h") in - gen_mlang_h fmt cprog flags vars stats_varinfos rules verifs chainings errors; + gen_mlang_h fmt cprog flags stats_varinfos rules verifs chainings errors; close_out oc; let oc, fmt = open_file (Filename.concat folder "mlang.c") in gen_mlang_c fmt; - close_out oc; - - extract_var_ids cprog vars + close_out oc diff --git a/src/mlang/backend_compilers/dgfip_varid.ml b/src/mlang/backend_compilers/dgfip_varid.ml index a7cd1fe8d..4d73354d9 100644 --- a/src/mlang/backend_compilers/dgfip_varid.ml +++ b/src/mlang/backend_compilers/dgfip_varid.ml @@ -14,87 +14,94 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -(* ID of a variable in its sub-array of the TGV *) -type var_id = - | VarInput of int - | VarBase of int - | VarComputed of int - | VarIterate of string * Mir.cat_variable_loc * Mir.cat_variable_data +let gen_tab = function + | Com.CatVar.LocComputed -> "C_" + | Com.CatVar.LocBase -> "B_" + | Com.CatVar.LocInput -> "S_" -(* Map from variables to their TGV ID *) -type var_id_map = var_id Mir.VariableMap.t +let gen_tgv pre (l : Com.loc_tgv) vn off = + Printf.sprintf "%s%s[%d/*%s*/%s]" pre (gen_tab l.loc_cat) l.loc_idx vn off -let gen_tab = function - | Mir.LocCalculated -> "C_" - | Mir.LocBase -> "B_" - | Mir.LocInput -> "S_" - -let gen_loc_type = function - | Mir.LocCalculated -> "EST_CALCULEE" - | Mir.LocBase -> "EST_BASE" - | Mir.LocInput -> "EST_SAISIE" - -let gen_access_def vm v offset = - let vn = Pos.unmark v.Mir.Variable.name in - if v.Mir.Variable.is_temp then Printf.sprintf "%s_def[0%s]" vn offset - else - match Mir.VariableMap.find v vm with - | VarInput i -> Printf.sprintf "DS_[%d/*%s*/%s]" i vn offset - | VarBase i -> Printf.sprintf "DB_[%d/*%s*/%s]" i vn offset - | VarComputed i -> Printf.sprintf "DC_[%d/*%s*/%s]" i vn offset - | VarIterate (t, l, _) -> - Printf.sprintf "D%s[%s->idx/*%s*/%s]" (gen_tab l) t vn offset - -let gen_access_val vm v offset = - let vn = Pos.unmark v.Mir.Variable.name in - if v.Mir.Variable.is_temp then Printf.sprintf "%s_val[0%s]" vn offset - else - match Mir.VariableMap.find v vm with - | VarInput i -> Printf.sprintf "S_[%d/*%s*/%s]" i vn offset - | VarBase i -> Printf.sprintf "B_[%d/*%s*/%s]" i vn offset - | VarComputed i -> Printf.sprintf "C_[%d/*%s*/%s]" i vn offset - | VarIterate (t, l, _) -> - Printf.sprintf "%s[%s->idx/*%s*/%s]" (gen_tab l) t vn offset - -let gen_access_pointer vm v = - let vn = Pos.unmark v.Mir.Variable.name in - if v.Mir.Variable.is_temp then Printf.sprintf "(%s_val)" vn - else - match Mir.VariableMap.find v vm with - | VarInput i -> Printf.sprintf "(S_ + %d/*%s*/)" i vn - | VarBase i -> Printf.sprintf "(B_ + %d/*%s*/)" i vn - | VarComputed i -> Printf.sprintf "(C_ + %d/*%s*/)" i vn - | VarIterate (t, l, _) -> - Printf.sprintf "(%s + %s->idx/*%s*/)" (gen_tab l) t vn - -let gen_access_def_pointer vm v = - let vn = Pos.unmark v.Mir.Variable.name in - if v.Mir.Variable.is_temp then Printf.sprintf "(%s_def)" vn - else - match Mir.VariableMap.find v vm with - | VarInput i -> Printf.sprintf "(DS_ + %d/*%s*/)" i vn - | VarBase i -> Printf.sprintf "(DB_ + %d/*%s*/)" i vn - | VarComputed i -> Printf.sprintf "(DC_ + %d/*%s*/)" i vn - | VarIterate (t, l, _) -> - Printf.sprintf "(D%s + %s->idx/*%s*/)" (gen_tab l) t vn - -let gen_access_pos_from_start vm v = - if v.Mir.Variable.is_temp then assert false - else - match Mir.VariableMap.find v vm with - | VarInput i -> Printf.sprintf "EST_SAISIE | %d" i - | VarBase i -> Printf.sprintf "EST_BASE | %d" i - | VarComputed i -> Printf.sprintf "EST_CALCULEE | %d" i - | VarIterate (t, l, _) -> Printf.sprintf "%s | %s->idx" (gen_loc_type l) t - -let gen_size vm v = - let get_size v = - match v.Mir.Variable.is_table with - | Some i -> Format.sprintf "%d" i - | None -> "1" - in - if v.Mir.Variable.is_temp then get_size v - else - match Mir.VariableMap.find v vm with - | VarInput _ | VarBase _ | VarComputed _ -> get_size v - | VarIterate (t, _, _) -> Format.sprintf "(%s->size)" t +let gen_tgv_ptr pre (l : Com.loc_tgv) vn = + Printf.sprintf "(%s%s + (%d)/*%s*/)" pre (gen_tab l.loc_cat) l.loc_idx vn + +let gen_tmp pre i vn off = + Printf.sprintf "irdata->%stmps[irdata->tmps_org + (%d)/*%s*/%s]" pre i vn off + +let gen_tmp_ptr pre i vn = Printf.sprintf "&(%s)" (gen_tmp pre i vn "") + +let gen_ref_ptr pre i vn = + Printf.sprintf "irdata->%sref[irdata->ref_org + (%d)/*%s*/]" pre i vn + +let gen_ref pre i vn off = Printf.sprintf "*(%s%s)" (gen_ref_ptr pre i vn) off + +let gen_def (v : Com.Var.t) offset = + let vn = Pos.unmark v.name in + match v.loc with + | LocTgv (_, l) -> gen_tgv "D" l vn offset + | LocTmp (_, i) -> gen_tmp "def_" i vn offset + | LocRef (_, i) -> gen_ref "def_" i vn offset + | LocArg (_, i) -> Pp.spr "def_arg%d" i + | LocRes _ -> Pp.spr "(*def_res)" + +let gen_val (v : Com.Var.t) offset = + let vn = Pos.unmark v.name in + match v.loc with + | LocTgv (_, l) -> gen_tgv "" l vn offset + | LocTmp (_, i) -> gen_tmp "" i vn offset + | LocRef (_, i) -> gen_ref "" i vn offset + | LocArg (_, i) -> Pp.spr "val_arg%d" i + | LocRes _ -> Pp.spr "(*val_res)" + +let gen_info_ptr (v : Com.Var.t) = + let vn = Pos.unmark v.name in + match v.loc with + | LocTgv (_, l) -> + Printf.sprintf "((T_varinfo *)&(varinfo_%s[%d]/*%s*/))" l.loc_cat_str + l.loc_cat_idx vn + | LocTmp (_, i) -> gen_tmp_ptr "info_" i vn + | LocRef (_, i) -> gen_ref_ptr "info_" i vn + | LocArg _ | LocRes _ -> "NULL" + +let gen_def_ptr (v : Com.Var.t) = + let vn = Pos.unmark v.name in + match v.loc with + | LocTgv (_, l) -> gen_tgv_ptr "D" l vn + | LocTmp (_, i) -> gen_tmp_ptr "def_" i vn + | LocRef (_, i) -> gen_ref_ptr "def_" i vn + | LocArg (_, i) -> Pp.spr "(&def_arg%d)" i + | LocRes _ -> Pp.spr "def_res" + +let gen_val_ptr (v : Com.Var.t) = + let vn = Pos.unmark v.name in + match v.loc with + | LocTgv (_, l) -> gen_tgv_ptr "" l vn + | LocTmp (_, i) -> gen_tmp_ptr "" i vn + | LocRef (_, i) -> gen_ref_ptr "" i vn + | LocArg (_, i) -> Pp.spr "(&val_arg%d)" i + | LocRes _ -> Pp.spr "val_res" + +let gen_pos_from_start (v : Com.Var.t) = + let vn = Pos.unmark v.name in + match v.loc with + | LocTgv (_, l) -> + let loc_tab = + match l.loc_cat with + | Com.CatVar.LocComputed -> "EST_CALCULEE" + | Com.CatVar.LocBase -> "EST_BASE" + | Com.CatVar.LocInput -> "EST_SAISIE" + in + Printf.sprintf "%s | %d" loc_tab l.loc_idx + | LocTmp (_, i) -> Printf.sprintf "EST_TEMPORAIRE | %d" i + | LocRef (_, i) -> + let info = gen_ref_ptr "info_" i vn in + Printf.sprintf "%s->loc_cat | %s->idx" info info + | LocArg (_, i) -> Printf.sprintf "EST_ARGUMENT | %d" i + | LocRes _ -> Printf.sprintf "EST_RESULTAT | 0" + +let gen_size (v : Com.Var.t) = + let vn = Pos.unmark v.name in + match v.loc with + | LocTgv _ | LocTmp _ -> Format.sprintf "%d" (Com.Var.size v) + | LocRef (_, i) -> Format.sprintf "(%s->size)" (gen_ref_ptr "info_" i vn) + | LocArg _ | LocRes _ -> "1" diff --git a/src/mlang/backend_ir/bir.ml b/src/mlang/backend_ir/bir.ml deleted file mode 100644 index 59cf5522e..000000000 --- a/src/mlang/backend_ir/bir.ml +++ /dev/null @@ -1,363 +0,0 @@ -(* Copyright (C) 2019-2021-2020 Inria, contributors: Denis Merigoux - Raphaël Monat - - 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 . *) - -type rov_id = Mir.rov_id - -module ROVMap = Mir.RuleMap - -type tgv_id = string - -let default_tgv = "primitif" - -type variable = { on_tgv : tgv_id; offset : int; mir_var : Mir.Variable.t } - -let compare_variable v1 v2 = - let c = String.compare v1.on_tgv v2.on_tgv in - if c <> 0 then c - else - let c = Stdlib.compare v1.offset v2.offset in - if c <> 0 then c else Mir.Variable.compare v1.mir_var v2.mir_var - -module VariableMap = MapExt.Make (struct - type t = variable - - let compare = compare_variable -end) - -module VariableSet = SetExt.Make (struct - type t = variable - - let compare = compare_variable -end) - -module NameMap = StrMap - -type offset_alloc = { mutable name_map : int NameMap.t; mutable size : int } - -(* Mutable state hidden away in the signature. Used for black-magicaly - transition variable representations from SSA duplications to offsets of TGV. - An issue though: this disregards tetantives to reduce the size of the TGV - through optimisations *) -let offset_alloc = { name_map = NameMap.empty; size = 0 } - -let allocate_variable (var : Mir.variable) : int = - let name = Pos.unmark var.Mir.Variable.name in - match NameMap.find_opt name offset_alloc.name_map with - | Some offset -> offset - | None -> - let var_size = - match var.Mir.Variable.is_table with None -> 1 | Some s -> s - in - let offset = offset_alloc.size in - offset_alloc.name_map <- NameMap.add name offset offset_alloc.name_map; - offset_alloc.size <- offset_alloc.size + var_size; - offset - -let size_of_tgv () = offset_alloc.size - -(* unify SSA variables *) -let var_from_mir (on_tgv : tgv_id) (v : Mir.Variable.t) : variable = - let mir_var = match v.origin with Some v -> v | None -> v in - { offset = allocate_variable mir_var; on_tgv; mir_var } - -let var_to_mir v = v.mir_var - -let map_from_mir_map on_tgv map = - Mir.VariableMap.fold - (fun var -> VariableMap.add (var_from_mir on_tgv var)) - map VariableMap.empty - -let set_from_mir_dict on_tgv dict = - Mir.VariableDict.fold - (fun var -> VariableSet.add (var_from_mir on_tgv var)) - dict VariableSet.empty - -type expression = variable Mir.expression_ - -type condition_data = variable Mir.condition_data_ - -type variable_def = variable Mir.variable_def_ - -type function_name = string - -type rule_or_verif_code = Rule of stmt list | Verif of stmt - -and rule_or_verif = { - rov_id : rov_id; - rov_name : string Pos.marked; - rov_code : rule_or_verif_code; -} - -and stmt = stmt_kind Pos.marked - -and stmt_kind = - | SAssign of variable * variable_def - | SConditional of expression * stmt list * stmt list - | SVerifBlock of stmt list - | SRovCall of rov_id - | SFunctionCall of function_name * Mir.Variable.t list - | SPrint of Mast.print_std * variable Mir.print_arg list - | SIterate of variable * Mir.CatVarSet.t * expression * stmt list - | SRestore of - VariableSet.t * (variable * Mir.CatVarSet.t * expression) list * stmt list - | SRaiseError of Mir.error * string option - | SCleanErrors - | SExportErrors - | SFinalizeErrors - -let rule_or_verif_as_statements (rov : rule_or_verif) : stmt list = - match rov.rov_code with Rule stmts -> stmts | Verif stmt -> [ stmt ] - -type mpp_function = { mppf_stmts : stmt list; mppf_is_verif : bool } - -type target_function = { - file : string option; - tmp_vars : (variable * Pos.t * int option) StrMap.t; - stmts : stmt list; - is_verif : bool; -} - -module FunctionMap = MapExt.Make (struct - type t = function_name - - let compare = String.compare -end) - -type program = { - mpp_functions : mpp_function FunctionMap.t; - targets : target_function Mir.TargetMap.t; - rules_and_verifs : rule_or_verif ROVMap.t; - main_function : function_name; - idmap : Mir.idmap; - mir_program : Mir.program; -} - -let main_statements (p : program) : stmt list = - try (FunctionMap.find p.main_function p.mpp_functions).mppf_stmts - with Not_found -> ( - try (Mir.TargetMap.find p.main_function p.targets).stmts - with Not_found -> - Errors.raise_error "Unable to find main function of Bir program") - -let rec get_block_statements (p : program) (stmts : stmt list) : stmt list = - List.fold_left - (fun stmts stmt -> - match Pos.unmark stmt with - | SRovCall r -> ( - match (ROVMap.find r p.rules_and_verifs).rov_code with - | Rule rstmts -> List.rev rstmts @ stmts - | Verif stmt -> stmt :: stmts) - | SConditional (e, t, f) -> - let t = get_block_statements p t in - let f = get_block_statements p f in - Pos.same_pos_as (SConditional (e, t, f)) stmt :: stmts - | SFunctionCall (f, _) -> - (get_block_statements p - (FunctionMap.find f p.mpp_functions).mppf_stmts - |> List.rev) - @ stmts - | _ -> stmt :: stmts) - [] stmts - |> List.rev - -(** Returns program statements with all rules inlined *) -let get_all_statements (p : program) : stmt list = - main_statements p |> get_block_statements p - -let rec count_instr_blocks (p : program) (stmts : stmt list) : int = - List.fold_left - (fun acc stmt -> - match Pos.unmark stmt with - | SAssign _ | SRovCall _ | SFunctionCall _ | SPrint _ | SRaiseError _ - | SCleanErrors | SExportErrors | SFinalizeErrors -> - acc + 1 - | SVerifBlock s -> acc + 1 + count_instr_blocks p s - | SIterate (_, _, _, s) -> acc + 1 + count_instr_blocks p s - | SRestore (_, _, s) -> acc + 1 + count_instr_blocks p s - | SConditional (_, s1, s2) -> - acc + 1 + count_instr_blocks p s1 + count_instr_blocks p s2) - 0 stmts - -let squish_statements (program : program) (threshold : int) - (rule_suffix : string) = - let rule_from_stmts stmts = - let id = Mir.RuleID (Mir.fresh_rule_num ()) in - { - rov_id = id; - rov_name = - ( rule_suffix ^ string_of_int (Mir.num_of_rule_or_verif_id id), - Pos.no_pos ); - rov_code = Rule (List.rev stmts); - } - in - let rec browse_bir (old_stmts : stmt list) (new_stmts : stmt list) - (curr_stmts : stmt list) (rules : rule_or_verif ROVMap.t) = - match old_stmts with - | [] -> (rules, List.rev (curr_stmts @ new_stmts)) - | hd :: tl -> - let give_pos stmt = Pos.same_pos_as stmt hd in - let rules, curr_stmts = - match Pos.unmark hd with - | SConditional (expr, t, f) -> - let t_rules, t_curr_list = browse_bir t [] [] rules in - let f_rules, f_curr_list = browse_bir f [] [] t_rules in - let cond = - give_pos (SConditional (expr, t_curr_list, f_curr_list)) - in - (f_rules, cond :: curr_stmts) - | _ -> (rules, hd :: curr_stmts) - in - if count_instr_blocks program curr_stmts < threshold then - browse_bir tl new_stmts curr_stmts rules - else - let squish_rule = rule_from_stmts curr_stmts in - browse_bir tl - (give_pos (SRovCall squish_rule.rov_id) :: new_stmts) - [] - (ROVMap.add squish_rule.rov_id squish_rule rules) - in - let rules_and_verifs, mpp_functions = - FunctionMap.fold - (fun f mpp_func (rules, mpp_functions) -> - let rules, mppf_stmts = browse_bir mpp_func.mppf_stmts [] [] rules in - let func = { mppf_stmts; mppf_is_verif = mpp_func.mppf_is_verif } in - (rules, FunctionMap.add f func mpp_functions)) - program.mpp_functions - (program.rules_and_verifs, FunctionMap.empty) - in - { program with rules_and_verifs; mpp_functions } - -let get_assigned_variables (p : program) : VariableSet.t = - let rec get_assigned_variables_block acc (stmts : stmt list) : VariableSet.t = - List.fold_left - (fun acc stmt -> - match Pos.unmark stmt with - | SAssign (var, _) -> VariableSet.add var acc - | SVerifBlock s -> get_assigned_variables_block acc s - | SIterate (_, _, _, s) -> get_assigned_variables_block acc s - | SRestore (_, _, s) -> get_assigned_variables_block acc s - | SConditional (_, s1, s2) -> - let acc = get_assigned_variables_block acc s1 in - get_assigned_variables_block acc s2 - | SPrint _ -> acc - | SRaiseError _ | SCleanErrors | SExportErrors | SFinalizeErrors -> acc - | SRovCall _ | SFunctionCall _ -> assert false - (* Cannot happen get_all_statements inlines all rule and mpp_function - calls *)) - acc stmts - in - get_assigned_variables_block VariableSet.empty (get_all_statements p) - -let get_local_variables (p : program) : unit Mir.LocalVariableMap.t = - let rec get_local_vars_expr acc (e : expression Pos.marked) : - unit Mir.LocalVariableMap.t = - match Pos.unmark e with - | Mir.Unop (_, e) | Mir.Index (_, e) -> get_local_vars_expr acc e - | Mir.Comparison (_, e1, e2) | Mir.Binop (_, e1, e2) -> - let acc = get_local_vars_expr acc e1 in - get_local_vars_expr acc e2 - | Mir.Conditional (e1, e2, e3) -> - let acc = get_local_vars_expr acc e1 in - let acc = get_local_vars_expr acc e2 in - get_local_vars_expr acc e3 - | Mir.FunctionCall (_, args) -> - List.fold_left - (fun (acc : unit Mir.LocalVariableMap.t) arg -> - get_local_vars_expr acc arg) - acc args - | Mir.Literal _ | Mir.Var _ | Mir.NbCategory _ | Mir.Attribut _ | Mir.Size _ - | Mir.NbAnomalies | Mir.NbDiscordances | Mir.NbInformatives - | Mir.NbBloquantes -> - acc - | Mir.LocalVar lvar -> Mir.LocalVariableMap.add lvar () acc - | Mir.LocalLet (lvar, e1, e2) -> - let acc = get_local_vars_expr acc e1 in - let acc = get_local_vars_expr acc e2 in - Mir.LocalVariableMap.add lvar () acc - in - let rec get_local_vars_block acc (stmts : stmt list) : - unit Mir.LocalVariableMap.t = - List.fold_left - (fun acc stmt -> - match Pos.unmark stmt with - | SAssign (_, def) -> ( - match def with - | Mir.SimpleVar e -> get_local_vars_expr acc e - | Mir.TableVar (_, defs) -> ( - match defs with - | Mir.IndexTable es -> - Mir.IndexMap.fold - (fun _ e acc -> get_local_vars_expr acc e) - es acc - | Mir.IndexGeneric (_v, e) -> get_local_vars_expr acc e) - | _ -> acc) - | SVerifBlock s -> get_local_vars_block acc s - | SIterate (_, _, expr, s) -> - let acc = get_local_vars_expr acc (expr, Pos.no_pos) in - get_local_vars_block acc s - | SRestore (_, vpl, s) -> - let acc = - List.fold_left - (fun acc (_, _, expr) -> - get_local_vars_expr acc (expr, Pos.no_pos)) - acc vpl - in - get_local_vars_block acc s - | SConditional (cond, s1, s2) -> - let acc = get_local_vars_expr acc (cond, Pos.no_pos) in - let acc = get_local_vars_block acc s1 in - get_local_vars_block acc s2 - | SPrint (_, args) -> - List.fold_left - (fun acc arg -> - match arg with - | Mir.PrintString _ | Mir.PrintName _ | Mir.PrintAlias _ -> acc - | Mir.PrintIndent e | Mir.PrintExpr (e, _, _) -> - get_local_vars_expr acc e) - acc args - | SRaiseError _ | SCleanErrors | SExportErrors | SFinalizeErrors -> acc - | SFunctionCall _ | SRovCall _ -> assert false - (* Can't happen because SFunctionCall and SRovCall are eliminated by - get_all_statements below*)) - acc stmts - in - get_local_vars_block Mir.LocalVariableMap.empty (get_all_statements p) - -let get_locals_size (p : program) : int = - Mir.LocalVariableMap.fold - (fun v () top -> max top v.Mir.LocalVariable.id) - (get_local_variables p) 0 - -let rec remove_empty_conditionals (stmts : stmt list) : stmt list = - List.rev - (List.fold_left - (fun acc stmt -> - match Pos.unmark stmt with - | SConditional (e, b1, b2) -> - let b1 = remove_empty_conditionals b1 in - let b2 = remove_empty_conditionals b2 in - if List.length b1 = 0 && List.length b2 = 0 then acc - (* empty conditional, we can discard it *) - else Pos.same_pos_as (SConditional (e, b1, b2)) stmt :: acc - | _ -> stmt :: acc) - [] stmts) - -let get_used_variables_ (e : expression Pos.marked) (acc : VariableSet.t) : - VariableSet.t = - Mir.fold_expr_var (fun acc var -> VariableSet.add var acc) acc (Pos.unmark e) - -let get_used_variables (e : expression Pos.marked) : VariableSet.t = - get_used_variables_ e VariableSet.empty diff --git a/src/mlang/backend_ir/bir.mli b/src/mlang/backend_ir/bir.mli deleted file mode 100644 index c2c128160..000000000 --- a/src/mlang/backend_ir/bir.mli +++ /dev/null @@ -1,139 +0,0 @@ -(* Copyright (C) 2019-2021-2020 Inria, contributors: Denis Merigoux - Raphaël Monat - - 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 . *) - -type rov_id = Mir.rov_id - -module ROVMap = Mir.RuleMap - -type tgv_id = string - -type variable = { on_tgv : tgv_id; offset : int; mir_var : Mir.Variable.t } - -module VariableMap : MapExt.T with type key = variable - -module VariableSet : SetExt.T with type elt = variable - -type expression = variable Mir.expression_ - -type condition_data = variable Mir.condition_data_ - -type variable_def = variable Mir.variable_def_ - -type function_name = string - -type rule_or_verif_code = Rule of stmt list | Verif of stmt - -and rule_or_verif = { - rov_id : rov_id; - rov_name : string Pos.marked; - rov_code : rule_or_verif_code; -} - -and stmt = stmt_kind Pos.marked - -and stmt_kind = - | SAssign of variable * variable_def - | SConditional of expression * stmt list * stmt list - | SVerifBlock of stmt list - | SRovCall of rov_id - | SFunctionCall of function_name * Mir.Variable.t list - | SPrint of Mast.print_std * variable Mir.print_arg list - | SIterate of variable * Mir.CatVarSet.t * expression * stmt list - | SRestore of - VariableSet.t * (variable * Mir.CatVarSet.t * expression) list * stmt list - | SRaiseError of Mir.error * string option - | SCleanErrors - | SExportErrors - | SFinalizeErrors - -type mpp_function = { mppf_stmts : stmt list; mppf_is_verif : bool } - -type target_function = { - file : string option; - tmp_vars : (variable * Pos.t * int option) StrMap.t; - stmts : stmt list; - is_verif : bool; -} - -module FunctionMap : MapExt.T with type key = function_name - -(** This record allows to store statements generated from the m_spec file - without modifying the [Bir.program] function map. Thus the map reflects the - computation strictly as described in M and MPP. - - Bir module public interface can then provide access to the statements - associated with the declared main function either: - - - as defined in M source, - - composed with the m_spec constant assignations and conditions, - - composed with an initialisation of the variable dictionnary and the m_spec - features. - - Initialisation of the variables at the [Bir] level including unused - variables is necessary to the [Bir.interpreter] but frowned upon in code - generation backends where the data structure size incites to use idiomatic - efficient methods of initialisation instead of resting upon a row of - assignments. *) - -type program = { - mpp_functions : mpp_function FunctionMap.t; - targets : target_function Mir.TargetMap.t; - rules_and_verifs : rule_or_verif ROVMap.t; - main_function : function_name; - idmap : Mir.idmap; - mir_program : Mir.program; -} - -val default_tgv : tgv_id - -val size_of_tgv : unit -> int - -val var_from_mir : tgv_id -> Mir.Variable.t -> variable - -val var_to_mir : variable -> Mir.Variable.t - -val compare_variable : variable -> variable -> int - -val map_from_mir_map : tgv_id -> 'a Mir.VariableMap.t -> 'a VariableMap.t - -val set_from_mir_dict : tgv_id -> Mir.VariableDict.t -> VariableSet.t - -val rule_or_verif_as_statements : rule_or_verif -> stmt list - -val main_statements : program -> stmt list - -val get_all_statements : program -> stmt list - -val squish_statements : program -> int -> string -> program -(** In order to handle backends with limited function / method capacity, such as - Java's 64kB of bytecode per method, class, etc, this funciton allows a - [program] to be split into chunks of an arbitrary size using the string - argument as a suffix to the new function / method name. We piggyback on the - existing rules semantics, with these chunks being rule definitions and - inserting rule calls in their place*) - -val get_assigned_variables : program -> VariableSet.t - -val get_local_variables : program -> unit Mir.LocalVariableMap.t - -val get_locals_size : program -> int - -val remove_empty_conditionals : stmt list -> stmt list - -val get_used_variables_ : - expression Pos.marked -> VariableSet.t -> VariableSet.t - -val get_used_variables : expression Pos.marked -> VariableSet.t diff --git a/src/mlang/backend_ir/bir_instrumentation.ml b/src/mlang/backend_ir/bir_instrumentation.ml deleted file mode 100644 index 189d08073..000000000 --- a/src/mlang/backend_ir/bir_instrumentation.ml +++ /dev/null @@ -1,156 +0,0 @@ -(* Copyright (C) 2019-2021 Inria, contributor: Denis Merigoux - - - 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 . *) - -module CodeLocationMap = MapExt.Make (struct - type t = Bir_interpreter.code_location - - let compare x y = compare x y -end) - -type code_coverage_result = - Bir_interpreter.var_literal CodeLocationMap.t Bir.VariableMap.t -(** The result of the code coverage measurement is a map of the successive - definitions of all the non-array variables during interpretation of the - program *) - -let empty_code_coverage_result : code_coverage_result = Bir.VariableMap.empty - -let code_coverage_acc : code_coverage_result ref = - ref empty_code_coverage_result - -let code_coverage_init () : unit = - code_coverage_acc := empty_code_coverage_result; - Bir_interpreter.assign_hook := - fun var literal code_loc -> - code_coverage_acc := - Bir.VariableMap.update var - (fun old_defs -> - match old_defs with - | None -> Some (CodeLocationMap.singleton code_loc (literal ())) - | Some old_defs -> - Some (CodeLocationMap.add code_loc (literal ()) old_defs)) - !code_coverage_acc - -let code_coverage_result () : code_coverage_result = !code_coverage_acc - -module VarLiteralSet = SetExt.Make (struct - type t = Bir_interpreter.var_literal - - let compare x y = - match (x, y) with - | Bir_interpreter.SimpleVar l1, Bir_interpreter.SimpleVar l2 -> - compare l1 l2 - | Bir_interpreter.TableVar (size1, t1), Bir_interpreter.TableVar (size2, t2) - -> ( - if size1 <> size2 then compare size1 size2 - else - let different = ref None in - Array.iter2 - (fun t1i t2i -> - if t1i = t2i then () else different := Some (compare t1i t2i)) - t1 t2; - match !different with None -> 0 | Some i -> i) - | _ -> compare x y -end) - -type code_coverage_map_value = VarLiteralSet.t - -type code_coverage_acc = - code_coverage_map_value CodeLocationMap.t Bir.VariableMap.t - -let merge_code_coverage_single_results_with_acc (results : code_coverage_result) - (acc : code_coverage_acc) : code_coverage_acc = - Bir.VariableMap.fold - (fun var (new_defs : Bir_interpreter.var_literal CodeLocationMap.t) acc -> - match Bir.VariableMap.find_opt var acc with - | None -> - Bir.VariableMap.add var - (CodeLocationMap.map (fun x -> VarLiteralSet.singleton x) new_defs) - acc - | Some old_defs -> - Bir.VariableMap.add var - (CodeLocationMap.fold - (fun code_loc new_def defs -> - match CodeLocationMap.find_opt code_loc defs with - | None -> - CodeLocationMap.add code_loc - (VarLiteralSet.singleton new_def) - defs - | Some old_def -> - CodeLocationMap.add code_loc - (VarLiteralSet.add new_def old_def) - defs) - new_defs old_defs) - acc) - results acc - -let merge_code_coverage_acc (acc1 : code_coverage_acc) - (acc2 : code_coverage_acc) : code_coverage_acc = - Bir.VariableMap.union - (fun _ defs1 defs2 -> - Some - (CodeLocationMap.union - (fun _ def1 def2 -> Some (VarLiteralSet.union def1 def2)) - defs1 defs2)) - acc1 acc2 - -type code_locs = Bir.variable CodeLocationMap.t - -let rec get_code_locs_stmt (p : Bir.program) (stmt : Bir.stmt) - (loc : Bir_interpreter.code_location) : code_locs = - match Pos.unmark stmt with - | Bir.SConditional (_, t, f) -> - CodeLocationMap.union - (fun _ _ _ -> assert false) - (get_code_locs_stmts p t - (Bir_interpreter.ConditionalBranch true :: loc)) - (get_code_locs_stmts p f - (Bir_interpreter.ConditionalBranch false :: loc)) - | Bir.SVerifBlock s -> - get_code_locs_stmts p s (Bir_interpreter.InsideBlock 0 :: loc) - | Bir.SAssign (var, _) -> CodeLocationMap.singleton loc var - | Bir.SRovCall r -> - get_code_locs_stmts p - (Bir.rule_or_verif_as_statements (Bir.ROVMap.find r p.rules_and_verifs)) - (Bir_interpreter.InsideRule r :: loc) - | Bir.SFunctionCall (f, _) -> - get_code_locs_stmts p (Bir.FunctionMap.find f p.mpp_functions).mppf_stmts - (Bir_interpreter.InsideFunction f :: loc) - | Bir.SPrint _ -> CodeLocationMap.empty - | Bir.SIterate (var, _, _, s) -> - get_code_locs_stmts p s (Bir_interpreter.InsideIterate var :: loc) - | Bir.SRestore (_, _, s) -> - get_code_locs_stmts p s (Bir_interpreter.InsideBlock 0 :: loc) - | Bir.SRaiseError _ | Bir.SCleanErrors | Bir.SExportErrors - | Bir.SFinalizeErrors -> - CodeLocationMap.empty - -and get_code_locs_stmts (p : Bir.program) (stmts : Bir.stmt list) - (loc : Bir_interpreter.code_location) : code_locs = - let locs, _ = - List.fold_left - (fun (locs, i) stmt -> - ( CodeLocationMap.union - (fun _ _ _ -> assert false) - (get_code_locs_stmt p stmt (Bir_interpreter.InsideBlock i :: loc)) - locs, - i + 1 )) - (CodeLocationMap.empty, 0) stmts - in - locs - -let get_code_locs (p : Bir.program) : code_locs = - get_code_locs_stmts p (Bir.main_statements p) [] diff --git a/src/mlang/backend_ir/bir_instrumentation.mli b/src/mlang/backend_ir/bir_instrumentation.mli deleted file mode 100644 index b432eea1b..000000000 --- a/src/mlang/backend_ir/bir_instrumentation.mli +++ /dev/null @@ -1,67 +0,0 @@ -(* Copyright (C) 2019-2021 Inria, contributor: Denis Merigoux - - - 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 . *) - -(** Instrumentation of the interpreter to computer code coverage *) - -(** {1 Code coverage for a single run}*) - -module CodeLocationMap : MapExt.T with type key = Bir_interpreter.code_location - -type code_coverage_result = - Bir_interpreter.var_literal CodeLocationMap.t Bir.VariableMap.t -(** For each variable, and for each code location where it is assigned, we - record the value it has been assigned to during an interpreter run *) - -val empty_code_coverage_result : code_coverage_result - -(** The code coverage is stateful, it has to be initialized before the run with - [code_coverage_init] and you can retrieve its results after with - [code_coverage_result]. *) - -val code_coverage_init : unit -> unit - -val code_coverage_result : unit -> code_coverage_result - -(** {1 Code coverage for multiple runs}*) - -(** Code coverage is best measured for multiple runs of the interpreter on a set - of test files. *) - -module VarLiteralSet : SetExt.T with type elt = Bir_interpreter.var_literal - -type code_coverage_map_value = VarLiteralSet.t - -type code_coverage_acc = - code_coverage_map_value CodeLocationMap.t Bir.VariableMap.t -(** The accumulated coverage is the set of distinct values a particular variable - assignment has received in the tests runs so far *) - -val merge_code_coverage_single_results_with_acc : - code_coverage_result -> code_coverage_acc -> code_coverage_acc -(** [merge_code_coverage_single_results_with_acc result acc] merges the code - coverage results of a single run [result] with the accumulated results over - the tests so far [acc] *) - -val merge_code_coverage_acc : - code_coverage_acc -> code_coverage_acc -> code_coverage_acc -(** Merges two partial code coverage accumulator into a single, bigger one *) - -(** {1 Code locations}*) - -type code_locs = Bir.variable CodeLocationMap.t - -val get_code_locs : Bir.program -> code_locs -(** Returns all code locations in a program *) diff --git a/src/mlang/backend_ir/bir_interpreter.ml b/src/mlang/backend_ir/bir_interpreter.ml deleted file mode 100644 index 8b2ba5deb..000000000 --- a/src/mlang/backend_ir/bir_interpreter.ml +++ /dev/null @@ -1,1098 +0,0 @@ -(* Copyright (C) 2019-2021 Inria, contributor: Denis Merigoux - - - 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 . *) - -type var_literal = - | SimpleVar of Mir.literal - | TableVar of int * Mir.literal array - -type code_location_segment = - | InsideBlock of int - | ConditionalBranch of bool - | InsideRule of Bir.rov_id - | InsideFunction of Bir.function_name - | InsideIterate of Bir.variable - -let format_code_location_segment (fmt : Format.formatter) - (s : code_location_segment) = - match s with - | InsideBlock i -> Format.fprintf fmt "#%d" i - | ConditionalBranch b -> Format.fprintf fmt "?%b" b - | InsideRule r -> Format.fprintf fmt "R_%d" (Mir.num_of_rule_or_verif_id r) - | InsideFunction f -> Format.fprintf fmt "%s" f - | InsideIterate v -> - Format.fprintf fmt "IT_%s" (Pos.unmark v.Bir.mir_var.name) - -type code_location = code_location_segment list - -let format_code_location (fmt : Format.formatter) (l : code_location) = - Format.pp_print_list - ~pp_sep:(fun fmt _ -> Format.fprintf fmt "->") - format_code_location_segment fmt l - -let assign_hook : - (Bir.variable -> (unit -> var_literal) -> code_location -> unit) ref = - ref (fun _var _lit _code_loc -> ()) - -let exit_on_rte = ref true - -let repl_debug = ref false - -module type S = sig - type custom_float - - type value = Number of custom_float | Undefined - - val format_value : Format.formatter -> value -> unit - - val format_value_prec : int -> int -> Format.formatter -> value -> unit - - type var_value = SimpleVar of value | TableVar of int * value array - - val format_var_value : Format.formatter -> var_value -> unit - - val format_var_value_prec : - int -> int -> Format.formatter -> var_value -> unit - - val format_var_value_with_var : - Format.formatter -> Bir.variable * var_value -> unit - - type print_ctx = { indent : int; is_newline : bool } - - type ctx = { - ctx_local_vars : value Pos.marked Mir.LocalVariableMap.t; - ctx_vars : var_value Bir.VariableMap.t; - ctx_it : Mir.variable IntMap.t; - ctx_pr_out : print_ctx; - ctx_pr_err : print_ctx; - ctx_anos : (Mir.error * string option) list; - ctx_old_anos : StrSet.t; - ctx_nb_anos : int; - ctx_nb_discos : int; - ctx_nb_infos : int; - ctx_nb_bloquantes : int; - ctx_finalized_anos : (Mir.error * string option) list; - ctx_exported_anos : (Mir.error * string option) list; - } - - val empty_ctx : ctx - - val literal_to_value : Mir.literal -> value - - val var_literal_to_var_value : var_literal -> var_value - - val value_to_literal : value -> Mir.literal - - val var_value_to_var_literal : var_value -> var_literal - - val update_ctx_with_inputs : ctx -> Mir.literal Bir.VariableMap.t -> ctx - - val complete_ctx : ctx -> Mir.VariableDict.t -> ctx - - type run_error = - | NanOrInf of string * Bir.expression Pos.marked - | StructuredError of - (string * (string option * Pos.t) list * (unit -> unit) option) - - exception RuntimeError of run_error * ctx - - val raise_runtime_as_structured : run_error -> 'a - - val compare_numbers : Mast.comp_op -> custom_float -> custom_float -> bool - - val evaluate_expr : ctx -> Mir.program -> Bir.expression Pos.marked -> value - - val evaluate_program : Bir.program -> ctx -> int -> ctx -end - -module Make (N : Bir_number.NumberInterface) (RF : Bir_roundops.RoundOpsFunctor) = -struct - (* Careful : this behavior mimics the one imposed by the original Mlang - compiler... *) - - module R = RF (N) - - type custom_float = N.t - - let truncatef (x : N.t) : N.t = R.truncatef x - - let roundf (x : N.t) = R.roundf x - - type value = Number of N.t | Undefined - - let false_value () = Number (N.zero ()) - - let true_value () = Number (N.one ()) - - let format_value (fmt : Format.formatter) (x : value) = - match x with - | Undefined -> Format_mir.format_literal fmt Mir.Undefined - | Number x -> N.format_t fmt x - - let format_value_prec (mi : int) (ma : int) (fmt : Format.formatter) - (x : value) = - match x with - | Undefined -> Format_mir.format_literal fmt Mir.Undefined - | Number x -> N.format_prec_t mi ma fmt x - - type var_value = SimpleVar of value | TableVar of int * value array - - let format_var_value (fmt : Format.formatter) (var_lit : var_value) : unit = - match var_lit with - | SimpleVar e -> Format.fprintf fmt "%a" format_value e - | TableVar (_, es) -> - Format.fprintf fmt "[%a]" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ") - (fun fmt e -> Format.fprintf fmt "%a" format_value e)) - (Array.to_list es) - - let format_var_value_prec (mi : int) (ma : int) (fmt : Format.formatter) - (var_lit : var_value) : unit = - match var_lit with - | SimpleVar e -> Format.fprintf fmt "%a" (format_value_prec mi ma) e - | TableVar (_, es) -> - Format.fprintf fmt "[%a]" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ") - (fun fmt e -> Format.fprintf fmt "%a" (format_value_prec mi ma) e)) - (Array.to_list es) - - let format_var_value_with_var (fmt : Format.formatter) - ((var, vl) : Bir.variable * var_value) = - let var = Bir.var_to_mir var in - match vl with - | SimpleVar value -> - Format.fprintf fmt "%s (%s): %a" - (Pos.unmark var.Mir.Variable.name) - (Pos.unmark var.Mir.Variable.descr) - format_value value - | TableVar (size, values) -> - Format.fprintf fmt "%s (%s): Table (%d values)@\n" - (Pos.unmark var.Mir.Variable.name) - (Pos.unmark var.Mir.Variable.descr) - size; - List.iteri - (fun idx value -> - Format.fprintf fmt "| %d -> %a\n" idx format_value value) - (Array.to_list values) - - type print_ctx = { indent : int; is_newline : bool } - - type ctx = { - ctx_local_vars : value Pos.marked Mir.LocalVariableMap.t; - ctx_vars : var_value Bir.VariableMap.t; - ctx_it : Mir.variable IntMap.t; - ctx_pr_out : print_ctx; - ctx_pr_err : print_ctx; - ctx_anos : (Mir.error * string option) list; - ctx_old_anos : StrSet.t; - ctx_nb_anos : int; - ctx_nb_discos : int; - ctx_nb_infos : int; - ctx_nb_bloquantes : int; - ctx_finalized_anos : (Mir.error * string option) list; - ctx_exported_anos : (Mir.error * string option) list; - } - - let empty_ctx : ctx = - { - ctx_local_vars = Mir.LocalVariableMap.empty; - ctx_vars = Bir.VariableMap.empty; - ctx_it = IntMap.empty; - ctx_pr_out = { indent = 0; is_newline = true }; - ctx_pr_err = { indent = 0; is_newline = true }; - ctx_anos = []; - ctx_old_anos = StrSet.empty; - ctx_nb_anos = 0; - ctx_nb_discos = 0; - ctx_nb_infos = 0; - ctx_nb_bloquantes = 0; - ctx_finalized_anos = []; - ctx_exported_anos = []; - } - - let literal_to_value (l : Mir.literal) : value = - match l with - | Mir.Undefined -> Undefined - | Mir.Float f -> Number (N.of_float f) - - let var_literal_to_var_value (def : var_literal) : var_value = - match def with - | SimpleVar v -> SimpleVar (literal_to_value v) - | TableVar (size, defs) -> - TableVar (size, Array.map (fun v -> literal_to_value v) defs) - - let value_to_literal (l : value) : Mir.literal = - match l with - | Undefined -> Mir.Undefined - | Number f -> Mir.Float (N.to_float f) - - let var_value_to_var_literal (def : var_value) : var_literal = - let l : var_literal = - match def with - | SimpleVar v -> SimpleVar (value_to_literal v) - | TableVar (size, defs) -> - TableVar (size, Array.map (fun v -> value_to_literal v) defs) - in - l - - let update_ctx_with_inputs (ctx : ctx) - (inputs : Mir.literal Bir.VariableMap.t) : ctx = - { - ctx with - ctx_vars = - Bir.VariableMap.fold - (fun var value ctx_vars -> - Bir.VariableMap.add var (SimpleVar value) ctx_vars) - (Bir.VariableMap.mapi - (fun v l -> - match l with - | Mir.Undefined -> Undefined - | Mir.Float f -> Number (N.of_float_input (Bir.var_to_mir v) f)) - inputs) - ctx.ctx_vars; - } - - let complete_ctx (ctx : ctx) (vars : Mir.VariableDict.t) : ctx = - { - ctx with - ctx_vars = - Mir.VariableDict.fold - (fun mvar ctx_vars -> - let var = Bir.(var_from_mir default_tgv) mvar in - match Bir.VariableMap.find_opt var ctx.ctx_vars with - | Some _ -> ctx_vars - | None -> - let value = - match (Bir.var_to_mir var).is_table with - | Some size -> TableVar (size, Array.make size Undefined) - | None -> SimpleVar Undefined - in - Bir.VariableMap.add var value ctx_vars) - vars ctx.ctx_vars; - } - - type run_error = - | NanOrInf of string * Bir.expression Pos.marked - | StructuredError of - (string * (string option * Pos.t) list * (unit -> unit) option) - - exception RuntimeError of run_error * ctx - - let raise_runtime_as_structured (e : run_error) = - match e with - | NanOrInf (v, e) -> - Errors.raise_spanned_error - (Format.asprintf "Expression evaluated to %s: %a" v - Format_bir.format_expression (Pos.unmark e)) - (Pos.get_position e) - | StructuredError (msg, pos, kont) -> - raise (Errors.StructuredError (msg, pos, kont)) - - let is_zero (l : value) : bool = - match l with Number z -> N.is_zero z | _ -> false - - let real_of_bool (b : bool) = if b then N.one () else N.zero () - - let bool_of_real (f : N.t) : bool = not N.(f =. zero ()) - - let evaluate_array_index (index : value) (size : int) (values : value array) : - value = - let idx = - match index with - | Undefined -> assert false (* should not happen *) - | Number f -> roundf f - in - if N.(idx >=. N.of_int (Int64.of_int size)) then Undefined - else if N.(idx <. N.zero ()) then Number (N.zero ()) - else values.(Int64.to_int (N.to_int idx)) - - let compare_numbers op i1 i2 = - let epsilon = N.of_float !Cli.comparison_error_margin in - match op with - | Mast.Gt -> N.(i1 >. i2 +. epsilon) - | Mast.Gte -> N.(i1 >. i2 -. epsilon) - | Mast.Lt -> N.(i1 +. epsilon <. i2) - | Mast.Lte -> N.(i1 -. epsilon <. i2) - | Mast.Eq -> N.(N.abs (i1 -. i2) <. epsilon) - | Mast.Neq -> N.(N.abs (i1 -. i2) >=. epsilon) - - let rec evaluate_expr (ctx : ctx) (p : Mir.program) - (e : Bir.expression Pos.marked) : value = - let out = - try - match Pos.unmark e with - | Comparison (op, e1, e2) -> ( - let new_e1 = evaluate_expr ctx p e1 in - let new_e2 = evaluate_expr ctx p e2 in - match (Pos.unmark op, new_e1, new_e2) with - | Mast.Gt, _, Undefined | Mast.Gt, Undefined, _ -> Undefined - | Mast.Gte, _, Undefined | Mast.Gte, Undefined, _ -> Undefined - | Mast.Lt, _, Undefined | Mast.Lt, Undefined, _ -> Undefined - | Mast.Lte, _, Undefined | Mast.Lte, Undefined, _ -> Undefined - | Mast.Eq, _, Undefined | Mast.Eq, Undefined, _ -> Undefined - | Mast.Neq, _, Undefined | Mast.Neq, Undefined, _ -> Undefined - | op, Number i1, Number i2 -> - Number (real_of_bool (compare_numbers op i1 i2))) - | Binop (op, e1, e2) -> ( - let new_e1 = evaluate_expr ctx p e1 in - let new_e2 = evaluate_expr ctx p e2 in - match (Pos.unmark op, new_e1, new_e2) with - | Mast.Add, Number i1, Number i2 -> Number N.(i1 +. i2) - | Mast.Add, Number i1, Undefined -> Number N.(i1 +. zero ()) - | Mast.Add, Undefined, Number i2 -> Number N.(zero () +. i2) - | Mast.Add, Undefined, Undefined -> Undefined - | Mast.Sub, Number i1, Number i2 -> Number N.(i1 -. i2) - | Mast.Sub, Number i1, Undefined -> Number N.(i1 -. zero ()) - | Mast.Sub, Undefined, Number i2 -> Number N.(zero () -. i2) - | Mast.Sub, Undefined, Undefined -> Undefined - | Mast.Mul, _, Undefined | Mast.Mul, Undefined, _ -> Undefined - | Mast.Mul, Number i1, Number i2 -> Number N.(i1 *. i2) - | Mast.Div, Undefined, _ | Mast.Div, _, Undefined -> - Undefined (* yes... *) - | Mast.Div, _, l2 when is_zero l2 -> Number (N.zero ()) - | Mast.Div, Number i1, Number i2 -> Number N.(i1 /. i2) - | Mast.And, Undefined, _ | Mast.And, _, Undefined -> Undefined - | Mast.Or, Undefined, Undefined -> Undefined - | Mast.Or, Undefined, Number i | Mast.Or, Number i, Undefined -> - Number i - | Mast.And, Number i1, Number i2 -> - Number (real_of_bool (bool_of_real i1 && bool_of_real i2)) - | Mast.Or, Number i1, Number i2 -> - Number (real_of_bool (bool_of_real i1 || bool_of_real i2))) - | Unop (op, e1) -> ( - let new_e1 = evaluate_expr ctx p e1 in - match (op, new_e1) with - | Mast.Not, Number b1 -> - Number (real_of_bool (not (bool_of_real b1))) - | Mast.Minus, Number f1 -> Number N.(zero () -. f1) - | Mast.Not, Undefined -> Undefined - | Mast.Minus, Undefined -> Undefined) - | Conditional (e1, e2, e3) -> ( - let new_e1 = evaluate_expr ctx p e1 in - match new_e1 with - | Number z when N.(z =. zero ()) -> evaluate_expr ctx p e3 - | Number _ -> evaluate_expr ctx p e2 (* the float is not zero *) - | Undefined -> Undefined) - | Literal Undefined -> Undefined - | Literal (Float f) -> Number (N.of_float f) - | Index (var, e1) -> ( - let var = Pos.unmark var in - let var = - match IntMap.find_opt var.Bir.mir_var.id ctx.ctx_it with - | Some mvar -> Bir.(var_from_mir default_tgv) mvar - | None -> var - in - let new_e1 = evaluate_expr ctx p e1 in - if new_e1 = Undefined then Undefined - else - match Bir.VariableMap.find var ctx.ctx_vars with - | SimpleVar e -> - let idx = - match new_e1 with - | Undefined -> assert false (* should not happen *) - | Number f -> roundf f - in - if N.(idx >=. N.of_int (Int64.of_int 1)) then Undefined - else if N.(idx <. N.zero ()) then Number (N.zero ()) - else e - | TableVar (size, values) -> - evaluate_array_index new_e1 size values) - | LocalVar lvar -> ( - try Pos.unmark (Mir.LocalVariableMap.find lvar ctx.ctx_local_vars) - with Not_found -> assert false (* should not happen*)) - | Var var -> - let var = - match IntMap.find_opt var.Bir.mir_var.id ctx.ctx_it with - | Some mvar -> Bir.(var_from_mir default_tgv) mvar - | None -> var - in - let r = - try - match Bir.VariableMap.find var ctx.ctx_vars with - | SimpleVar l -> l - | TableVar (size, tab) -> - if size > 0 then tab.(0) else Undefined - with Not_found -> - Errors.raise_spanned_error - ("Var not found (should not happen): " - ^ Pos.unmark (Bir.var_to_mir var).Mir.Variable.name) - (Pos.get_position e) - in - r - | LocalLet (lvar, e1, e2) -> - let new_e1 = evaluate_expr ctx p e1 in - let new_e2 = - evaluate_expr - { - ctx with - ctx_local_vars = - Mir.LocalVariableMap.add lvar - (Pos.same_pos_as new_e1 e1) - ctx.ctx_local_vars; - } - p e2 - in - new_e2 - | FunctionCall (ArrFunc, [ arg ]) -> ( - let new_arg = evaluate_expr ctx p arg in - match new_arg with - | Number x -> Number (roundf x) - | Undefined -> Undefined - (*nope:Float 0.*)) - | FunctionCall (InfFunc, [ arg ]) -> ( - let new_arg = evaluate_expr ctx p arg in - match new_arg with - | Number x -> Number (truncatef x) - | Undefined -> Undefined - (*Float 0.*)) - | FunctionCall (PresentFunc, [ arg ]) -> ( - match evaluate_expr ctx p arg with - | Undefined -> false_value () - | _ -> true_value ()) - | FunctionCall (Supzero, [ arg ]) -> ( - match evaluate_expr ctx p arg with - | Undefined -> Undefined - | Number f as n -> - if compare_numbers Mast.Lte f (N.zero ()) then Undefined else n) - | FunctionCall (AbsFunc, [ arg ]) -> ( - match evaluate_expr ctx p arg with - | Undefined -> Undefined - | Number f -> Number (N.abs f)) - | FunctionCall (MinFunc, [ arg1; arg2 ]) -> ( - match (evaluate_expr ctx p arg1, evaluate_expr ctx p arg2) with - | Undefined, Undefined -> Undefined - | Undefined, Number f | Number f, Undefined -> - Number (N.min (N.zero ()) f) - | Number fl, Number fr -> Number (N.min fl fr)) - | FunctionCall (MaxFunc, [ arg1; arg2 ]) -> ( - match (evaluate_expr ctx p arg1, evaluate_expr ctx p arg2) with - | Undefined, Undefined -> Undefined - | Undefined, Number f | Number f, Undefined -> - Number (N.max (N.zero ()) f) - | Number fl, Number fr -> Number (N.max fl fr)) - | FunctionCall (Multimax, [ arg1; arg2 ]) -> ( - match evaluate_expr ctx p arg1 with - | Undefined -> Undefined - | Number f -> ( - let up = N.to_int (roundf f) in - let var_arg2 = - match Pos.unmark arg2 with Var v -> v | _ -> assert false - (* todo: rte *) - in - let cast_to_int (v : value) : Int64.t option = - match v with - | Number f -> Some (N.to_int (roundf f)) - | Undefined -> None - in - let pos = Pos.get_position arg2 in - let access_index (i : int) : Int64.t option = - cast_to_int - @@ evaluate_expr ctx p - ( Index - ( (var_arg2, pos), - (Literal (Float (float_of_int i)), pos) ), - pos ) - in - let maxi = ref (access_index 0) in - for i = 0 to Int64.to_int up do - match access_index i with - | None -> () - | Some n -> - maxi := - Option.fold ~none:(Some n) - ~some:(fun m -> Some (max n m)) - !maxi - done; - match !maxi with - | None -> Undefined - | Some f -> Number (N.of_int f))) - | FunctionCall (_func, _) -> assert false - | Attribut (_v, var, a) -> ( - match IntMap.find_opt var.mir_var.id ctx.ctx_it with - | Some mvar -> ( - match - List.find_opt - (fun (attr, _) -> Pos.unmark a = Pos.unmark attr) - mvar.attributes - with - | Some (_, l) -> Number (N.of_float (float (Pos.unmark l))) - | None -> Undefined) - | None -> assert false) - | Size var -> ( - match IntMap.find_opt var.mir_var.id ctx.ctx_it with - | Some mvar -> ( - match mvar.is_table with - | Some i -> Number (N.of_float (float_of_int i)) - | None -> Number (N.of_float 1.0)) - | None -> assert false) - | NbAnomalies -> Number (N.of_float (float ctx.ctx_nb_anos)) - | NbDiscordances -> Number (N.of_float (float ctx.ctx_nb_discos)) - | NbInformatives -> Number (N.of_float (float ctx.ctx_nb_infos)) - | NbBloquantes -> Number (N.of_float (float ctx.ctx_nb_bloquantes)) - | NbCategory _ -> assert false - with - | RuntimeError (e, ctx) -> - if !exit_on_rte then raise_runtime_as_structured e - else raise (RuntimeError (e, ctx)) - | Errors.StructuredError (msg, pos, kont) -> - if !exit_on_rte then - raise - (Errors.StructuredError - ( msg, - pos - @ [ - (Some "Expression raising the error:", Pos.get_position e); - ], - kont )) - else raise (RuntimeError (StructuredError (msg, pos, kont), ctx)) - in - if match out with Undefined -> false | Number out -> N.is_nan_or_inf out - then - let e = - NanOrInf - ( (match out with - | Undefined -> assert false - | Number out -> Format.asprintf "%a" N.format_t out), - e ) - in - if !exit_on_rte then raise_runtime_as_structured e - else raise (RuntimeError (e, ctx)) - else out - - let evaluate_simple_variable (p : Bir.program) (ctx : ctx) - (expr : Bir.expression) : var_value = - SimpleVar (evaluate_expr ctx p.mir_program (expr, Pos.no_pos)) - - let evaluate_variable (p : Bir.program) (ctx : ctx) (var : Bir.variable) - (curr_value : var_value) (vdef : Bir.variable Mir.variable_def_) : - var_value = - match vdef with - | Mir.SimpleVar e -> ( - match var.Bir.mir_var.Mir.is_table with - | Some sz -> - let value = evaluate_expr ctx p.mir_program e in - let tab = - match curr_value with - | SimpleVar _ -> Array.make sz value - | TableVar (size, tab) -> - assert (size = sz); - for i = 0 to size - 1 do - tab.(i) <- value - done; - tab - in - TableVar (sz, tab) - | None -> SimpleVar (evaluate_expr ctx p.mir_program e)) - | Mir.TableVar (size, es) -> ( - match es with - | IndexGeneric (v, e) -> ( - let i = - match Bir.VariableMap.find_opt v ctx.ctx_vars with - | Some (SimpleVar n) -> n - | Some (TableVar (s, t)) -> if s > 0 then t.(0) else Undefined - | None -> assert false - in - match var.Bir.mir_var.Mir.is_table with - | Some sz -> - assert (size = sz); - let tab = - match curr_value with - | SimpleVar e -> Array.make sz e - | TableVar (s, vals) -> - assert (s = size); - vals - in - (match i with - | Undefined -> () - | Number f -> - let i' = int_of_float (N.to_float f) in - if 0 <= i' && i' < size then - tab.(i') <- evaluate_expr ctx p.mir_program e); - TableVar (size, tab) - | None -> ( - match i with - | Undefined -> curr_value - | Number f -> - let i' = int_of_float (N.to_float f) in - if i' = 0 then SimpleVar (evaluate_expr ctx p.mir_program e) - else curr_value)) - | IndexTable it -> ( - match var.Bir.mir_var.Mir.is_table with - | Some sz -> - assert (size = sz); - let tab = - match curr_value with - | SimpleVar e -> Array.make sz e - | TableVar (s, vals) -> - assert (s = size); - vals - in - Mir.IndexMap.iter - (fun i e -> - if 0 <= i && i < sz then - tab.(i) <- evaluate_expr ctx p.mir_program e) - it; - TableVar (size, tab) - | None -> ( - match Mir.IndexMap.find_opt 0 it with - | Some e -> SimpleVar (evaluate_expr ctx p.mir_program e) - | None -> curr_value))) - | Mir.InputVar -> assert false - - exception BlockingError of ctx - - let rec evaluate_stmt (canBlock : bool) (p : Bir.program) (ctx : ctx) - (stmt : Bir.stmt) (loc : code_location) = - match Pos.unmark stmt with - | Bir.SAssign (var, vdef) -> - let var = - match IntMap.find_opt var.Bir.mir_var.id ctx.ctx_it with - | Some mvar -> Bir.(var_from_mir default_tgv) mvar - | None -> var - in - let value = - try Bir.VariableMap.find var ctx.ctx_vars - with Not_found -> ( - match (Bir.var_to_mir var).is_table with - | Some size -> TableVar (size, Array.make size Undefined) - | None -> SimpleVar Undefined) - in - let res = evaluate_variable p ctx var value vdef in - !assign_hook var (fun _ -> var_value_to_var_literal res) loc; - { ctx with ctx_vars = Bir.VariableMap.add var res ctx.ctx_vars } - | Bir.SConditional (b, t, f) -> ( - match evaluate_simple_variable p ctx b with - | SimpleVar (Number z) when N.(z =. zero ()) -> - evaluate_stmts canBlock p ctx f (ConditionalBranch false :: loc) 0 - | SimpleVar (Number _) -> - evaluate_stmts canBlock p ctx t (ConditionalBranch true :: loc) 0 - | SimpleVar Undefined -> ctx - | _ -> assert false) - | Bir.SVerifBlock stmts -> - evaluate_stmts true p ctx stmts (InsideBlock 0 :: loc) 0 - | Bir.SRovCall r -> - let rule = Bir.ROVMap.find r p.rules_and_verifs in - evaluate_stmts canBlock p ctx - (Bir.rule_or_verif_as_statements rule) - (InsideRule r :: loc) 0 - | Bir.SFunctionCall (f, _args) -> ( - match Mir.TargetMap.find_opt f p.targets with - | Some tf -> evaluate_target canBlock p ctx loc tf - | None -> - evaluate_stmts canBlock p ctx - (Bir.FunctionMap.find f p.mpp_functions).mppf_stmts loc 0) - (* Mpp_function arguments seem to be used only to determine which variables - are actually output. Does this actually make sense ? *) - | Bir.SPrint (std, args) -> ( - let std_fmt, ctx_pr = - match std with - | Mast.StdOut -> (Format.std_formatter, ctx.ctx_pr_out) - | Mast.StdErr -> (Format.err_formatter, ctx.ctx_pr_err) - in - let pr_indent ctx_pr = - if ctx_pr.is_newline then ( - for _i = 1 to ctx_pr.indent do - Format.fprintf std_fmt " " - done; - { ctx_pr with is_newline = false }) - else ctx_pr - in - let pr_raw ctx_pr s = - let len = String.length s in - let rec aux ctx_pr = function - | n when n >= len -> ctx_pr - | n -> ( - match s.[n] with - | '\n' -> - Format.fprintf std_fmt "\n"; - aux { ctx_pr with is_newline = true } (n + 1) - | c -> - let ctx_pr = pr_indent ctx_pr in - Format.fprintf std_fmt "%c" c; - aux ctx_pr (n + 1)) - in - aux ctx_pr 0 - in - let ctx_pr = - List.fold_left - (fun ctx_pr arg -> - match arg with - | Mir.PrintString s -> pr_raw ctx_pr s - | Mir.PrintName (_, var) -> ( - match IntMap.find_opt var.Mir.id ctx.ctx_it with - | Some mvar -> pr_raw ctx_pr (Pos.unmark mvar.Mir.name) - | None -> assert false) - | Mir.PrintAlias (_, var) -> ( - match IntMap.find_opt var.Mir.id ctx.ctx_it with - | Some mvar -> - pr_raw ctx_pr - (match mvar.Mir.alias with Some a -> a | None -> "") - | None -> assert false) - | Mir.PrintIndent e -> - let var_value = - evaluate_simple_variable p ctx (Pos.unmark e) - in - let diff = - match var_value with - | SimpleVar e -> ( - match e with - | Undefined -> 0 - | Number x -> Int64.to_int (N.to_int (roundf x))) - | TableVar (_, es) -> ( - if Array.length es = 0 then 0 - else - match es.(0) with - | Undefined -> 0 - | Number x -> Int64.to_int (N.to_int (roundf x))) - in - { ctx_pr with indent = max 0 (ctx_pr.indent + diff) } - | Mir.PrintExpr (e, mi, ma) -> - let var_value = - evaluate_simple_variable p ctx (Pos.unmark e) - in - let ctx_pr = pr_indent ctx_pr in - format_var_value_prec mi ma std_fmt var_value; - ctx_pr) - ctx_pr args - in - match std with - | Mast.StdOut -> { ctx with ctx_pr_out = ctx_pr } - | Mast.StdErr -> { ctx with ctx_pr_err = ctx_pr }) - | Bir.SIterate (var, vcs, expr, stmts) -> - let eval vc ctx = - Mir.VariableDict.fold - (fun v ctx -> - if v.Mir.cats = Some vc then - let ctx = - { - ctx with - ctx_it = IntMap.add var.Bir.mir_var.id v ctx.ctx_it; - } - in - match evaluate_simple_variable p ctx expr with - | SimpleVar (Number z) when N.(z =. one ()) -> - evaluate_stmts canBlock p ctx stmts - (ConditionalBranch true :: loc) - 0 - | SimpleVar _ -> ctx - | _ -> assert false - else ctx) - p.Bir.mir_program.program_vars ctx - in - Mir.CatVarSet.fold eval vcs ctx - | Bir.SRestore (vars, var_params, stmts) -> - let backup = - Bir.VariableSet.fold - (fun v backup -> - let v = - match IntMap.find_opt v.mir_var.id ctx.ctx_it with - | None -> v - | Some v -> Bir.(var_from_mir default_tgv) v - in - let value = Bir.VariableMap.find v ctx.ctx_vars in - (v, value) :: backup) - vars [] - in - let backup = - List.fold_left - (fun backup (var, vcs, expr) -> - Mir.CatVarSet.fold - (fun vc backup -> - Mir.VariableDict.fold - (fun v backup -> - if v.Mir.cats = Some vc then - let ctx = - { - ctx with - ctx_it = IntMap.add var.Bir.mir_var.id v ctx.ctx_it; - } - in - match evaluate_simple_variable p ctx expr with - | SimpleVar (Number z) when N.(z =. one ()) -> - let v = Bir.(var_from_mir default_tgv) v in - let value = Bir.VariableMap.find v ctx.ctx_vars in - (v, value) :: backup - | SimpleVar _ -> backup - | _ -> assert false - else backup) - p.Bir.mir_program.program_vars backup) - vcs backup) - backup var_params - in - let ctx = - evaluate_stmts canBlock p ctx stmts (InsideBlock 0 :: loc) 0 - in - let ctx_vars = - List.fold_left - (fun ctx_vars (v, value) -> - Bir.VariableMap.update v (fun _ -> Some value) ctx_vars) - ctx.ctx_vars backup - in - { ctx with ctx_vars } - | Bir.SRaiseError (err, var_opt) -> - let ctx_nb_anos = - if err.typ = Mast.Anomaly then ctx.ctx_nb_anos + 1 - else ctx.ctx_nb_anos - in - let ctx_nb_discos = - if err.typ = Mast.Discordance then ctx.ctx_nb_discos + 1 - else ctx.ctx_nb_discos - in - let ctx_nb_infos = - if err.typ = Mast.Information then ctx.ctx_nb_infos + 1 - else ctx.ctx_nb_infos - in - let ctx_nb_bloquantes, is_blocking = - let is_b = - err.typ = Mast.Anomaly && Pos.unmark err.descr.isisf = "N" - in - ((ctx.ctx_nb_bloquantes + if is_b then 1 else 0), is_b) - in - let ctx = - { - ctx with - ctx_anos = ctx.ctx_anos @ [ (err, var_opt) ]; - ctx_nb_anos; - ctx_nb_discos; - ctx_nb_infos; - ctx_nb_bloquantes; - } - in - (* Format.eprintf "leve erreur %s\n" (Pos.unmark err.Mir.name);*) - if is_blocking && ctx.ctx_nb_bloquantes >= 4 && canBlock then - raise (BlockingError ctx) - else ctx - | Bir.SCleanErrors -> - (*Format.eprintf "nettoie erreurs\n";*) - { - ctx with - ctx_anos = []; - ctx_nb_anos = 0; - ctx_nb_discos = 0; - ctx_nb_infos = 0; - ctx_nb_bloquantes = 0; - } - | Bir.SFinalizeErrors -> - let not_in_old_anos (err, _) = - let name = Pos.unmark err.Mir.name in - not (StrSet.mem name ctx.ctx_old_anos) - in - let ctx_finalized_anos = - let rec merge_anos old_anos new_anos = - match (old_anos, new_anos) with - | [], anos | anos, [] -> anos - | _ :: old_tl, a :: new_tl -> a :: merge_anos old_tl new_tl - in - let new_anos = List.filter not_in_old_anos ctx.ctx_anos in - (* List.iter (fun (err, _) -> Format.eprintf "finalise: %s\n" - (Pos.unmark err.Mir.name)) new_anos;*) - merge_anos ctx.ctx_finalized_anos new_anos - in - let add_ano res (err, _) = StrSet.add (Pos.unmark err.Mir.name) res in - let ctx_old_anos = - List.fold_left add_ano ctx.ctx_old_anos ctx.ctx_anos - in - { ctx with ctx_finalized_anos; ctx_old_anos } - | Bir.SExportErrors -> - let ctx_exported_anos = - ctx.ctx_exported_anos @ ctx.ctx_finalized_anos - in - (* List.iter (fun (err, _) -> Format.eprintf "sortie: %s\n" (Pos.unmark - err.Mir.name)) ctx.ctx_finalized_anos;*) - { ctx with ctx_exported_anos; ctx_finalized_anos = [] } - - and evaluate_stmts canBlock (p : Bir.program) (ctx : ctx) - (stmts : Bir.stmt list) (loc : code_location) (start_value : int) : ctx = - let ctx, _ = - try - List.fold_left - (fun (ctx, i) stmt -> - (evaluate_stmt canBlock p ctx stmt (InsideBlock i :: loc), i + 1)) - (ctx, start_value) stmts - with BlockingError ctx as b_err -> - if canBlock then raise b_err else (ctx, 0) - in - ctx - - and evaluate_target canBlock (p : Bir.program) (ctx : ctx) - (loc : code_location) (tf : Bir.target_function) = - let ctx = - let ctx_vars = - StrMap.fold - (fun _ (var, _, size) ctx_vars -> - match size with - | None -> Bir.VariableMap.add var (SimpleVar Undefined) ctx_vars - | Some sz -> - let values = Array.init sz (fun _ -> Undefined) in - Bir.VariableMap.add var (TableVar (sz, values)) ctx_vars) - tf.tmp_vars ctx.ctx_vars - in - { ctx with ctx_vars } - in - evaluate_stmts canBlock p ctx tf.stmts loc 0 - - let evaluate_program (p : Bir.program) (ctx : ctx) - (code_loc_start_value : int) : ctx = - try - let ctx = - evaluate_stmts false p ctx - (Bir.main_statements p @ [ (Bir.SExportErrors, Pos.no_pos) ]) - [] code_loc_start_value - (* For the interpreter to operate properly, all input variables must be - declared at some point, even if they aren't used as input (either - contextual constants or entered at interpreter prompt). The M program - doesn't include default assignation for non-entered input variables, - so unused inputs are not declared in the main statements. - - The use of main_statement_with_context_and_tgv_init ensures every - variable from the TGV dictionnary is assigned to "undefined" by - default, before context statements overload the contextual constants - according to the spec file and interpreter prompt assignements - overload entered variables. *) - in - ctx - with RuntimeError (e, ctx) -> - if !exit_on_rte then raise_runtime_as_structured e - else raise (RuntimeError (e, ctx)) -end - -module BigIntPrecision = struct - let scaling_factor_bits = ref 64 -end - -module MainframeLongSize = struct - let max_long = ref Int64.max_int -end - -module FloatDefInterp = - Make (Bir_number.RegularFloatNumber) (Bir_roundops.DefaultRoundOps) -module FloatMultInterp = - Make (Bir_number.RegularFloatNumber) (Bir_roundops.MultiRoundOps) -module FloatMfInterp = - Make - (Bir_number.RegularFloatNumber) - (Bir_roundops.MainframeRoundOps (MainframeLongSize)) -module MPFRDefInterp = - Make (Bir_number.MPFRNumber) (Bir_roundops.DefaultRoundOps) -module MPFRMultInterp = - Make (Bir_number.MPFRNumber) (Bir_roundops.MultiRoundOps) -module MPFRMfInterp = - Make - (Bir_number.MPFRNumber) - (Bir_roundops.MainframeRoundOps (MainframeLongSize)) -module BigIntDefInterp = - Make - (Bir_number.BigIntFixedPointNumber - (BigIntPrecision)) - (Bir_roundops.DefaultRoundOps) -module BigIntMultInterp = - Make - (Bir_number.BigIntFixedPointNumber - (BigIntPrecision)) - (Bir_roundops.MultiRoundOps) -module BigIntMfInterp = - Make - (Bir_number.BigIntFixedPointNumber - (BigIntPrecision)) - (Bir_roundops.MainframeRoundOps (MainframeLongSize)) -module IntvDefInterp = - Make (Bir_number.IntervalNumber) (Bir_roundops.DefaultRoundOps) -module IntvMultInterp = - Make (Bir_number.IntervalNumber) (Bir_roundops.MultiRoundOps) -module IntvMfInterp = - Make - (Bir_number.IntervalNumber) - (Bir_roundops.MainframeRoundOps (MainframeLongSize)) -module RatDefInterp = - Make (Bir_number.RationalNumber) (Bir_roundops.DefaultRoundOps) -module RatMultInterp = - Make (Bir_number.RationalNumber) (Bir_roundops.MultiRoundOps) -module RatMfInterp = - Make - (Bir_number.RationalNumber) - (Bir_roundops.MainframeRoundOps (MainframeLongSize)) - -let get_interp (sort : Cli.value_sort) (roundops : Cli.round_ops) : (module S) = - match (sort, roundops) with - | RegularFloat, RODefault -> (module FloatDefInterp) - | RegularFloat, ROMulti -> (module FloatMultInterp) - | RegularFloat, ROMainframe _ -> (module FloatMfInterp) - | MPFR _, RODefault -> (module MPFRDefInterp) - | MPFR _, ROMulti -> (module MPFRMultInterp) - | MPFR _, ROMainframe _ -> (module MPFRMfInterp) - | BigInt _, RODefault -> (module BigIntDefInterp) - | BigInt _, ROMulti -> (module BigIntMultInterp) - | BigInt _, ROMainframe _ -> (module BigIntMfInterp) - | Interval, RODefault -> (module IntvDefInterp) - | Interval, ROMulti -> (module IntvMultInterp) - | Interval, ROMainframe _ -> (module IntvMfInterp) - | Rational, RODefault -> (module RatDefInterp) - | Rational, ROMulti -> (module RatMultInterp) - | Rational, ROMainframe _ -> (module RatMfInterp) - -let prepare_interp (sort : Cli.value_sort) (roundops : Cli.round_ops) : unit = - begin - match sort with - | MPFR prec -> Mpfr.set_default_prec prec - | BigInt prec -> BigIntPrecision.scaling_factor_bits := prec - | Interval -> Mpfr.set_default_prec 64 - | _ -> () - end; - match roundops with - | ROMainframe long_size -> - let max_long = - if long_size = 32 then Int64.of_int32 Int32.max_int - else if long_size = 64 then Int64.max_int - else assert false - (* checked when parsing command line *) - in - MainframeLongSize.max_long := max_long - | _ -> () - -let evaluate_program (p : Bir.program) (inputs : Mir.literal Bir.VariableMap.t) - (sort : Cli.value_sort) (roundops : Cli.round_ops) : - float option StrMap.t * StrSet.t = - prepare_interp sort roundops; - let module Interp = (val get_interp sort roundops : S) in - let ctx = Interp.update_ctx_with_inputs Interp.empty_ctx inputs in - let ctx = Interp.complete_ctx ctx p.Bir.mir_program.Mir.program_vars in - let ctx = Interp.evaluate_program p ctx 0 in - let varMap = - let fold var value res = - let name = Pos.unmark var.Bir.mir_var.Mir.name in - let fVal = - match value with - | Interp.SimpleVar litt -> ( - match Interp.value_to_literal litt with - | Mir.Float f -> Some f - | Mir.Undefined -> None) - | _ -> None - in - StrMap.add name fVal res - in - Bir.VariableMap.fold fold ctx.ctx_vars StrMap.empty - in - let anoSet = - let fold res (e, _) = StrSet.add (Pos.unmark e.Mir.name) res in - List.fold_left fold StrSet.empty ctx.ctx_exported_anos - in - (varMap, anoSet) - -let evaluate_expr (p : Mir.program) (e : Bir.expression Pos.marked) - (sort : Cli.value_sort) (roundops : Cli.round_ops) : Mir.literal = - let module Interp = (val get_interp sort roundops : S) in - Interp.value_to_literal (Interp.evaluate_expr Interp.empty_ctx p e) diff --git a/src/mlang/backend_ir/format_bir.ml b/src/mlang/backend_ir/format_bir.ml deleted file mode 100644 index 4515db462..000000000 --- a/src/mlang/backend_ir/format_bir.ml +++ /dev/null @@ -1,126 +0,0 @@ -(* Copyright (C) 2019-2021-2020 Inria, contributors: Denis Merigoux - Raphaël Monat - - 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 Bir - -let format_expression fmt (e : expression) = - Format_mir.format_expression fmt (Mir.map_expr_var Bir.var_to_mir e) - -let format_variable_def fmt (vdef : variable_def) = - Format_mir.format_variable_def fmt (Mir.map_var_def_var Bir.var_to_mir vdef) - -let format_print_arg fmt = function - | Mir.PrintString s -> Format.fprintf fmt "\"%s\"" s - | Mir.PrintName (v, _) -> Format.fprintf fmt "nom(%s)" (Pos.unmark v) - | Mir.PrintAlias (v, _) -> Format.fprintf fmt "alias(%s)" (Pos.unmark v) - | Mir.PrintIndent e -> - Format.fprintf fmt "indenter(%a)" - (Format_mast.pp_unmark format_expression) - e - | Mir.PrintExpr (e, min, max) -> - if min = max_int then - Format.fprintf fmt "(%a)" (Format_mast.pp_unmark format_expression) e - else if max = max_int then - Format.fprintf fmt "(%a):%d" - (Format_mast.pp_unmark format_expression) - e min - else - Format.fprintf fmt "(%a):%d..%d" - (Format_mast.pp_unmark format_expression) - e min max - -let rec format_stmt fmt (stmt : stmt) = - match Pos.unmark stmt with - | SAssign (v, vdef) -> - Format.fprintf fmt "%s = %a" - (Pos.unmark (var_to_mir v).Mir.Variable.name) - format_variable_def vdef - | SConditional (cond, t, []) -> - Format.fprintf fmt "if(%a):@\n@[ %a@]@\n" format_expression cond - format_stmts t - | SConditional (cond, t, f) -> - Format.fprintf fmt "if(%a):@\n@[ %a@]else:@\n@[ %a@]@\n" - format_expression cond format_stmts t format_stmts f - | SVerifBlock stmts -> - Format.fprintf fmt - "@[# debut verif block@\n%a@]@\n# fin verif block@\n" format_stmts - stmts - | SRovCall r -> - Format.fprintf fmt "call_rule(%d)@\n" (Mir.num_of_rule_or_verif_id r) - | SFunctionCall (func, args) -> - Format.fprintf fmt "call_function: %s with args %a@," func - (Format.pp_print_list (fun fmt arg -> - Format.fprintf fmt "%s" (arg.Mir.Variable.name |> Pos.unmark))) - args - | SPrint (std, args) -> - let print_cmd = - match std with StdOut -> "afficher" | StdErr -> "afficher_erreur" - in - Format.fprintf fmt "%s %a;" print_cmd - (Format_mast.pp_print_list_space format_print_arg) - args - | SIterate (var, vcs, expr, stmts) -> - Format.fprintf fmt - "iterate variable %s@\n: categorie %a@\n: avec %a@\n: dans (" - (Pos.unmark (var_to_mir var).Mir.Variable.name) - (Mir.CatVarSet.pp ()) vcs format_expression expr; - Format.fprintf fmt "@[ %a@]@\n)@\n" format_stmts stmts - | SRestore (vars, var_params, stmts) -> - let format_var_param fmt (var, vcs, expr) = - Format.fprintf fmt ": variable %s : categorie %a : avec %a@\n" - (Pos.unmark (var_to_mir var).Mir.Variable.name) - (Mir.CatVarSet.pp ()) vcs format_expression expr - in - Format.fprintf fmt "restaure@;: %a@\n%a: apres (" - (VariableSet.pp ~sep:", " - ~pp_elt:(fun fmt var -> - Format.fprintf fmt "%s" - (Pos.unmark (var_to_mir var).Mir.Variable.name)) - ()) - vars - (Format_mast.pp_print_list_space format_var_param) - var_params; - Format.fprintf fmt "@[ %a@]@\n)@\n" format_stmts stmts - | SRaiseError (err, var_opt) -> - Format.fprintf fmt "leve_erreur %s %s\n" (Pos.unmark err.Mir.name) - (match var_opt with Some var -> " " ^ var | None -> "") - | SCleanErrors -> Format.fprintf fmt "nettoie_erreurs\n" - | SExportErrors -> Format.fprintf fmt "exporte_erreurs\n" - | SFinalizeErrors -> Format.fprintf fmt "finalise_erreurs\n" - -and format_stmts fmt (stmts : stmt list) = - Format.pp_print_list ~pp_sep:(fun _ () -> ()) format_stmt fmt stmts - -let format_rule fmt rule = - match rule.rov_code with - | Rule stmts -> - Format.fprintf fmt "rule %d:@\n@[ %a@]@\n" - (Mir.num_of_rule_or_verif_id rule.rov_id) - format_stmts stmts - | Verif stmt -> - Format.fprintf fmt "verif %d:@\n@[ %a@]@\n" - (Mir.num_of_rule_or_verif_id rule.rov_id) - format_stmts [ stmt ] - -let format_rules fmt rules = - Format.pp_print_list - ~pp_sep:(fun _ () -> ()) - format_rule fmt - (Bir.ROVMap.bindings rules |> List.map snd) - -let format_program fmt (p : program) = - Format.fprintf fmt "%a%a" format_rules p.rules_and_verifs format_stmts - (Bir.main_statements p) diff --git a/src/mlang/backend_ir/format_bir.mli b/src/mlang/backend_ir/format_bir.mli deleted file mode 100644 index 0d16f3059..000000000 --- a/src/mlang/backend_ir/format_bir.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright (C) 2019-2021-2020 Inria, contributors: Denis Merigoux - Raphaël Monat - - 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 format_print_arg : Format.formatter -> Bir.variable Mir.print_arg -> unit - -val format_expression : Format.formatter -> Bir.expression -> unit - -val format_variable_def : Format.formatter -> Bir.variable_def -> unit - -val format_stmt : Format.formatter -> Bir.stmt -> unit - -val format_stmts : Format.formatter -> Bir.stmt list -> unit - -val format_rule : Format.formatter -> Bir.rule_or_verif -> unit - -val format_rules : Format.formatter -> Bir.rule_or_verif Bir.ROVMap.t -> unit - -val format_program : Format.formatter -> Bir.program -> unit diff --git a/src/mlang/backend_ir/mir_to_bir.ml b/src/mlang/backend_ir/mir_to_bir.ml deleted file mode 100644 index 93b5ac661..000000000 --- a/src/mlang/backend_ir/mir_to_bir.ml +++ /dev/null @@ -1,178 +0,0 @@ -(* Copyright (C) 2019-2021 Inria, contributors: Denis Merigoux - Raphaël Monat - - 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 . *) - -let rec translate_m_code (m_program : Mir.program) - (instrs : Mir.instruction Pos.marked list) = - let rec aux res = function - | [] -> List.rev res - | (Mir.Affectation (vid, vdef), pos) :: instrs -> ( - try - let var = Mir.VariableDict.find vid m_program.program_vars in - let var_definition = - Mir.map_var_def_var - Bir.(var_from_mir default_tgv) - vdef.Mir.var_definition - in - match var_definition with - | InputVar -> aux res instrs - | TableVar _ | SimpleVar _ -> - aux - (( Bir.SAssign - (Bir.(var_from_mir default_tgv) var, var_definition), - Pos.get_position var.name ) - :: res) - instrs - with Not_found -> - Errors.raise_spanned_error - (Format.sprintf "unknown variable id %d" vid) - pos) - | (Mir.IfThenElse (e, ilt, ile), pos) :: instrs -> - let expr = Mir.map_expr_var Bir.(var_from_mir default_tgv) e in - let stmts_then = translate_m_code m_program ilt in - let stmts_else = translate_m_code m_program ile in - aux - ((Bir.SConditional (expr, stmts_then, stmts_else), pos) :: res) - instrs - | (Mir.ComputeTarget tn, pos) :: instrs -> - let name = Pos.unmark tn in - let stmt = - match Mir.TargetMap.find_opt name m_program.program_targets with - | Some _ -> (Bir.SFunctionCall (name, []), pos) - | None -> - Errors.raise_spanned_error - (Format.asprintf "Unknown target: %s" name) - (Pos.get_position tn) - in - aux (stmt :: res) instrs - | (Mir.VerifBlock stmts, pos) :: instrs -> - let stmts' = translate_m_code m_program stmts in - aux ((Bir.SVerifBlock stmts', pos) :: res) instrs - | (Mir.Print (std, args), pos) :: instrs -> - let bir_args = - List.rev - (List.fold_left - (fun res arg -> - let bir_arg = - match Pos.unmark arg with - | Mir.PrintString s -> Mir.PrintString s - | Mir.PrintName (v, vid) -> Mir.PrintName (v, vid) - | Mir.PrintAlias (v, vid) -> Mir.PrintAlias (v, vid) - | Mir.PrintIndent e -> - Mir.PrintIndent - (Pos.same_pos_as - (Mir.map_expr_var - Bir.(var_from_mir default_tgv) - (Pos.unmark e)) - e) - | Mir.PrintExpr (e, min, max) -> - Mir.PrintExpr - ( Pos.same_pos_as - (Mir.map_expr_var - Bir.(var_from_mir default_tgv) - (Pos.unmark e)) - e, - min, - max ) - in - bir_arg :: res) - [] args) - in - aux ((Bir.SPrint (std, bir_args), pos) :: res) instrs - | (Mir.Iterate (v, vcs, e, iit), pos) :: instrs -> - let var = - Bir.(var_from_mir default_tgv) - (Mir.VariableDict.find v m_program.program_vars) - in - let expr = - Mir.map_expr_var Bir.(var_from_mir default_tgv) (Pos.unmark e) - in - let stmts = translate_m_code m_program iit in - aux ((Bir.SIterate (var, vcs, expr, stmts), pos) :: res) instrs - | (Mir.Restore (vars, var_params, irest), pos) :: instrs -> - let vars = - Mir.VariableMap.fold - (fun v _ vars -> - let var = - Bir.(var_from_mir default_tgv) - (Mir.VariableDict.find v.Mir.id m_program.program_vars) - in - Bir.VariableSet.add var vars) - vars Bir.VariableSet.empty - in - let var_params = - List.fold_left - (fun var_params ((v : Mir.variable), vcs, expr) -> - let var = - Bir.(var_from_mir default_tgv) - (Mir.VariableDict.find v.Mir.id m_program.program_vars) - in - let expr = - Mir.map_expr_var - Bir.(var_from_mir default_tgv) - (Pos.unmark expr) - in - (var, vcs, expr) :: var_params) - [] var_params - in - let stmts = translate_m_code m_program irest in - aux ((Bir.SRestore (vars, var_params, stmts), pos) :: res) instrs - | (Mir.RaiseError (err, var_opt), pos) :: instrs -> - aux ((Bir.SRaiseError (err, var_opt), pos) :: res) instrs - | (Mir.CleanErrors, pos) :: instrs -> - aux ((Bir.SCleanErrors, pos) :: res) instrs - | (Mir.ExportErrors, pos) :: instrs -> - aux ((Bir.SExportErrors, pos) :: res) instrs - | (Mir.FinalizeErrors, pos) :: instrs -> - aux ((Bir.SFinalizeErrors, pos) :: res) instrs - in - aux [] instrs - -let create_combined_program (m_program : Mir.program) - (mpp_function_to_extract : string) : Bir.program = - try - let targets = - Mir.TargetMap.fold - (fun n t targets -> - let code = translate_m_code m_program t.Mir.target_prog in - Mir.TargetMap.add n - Bir. - { - file = t.Mir.target_file; - tmp_vars = - StrMap.map - (fun (var, pos, size) -> - (Bir.(var_from_mir default_tgv) var, pos, size)) - t.Mir.target_tmp_vars; - stmts = code; - is_verif = true; - } - targets) - m_program.program_targets Mir.TargetMap.empty - in - if not (Mir.TargetMap.mem mpp_function_to_extract targets) then - Errors.raise_error - (Format.asprintf "M target %s not found in M file!" - mpp_function_to_extract); - { - targets; - rules_and_verifs = Bir.ROVMap.empty; - mpp_functions = Bir.FunctionMap.empty; - main_function = mpp_function_to_extract; - idmap = m_program.program_idmap; - mir_program = m_program; - } - with Bir_interpreter.FloatDefInterp.RuntimeError (r, _ctx) -> - Bir_interpreter.FloatDefInterp.raise_runtime_as_structured r diff --git a/src/mlang/backend_ir/mir_to_bir.mli b/src/mlang/backend_ir/mir_to_bir.mli deleted file mode 100644 index 440153d46..000000000 --- a/src/mlang/backend_ir/mir_to_bir.mli +++ /dev/null @@ -1,22 +0,0 @@ -(* Copyright (C) 2019-2021 Inria, contributors: Denis Merigoux - Raphaël Monat - - 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 . *) - -(* Compiles the MPP IR and the M codebase into an MIR program. Partitioning can - be done by putting excluded inputs to undef and storing them into an - auxiliary variable (which is merged back afterwards) *) - -val create_combined_program : - Mir.program -> (* function to extract *) string -> Bir.program diff --git a/src/mlang/driver.ml b/src/mlang/driver.ml index f55938a00..1ddc1723c 100644 --- a/src/mlang/driver.ml +++ b/src/mlang/driver.ml @@ -42,11 +42,8 @@ let patch_rule_1 (backend : string option) (dgfip_flags : Dgfip_options.flags) let open Mast in let mk_assign var val_ = let v = if val_ then 1.0 else 0.0 in - ( SingleFormula - { - lvalue = ({ var = (Normal var, Pos.no_pos); index = None }, Pos.no_pos); - formula = (Literal (Float v), Pos.no_pos); - }, + ( Com.SingleFormula + ((Normal var, Pos.no_pos), None, (Literal (Float v), Pos.no_pos)), Pos.no_pos ) in let oceans, batch, iliad = @@ -60,11 +57,13 @@ let patch_rule_1 (backend : string option) (dgfip_flags : Dgfip_options.flags) match Pos.unmark item with | Rule r when Pos.unmark r.rule_number = 1 -> let fl = - [ - mk_assign "APPLI_OCEANS" oceans; - mk_assign "APPLI_BATCH" batch; - mk_assign "APPLI_ILIAD" iliad; - ] + List.map + (fun f -> Pos.same_pos_as (Com.Affectation f) f) + [ + mk_assign "APPLI_OCEANS" oceans; + mk_assign "APPLI_BATCH" batch; + mk_assign "APPLI_ILIAD" iliad; + ] in ( Rule { r with rule_formulaes = r.rule_formulaes @ fl }, Pos.get_position item ) @@ -79,10 +78,10 @@ let driver (files : string list) (without_dgfip_m : bool) (debug : bool) (output : string option) (run_all_tests : string option) (dgfip_test_filter : bool) (run_test : string option) (mpp_function : string) (optimize_unsafe_float : bool) - (code_coverage : bool) (precision : string option) - (roundops : string option) (comparison_error_margin : float option) - (income_year : int option) (m_clean_calls : bool) - (dgfip_options : string list option) = + (precision : string option) (roundops : string option) + (comparison_error_margin : float option) (income_year : int option) + (m_clean_calls : bool) (dgfip_options : string list option) = + let dgfip_flags = process_dgfip_options backend dgfip_options in if income_year = None then Errors.raise_error "income year missing (--income-year YEAR)"; let value_sort = @@ -132,7 +131,6 @@ let driver (files : string list) (without_dgfip_m : bool) (debug : bool) dep_graph_file print_cycles output optimize_unsafe_float m_clean_calls comparison_error_margin income_year value_sort round_ops; try - let dgfip_flags = process_dgfip_options backend dgfip_options in Cli.debug_print "Reading M files..."; let current_progress, finish = Cli.create_progress_bar "Parsing" in let m_program = ref [] in @@ -182,12 +180,9 @@ let driver (files : string list) (without_dgfip_m : bool) (debug : bool) finish "completed!"; Cli.debug_print "Elaborating..."; let source_m_program = !m_program in - let m_program = Mast_to_mir.translate !m_program in + let m_program = Mast_to_mir.translate !m_program mpp_function in let m_program = Mir.expand_functions m_program in Cli.debug_print "Creating combined program suitable for execution..."; - let combined_program = - Mir_to_bir.create_combined_program m_program mpp_function - in if run_all_tests <> None then let tests : string = match run_all_tests with Some s -> s | _ -> assert false @@ -197,19 +192,14 @@ let driver (files : string list) (without_dgfip_m : bool) (debug : bool) | false -> fun _ -> true | true -> ( fun x -> match x.[0] with 'A' .. 'Z' -> true | _ -> false) in - Test_interpreter.check_all_tests combined_program tests code_coverage - value_sort round_ops filter_function + Test_interpreter.check_all_tests m_program tests value_sort round_ops + filter_function else if run_test <> None then begin - Bir_interpreter.repl_debug := true; - if code_coverage then - Cli.warning_print - "The code coverage flag is ignored when running a single test"; + Mir_interpreter.repl_debug := true; let test : string = match run_test with Some s -> s | _ -> assert false in - ignore - (Test_interpreter.check_test combined_program test false value_sort - round_ops); + ignore (Test_interpreter.check_test m_program test value_sort round_ops); Cli.result_print "Test passed!" end else begin @@ -217,22 +207,14 @@ let driver (files : string list) (without_dgfip_m : bool) (debug : bool) "Extracting the desired function from the whole program..."; match backend with | Some backend -> - if String.lowercase_ascii backend = "java" then begin - Cli.debug_print "Compiling codebase to Java..."; - if !Cli.output_file = "" then - Errors.raise_error "an output file must be defined with --output"; - Bir_to_java.generate_java_program combined_program !Cli.output_file - end - else if String.lowercase_ascii backend = "dgfip_c" then begin + if String.lowercase_ascii backend = "dgfip_c" then begin Cli.debug_print "Compiling the codebase to DGFiP C..."; if !Cli.output_file = "" then Errors.raise_error "an output file must be defined with --output"; - let vm = - Dgfip_gen_files.generate_auxiliary_files dgfip_flags - source_m_program combined_program - in - Bir_to_dgfip_c.generate_c_program dgfip_flags combined_program - !Cli.output_file vm; + Dgfip_gen_files.generate_auxiliary_files dgfip_flags + source_m_program m_program; + Bir_to_dgfip_c.generate_c_program dgfip_flags m_program + !Cli.output_file; Cli.debug_print "Result written to %s" !Cli.output_file end else diff --git a/src/mlang/m_frontend/check_validity.ml b/src/mlang/m_frontend/check_validity.ml index 8db30224b..8970db70d 100644 --- a/src/mlang/m_frontend/check_validity.ml +++ b/src/mlang/m_frontend/check_validity.ml @@ -12,7 +12,7 @@ type rule_or_verif = Rule | Verif -type rdom_or_chain = RuleDomain of Mast.DomainId.t | Chaining of string +type rdom_or_chain = RuleDomain of Com.DomainId.t | Chaining of string module Err = struct let rov_to_str rov = match rov with Rule -> "rule" | Verif -> "verif" @@ -53,7 +53,7 @@ module Err = struct let msg = Format.asprintf "Category \"%a\" defined more than once: already defined %a" - Mir.pp_cat_variable cat Pos.format_position old_pos + Com.CatVar.pp cat Pos.format_position old_pos in Errors.raise_spanned_error msg pos @@ -67,8 +67,7 @@ module Err = struct let variable_of_unknown_category cat name_pos = let msg = - Format.asprintf "variable with unknown category %a" Mir.pp_cat_variable - cat + Format.asprintf "variable with unknown category %a" Com.CatVar.pp cat in Errors.raise_spanned_error msg name_pos @@ -126,8 +125,8 @@ module Err = struct let loop_in_domains rov cycle = let pp_cycle fmt cycle = let foldCycle first id = - if first then Format.fprintf fmt "%a@;" (Mast.DomainId.pp ()) id - else Format.fprintf fmt "-> %a@;" (Mast.DomainId.pp ()) id; + if first then Format.fprintf fmt "%a@;" (Com.DomainId.pp ()) id + else Format.fprintf fmt "-> %a@;" (Com.DomainId.pp ()) id; false in ignore (List.fold_left foldCycle true cycle) @@ -141,7 +140,7 @@ module Err = struct let domain_specialize_itself rov dom_id pos = let msg = Format.asprintf "%s domain \"%a\" specialize itself" (rov_to_str rov) - (Mast.DomainId.pp ()) dom_id + (Com.DomainId.pp ()) dom_id in Errors.raise_spanned_error msg pos @@ -172,7 +171,7 @@ module Err = struct let unknown_attribut_for_var cat pos = let msg = Format.asprintf "unknown attribute for a variable of category \"%a\"" - Mir.pp_cat_variable cat + Com.CatVar.pp cat in Errors.raise_spanned_error msg pos @@ -218,7 +217,7 @@ module Err = struct let rdom_chain_str = match rdom_chain with | RuleDomain rdom_id -> - Format.asprintf "rule domain \"%a\"" (Mast.DomainId.pp ()) rdom_id + Format.asprintf "rule domain \"%a\"" (Com.DomainId.pp ()) rdom_id | Chaining ch -> Format.sprintf "chaining \"%s\"" ch in let pp_cycle fmt cycle = @@ -270,64 +269,78 @@ module Err = struct let wrong_arity_of_function func_name arity pos = let msg = - Format.sprintf "wrong arity: function \"%s\" expect %d argument%s" - func_name arity + Format.asprintf "wrong arity: function \"%a\" expect %d argument%s" + Com.format_func func_name arity (if arity = 1 then "" else "s") in Errors.raise_spanned_error msg pos - let unknown_function func_name pos = - let msg = Format.sprintf "unknown function \"%s\"" func_name in - Errors.raise_spanned_error msg pos - let variable_with_forbidden_category pos = let msg = Format.sprintf "variable with forbidden category in verif" in Errors.raise_spanned_error msg pos -end -type global_variable = { - global_name : string Pos.marked; - global_category : Mir.cat_variable; - global_attrs : int Pos.marked StrMap.t; - global_alias : string Pos.marked option; - global_table : int option; - global_description : string Pos.marked; - global_typ : Mast.value_typ option; -} + let variable_already_specified name old_pos pos = + let msg = + Format.asprintf + "variable \"%s\" specified more than once: already specified %a" name + Pos.format_position old_pos + in + Errors.raise_spanned_error msg pos -type error = { - name : string Pos.marked; - typ : Mast.error_typ; - kind : string Pos.marked; - major_code : string Pos.marked; - minor_code : string Pos.marked; - isisf : string Pos.marked; - description : string; -} + let main_target_not_found main_target = + Errors.raise_error + (Format.sprintf "main target \"%s\" not found" main_target) + + let unknown_target name pos = + let msg = Format.asprintf "unknown target %s" name in + Errors.raise_spanned_error msg pos + + let wrong_number_of_args nb_args pos = + let msg = + Format.asprintf "wrong number of arguments, %d required" nb_args + in + Errors.raise_spanned_error msg pos + + let target_must_not_have_a_result tn pos = + let msg = Format.sprintf "target %s must not have a result" tn in + Errors.raise_spanned_error msg pos + + let function_result_missing fn pos = + let msg = Format.sprintf "result missing in function %s" fn in + Errors.raise_spanned_error msg pos + + let forbidden_out_var_in_function vn fn pos = + let msg = + Format.sprintf "variable %s cannot be written in function %s" vn fn + in + Errors.raise_spanned_error msg pos + + let function_does_not_exist fn pos = + let msg = Format.sprintf "function %s does not exist" fn in + Errors.raise_spanned_error msg pos + + let is_base_function fn pos = + let msg = Format.sprintf "function %s already exist as base function" fn in + Errors.raise_spanned_error msg pos +end -type syms = Mast.DomainId.t Pos.marked Mast.DomainIdMap.t +type syms = Com.DomainId.t Pos.marked Com.DomainIdMap.t -type 'a doms = 'a Mir.domain Mast.DomainIdMap.t +type 'a doms = 'a Com.domain Com.DomainIdMap.t type chaining = { chain_name : string Pos.marked; chain_apps : Pos.t StrMap.t; - chain_rules : Mir.rule_domain Pos.marked IntMap.t; -} - -type target = { - target_name : string Pos.marked; - target_file : string option; - target_apps : Pos.t StrMap.t; - target_tmp_vars : int option Pos.marked StrMap.t; - target_prog : Mast.instruction Pos.marked list; + chain_rules : Com.rule_domain Pos.marked IntMap.t; } type rule = { rule_id : int Pos.marked; rule_apps : Pos.t StrMap.t; - rule_domain : Mir.rule_domain; + rule_domain : Com.rule_domain; rule_chain : string option; + rule_tmp_vars : + (string Pos.marked * Mast.table_size Pos.marked option) StrMap.t; rule_instrs : Mast.instruction Pos.marked list; rule_in_vars : StrSet.t; rule_out_vars : StrSet.t; @@ -337,12 +350,12 @@ type rule = { type verif = { verif_id : int Pos.marked; verif_apps : Pos.t StrMap.t; - verif_domain : Mir.verif_domain; + verif_domain : Com.verif_domain; verif_expr : Mast.expression Pos.marked; verif_error : Mast.error_name Pos.marked; verif_var : Mast.variable_name Pos.marked option; verif_is_blocking : bool; - verif_cat_var_stats : int Mir.CatVarMap.t; + verif_cat_var_stats : int Com.CatVar.Map.t; verif_var_stats : int StrMap.t; verif_seq : int; } @@ -353,20 +366,23 @@ type program = { prog_app : string; prog_apps : Pos.t StrMap.t; prog_chainings : chaining StrMap.t; - prog_var_cats : Mir.cat_variable_data Mir.CatVarMap.t; - prog_vars : global_variable StrMap.t; - prog_alias : global_variable StrMap.t; - prog_errors : error StrMap.t; - prog_rdoms : Mir.rule_domain_data doms; + prog_var_cats : Com.CatVar.data Com.CatVar.Map.t; + prog_vars : Com.Var.t StrMap.t; + prog_alias : Com.Var.t StrMap.t; + prog_errors : Com.Error.t StrMap.t; + prog_rdoms : Com.rule_domain_data doms; prog_rdom_syms : syms; - prog_vdoms : Mir.verif_domain_data doms; + prog_vdoms : Com.verif_domain_data doms; prog_vdom_syms : syms; + prog_functions : Mast.target StrMap.t; prog_rules : rule IntMap.t; - prog_rdom_calls : (int Pos.marked * Mast.DomainId.t) StrMap.t; + prog_rdom_calls : (int Pos.marked * Com.DomainId.t) StrMap.t; prog_verifs : verif IntMap.t; prog_vdom_calls : - (int Pos.marked * Mast.DomainId.t * Mast.expression Pos.marked) StrMap.t; - prog_targets : target StrMap.t; + (int Pos.marked * Com.DomainId.t * Mast.expression Pos.marked) StrMap.t; + prog_targets : Mast.target StrMap.t; + prog_main_target : string; + prog_stats : Mir.stats; } let get_target_file (pos : Pos.t) : string = @@ -415,26 +431,42 @@ let safe_prefix (p : Mast.program) : string = in make_prefix sorted_names -let empty_program (p : Mast.program) prog_app = +let empty_program (p : Mast.program) prog_app main_target = { prog_prefix = safe_prefix p; prog_seq = 0; prog_app; prog_apps = StrMap.empty; prog_chainings = StrMap.empty; - prog_var_cats = Mir.CatVarMap.empty; + prog_var_cats = Com.CatVar.Map.empty; prog_vars = StrMap.empty; prog_alias = StrMap.empty; prog_errors = StrMap.empty; - prog_rdoms = Mast.DomainIdMap.empty; - prog_rdom_syms = Mast.DomainIdMap.empty; - prog_vdoms = Mast.DomainIdMap.empty; - prog_vdom_syms = Mast.DomainIdMap.empty; + prog_rdoms = Com.DomainIdMap.empty; + prog_rdom_syms = Com.DomainIdMap.empty; + prog_vdoms = Com.DomainIdMap.empty; + prog_vdom_syms = Com.DomainIdMap.empty; + prog_functions = StrMap.empty; prog_rules = IntMap.empty; prog_rdom_calls = StrMap.empty; prog_verifs = IntMap.empty; prog_vdom_calls = StrMap.empty; prog_targets = StrMap.empty; + prog_main_target = main_target; + prog_stats = + { + nb_calculated = 0; + nb_base = 0; + nb_input = 0; + nb_vars = 0; + nb_all_tmps = 0; + nb_all_refs = 0; + sz_calculated = 0; + sz_base = 0; + sz_input = 0; + sz_vars = 0; + sz_all_tmps = 0; + }; } let get_seq (prog : program) : int * program = @@ -473,17 +505,13 @@ let check_chaining (name : string) (pos : Pos.t) let prog_chainings = StrMap.add name chaining prog.prog_chainings in { prog with prog_chainings } -let get_var_cat_id_str (var_cat : Mir.cat_variable) : string = +let get_var_cat_id_str (var_cat : Com.CatVar.t) : string = let buf = Buffer.create 100 in (match var_cat with - | Mir.CatComputed ccs -> + | Com.CatVar.Computed { is_base } -> Buffer.add_string buf "calculee"; - Mir.CatCompSet.iter - (function - | Mir.Base -> Buffer.add_string buf "_base" - | Mir.GivenBack -> Buffer.add_string buf "_restituee") - ccs - | Mir.CatInput ss -> + if is_base then Buffer.add_string buf "_base" + | Com.CatVar.Input ss -> Buffer.add_string buf "saisie"; let add buf s = String.iter @@ -498,26 +526,21 @@ let get_var_cat_id_str (var_cat : Mir.cat_variable) : string = ss); Buffer.contents buf -let get_var_cat_loc (var_cat : Mir.cat_variable) : Mir.cat_variable_loc = +let get_var_cat_loc (var_cat : Com.CatVar.t) : Com.CatVar.loc = match var_cat with - | Mir.CatComputed ccs -> - if Mir.CatCompSet.mem Mir.Base ccs then Mir.LocBase else Mir.LocCalculated - | Mir.CatInput _ -> Mir.LocInput + | Com.CatVar.Computed { is_base } -> + if is_base then Com.CatVar.LocBase else Com.CatVar.LocComputed + | Com.CatVar.Input _ -> Com.CatVar.LocInput -let get_var_cats (cat_decl : Mast.var_category_decl) : Mir.cat_variable list = +let get_var_cats (cat_decl : Mast.var_category_decl) : Com.CatVar.t list = match cat_decl.Mast.var_type with | Mast.Input -> let id = StrSet.from_marked_list cat_decl.Mast.var_category in - [ Mir.CatInput id ] + [ Com.CatVar.Input id ] | Mast.Computed -> - let base = Mir.CatCompSet.singleton Base in - let givenBack = Mir.CatCompSet.singleton GivenBack in - let baseAndGivenBack = base |> Mir.CatCompSet.add GivenBack in [ - Mir.CatComputed Mir.CatCompSet.empty; - Mir.CatComputed base; - Mir.CatComputed givenBack; - Mir.CatComputed baseAndGivenBack; + Com.CatVar.Computed { is_base = false }; + Com.CatVar.Computed { is_base = true }; ] let check_var_category (cat_decl : Mast.var_category_decl) (decl_pos : Pos.t) @@ -531,21 +554,22 @@ let check_var_category (cat_decl : Mast.var_category_decl) (decl_pos : Pos.t) StrMap.empty cat_decl.Mast.var_attributes in let add_cat cats cat = - match Mir.CatVarMap.find_opt cat cats with - | Some Mir.{ pos; _ } -> Err.var_category_already_definied cat pos decl_pos + match Com.CatVar.Map.find_opt cat cats with + | Some Com.CatVar.{ pos; _ } -> + Err.var_category_already_definied cat pos decl_pos | None -> let data = - Mir. + Com.CatVar. { id = cat; id_str = get_var_cat_id_str cat; - id_int = Mir.CatVarMap.cardinal cats; + id_int = Com.CatVar.Map.cardinal cats; loc = get_var_cat_loc cat; attributs; pos = decl_pos; } in - Mir.CatVarMap.add cat data cats + Com.CatVar.Map.add cat data cats in let prog_var_cats = List.fold_left add_cat prog.prog_var_cats (get_var_cats cat_decl) @@ -563,31 +587,32 @@ let get_attributes (attr_list : Mast.variable_attribute list) : | None -> StrMap.add attr (value, attr_pos) attributes) StrMap.empty attr_list -let check_global_var (var : global_variable) (prog : program) : program = - let name, name_pos = var.global_name in +let check_global_var (var : Com.Var.t) (prog : program) : program = + let name, name_pos = var.name in let cat = - match Mir.CatVarMap.find_opt var.global_category prog.prog_var_cats with - | None -> Err.variable_of_unknown_category var.global_category name_pos + let cat = Com.Var.cat var in + match Com.CatVar.Map.find_opt cat prog.prog_var_cats with + | None -> Err.variable_of_unknown_category cat name_pos | Some cat -> cat in StrMap.iter (fun attr _ -> - if not (StrMap.mem attr var.global_attrs) then + if not (StrMap.mem attr (Com.Var.attrs var)) then Err.attribute_is_not_defined name attr name_pos) - cat.Mir.attributs; + cat.attributs; let prog_vars = match StrMap.find_opt name prog.prog_vars with - | Some gvar -> - let old_pos = Pos.get_position gvar.global_name in + | Some (gvar : Com.Var.t) -> + let old_pos = Pos.get_position gvar.name in Err.variable_already_declared name old_pos name_pos | None -> StrMap.add name var prog.prog_vars in let prog_alias = - match var.global_alias with + match Com.Var.alias var with | Some (alias, alias_pos) -> ( match StrMap.find_opt alias prog.prog_alias with - | Some gvar -> - let old_pos = Pos.get_position (Option.get gvar.global_alias) in + | Some (gvar : Com.Var.t) -> + let old_pos = Pos.get_position (Option.get (Com.Var.alias gvar)) in Err.alias_already_declared alias old_pos alias_pos | None -> StrMap.add alias var prog.prog_alias) | None -> prog.prog_alias @@ -604,35 +629,26 @@ let check_var_decl (var_decl : Mast.variable_decl) (prog : program) : program = (fun res (str, _pos) -> StrSet.add str res) StrSet.empty input_var.input_category in - Mir.CatInput input_set + Com.CatVar.Input input_set in let var = - { - global_name = input_var.Mast.input_name; - global_category; - global_attrs = get_attributes input_var.Mast.input_attributes; - global_alias = Some input_var.Mast.input_alias; - global_table = None; - global_description = input_var.Mast.input_description; - global_typ = Option.map Pos.unmark input_var.Mast.input_typ; - } + Com.Var.new_tgv ~name:input_var.Mast.input_name ~is_table:None + ~is_given_back:input_var.input_is_givenback + ~alias:(Some input_var.Mast.input_alias) + ~descr:input_var.Mast.input_description + ~attrs:(get_attributes input_var.Mast.input_attributes) + ~cat:global_category + ~typ:(Option.map Pos.unmark input_var.Mast.input_typ) in check_global_var var prog | Mast.ComputedVar (comp_var, _decl_pos) -> let global_category = - let comp_set = + let is_base = List.fold_left - (fun res (str, _pos) -> - let elt = - match str with - | "base" -> Mir.Base - | "restituee" -> Mir.GivenBack - | _ -> assert false - in - Mir.CatCompSet.add elt res) - Mir.CatCompSet.empty comp_var.comp_category + (fun res (str, _pos) -> match str with "base" -> true | _ -> res) + false comp_var.comp_category in - Mir.CatComputed comp_set + Com.CatVar.Computed { is_base } in let global_table = match comp_var.Mast.comp_table with @@ -641,15 +657,12 @@ let check_var_decl (var_decl : Mast.variable_decl) (prog : program) : program = | None -> None in let var = - { - global_name = comp_var.Mast.comp_name; - global_category; - global_attrs = get_attributes comp_var.Mast.comp_attributes; - global_alias = None; - global_table; - global_description = comp_var.Mast.comp_description; - global_typ = Option.map Pos.unmark comp_var.Mast.comp_typ; - } + Com.Var.new_tgv ~name:comp_var.Mast.comp_name ~is_table:global_table + ~is_given_back:comp_var.comp_is_givenback ~alias:None + ~descr:comp_var.Mast.comp_description + ~attrs:(get_attributes comp_var.Mast.comp_attributes) + ~cat:global_category + ~typ:(Option.map Pos.unmark comp_var.Mast.comp_typ) in check_global_var var prog @@ -657,26 +670,23 @@ let check_error (error : Mast.error_) (prog : program) : program = let kind = List.nth error.error_descr 0 in let major_code = List.nth error.error_descr 1 in let minor_code = List.nth error.error_descr 2 in - let descr = List.nth error.error_descr 3 in + let description = List.nth error.error_descr 3 in let isisf = match List.nth_opt error.error_descr 4 with | Some s -> s | None -> ("", Pos.no_pos) in - let description = - let params = [ kind; major_code; minor_code; descr; isisf ] in - String.concat ":" (List.map Pos.unmark params) - in let err = - { - name = error.Mast.error_name; - typ = Pos.unmark error.Mast.error_typ; - kind; - major_code; - minor_code; - isisf; - description; - } + Com.Error. + { + name = error.Mast.error_name; + typ = Pos.unmark error.Mast.error_typ; + kind; + major_code; + minor_code; + isisf; + description; + } in let name, name_pos = err.name in match StrMap.find_opt name prog.prog_errors with @@ -692,19 +702,19 @@ let check_domain (rov : rule_or_verif) (decl : 'a Mast.domain_decl) let dom_names = List.fold_left (fun dom_names (sl, sl_pos) -> - let id = Mast.DomainId.from_marked_list sl in - Mast.DomainIdMap.add id sl_pos dom_names) - Mast.DomainIdMap.empty decl.dom_names + let id = Com.DomainId.from_marked_list sl in + Com.DomainIdMap.add id sl_pos dom_names) + Com.DomainIdMap.empty decl.dom_names in - let dom_id = Mast.DomainIdMap.min_binding dom_names in + let dom_id = Com.DomainIdMap.min_binding dom_names in let domain = - Mir. + Com. { dom_id; dom_names; dom_by_default = decl.dom_by_default; - dom_min = Mast.DomainIdSet.from_marked_list_list decl.dom_parents; - dom_max = Mast.DomainIdSet.empty; + dom_min = DomainIdSet.from_marked_list_list decl.dom_parents; + dom_max = DomainIdSet.empty; dom_rov = IntSet.empty; dom_data; dom_used = None; @@ -712,86 +722,54 @@ let check_domain (rov : rule_or_verif) (decl : 'a Mast.domain_decl) in let dom_id_name, dom_id_pos = dom_id in let syms = - Mast.DomainIdMap.fold + Com.DomainIdMap.fold (fun name name_pos syms -> - match Mast.DomainIdMap.find_opt name syms with + match Com.DomainIdMap.find_opt name syms with | Some (_, old_pos) -> Err.domain_already_declared rov old_pos name_pos | None -> let value = (dom_id_name, name_pos) in - Mast.DomainIdMap.add name value syms) + Com.DomainIdMap.add name value syms) dom_names syms in let syms = if decl.dom_by_default then - match Mast.DomainIdMap.find_opt Mast.DomainId.empty syms with + match Com.DomainIdMap.find_opt Com.DomainId.empty syms with | Some (_, old_pos) -> Err.default_domain_already_declared rov old_pos dom_id_pos | None -> let value = (dom_id_name, Pos.no_pos) in - Mast.DomainIdMap.add Mast.DomainId.empty value syms + Com.DomainIdMap.add Com.DomainId.empty value syms else syms in - let doms = Mast.DomainIdMap.add dom_id_name domain doms in + let doms = Com.DomainIdMap.add dom_id_name domain doms in (doms, syms) let check_rule_dom_decl (decl : Mast.rule_domain_decl) (prog : program) : program = - let dom_data = Mir.{ rdom_computable = decl.Mast.dom_data.rdom_computable } in + let dom_data = Com.{ rdom_computable = decl.Mast.dom_data.rdom_computable } in let doms_syms = (prog.prog_rdoms, prog.prog_rdom_syms) in let doms, syms = check_domain Rule decl dom_data doms_syms in { prog with prog_rdoms = doms; prog_rdom_syms = syms } -let mast_to_catvars (l : Mast.var_category_id) (cats : 'a Mir.CatVarMap.t) : - Mir.CatVarSet.t = +let mast_to_catvars (cs : Pos.t Com.CatVar.Map.t) + (cats : Com.CatVar.data Com.CatVar.Map.t) : Pos.t Com.CatVar.Map.t = let filter_cats pred = - Mir.CatVarMap.fold - (fun cv _ res -> if pred cv then Mir.CatVarSet.add cv res else res) - cats Mir.CatVarSet.empty + Com.CatVar.Map.fold + (fun cv (cvd : Com.CatVar.data) res -> + if pred cv then Com.CatVar.Map.add cv cvd.pos res else res) + cats Com.CatVar.Map.empty in - match l with - | [ ("*", _) ], _ -> filter_cats (fun _ -> true) - | [ ("saisie", _); ("*", _) ], _ -> - filter_cats (fun cv -> - match cv with Mir.CatInput _ -> true | _ -> false) - | ("saisie", _) :: id, pos -> - let vcat = Mir.CatInput (StrSet.from_marked_list id) in - if Mir.CatVarMap.mem vcat cats then Mir.CatVarSet.singleton vcat - else Err.unknown_variable_category pos - | ("calculee", _) :: id, id_pos -> ( - match id with - | [] -> Mir.CatVarSet.singleton (Mir.CatComputed Mir.CatCompSet.empty) - | [ ("base", _) ] -> - let base = Mir.CatCompSet.singleton Mir.Base in - Mir.CatVarSet.singleton (Mir.CatComputed base) - | [ ("base", _); ("*", _) ] -> - let base = Mir.CatCompSet.singleton Mir.Base in - let baseAndGivenBack = base |> Mir.CatCompSet.add Mir.GivenBack in - Mir.CatVarSet.singleton (Mir.CatComputed base) - |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) - | [ ("restituee", _) ] -> - let givenBack = Mir.CatCompSet.singleton Mir.GivenBack in - Mir.CatVarSet.singleton (Mir.CatComputed givenBack) - | [ ("restituee", _); ("*", _) ] -> - let givenBack = Mir.CatCompSet.singleton Mir.GivenBack in - let baseAndGivenBack = givenBack |> Mir.CatCompSet.add Mir.Base in - Mir.CatVarSet.singleton (Mir.CatComputed givenBack) - |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) - | [ ("base", _); ("restituee", _) ] | [ ("restituee", _); ("base", _) ] -> - let baseAndGivenBack = - Mir.CatCompSet.singleton Mir.Base - |> Mir.CatCompSet.add Mir.GivenBack - in - Mir.CatVarSet.singleton (Mir.CatComputed baseAndGivenBack) - | [ ("*", _) ] -> - let base = Mir.CatCompSet.singleton Mir.Base in - let givenBack = Mir.CatCompSet.singleton Mir.GivenBack in - let baseAndGivenBack = base |> Mir.CatCompSet.add Mir.GivenBack in - Mir.CatVarSet.singleton (Mir.CatComputed Mir.CatCompSet.empty) - |> Mir.CatVarSet.add (Mir.CatComputed base) - |> Mir.CatVarSet.add (Mir.CatComputed givenBack) - |> Mir.CatVarSet.add (Mir.CatComputed baseAndGivenBack) - | _ -> Err.unknown_variable_category id_pos) - | _ -> assert false + let fold cv pos res = + match cv with + | Com.CatVar.Input set when StrSet.mem "*" set -> + filter_cats (function Com.CatVar.Input _ -> true | _ -> false) + |> Com.CatVar.Map.union (fun _ p _ -> Some p) res + | Com.CatVar.Input _ -> + if Com.CatVar.Map.mem cv cats then Com.CatVar.Map.add cv pos res + else Err.unknown_variable_category pos + | _ -> Com.CatVar.Map.add cv pos res + in + Com.CatVar.Map.fold fold cs Com.CatVar.Map.empty let check_verif_dom_decl (decl : Mast.verif_domain_decl) (prog : program) : program = @@ -799,55 +777,291 @@ let check_verif_dom_decl (decl : Mast.verif_domain_decl) (prog : program) : let rec aux vdom_auth = function | [] -> vdom_auth | l :: t -> - let vcats = mast_to_catvars l prog.prog_var_cats in - aux (Mir.CatVarSet.union vcats vdom_auth) t + let vcats = + mast_to_catvars + (Com.CatVar.Map.from_string_list l) + prog.prog_var_cats + in + aux (Com.CatVar.Map.union (fun _ p _ -> Some p) vcats vdom_auth) t in - aux Mir.CatVarSet.empty decl.Mast.dom_data.vdom_auth + aux Com.CatVar.Map.empty decl.Mast.dom_data.vdom_auth in let vdom_verifiable = decl.Mast.dom_data.vdom_verifiable in - let dom_data = Mir.{ vdom_auth; vdom_verifiable } in + let dom_data = Com.{ vdom_auth; vdom_verifiable } in let doms_syms = (prog.prog_vdoms, prog.prog_vdom_syms) in let doms, syms = check_domain Verif decl dom_data doms_syms in { prog with prog_vdoms = doms; prog_vdom_syms = syms } +let complete_vars (prog : program) : program = + let prog_vars = prog.prog_vars in + let prog_vars = + let incr_cpt cat cpt = + let i = Com.CatVar.Map.find cat cpt in + let cpt = Com.CatVar.Map.add cat (i + 1) cpt in + (cpt, i) + in + let cat_cpt = Com.CatVar.Map.map (fun _ -> 0) prog.prog_var_cats in + let prog_vars, _ = + StrMap.fold + (fun vn (var : Com.Var.t) (res, cpt) -> + let tgv = Com.Var.tgv var in + let dcat = Com.CatVar.Map.find tgv.cat prog.prog_var_cats in + let cpt, i = incr_cpt tgv.cat cpt in + let loc = Com.set_loc_tgv_cat var.loc dcat.loc dcat.id_str i in + let var = Com.Var.{ var with loc } in + let res = StrMap.add vn var res in + (res, cpt)) + prog_vars (StrMap.empty, cat_cpt) + in + prog_vars + in + let module CatLoc = struct + type t = Com.CatVar.loc + + let pp fmt (loc : t) = + match loc with + | Com.CatVar.LocComputed -> Format.fprintf fmt "calculee" + | Com.CatVar.LocBase -> Format.fprintf fmt "base" + | Com.CatVar.LocInput -> Format.fprintf fmt "saisie" + + let compare x y = compare x y + end in + let module CatLocMap = struct + include MapExt.Make (CatLoc) + + let _pp ?(sep = ", ") ?(pp_key = CatLoc.pp) ?(assoc = " => ") + (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (map : 'a t) : unit = + pp ~sep ~pp_key ~assoc pp_val fmt map + end in + let loc_vars, sz_loc_vars, sz_vars = + let fold _ (var : Com.Var.t) (loc_vars, sz_loc_vars, n) = + let var = Com.Var.{ var with loc = Com.set_loc_int var.loc n } in + let loc_cat = + (Com.CatVar.Map.find (Com.Var.cat var) prog.prog_var_cats).loc + in + let loc_vars = + let upd = function + | None -> Some (Com.Var.Set.one var) + | Some set -> Some (Com.Var.Set.add var set) + in + CatLocMap.update loc_cat upd loc_vars + in + let sz = Com.Var.size var in + let sz_loc_vars = + let upd = function + | None -> Some sz + | Some n_loc -> Some (n_loc + sz) + in + CatLocMap.update loc_cat upd sz_loc_vars + in + (loc_vars, sz_loc_vars, n + sz) + in + StrMap.fold fold prog_vars (CatLocMap.empty, CatLocMap.empty, 0) + in + let update_loc (var : Com.Var.t) (vars, n) = + let loc = Com.set_loc_tgv_idx var.loc n in + let vars = + StrMap.add (Com.Var.name_str var) Com.Var.{ var with loc } vars + in + (vars, n + Com.Var.size var) + in + let prog_vars = + CatLocMap.fold + (fun _loc_cat vars prog_vars -> + (prog_vars, 0) |> Com.Var.Set.fold update_loc vars |> fst) + loc_vars StrMap.empty + in + let nb_loc loc_cat = + match CatLocMap.find_opt loc_cat loc_vars with + | Some set -> Com.Var.Set.cardinal set + | None -> 0 + in + let sz_loc loc_cat = + match CatLocMap.find_opt loc_cat sz_loc_vars with + | Some sz -> sz + | None -> 0 + in + let prog_targets = + let rec aux nbRef = function + | [] -> nbRef + | (instr, _) :: il -> ( + match instr with + | Com.IfThenElse (_, ilt, ile) -> + aux (nbRef + max (aux 0 ilt) (aux 0 ile)) il + | Com.WhenDoElse (wdl, ed) -> + let rec wde nbRef = function + | (_, dl, _) :: wdl' -> wde (max nbRef (aux 0 dl)) wdl' + | [] -> max nbRef (aux 0 (Pos.unmark ed)) + in + aux (wde nbRef wdl) il + | Com.VerifBlock instrs -> aux (nbRef + aux 0 instrs) il + | Com.Iterate (_, _, _, instrs) -> aux (nbRef + 1 + aux 0 instrs) il + | Com.Restore (_, _, instrs) -> aux (nbRef + max 1 (aux 0 instrs)) il + | Com.ComputeTarget _ | Com.Affectation _ | Com.Print _ + | Com.RaiseError _ | Com.CleanErrors | Com.ExportErrors + | Com.FinalizeErrors -> + aux nbRef il + | Com.ComputeDomain _ | Com.ComputeChaining _ | Com.ComputeVerifs _ -> + assert false) + in + let map (t : Mast.target) = + let target_nb_tmps = StrMap.cardinal t.target_tmp_vars in + let target_sz_tmps = + let fold _ (_, tsz_opt) sz = + match tsz_opt with + | None -> sz + 1 + | Some (tsz, _) -> sz + Mast.get_table_size tsz + in + StrMap.fold fold t.target_tmp_vars 0 + in + let target_nb_refs = List.length t.target_args + aux 0 t.target_prog in + { t with target_nb_tmps; target_sz_tmps; target_nb_refs } + in + StrMap.map map prog.prog_targets + in + let nb_all_tmps, sz_all_tmps, nb_all_refs = + let rec aux (nb, sz, nbRef, tdata) = function + | [] -> (nb, sz, nbRef, tdata) + | (instr, _) :: il -> ( + match instr with + | Com.ComputeTarget (tn, _targs) -> + let name = Pos.unmark tn in + let target = StrMap.find name prog_targets in + let nb1, sz1 = (target.target_nb_tmps, target.target_sz_tmps) in + let nbRef1 = List.length target.target_args in + let nbt, szt, nbRefT, tdata = + match StrMap.find_opt name tdata with + | None -> + let nbt, szt, nbRefT, tdata = + aux (0, 0, 0, tdata) target.target_prog + in + let tdata = StrMap.add name (nbt, szt, nbRefT) tdata in + (nbt, szt, nbRefT, tdata) + | Some (nbt, szt, nbRefT) -> (nbt, szt, nbRefT, tdata) + in + let nb = nb + nb1 + nbt in + let sz = sz + sz1 + szt in + let nbRef = nbRef + nbRef1 + nbRefT in + aux (nb, sz, nbRef, tdata) il + | Com.IfThenElse (_, ilt, ile) -> + let nb1, sz1, nbRef1, tdata = aux (0, 0, 0, tdata) ilt in + let nb2, sz2, nbRef2, tdata = aux (0, 0, 0, tdata) ile in + let nb = nb + max nb1 nb2 in + let sz = sz + max sz1 sz2 in + let nbRef = nbRef + max nbRef1 nbRef2 in + aux (nb, sz, nbRef, tdata) il + | Com.WhenDoElse (wdl, ed) -> + let rec wde (nb, sz, nbRef, tdata) = function + | (_, dl, _) :: wdl' -> + let nb', sz', nbRef', tdata = aux (0, 0, 0, tdata) dl in + let nb = max nb nb' in + let sz = max sz sz' in + let nbRef = max nbRef nbRef' in + wde (nb, sz, nbRef, tdata) wdl' + | [] -> + let nb', sz', nbRef', tdata = + aux (0, 0, 0, tdata) (Pos.unmark ed) + in + let nb = max nb nb' in + let sz = max sz sz' in + let nbRef = max nbRef nbRef' in + (nb, sz, nbRef, tdata) + in + let nb', sz', nbRef', tdata = wde (0, 0, 0, tdata) wdl in + let nb = nb + nb' in + let sz = sz + sz' in + let nbRef = nbRef + nbRef' in + aux (nb, sz, nbRef, tdata) il + | Com.VerifBlock instrs -> + let nb1, sz1, nbRef1, tdata = aux (0, 0, 0, tdata) instrs in + let nb = nb + nb1 in + let sz = sz + sz1 in + let nbRef = nbRef + nbRef1 in + aux (nb, sz, nbRef, tdata) il + | Com.Iterate (_, _, _, instrs) -> + let nb1, sz1, nbRef1, tdata = aux (0, 0, 0, tdata) instrs in + let nb = nb + nb1 in + let sz = sz + sz1 in + let nbRef = nbRef + 1 + nbRef1 in + aux (nb, sz, nbRef, tdata) il + | Com.Restore (_, _, instrs) -> + let nb1, sz1, nbRef1, tdata = aux (0, 0, 0, tdata) instrs in + let nb = nb + nb1 in + let sz = sz + sz1 in + let nbRef = nbRef + max 1 nbRef1 in + aux (nb, sz, nbRef, tdata) il + | Com.Affectation _ | Com.Print _ | Com.RaiseError _ | Com.CleanErrors + | Com.ExportErrors | Com.FinalizeErrors -> + aux (nb, sz, nbRef, tdata) il + | Com.ComputeDomain _ | Com.ComputeChaining _ | Com.ComputeVerifs _ -> + assert false) + in + match StrMap.find_opt prog.prog_main_target prog_targets with + | None -> Err.main_target_not_found prog.prog_main_target + | Some t -> + let init_instrs = + [ (Com.ComputeTarget (t.target_name, []), Pos.no_pos) ] + in + let nb, sz, nbRef, _ = aux (0, 0, 0, StrMap.empty) init_instrs in + (nb, sz, nbRef) + in + let prog_stats = + Mir. + { + nb_calculated = nb_loc Com.CatVar.LocComputed; + nb_input = nb_loc Com.CatVar.LocInput; + nb_base = nb_loc Com.CatVar.LocBase; + nb_vars = StrMap.cardinal prog_vars; + nb_all_tmps; + nb_all_refs; + sz_calculated = sz_loc Com.CatVar.LocComputed; + sz_input = sz_loc Com.CatVar.LocInput; + sz_base = sz_loc Com.CatVar.LocBase; + sz_vars; + sz_all_tmps; + } + in + { prog with prog_vars; prog_targets; prog_stats } + let complete_dom_decls (rov : rule_or_verif) ((doms, syms) : 'a doms * syms) : 'a doms = - let get_id id = Pos.unmark (Mast.DomainIdMap.find id syms) in - let get_dom id doms = Mast.DomainIdMap.find (get_id id) doms in + let get_id id = Pos.unmark (Com.DomainIdMap.find id syms) in + let get_dom id doms = Com.DomainIdMap.find (get_id id) doms in let module DomGraph : TopologicalSorting.GRAPH with type 'a t = 'a doms - and type vertex = Mast.DomainId.t + and type vertex = Com.DomainId.t and type edge = unit = struct type 'a t = 'a doms - type vertex = Mast.DomainId.t + type vertex = Com.DomainId.t type edge = unit - type 'a vertexMap = 'a Mast.DomainIdMap.t + type 'a vertexMap = 'a Com.DomainIdMap.t - let vertexMapEmpty = Mast.DomainIdMap.empty + let vertexMapEmpty = Com.DomainIdMap.empty - let vertexMapAdd id value map = Mast.DomainIdMap.add (get_id id) value map + let vertexMapAdd id value map = Com.DomainIdMap.add (get_id id) value map - let vertexMapRemove id map = Mast.DomainIdMap.remove (get_id id) map + let vertexMapRemove id map = Com.DomainIdMap.remove (get_id id) map - let vertexMapFindOpt id map = Mast.DomainIdMap.find_opt (get_id id) map + let vertexMapFindOpt id map = Com.DomainIdMap.find_opt (get_id id) map let vertexMapFold fold map res = - Mast.DomainIdMap.fold + Com.DomainIdMap.fold (fun id edge res -> fold (get_id id) edge res) map res let vertices doms = - let get_vertex id _ nds = Mast.DomainIdMap.add id None nds in - Mast.DomainIdMap.fold get_vertex doms Mast.DomainIdMap.empty + let get_vertex id _ nds = Com.DomainIdMap.add id None nds in + Com.DomainIdMap.fold get_vertex doms Com.DomainIdMap.empty let edges doms id = - Mast.DomainIdSet.fold - (fun id res -> Mast.DomainIdMap.add id None res) - (get_dom id doms).Mir.dom_min Mast.DomainIdMap.empty + Com.DomainIdSet.fold + (fun id res -> Com.DomainIdMap.add id None res) + (get_dom id doms).Com.dom_min Com.DomainIdMap.empty end in let module DomSorting = TopologicalSorting.Make (DomGraph) in let sorted_doms = @@ -855,7 +1069,7 @@ let complete_dom_decls (rov : rule_or_verif) ((doms, syms) : 'a doms * syms) : | DomSorting.Cycle cycle -> Err.loop_in_domains rov (List.map fst cycle) | DomSorting.AutoCycle (id, _) -> let dom = get_dom id doms in - let dom_id, dom_id_pos = dom.Mir.dom_id in + let dom_id, dom_id_pos = dom.Com.dom_id in Err.domain_specialize_itself rov dom_id dom_id_pos in let doms = @@ -864,38 +1078,38 @@ let complete_dom_decls (rov : rule_or_verif) ((doms, syms) : 'a doms * syms) : let dom_min = let fold parent_id res = let parent_dom = get_dom parent_id doms in - let parent_id = Pos.unmark parent_dom.Mir.dom_id in - let dom_min = Mast.DomainIdSet.map get_id parent_dom.Mir.dom_min in - Mast.DomainIdSet.singleton parent_id - |> Mast.DomainIdSet.union dom_min - |> Mast.DomainIdSet.union res + let parent_id = Pos.unmark parent_dom.Com.dom_id in + let dom_min = Com.DomainIdSet.map get_id parent_dom.Com.dom_min in + Com.DomainIdSet.one parent_id + |> Com.DomainIdSet.union dom_min + |> Com.DomainIdSet.union res in - Mast.DomainIdSet.fold fold dom.Mir.dom_min Mast.DomainIdSet.empty + Com.DomainIdSet.fold fold dom.Com.dom_min Com.DomainIdSet.empty in - let dom = Mir.{ dom with dom_min } in - Mast.DomainIdMap.add id dom doms + let dom = Com.{ dom with dom_min } in + Com.DomainIdMap.add id dom doms in List.fold_left set_min doms sorted_doms in let doms = let set_max id dom doms = let fold min_id doms = - let min_dom = Mast.DomainIdMap.find min_id doms in - let dom_max = Mast.DomainIdSet.add id min_dom.Mir.dom_max in - let min_dom = Mir.{ min_dom with dom_max } in - Mast.DomainIdMap.add min_id min_dom doms + let min_dom = Com.DomainIdMap.find min_id doms in + let dom_max = Com.DomainIdSet.add id min_dom.Com.dom_max in + let min_dom = Com.{ min_dom with dom_max } in + Com.DomainIdMap.add min_id min_dom doms in - Mast.DomainIdSet.fold fold dom.Mir.dom_min doms + Com.DomainIdSet.fold fold dom.Com.dom_min doms in - Mast.DomainIdMap.fold set_max doms doms + Com.DomainIdMap.fold set_max doms doms in let doms = let add_sym name (id, _) doms = - Mast.DomainIdMap.add name (get_dom id doms) doms + Com.DomainIdMap.add name (get_dom id doms) doms in - Mast.DomainIdMap.fold add_sym syms doms + Com.DomainIdMap.fold add_sym syms doms in - match Mast.DomainIdMap.find_opt Mast.DomainId.empty doms with + match Com.DomainIdMap.find_opt Com.DomainId.empty doms with | None -> Err.no_default_domain rov | Some _ -> doms @@ -905,17 +1119,17 @@ let complete_rdom_decls (prog : program) : program = let prog_rdoms = complete_dom_decls Rule doms_syms in StrMap.fold (fun _ (m_seq, rdom_id) prog_rdoms -> - let rdom = Mast.DomainIdMap.find rdom_id prog_rdoms in - Mast.DomainIdSet.fold + let rdom = Com.DomainIdMap.find rdom_id prog_rdoms in + Com.DomainIdSet.fold (fun rid prog_rdoms -> - let rd = Mast.DomainIdMap.find rid prog_rdoms in + let rd = Com.DomainIdMap.find rid prog_rdoms in let rd = - match rd.Mir.dom_used with + match rd.Com.dom_used with | Some _ -> rd - | None -> { rd with Mir.dom_used = Some m_seq } + | None -> { rd with Com.dom_used = Some m_seq } in - Mast.DomainIdMap.add rid rd prog_rdoms) - (Mast.DomainIdSet.add rdom_id rdom.Mir.dom_min) + Com.DomainIdMap.add rid rd prog_rdoms) + (Com.DomainIdSet.add rdom_id rdom.Com.dom_min) prog_rdoms) prog.prog_rdom_calls prog_rdoms in @@ -927,17 +1141,17 @@ let complete_vdom_decls (prog : program) : program = let prog_vdoms = complete_dom_decls Verif doms_syms in StrMap.fold (fun _ (m_seq, vdom_id, _) prog_vdoms -> - let vdom = Mast.DomainIdMap.find vdom_id prog_vdoms in - Mast.DomainIdSet.fold + let vdom = Com.DomainIdMap.find vdom_id prog_vdoms in + Com.DomainIdSet.fold (fun vid prog_vdoms -> - let vd = Mast.DomainIdMap.find vid prog_vdoms in + let vd = Com.DomainIdMap.find vid prog_vdoms in let vd = - match vd.Mir.dom_used with + match vd.Com.dom_used with | Some _ -> vd - | None -> { vd with Mir.dom_used = Some m_seq } + | None -> { vd with Com.dom_used = Some m_seq } in - Mast.DomainIdMap.add vid vd prog_vdoms) - (Mast.DomainIdSet.add vdom_id vdom.Mir.dom_min) + Com.DomainIdMap.add vid vd prog_vdoms) + (Com.DomainIdSet.add vdom_id vdom.Com.dom_min) prog_vdoms) prog.prog_vdom_calls prog_vdoms in @@ -948,7 +1162,8 @@ type 'a var_mem_type = Both | OneOf of 'a option type var_env = { prog : program; tmp_vars : int option Pos.marked StrMap.t; - it_vars : Pos.t StrMap.t; + ref_vars : Pos.t StrMap.t; + res_var : string Pos.marked option; } let rec fold_var_expr @@ -958,116 +1173,114 @@ let rec fold_var_expr (env : var_env) : 'a = let expr, expr_pos = m_expr in match expr with - | Mast.TestInSet (_positive, e, values) -> + | TestInSet (_positive, e, values) -> let res = fold_var_expr fold_var is_filter acc e env in List.fold_left (fun res set_value -> match set_value with - | Mast.VarValue v -> + | Com.VarValue v -> if is_filter then Err.forbidden_expresion_in_filter (Pos.get_position v); fold_var v (OneOf None) env res - | Mast.FloatValue _ -> res - | Mast.Interval (bn, en) -> + | Com.FloatValue _ -> res + | Com.Interval (bn, en) -> if Pos.unmark bn > Pos.unmark en then Err.wrong_interval_bounds (Pos.get_position bn); res) res values - | Mast.Comparison (_op, e1, e2) -> + | Comparison (_op, e1, e2) -> let acc = fold_var_expr fold_var is_filter acc e1 env in fold_var_expr fold_var is_filter acc e2 env - | Mast.Binop (_op, e1, e2) -> + | Binop (_op, e1, e2) -> let acc = fold_var_expr fold_var is_filter acc e1 env in fold_var_expr fold_var is_filter acc e2 env - | Mast.Unop (_op, e) -> fold_var_expr fold_var is_filter acc e env - | Mast.Index (t, (i, i_pos)) -> + | Unop (_op, e) -> fold_var_expr fold_var is_filter acc e env + | Index (t, e) -> if is_filter then Err.forbidden_expresion_in_filter expr_pos; - let acc = - match i with - | Mast.LiteralIndex _ -> acc - | Mast.SymbolIndex v -> fold_var (v, i_pos) (OneOf None) env acc - in + let acc = fold_var_expr fold_var is_filter acc e env in fold_var t (OneOf (Some ())) env acc - | Mast.Conditional (e1, e2, e3_opt) -> ( + | Conditional (e1, e2, e3_opt) -> ( let acc = fold_var_expr fold_var is_filter acc e1 env in let acc = fold_var_expr fold_var is_filter acc e2 env in match e3_opt with | Some e3 -> fold_var_expr fold_var is_filter acc e3 env | None -> acc) - | Mast.FunctionCall ((func_name, _), args) -> ( + | FuncCall ((func_name, fpos), args) -> ( let check_func arity = - match args with - | Mast.ArgList args -> - if arity > -1 && List.length args <> arity then - Err.wrong_arity_of_function func_name arity expr_pos; - List.fold_left - (fun acc e -> fold_var_expr fold_var is_filter acc e env) - acc args - | Mast.LoopList _ -> assert false + if arity > -1 && List.length args <> arity then + Err.wrong_arity_of_function func_name arity expr_pos; + List.fold_left + (fun acc e -> fold_var_expr fold_var is_filter acc e env) + acc args in match func_name with - | "multimax" -> ( + | Com.Multimax -> ( if is_filter then Err.forbidden_expresion_in_filter expr_pos; match args with - | Mast.ArgList [ expr; var_expr ] -> ( + | [ expr; var_expr ] -> ( match var_expr with - | Mast.Literal (Mast.Variable var), var_pos -> + | Var var, var_pos -> let acc = fold_var_expr fold_var is_filter acc expr env in fold_var (var, var_pos) Both env acc | _ -> Err.second_arg_of_multimax (Pos.get_position var_expr)) - | Mast.ArgList _ -> Err.multimax_require_two_args expr_pos - | Mast.LoopList _ -> assert false) - | "somme" -> check_func (-1) - | "numero_verif" -> check_func 0 - | "abs" -> check_func 1 - | "min" -> check_func 2 - | "max" -> check_func 2 - | "positif" -> check_func 1 - | "positif_ou_nul" -> check_func 1 - | "null" -> check_func 1 - | "arr" -> check_func 1 - | "inf" -> check_func 1 - | "supzero" -> check_func 1 - | "present" -> + | _ -> Err.multimax_require_two_args expr_pos) + | Com.SumFunc -> check_func (-1) + | Com.VerifNumber -> check_func 0 + | Com.ComplNumber -> check_func 0 + | Com.AbsFunc -> check_func 1 + | Com.MinFunc -> check_func 2 + | Com.MaxFunc -> check_func 2 + | Com.GtzFunc -> check_func 1 + | Com.GtezFunc -> check_func 1 + | Com.NullFunc -> check_func 1 + | Com.ArrFunc -> check_func 1 + | Com.InfFunc -> check_func 1 + | Com.Supzero -> check_func 1 + | Com.PresentFunc -> if is_filter then Err.forbidden_expresion_in_filter expr_pos; check_func 1 - | _ -> Err.unknown_function func_name expr_pos) - | Mast.Literal l -> ( - match l with - | Mast.Variable var -> - if is_filter then Err.variable_forbidden_in_filter expr_pos; - fold_var (var, expr_pos) (OneOf None) env acc - | Mast.Float _ | Mast.Undefined -> acc) - | Mast.NbCategory l -> + | Com.Func fn -> + if is_filter then Err.forbidden_expresion_in_filter expr_pos; + let fd = + match StrMap.find_opt fn env.prog.prog_functions with + | Some fd -> fd + | None -> Err.function_does_not_exist fn fpos + in + check_func (List.length fd.target_args)) + | Literal _ -> acc + | Var var -> + if is_filter then Err.variable_forbidden_in_filter expr_pos; + fold_var (var, expr_pos) (OneOf None) env acc + | NbCategory cs -> if not is_filter then Err.expression_only_in_filter expr_pos; - let cats = mast_to_catvars l env.prog.prog_var_cats in - Mir.CatVarSet.iter - (fun cat -> - if not (Mir.CatVarMap.mem cat env.prog.prog_var_cats) then - Err.unknown_domain Verif (Pos.get_position l)) + let cats = mast_to_catvars cs env.prog.prog_var_cats in + Com.CatVar.Map.iter + (fun cat pos -> + if not (Com.CatVar.Map.mem cat env.prog.prog_var_cats) then + Err.unknown_domain Verif pos) cats; acc - | Mast.Attribut (v, a) -> + | Attribut (v, a) -> let name, var_pos = match v with | Mast.Normal name, var_pos -> (name, var_pos) | Mast.Generic _, _ -> assert false in (match StrMap.find_opt name env.prog.prog_vars with - | Some { global_attrs; global_category; _ } -> - if not (StrMap.mem (Pos.unmark a) global_attrs) then - Err.unknown_attribut_for_var global_category (Pos.get_position a) + | Some var -> + let cat = Com.Var.cat var in + if not (StrMap.mem (Pos.unmark a) (Com.Var.attrs var)) then + Err.unknown_attribut_for_var cat (Pos.get_position a) | None -> ( match StrMap.find_opt name env.tmp_vars with | Some _ -> Err.tmp_vars_have_no_attrs var_pos | None -> ())); fold_var v Both env acc - | Mast.Size v -> fold_var v Both env acc - | Mast.NbAnomalies | Mast.NbDiscordances | Mast.NbInformatives - | Mast.NbBloquantes -> + | Size v -> fold_var v Both env acc + | NbAnomalies | NbDiscordances | NbInformatives | NbBloquantes -> if is_filter then Err.forbidden_expresion_in_filter expr_pos; acc - | Mast.Loop _ -> assert false + | FuncCallLoop _ | Loop _ -> assert false let check_variable (var : Mast.variable Pos.marked) (idx_mem : unit var_mem_type) (env : var_env) : string = @@ -1076,15 +1289,19 @@ let check_variable (var : Mast.variable Pos.marked) match var_data with | Normal vn -> ( match StrMap.find_opt vn env.prog.prog_vars with - | Some { global_name = _, decl_pos; global_table; _ } -> - (vn, OneOf global_table, decl_pos) + | Some v -> + (vn, OneOf (Com.Var.is_table v), Pos.get_position (Com.Var.name v)) | None -> ( match StrMap.find_opt vn env.tmp_vars with | Some (decl_size, decl_pos) -> (vn, OneOf decl_size, decl_pos) | None -> ( - match StrMap.find_opt vn env.it_vars with + match StrMap.find_opt vn env.ref_vars with | Some decl_pos -> (vn, Both, decl_pos) - | None -> Err.unknown_variable var_pos))) + | None -> ( + match env.res_var with + | Some (vr, decl_pos) when vr = vn -> + (vn, OneOf None, decl_pos) + | Some _ | None -> Err.unknown_variable var_pos)))) | Generic _ -> assert false in match (idx_mem, decl_mem) with @@ -1108,14 +1325,14 @@ let get_compute_id_str (instr : Mast.instruction) (prog : program) : string = let buf = Buffer.create 100 in Buffer.add_string buf prog.prog_prefix; let add_sml buf sml = - let id = Mast.DomainId.from_marked_list (Pos.unmark sml) in + let id = Com.DomainId.from_marked_list (Pos.unmark sml) in let add s = String.iter (function | '_' -> Buffer.add_string buf "__" | c -> Buffer.add_char buf c) s in - Mast.DomainId.iter + Com.DomainId.iter (fun s -> Buffer.add_char buf '_'; add s) @@ -1123,71 +1340,67 @@ let get_compute_id_str (instr : Mast.instruction) (prog : program) : string = id in (match instr with - | Mast.ComputeDomain l -> ( + | Com.ComputeDomain l -> ( Buffer.add_string buf "_rules"; let id = add_sml buf l in - match Mast.DomainIdMap.find_opt id prog.prog_rdom_syms with + match Com.DomainIdMap.find_opt id prog.prog_rdom_syms with | Some (dom_id, _) -> - let rdom = Mast.DomainIdMap.find dom_id prog.prog_rdoms in - if not rdom.Mir.dom_data.rdom_computable then + let rdom = Com.DomainIdMap.find dom_id prog.prog_rdoms in + if not rdom.Com.dom_data.rdom_computable then Err.rule_domain_not_computable (Pos.get_position l) | None -> Err.unknown_domain Rule (Pos.get_position l)) - | Mast.ComputeChaining (ch_name, ch_pos) -> ( + | Com.ComputeChaining (ch_name, ch_pos) -> ( Buffer.add_string buf "_chaining_"; Buffer.add_string buf ch_name; match StrMap.find_opt ch_name prog.prog_chainings with | Some _ -> () | None -> Err.unknown_chaining ch_pos) - | Mast.ComputeVerifs (l, _) -> ( + | Com.ComputeVerifs (l, _) -> ( Buffer.add_string buf "_verifs"; let id = add_sml buf l in Buffer.add_char buf '_'; let cpt = StrMap.cardinal prog.prog_vdom_calls in Buffer.add_string buf (Format.sprintf "%d" cpt); - match Mast.DomainIdMap.find_opt id prog.prog_vdom_syms with + match Com.DomainIdMap.find_opt id prog.prog_vdom_syms with | Some (dom_id, _) -> - let vdom = Mast.DomainIdMap.find dom_id prog.prog_vdoms in - if not vdom.Mir.dom_data.vdom_verifiable then + let vdom = Com.DomainIdMap.find dom_id prog.prog_vdoms in + if not vdom.Com.dom_data.vdom_verifiable then Err.verif_domain_not_verifiable (Pos.get_position l) | None -> Err.unknown_domain Verif (Pos.get_position l)) | _ -> assert false); Buffer.contents buf let cats_variable_from_decl_list (l : Mast.var_category_id list) - (cats : 'a Mir.CatVarMap.t) : Mir.CatVarSet.t = + (cats : Com.CatVar.data Com.CatVar.Map.t) : Pos.t Com.CatVar.Map.t = let rec aux res = function | [] -> res | l :: t -> - let vcats = mast_to_catvars l cats in - aux (Mir.CatVarSet.union vcats res) t + let vcats = mast_to_catvars (Com.CatVar.Map.from_string_list l) cats in + aux (Com.CatVar.Map.union (fun _ p _ -> Some p) vcats res) t in - aux Mir.CatVarSet.empty l + aux Com.CatVar.Map.empty l let rec check_instructions (instrs : Mast.instruction Pos.marked list) (is_rule : bool) (env : var_env) : program * Mast.instruction Pos.marked list * StrSet.t * StrSet.t = let rec aux (env, res, in_vars, out_vars) = function - | [] -> (env.prog, List.rev res, in_vars, out_vars) + | [] -> (env, List.rev res, in_vars, out_vars) | m_instr :: il -> ( let instr, instr_pos = m_instr in match instr with - | Mast.Formula (f, _) -> ( + | Com.Affectation (f, _) -> ( match f with - | Mast.SingleFormula sf -> - let lval = Pos.unmark sf.lvalue in + | Com.SingleFormula (v, idx, e) -> let out_var = - let idx_mem = OneOf (Option.map (fun _ -> ()) lval.index) in - check_variable lval.var idx_mem env + let idx_mem = OneOf (Option.map (fun _ -> ()) idx) in + check_variable v idx_mem env in let in_vars_index = - match lval.index with - | Some (Mast.SymbolIndex vn, vpos) -> - let var = (vn, vpos) in - let name = check_variable var (OneOf None) env in - StrSet.singleton name - | Some (Mast.LiteralIndex _, _) | None -> StrSet.empty + match idx with + | Some ei -> check_expression false ei env + | None -> StrSet.empty in - let in_vars_expr = check_expression false sf.formula env in + let in_vars_expr = check_expression false e env in if is_rule then let in_vars_aff = StrSet.union in_vars_index in_vars_expr in let in_vars = @@ -1196,22 +1409,60 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) let out_vars = StrSet.add out_var out_vars in aux (env, m_instr :: res, in_vars, out_vars) il else aux (env, m_instr :: res, in_vars, out_vars) il - | Mast.MultipleFormulaes _ -> assert false) - | Mast.IfThenElse (expr, i_then, i_else) -> - if is_rule then Err.insruction_forbidden_in_rules instr_pos; - let _ = check_expression false expr env in - let prog, res_then, _, _ = check_instructions i_then is_rule env in + | Com.MultipleFormulaes _ -> assert false) + | Com.IfThenElse (expr, i_then, i_else) -> + (* if is_rule then Err.insruction_forbidden_in_rules instr_pos; *) + let in_expr = check_expression false expr env in + let prog, res_then, in_then, out_then = + check_instructions i_then is_rule env + in let env = { env with prog } in - let prog, res_else, _, _ = check_instructions i_else is_rule env in + let prog, res_else, in_else, out_else = + check_instructions i_else is_rule env + in let env = { env with prog } in - let res_instr = Mast.IfThenElse (expr, res_then, res_else) in + let res_instr = Com.IfThenElse (expr, res_then, res_else) in + let in_vars = + in_vars |> StrSet.union in_expr |> StrSet.union in_then + |> StrSet.union in_else + in + let out_vars = + out_vars |> StrSet.union out_then |> StrSet.union out_else + in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il - | Mast.ComputeDomain (rdom_list, rdom_pos) -> + | Com.WhenDoElse (wdl, ed) -> + let rec wde (env, res, in_vars, out_vars) = function + | (expr, dl, pos) :: l -> + let in_expr = check_expression false expr env in + let prog, res_do, in_do, out_do = + check_instructions dl is_rule env + in + let env = { env with prog } in + let in_vars = + in_vars |> StrSet.union in_expr |> StrSet.union in_do + in + let out_vars = out_vars |> StrSet.union out_do in + wde (env, (expr, res_do, pos) :: res, in_vars, out_vars) l + | [] -> + let prog, res_ed, in_ed, out_ed = + check_instructions (Pos.unmark ed) is_rule env + in + let env = { env with prog } in + let ed' = Pos.same_pos_as res_ed ed in + let in_vars = in_vars |> StrSet.union in_ed in + let out_vars = out_vars |> StrSet.union out_ed in + (env, Com.WhenDoElse (List.rev res, ed'), in_vars, out_vars) + in + let env, wde_res, in_vars, out_vars = + wde (env, [], in_vars, out_vars) wdl + in + aux (env, (wde_res, instr_pos) :: res, in_vars, out_vars) il + | Com.ComputeDomain (rdom_list, rdom_pos) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; let tname = get_compute_id_str instr env.prog in let rdom_id = - let id = Mast.DomainId.from_marked_list rdom_list in - Pos.unmark (Mast.DomainIdMap.find id env.prog.prog_rdom_syms) + let id = Com.DomainId.from_marked_list rdom_list in + Pos.unmark (Com.DomainIdMap.find id env.prog.prog_rdom_syms) in let seq, prog = get_seq env.prog in let prog_rdom_calls = @@ -1220,19 +1471,19 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) in let prog = { prog with prog_rdom_calls } in let env = { env with prog } in - let res_instr = Mast.ComputeTarget (tname, Pos.no_pos) in + let res_instr = Com.ComputeTarget ((tname, Pos.no_pos), []) in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il - | Mast.ComputeChaining _ -> + | Com.ComputeChaining _ -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; let tname = get_compute_id_str instr env.prog in - let res_instr = Mast.ComputeTarget (tname, Pos.no_pos) in + let res_instr = Com.ComputeTarget ((tname, Pos.no_pos), []) in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il - | Mast.ComputeVerifs ((vdom_list, vdom_pos), expr) -> + | Com.ComputeVerifs ((vdom_list, vdom_pos), expr) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; let tname = get_compute_id_str instr env.prog in let vdom_id = - let id = Mast.DomainId.from_marked_list vdom_list in - Pos.unmark (Mast.DomainIdMap.find id env.prog.prog_vdom_syms) + let id = Com.DomainId.from_marked_list vdom_list in + Pos.unmark (Com.DomainIdMap.find id env.prog.prog_vdom_syms) in let seq, prog = get_seq env.prog in ignore (check_expression true expr env); @@ -1242,99 +1493,128 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) in let prog = { prog with prog_vdom_calls } in let env = { env with prog } in - let res_instr = Mast.ComputeTarget (tname, Pos.no_pos) in + let res_instr = Com.ComputeTarget ((tname, Pos.no_pos), []) in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il - | Mast.VerifBlock instrs -> + | Com.VerifBlock instrs -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; let prog, res_instrs, _, _ = check_instructions instrs is_rule env in let env = { env with prog } in - let res_instr = Mast.VerifBlock res_instrs in + let res_instr = Com.VerifBlock res_instrs in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il - | Mast.ComputeTarget _tn -> + | Com.ComputeTarget ((tn, tpos), targs) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; + (match StrMap.find_opt tn env.prog.prog_targets with + | None -> Err.unknown_target tn tpos + | Some target -> + let nb_args = List.length target.target_args in + if List.length targs <> nb_args then + Err.wrong_number_of_args nb_args tpos); + List.iter (fun var -> ignore (check_variable var Both env)) targs; aux (env, m_instr :: res, in_vars, out_vars) il - | Mast.Print (_std, args) -> + | Com.Print (_std, args) -> List.iter (fun arg -> match Pos.unmark arg with - | Mast.PrintString _ -> () - | Mast.PrintName v | Mast.PrintAlias v -> + | Com.PrintString _ -> () + | Com.PrintName v | Com.PrintAlias v -> ignore (check_variable v Both env) - | Mast.PrintIndent e -> ignore (check_expression false e env) - | Mast.PrintExpr (e, _min, _max) -> + | Com.PrintIndent e -> ignore (check_expression false e env) + | Com.PrintExpr (e, _min, _max) -> ignore (check_expression false e env)) args; aux (env, m_instr :: res, in_vars, out_vars) il - | Mast.Iterate (var, vcats, expr, instrs) -> + | Com.Iterate (var, vars, var_params, instrs) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; - let var_name, var_pos = var in + let var_pos = Pos.get_position var in + let var_name = + match Pos.unmark var with + | Mast.Normal var -> var + | Mast.Generic _ -> assert false + in (match StrMap.find_opt var_name env.prog.prog_vars with - | Some { global_name = _, old_pos; _ } -> + | Some Com.Var.{ name = _, old_pos; _ } -> Err.variable_already_declared var_name old_pos var_pos | None -> ()); (match StrMap.find_opt var_name env.tmp_vars with | Some (_, old_pos) -> Err.variable_already_declared var_name old_pos var_pos | None -> ()); - (match StrMap.find_opt var_name env.it_vars with + (match StrMap.find_opt var_name env.ref_vars with | Some old_pos -> Err.variable_already_declared var_name old_pos var_pos | None -> ()); - ignore (cats_variable_from_decl_list vcats env.prog.prog_var_cats); let env' = - { env with it_vars = StrMap.add var_name var_pos env.it_vars } + { env with ref_vars = StrMap.add var_name var_pos env.ref_vars } in - ignore (check_expression false expr env'); + ignore + (List.fold_left + (fun seen var -> + let var_pos = Pos.get_position var in + let var_name = Mast.get_normal_var (Pos.unmark var) in + ignore (check_variable var Both env); + match StrMap.find_opt var_name seen with + | None -> StrMap.add var_name var_pos seen + | Some old_pos -> + Err.variable_already_specified var_name old_pos var_pos) + StrMap.empty vars); + List.iter + (fun (vcats, expr) -> + ignore (mast_to_catvars vcats env.prog.prog_var_cats); + ignore (check_expression false expr env')) + var_params; let prog, res_instrs, _, _ = check_instructions instrs is_rule env' in let env = { env with prog } in - let res_instr = Mast.Iterate (var, vcats, expr, res_instrs) in + let res_instr = Com.Iterate (var, vars, var_params, res_instrs) in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il - | Mast.Restore (rest_params, instrs) -> + | Com.Restore (vars, var_params, instrs) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; + ignore + (List.fold_left + (fun seen var -> + let var_pos = Pos.get_position var in + let var_name = Mast.get_normal_var (Pos.unmark var) in + ignore (check_variable var Both env); + match StrMap.find_opt var_name seen with + | None -> StrMap.add var_name var_pos seen + | Some old_pos -> + Err.variable_already_specified var_name old_pos var_pos) + StrMap.empty vars); List.iter - (fun rest_param -> - match Pos.unmark rest_param with - | Mast.VarList vl -> - List.iter - (fun (vn, vpos) -> - let var = (Mast.Normal vn, vpos) in - ignore (check_variable var Both env)) - vl - | Mast.VarCats (vn, vcats, expr) -> - let var_name, var_pos = vn in - (match StrMap.find_opt var_name env.prog.prog_vars with - | Some { global_name = _, old_pos; _ } -> - Err.variable_already_declared var_name old_pos var_pos - | None -> ()); - (match StrMap.find_opt var_name env.tmp_vars with - | Some (_, old_pos) -> - Err.variable_already_declared var_name old_pos var_pos - | None -> ()); - (match StrMap.find_opt var_name env.it_vars with - | Some old_pos -> - Err.variable_already_declared var_name old_pos var_pos - | None -> ()); - ignore - (cats_variable_from_decl_list vcats env.prog.prog_var_cats); - let env = - { - env with - it_vars = StrMap.add var_name var_pos env.it_vars; - } - in - ignore (check_expression false expr env)) - rest_params; + (fun (var, vcats, expr) -> + let var_pos = Pos.get_position var in + let var_name = Mast.get_normal_var (Pos.unmark var) in + (match StrMap.find_opt var_name env.prog.prog_vars with + | Some Com.Var.{ name = _, old_pos; _ } -> + Err.variable_already_declared var_name old_pos var_pos + | None -> ()); + (match StrMap.find_opt var_name env.tmp_vars with + | Some (_, old_pos) -> + Err.variable_already_declared var_name old_pos var_pos + | None -> ()); + (match StrMap.find_opt var_name env.ref_vars with + | Some old_pos -> + Err.variable_already_declared var_name old_pos var_pos + | None -> ()); + ignore (mast_to_catvars vcats env.prog.prog_var_cats); + let env = + { + env with + ref_vars = StrMap.add var_name var_pos env.ref_vars; + } + in + ignore (check_expression false expr env)) + var_params; let prog, res_instrs, _, _ = check_instructions instrs is_rule env in let env = { env with prog } in - let res_instr = Mast.Restore (rest_params, res_instrs) in + let res_instr = Com.Restore (vars, var_params, res_instrs) in aux (env, (res_instr, instr_pos) :: res, in_vars, out_vars) il - | Mast.RaiseError (m_err, m_var_opt) -> + | Com.RaiseError (m_err, m_var_opt) -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; let err_name, err_pos = m_err in (match StrMap.find_opt err_name env.prog.prog_errors with @@ -1344,83 +1624,154 @@ let rec check_instructions (instrs : Mast.instruction Pos.marked list) | Some (var_name, var_pos) -> ( if (not (StrMap.mem var_name env.tmp_vars)) - && not (StrMap.mem var_name env.it_vars) + && not (StrMap.mem var_name env.ref_vars) then match StrMap.find_opt var_name env.prog.prog_vars with | None -> Err.unknown_variable var_pos | Some _ -> ()) | None -> ()); aux (env, m_instr :: res, in_vars, out_vars) il - | Mast.CleanErrors | Mast.ExportErrors | Mast.FinalizeErrors -> + | Com.CleanErrors | Com.ExportErrors | Com.FinalizeErrors -> if is_rule then Err.insruction_forbidden_in_rules instr_pos; aux (env, m_instr :: res, in_vars, out_vars) il) in - aux (env, [], StrSet.empty, StrSet.empty) instrs - -let check_target (t : Mast.target) (prog : program) : program = - let tname, tpos = t.Mast.target_name in - let target_name = - (match StrMap.find_opt tname prog.prog_targets with - | Some { target_name = _, old_pos; _ } -> - Err.target_already_declared tname old_pos tpos - | None -> ()); - (tname, tpos) + let env, res, in_vars, out_vars = + aux (env, [], StrSet.empty, StrSet.empty) instrs in - let target_file = Some (get_target_file tpos) in - let target_apps = - List.fold_left - (fun target_apps (app, app_pos) -> - (match StrMap.find_opt app prog.prog_apps with - | None -> Err.unknown_application app_pos - | Some _ -> ()); - (match StrMap.find_opt app target_apps with - | Some old_pos -> Err.application_already_specified old_pos app_pos - | None -> ()); - StrMap.add app app_pos target_apps) - StrMap.empty t.Mast.target_applications + let tmp_vars = + StrMap.fold (fun vn _ s -> StrSet.add vn s) env.tmp_vars StrSet.empty in - if StrMap.mem prog.prog_app target_apps then - let target_tmp_vars = - let check_tmp_var (vn, vpos) tmp_vars = - (match StrMap.find_opt vn prog.prog_vars with - | Some { global_name = _, old_pos; _ } -> - Err.variable_already_declared vn old_pos vpos - | None -> ()); - match StrMap.find_opt vn tmp_vars with - | Some (_, old_pos) -> Err.variable_already_declared vn old_pos vpos - | None -> () + let in_vars = StrSet.diff in_vars tmp_vars in + let out_vars = StrSet.diff out_vars tmp_vars in + (env.prog, res, in_vars, out_vars) + +let check_target (is_function : bool) (t : Mast.target) (prog : program) : + program = + let target_name = t.target_name in + let tname, tpos = target_name in + if Com.Func tname <> Pos.unmark (Parse_utils.parse_function_name target_name) + then Err.is_base_function tname tpos; + (match StrMap.find_opt tname prog.prog_targets with + | Some { target_name = _, old_pos; _ } -> + Err.target_already_declared tname old_pos tpos + | None -> ()); + let target_file = Some (get_target_file tpos) in + let target_apps = t.target_apps in + StrMap.iter + (fun _ (app, app_pos) -> + match StrMap.find_opt app prog.prog_apps with + | None -> Err.unknown_application app_pos + | Some _ -> ()) + target_apps; + let target, prog = + if StrMap.mem prog.prog_app target_apps then ( + let target_args = t.target_args in + List.iter + (fun (vn, vpos) -> + match StrMap.find_opt vn prog.prog_vars with + | Some Com.Var.{ name = _, old_pos; _ } -> + Err.variable_already_declared vn old_pos vpos + | None -> ()) + target_args; + let target_tmp_vars = t.target_tmp_vars in + StrMap.iter + (fun _ ((vn, vpos), _) -> + match StrMap.find_opt vn prog.prog_vars with + | Some Com.Var.{ name = _, old_pos; _ } -> + Err.variable_already_declared vn old_pos vpos + | None -> ()) + target_tmp_vars; + List.iter + (fun (vn, vpos) -> + match StrMap.find_opt vn target_tmp_vars with + | Some ((_, old_pos), _) -> + Err.variable_already_declared vn old_pos vpos + | None -> ()) + target_args; + let target_result = t.target_result in + (match target_result with + | Some (vn, vpos) -> ( + if not is_function then Err.target_must_not_have_a_result tname tpos; + (match StrMap.find_opt vn prog.prog_vars with + | Some { name = _, old_pos; _ } -> + Err.variable_already_declared vn old_pos vpos + | None -> ()); + (match List.find_opt (fun (va, _) -> vn = va) target_args with + | Some (_, old_pos) -> Err.variable_already_declared vn old_pos vpos + | None -> ()); + match StrMap.find_opt vn target_tmp_vars with + | Some ((_, old_pos), _) -> + Err.variable_already_declared vn old_pos vpos + | None -> ()) + | None -> if is_function then Err.function_result_missing tname tpos); + let tmp_vars = + StrMap.map + (fun (var, size) -> + let vpos = Pos.get_position var in + let sz = + match size with + | None -> None + | Some (Mast.LiteralSize i, _) -> Some i + | Some (Mast.SymbolSize _, _) -> assert false + in + (sz, vpos)) + target_tmp_vars in - List.fold_left - (fun target_tmp_vars (var, size) -> - check_tmp_var var target_tmp_vars; - let vn, vpos = var in - let sz = - match size with - | None -> None - | Some (Mast.LiteralSize i, _) -> Some i - | Some (Mast.SymbolSize _, _) -> assert false - in - StrMap.add vn (sz, vpos) target_tmp_vars) - StrMap.empty t.Mast.target_tmp_vars - in - let prog, target_prog = - let env = { prog; tmp_vars = target_tmp_vars; it_vars = StrMap.empty } in - let prog, target_prog, _, _ = - check_instructions t.Mast.target_prog false env + let ref_vars = + List.fold_left + (fun res (vn, vpos) -> StrMap.add vn vpos res) + StrMap.empty target_args in - (prog, target_prog) - in - let target = - { target_name; target_file; target_apps; target_tmp_vars; target_prog } - in - let prog_targets = StrMap.add tname target prog.prog_targets in - { prog with prog_targets } + let res_var = target_result in + let prog, target_prog = + let env = { prog; tmp_vars; ref_vars; res_var } in + let prog, target_prog, _in_vars, out_vars = + check_instructions t.target_prog is_function env + in + (if is_function then + let vr = Pos.unmark (Option.get target_result) in + let bad_out_vars = StrSet.remove vr out_vars in + if StrSet.card bad_out_vars > 0 then + let vn = StrSet.min_elt bad_out_vars in + Err.forbidden_out_var_in_function vn tname tpos); + (prog, target_prog) + in + let target = + { + t with + target_name; + target_file; + target_apps; + target_args; + target_result; + target_tmp_vars; + target_prog; + } + in + (target, prog)) + else + let target_args = [] in + let target_result = Option.map (Pos.same_pos_as "") t.target_result in + let target_tmp_vars = StrMap.empty in + let target_prog = [] in + let target = + { + t with + target_name; + target_file; + target_apps; + target_args; + target_result; + target_tmp_vars; + target_prog; + } + in + (target, prog) + in + if is_function then + let prog_functions = StrMap.add tname target prog.prog_functions in + { prog with prog_functions } else - let target_tmp_vars = StrMap.empty in - let target_prog = [] in - let target = - { target_name; target_file; target_apps; target_tmp_vars; target_prog } - in let prog_targets = StrMap.add tname target prog.prog_targets in { prog with prog_targets } @@ -1428,25 +1779,25 @@ let check_rule (r : Mast.rule) (prog : program) : program = let id, id_pos = r.Mast.rule_number in let rule_id = (id, id_pos) in let rule_apps = - List.fold_left - (fun rule_apps (app, app_pos) -> + StrMap.fold + (fun _ (app, app_pos) rule_apps -> match StrMap.find_opt app prog.prog_apps with | None -> Err.unknown_application app_pos | Some _ -> StrMap.add app app_pos rule_apps) - StrMap.empty r.Mast.rule_applications + r.Mast.rule_apps StrMap.empty in if StrMap.mem prog.prog_app rule_apps then ( let rdom_id = - Mast.DomainId.from_marked_list (Pos.unmark r.Mast.rule_tag_names) + Com.DomainId.from_marked_list (Pos.unmark r.Mast.rule_tag_names) in let rule_domain, rule_domain_pos = let rid, rid_pos = - match Mast.DomainIdMap.find_opt rdom_id prog.prog_rdom_syms with + match Com.DomainIdMap.find_opt rdom_id prog.prog_rdom_syms with | Some m_rid -> m_rid | None -> Err.unknown_domain Rule (Pos.get_position r.Mast.rule_tag_names) in - let rule_domain = Mast.DomainIdMap.find rid prog.prog_rdoms in + let rule_domain = Com.DomainIdMap.find rid prog.prog_rdoms in (rule_domain, rid_pos) in let rule_app_set = @@ -1477,13 +1828,30 @@ let check_rule (r : Mast.rule) (prog : program) : program = (Some ch_name, prog_chainings) else (None, prog.prog_chainings)) in - let rule_instrs = - List.map - (fun f -> Pos.same_pos_as (Mast.Formula f) f) - r.Mast.rule_formulaes + let rule_tmp_vars = r.Mast.rule_tmp_vars in + StrMap.iter + (fun _ ((vn, vpos), _) -> + match StrMap.find_opt vn prog.prog_vars with + | Some Com.Var.{ name = _, old_pos; _ } -> + Err.variable_already_declared vn old_pos vpos + | None -> ()) + rule_tmp_vars; + let tmp_vars = + StrMap.map + (fun (var, size) -> + let vpos = Pos.get_position var in + let sz = + match size with + | None -> None + | Some (Mast.LiteralSize i, _) -> Some i + | Some (Mast.SymbolSize _, _) -> assert false + in + (sz, vpos)) + rule_tmp_vars in + let rule_instrs = r.Mast.rule_formulaes in let prog, rule_instrs, rule_in_vars, rule_out_vars = - let env = { prog; tmp_vars = StrMap.empty; it_vars = StrMap.empty } in + let env = { prog; tmp_vars; ref_vars = StrMap.empty; res_var = None } in check_instructions rule_instrs true env in let rule_seq, prog = get_seq prog in @@ -1493,6 +1861,7 @@ let check_rule (r : Mast.rule) (prog : program) : program = rule_apps; rule_domain; rule_chain; + rule_tmp_vars; rule_instrs; rule_in_vars; rule_out_vars; @@ -1517,13 +1886,19 @@ let convert_rules (prog : program) : program = Some (get_target_file (Pos.get_position rule.rule_id)) in let target = - { - target_name = (tname, Pos.no_pos); - target_file; - target_apps = StrMap.singleton prog.prog_app Pos.no_pos; - target_tmp_vars = StrMap.empty; - target_prog = rule.rule_instrs; - } + Mast. + { + target_name = (tname, Pos.no_pos); + target_file; + target_apps = StrMap.one prog.prog_app (prog.prog_app, Pos.no_pos); + target_args = []; + target_result = None; + target_tmp_vars = rule.rule_tmp_vars; + target_prog = rule.rule_instrs; + target_nb_tmps = 0; + target_sz_tmps = 0; + target_nb_refs = 0; + } in StrMap.add tname target prog_targets) prog.prog_rules prog.prog_targets @@ -1545,7 +1920,7 @@ let create_rule_graph (in_vars_from : rule -> StrSet.t) else StrMap.update var (function - | None -> Some (IntSet.singleton id) + | None -> Some (IntSet.one id) | Some set -> Some (IntSet.add id set)) var_map) (in_vars_from rule) var_map) @@ -1618,26 +1993,26 @@ let rule_graph_to_instrs (rdom_chain : rdom_or_chain) (prog : program) List.map (fun id -> let name = Format.sprintf "%s_regle_%d" prog.prog_prefix id in - (Mast.ComputeTarget (name, Pos.no_pos), Pos.no_pos)) + (Com.ComputeTarget ((name, Pos.no_pos), []), Pos.no_pos)) sorted_rules -let rdom_rule_filter (rdom : Mir.rule_domain_data Mir.domain) (rule : rule) : +let rdom_rule_filter (rdom : Com.rule_domain_data Com.domain) (rule : rule) : bool = - (match rdom.Mir.dom_used with + (match rdom.Com.dom_used with | Some (rdom_seq, seq_pos) -> if rdom_seq <= rule.rule_seq then Err.domain_already_used Rule seq_pos (Pos.get_position rule.rule_id) | None -> ()); let rdom_id = Pos.unmark rdom.dom_id in let rule_rdom_id = Pos.unmark rule.rule_domain.dom_id in - Mast.DomainId.equal rdom_id rule_rdom_id - || Mast.DomainIdSet.mem rule_rdom_id rdom.Mir.dom_min + Com.DomainId.equal rdom_id rule_rdom_id + || Com.DomainIdSet.mem rule_rdom_id rdom.Com.dom_min let complete_rule_domains (prog : program) : program = let prog_targets = - Mast.DomainIdMap.fold + Com.DomainIdMap.fold (fun rdom_id rdom prog_targets -> - if rdom.Mir.dom_data.Mir.rdom_computable then + if rdom.Com.dom_data.Com.rdom_computable then let rdom_rules = IntMap.filter (fun _ rule -> rdom_rule_filter rdom rule) @@ -1654,18 +2029,25 @@ let complete_rule_domains (prog : program) : program = in let tname = let spl = - Mast.DomainId.fold (fun s l -> (s, Pos.no_pos) :: l) rdom_id [] + Com.DomainId.fold (fun s l -> (s, Pos.no_pos) :: l) rdom_id [] in - get_compute_id_str (Mast.ComputeDomain (spl, Pos.no_pos)) prog + get_compute_id_str (Com.ComputeDomain (spl, Pos.no_pos)) prog in let target = - { - target_name = (tname, Pos.no_pos); - target_file = None; - target_apps = StrMap.singleton prog.prog_app Pos.no_pos; - target_tmp_vars = StrMap.empty; - target_prog; - } + Mast. + { + target_name = (tname, Pos.no_pos); + target_file = None; + target_apps = + StrMap.one prog.prog_app (prog.prog_app, Pos.no_pos); + target_args = []; + target_result = None; + target_tmp_vars = StrMap.empty; + target_prog; + target_nb_tmps = 0; + target_sz_tmps = 0; + target_nb_refs = 0; + } in StrMap.add tname target prog_targets else prog_targets) @@ -1673,14 +2055,14 @@ let complete_rule_domains (prog : program) : program = in { prog with prog_targets } -let rdom_id_rule_filter (prog : program) (rdom_id : Mast.DomainId.t) +let rdom_id_rule_filter (prog : program) (rdom_id : Com.DomainId.t) (rule : rule) : bool = - let rdom = Mast.DomainIdMap.find rdom_id prog.prog_rdoms in + let rdom = Com.DomainIdMap.find rdom_id prog.prog_rdoms in rdom_rule_filter rdom rule -let rdom_ids_rule_filter (prog : program) (rdom_ids : Mast.DomainIdSet.t) +let rdom_ids_rule_filter (prog : program) (rdom_ids : Com.DomainIdSet.t) (rule : rule) : bool = - Mast.DomainIdSet.exists + Com.DomainIdSet.exists (fun rdom_id -> rdom_id_rule_filter prog rdom_id rule) rdom_ids @@ -1689,29 +2071,29 @@ let complete_chainings (prog : program) : program = StrMap.fold (fun ch_name chain prog_targets -> let all_ids = - Mast.DomainIdMap.fold + Com.DomainIdMap.fold (fun _ rdom ids -> - let uid = Pos.unmark rdom.Mir.dom_id in - Mast.DomainIdSet.add uid ids) - prog.prog_rdoms Mast.DomainIdSet.empty + let uid = Pos.unmark rdom.Com.dom_id in + Com.DomainIdSet.add uid ids) + prog.prog_rdoms Com.DomainIdSet.empty in let sup_ids = IntMap.fold (fun _ (rdom, id_pos) sup_ids -> - let uid = Pos.unmark rdom.Mir.dom_id in - let rdom_supeq = Mast.DomainIdSet.add uid rdom.Mir.dom_max in - let sup_ids = Mast.DomainIdSet.inter sup_ids rdom_supeq in - if Mast.DomainIdSet.cardinal sup_ids = 0 then + let uid = Pos.unmark rdom.Com.dom_id in + let rdom_supeq = Com.DomainIdSet.add uid rdom.Com.dom_max in + let sup_ids = Com.DomainIdSet.inter sup_ids rdom_supeq in + if Com.DomainIdSet.cardinal sup_ids = 0 then Err.rule_domain_incompatible_with_chaining ch_name id_pos else sup_ids) chain.chain_rules all_ids in let min_ids = - Mast.DomainIdSet.filter + Com.DomainIdSet.filter (fun id -> - let rdom = Mast.DomainIdMap.find id prog.prog_rdoms in - let min_sups = Mast.DomainIdSet.inter sup_ids rdom.Mir.dom_min in - Mast.DomainIdSet.is_empty min_sups) + let rdom = Com.DomainIdMap.find id prog.prog_rdoms in + let min_sups = Com.DomainIdSet.inter sup_ids rdom.Com.dom_min in + Com.DomainIdSet.is_empty min_sups) sup_ids in let rdom_rules = @@ -1749,16 +2131,22 @@ let complete_chainings (prog : program) : program = rule_graph_to_instrs (Chaining ch_name) prog rule_graph in let tname = - get_compute_id_str (Mast.ComputeChaining (ch_name, Pos.no_pos)) prog + get_compute_id_str (Com.ComputeChaining (ch_name, Pos.no_pos)) prog in let target = - { - target_name = (tname, Pos.no_pos); - target_file = None; - target_apps = StrMap.singleton prog.prog_app Pos.no_pos; - target_tmp_vars = StrMap.empty; - target_prog; - } + Mast. + { + target_name = (tname, Pos.no_pos); + target_file = None; + target_apps = StrMap.one prog.prog_app (prog.prog_app, Pos.no_pos); + target_args = []; + target_result = None; + target_tmp_vars = StrMap.empty; + target_prog; + target_nb_tmps = 0; + target_sz_tmps = 0; + target_nb_refs = 0; + } in StrMap.add tname target prog_targets) prog.prog_chainings prog.prog_targets @@ -1767,25 +2155,25 @@ let complete_chainings (prog : program) : program = let check_verif (v : Mast.verification) (prog : program) : program = let verif_apps = - List.fold_left - (fun verif_apps (app, app_pos) -> + StrMap.fold + (fun _ (app, app_pos) verif_apps -> match StrMap.find_opt app prog.prog_apps with | None -> Err.unknown_application app_pos | Some _ -> StrMap.add app app_pos verif_apps) - StrMap.empty v.Mast.verif_applications + v.Mast.verif_apps StrMap.empty in if StrMap.mem prog.prog_app verif_apps then let vdom_id = - Mast.DomainId.from_marked_list (Pos.unmark v.Mast.verif_tag_names) + Com.DomainId.from_marked_list (Pos.unmark v.Mast.verif_tag_names) in let verif_domain = let vid = - match Mast.DomainIdMap.find_opt vdom_id prog.prog_vdom_syms with + match Com.DomainIdMap.find_opt vdom_id prog.prog_vdom_syms with | Some (vid, _) -> vid | None -> Err.unknown_domain Verif (Pos.get_position v.Mast.verif_tag_names) in - Mast.DomainIdMap.find vid prog.prog_vdoms + Com.DomainIdMap.find vid prog.prog_vdoms in let prog_verifs, prog, _ = List.fold_left @@ -1800,7 +2188,7 @@ let check_verif (v : Mast.verification) (prog : program) : program = match StrMap.find_opt err_name prog.prog_errors with | None -> Err.unknown_error err_pos | Some err -> ( - match err.typ with Mast.Anomaly -> true | _ -> false) + match err.typ with Com.Error.Anomaly -> true | _ -> false) in (match verif_var with | Some (var_name, var_pos) -> ( @@ -1812,21 +2200,22 @@ let check_verif (v : Mast.verification) (prog : program) : program = let fold_var var idx_mem env (vdom_sts, var_sts) = let name = check_variable var idx_mem env in let var_data = StrMap.find name env.prog.prog_vars in - if - not - (Mir.CatVarSet.mem var_data.global_category - verif_domain.dom_data.vdom_auth) + let cat = Com.Var.cat var_data in + if not (Com.CatVar.Map.mem cat verif_domain.dom_data.vdom_auth) then Err.variable_with_forbidden_category (Pos.get_position var); let incr = function None -> Some 1 | Some i -> Some (i + 1) in - let vdom_sts = - Mir.CatVarMap.update var_data.global_category incr vdom_sts - in + let vdom_sts = Com.CatVar.Map.update cat incr vdom_sts in let var_sts = StrMap.update name incr var_sts in (vdom_sts, var_sts) in - let init = (Mir.CatVarMap.empty, StrMap.empty) in + let init = (Com.CatVar.Map.empty, StrMap.empty) in let env = - { prog; tmp_vars = StrMap.empty; it_vars = StrMap.empty } + { + prog; + tmp_vars = StrMap.empty; + ref_vars = StrMap.empty; + res_var = None; + } in fold_var_expr fold_var false init verif_expr env in @@ -1868,10 +2257,10 @@ let convert_verifs (prog : program) : program = in let target_prog = [ - ( Mast.IfThenElse + ( Com.IfThenElse ( verif.verif_expr, [ - ( Mast.RaiseError (verif.verif_error, verif.verif_var), + ( Com.RaiseError (verif.verif_error, verif.verif_var), Pos.no_pos ); ], [] ), @@ -1879,13 +2268,19 @@ let convert_verifs (prog : program) : program = ] in let target = - { - target_name = (tname, Pos.no_pos); - target_file; - target_apps = StrMap.singleton prog.prog_app Pos.no_pos; - target_tmp_vars = StrMap.empty; - target_prog; - } + Mast. + { + target_name = (tname, Pos.no_pos); + target_file; + target_apps = StrMap.one prog.prog_app (prog.prog_app, Pos.no_pos); + target_args = []; + target_result = None; + target_tmp_vars = StrMap.empty; + target_prog; + target_nb_tmps = 0; + target_sz_tmps = 0; + target_nb_refs = 0; + } in StrMap.add tname target prog_targets) prog.prog_verifs prog.prog_targets @@ -1905,47 +2300,44 @@ let eval_expr_verif (prog : program) (verif : verif) in let rec aux expr = match Pos.unmark expr with - | Mast.Literal (Mast.Float f) -> Some f - | Mast.Literal Mast.Undefined -> None - | Mast.Literal (Mast.Variable _) -> - Err.variable_forbidden_in_filter (Pos.get_position expr) - | Mast.Attribut (m_var, m_attr) -> + | Com.Literal (Com.Float f) -> Some f + | Literal Com.Undefined -> None + | Var _ -> Err.variable_forbidden_in_filter (Pos.get_position expr) + | Attribut (m_var, m_attr) -> let var = match Pos.unmark m_var with | Mast.Normal var -> var | _ -> assert false in - let attrs = (StrMap.find var prog.prog_vars).global_attrs in + let attrs = Com.Var.attrs (StrMap.find var prog.prog_vars) in let m_val = StrMap.find (Pos.unmark m_attr) attrs in Some (float (Pos.unmark m_val)) - | Mast.Size m_var -> ( + | Size m_var -> ( let var = match Pos.unmark m_var with | Mast.Normal var -> var | _ -> assert false in - match (StrMap.find var prog.prog_vars).global_table with + match Com.Var.is_table (StrMap.find var prog.prog_vars) with | Some sz -> Some (float sz) | None -> Some 1.0) - | Mast.NbCategory l -> - let cats = mast_to_catvars l prog.prog_var_cats in + | NbCategory cs -> + let cats = mast_to_catvars cs prog.prog_var_cats in let sum = - Mir.CatVarSet.fold - (fun cat sum -> - match Mir.CatVarMap.find_opt cat verif.verif_cat_var_stats with + Com.CatVar.Map.fold + (fun cat _ sum -> + match Com.CatVar.Map.find_opt cat verif.verif_cat_var_stats with | Some i -> sum + i | None -> sum) cats 0 in Some (float sum) - | Mast.Unop (op, e0) -> ( + | Unop (op, e0) -> ( match aux e0 with | None -> None | Some f -> ( - match op with - | Mast.Not -> Some (1.0 -. f) - | Mast.Minus -> Some ~-.f)) - | Mast.FunctionCall (func, Mast.ArgList args) -> ( + match op with Com.Not -> Some (1.0 -. f) | Com.Minus -> Some ~-.f)) + | FuncCall (func, args) -> ( let rl = List.map aux args in let unFunc f = match rl with @@ -1961,9 +2353,9 @@ let eval_expr_verif (prog : program) (verif : verif) | _ -> assert false in match Pos.unmark func with - | "numero_verif" -> Some (float (Pos.unmark verif.verif_id)) - | "numero_compl" -> assert false - | "somme" -> + | Com.VerifNumber -> Some (float (Pos.unmark verif.verif_id)) + | Com.ComplNumber -> assert false + | Com.SumFunc -> List.fold_left (fun res r -> match r with @@ -1971,69 +2363,69 @@ let eval_expr_verif (prog : program) (verif : verif) | Some f -> ( match res with None -> r | Some fr -> Some (f +. fr))) None rl - | "abs" -> unFunc abs_float - | "min" -> biFunc min - | "max" -> biFunc max - | "positif" -> unFunc (fun x -> if x > 0.0 then 1.0 else 0.0) - | "positif_ou_nul" -> unFunc (fun x -> if x >= 0.0 then 1.0 else 0.0) - | "null" -> unFunc (fun x -> if x = 0.0 then 1.0 else 0.0) - | "arr" -> unFunc my_arr - | "inf" -> unFunc my_floor - | "supzero" -> ( + | Com.AbsFunc -> unFunc abs_float + | Com.MinFunc -> biFunc min + | Com.MaxFunc -> biFunc max + | Com.GtzFunc -> unFunc (fun x -> if x > 0.0 then 1.0 else 0.0) + | Com.GtezFunc -> unFunc (fun x -> if x >= 0.0 then 1.0 else 0.0) + | Com.NullFunc -> unFunc (fun x -> if x = 0.0 then 1.0 else 0.0) + | Com.ArrFunc -> unFunc my_arr + | Com.InfFunc -> unFunc my_floor + | Com.Supzero -> ( match rl with | [ None ] -> None | [ Some f ] when f = 0.0 -> None | [ r ] -> r | _ -> assert false) - | _ -> assert false) - | Mast.FunctionCall (_func, Mast.LoopList _) -> assert false - | Mast.Comparison (op, e0, e1) -> ( + | Com.PresentFunc | Com.Multimax | Com.Func _ -> assert false) + | Comparison (op, e0, e1) -> ( match (aux e0, aux e1) with | None, _ | _, None -> None | Some f0, Some f1 -> ( + let open Com in match Pos.unmark op with - | Mast.Gt -> Some (if f0 > f1 then 1.0 else 0.0) - | Mast.Gte -> Some (if f0 >= f1 then 1.0 else 0.0) - | Mast.Lt -> Some (if f0 < f1 then 1.0 else 0.0) - | Mast.Lte -> Some (if f0 <= f1 then 1.0 else 0.0) - | Mast.Eq -> Some (if f0 = f1 then 1.0 else 0.0) - | Mast.Neq -> Some (if f0 <> f1 then 1.0 else 0.0))) - | Mast.Binop (op, e0, e1) -> ( + | Gt -> Some (if f0 > f1 then 1.0 else 0.0) + | Gte -> Some (if f0 >= f1 then 1.0 else 0.0) + | Lt -> Some (if f0 < f1 then 1.0 else 0.0) + | Lte -> Some (if f0 <= f1 then 1.0 else 0.0) + | Eq -> Some (if f0 = f1 then 1.0 else 0.0) + | Neq -> Some (if f0 <> f1 then 1.0 else 0.0))) + | Binop (op, e0, e1) -> ( let r0 = aux e0 in let r1 = aux e1 in match Pos.unmark op with - | Mast.And -> ( + | Com.And -> ( match r0 with | None -> None | Some f0 -> if f0 = 0.0 then r0 else r1) - | Mast.Or -> ( + | Com.Or -> ( match r0 with None -> r1 | Some f0 -> if f0 = 0.0 then r1 else r0) - | Mast.Add -> ( + | Com.Add -> ( match (r0, r1) with | None, None -> None | None, Some _ -> r1 | Some _, None -> r0 | Some f0, Some f1 -> Some (f0 +. f1)) - | Mast.Sub -> ( + | Com.Sub -> ( match (r0, r1) with | None, None -> None | None, Some _ -> r1 | Some _, None -> r0 | Some f0, Some f1 -> Some (f0 +. f1)) - | Mast.Mul -> ( + | Com.Mul -> ( match (r0, r1) with | None, _ | _, None -> None | Some f0, Some f1 -> Some (f0 *. f1)) - | Mast.Div -> ( + | Com.Div -> ( match (r0, r1) with | None, _ | _, None -> None | Some f0, Some f1 -> if f1 = 0.0 then r1 else Some (f0 /. f1))) - | Mast.Conditional (e0, e1, e2) -> ( + | Conditional (e0, e1, e2) -> ( let r0 = aux e0 in let r1 = aux e1 in let r2 = match e2 with Some e -> aux e | None -> None in match r0 with None -> None | Some f -> if f = 1.0 then r1 else r2) - | Mast.TestInSet (positive, e, values) -> ( + | TestInSet (positive, e, values) -> ( match aux e with | None -> None | Some v -> @@ -2041,22 +2433,22 @@ let eval_expr_verif (prog : program) (verif : verif) List.fold_left (fun res set_value -> match set_value with - | Mast.VarValue _ -> assert false - | Mast.FloatValue (f, _) -> res || f = v - | Mast.Interval ((bn, _), (en, _)) -> + | Com.VarValue _ -> assert false + | Com.FloatValue (f, _) -> res || f = v + | Com.Interval ((bn, _), (en, _)) -> res || (float bn <= v && v <= float en)) false values in Some (if res = positive then 1.0 else 0.0)) - | Mast.NbAnomalies | Mast.NbDiscordances | Mast.NbInformatives - | Mast.NbBloquantes | Mast.Index _ | Mast.Loop _ -> + | NbAnomalies | NbDiscordances | NbInformatives | NbBloquantes | Index _ + | FuncCallLoop _ | Loop _ -> assert false in aux expr -let vdom_rule_filter (prog : program) (vdom : Mir.verif_domain_data Mir.domain) +let vdom_rule_filter (prog : program) (vdom : Com.verif_domain_data Com.domain) (expr : Mast.expression Pos.marked) (verif : verif) : bool = - (match vdom.Mir.dom_used with + (match vdom.Com.dom_used with | Some (vdom_seq, seq_pos) -> if vdom_seq <= verif.verif_seq then Err.domain_already_used Verif seq_pos (Pos.get_position verif.verif_id) @@ -2067,8 +2459,8 @@ let vdom_rule_filter (prog : program) (vdom : Mir.verif_domain_data Mir.domain) let vdom_id = Pos.unmark vdom.dom_id in let verif_vdom_id = Pos.unmark verif.verif_domain.dom_id in filter_expr - && (Mast.DomainId.equal vdom_id verif_vdom_id - || Mast.DomainIdSet.mem verif_vdom_id vdom.Mir.dom_min) + && (Com.DomainId.equal vdom_id verif_vdom_id + || Com.DomainIdSet.mem verif_vdom_id vdom.Com.dom_min) module OrdVerif = struct type t = int * int * int @@ -2108,7 +2500,7 @@ let complete_verif_calls (prog : program) : program = let verif_set = IntMap.fold (fun _verif_id verif verif_set -> - let vdom = Mast.DomainIdMap.find vdom_id prog.prog_vdoms in + let vdom = Com.DomainIdMap.find vdom_id prog.prog_vdoms in if vdom_rule_filter prog vdom expr verif then OrdVerifSet.add (OrdVerif.make verif) verif_set else verif_set) @@ -2117,16 +2509,23 @@ let complete_verif_calls (prog : program) : program = match OrdVerifSetMap.find_opt verif_set verif_calls with | Some tn -> let target_prog = - [ (Mast.ComputeTarget (tn, Pos.no_pos), Pos.no_pos) ] + [ (Com.ComputeTarget ((tn, Pos.no_pos), []), Pos.no_pos) ] in let target = - { - target_name = (tname, Pos.no_pos); - target_file = None; - target_apps = StrMap.singleton prog.prog_app Pos.no_pos; - target_tmp_vars = StrMap.empty; - target_prog; - } + Mast. + { + target_name = (tname, Pos.no_pos); + target_file = None; + target_apps = + StrMap.one prog.prog_app (prog.prog_app, Pos.no_pos); + target_args = []; + target_result = None; + target_tmp_vars = StrMap.empty; + target_prog; + target_nb_tmps = 0; + target_sz_tmps = 0; + target_nb_refs = 0; + } in let prog_targets = StrMap.add tname target prog_targets in (prog_targets, verif_calls) @@ -2139,21 +2538,28 @@ let complete_verif_calls (prog : program) : program = let verif_tn = Format.sprintf "%s_verif_%d" prog.prog_prefix verif_id in - (Mast.ComputeTarget (verif_tn, Pos.no_pos), Pos.no_pos) + (Com.ComputeTarget ((verif_tn, Pos.no_pos), []), Pos.no_pos) :: target_prog) verif_set [] in List.rev instrs in - let target_prog = [ (Mast.VerifBlock instrs, Pos.no_pos) ] in + let target_prog = [ (Com.VerifBlock instrs, Pos.no_pos) ] in let target = - { - target_name = (tname, Pos.no_pos); - target_file = None; - target_apps = StrMap.singleton prog.prog_app Pos.no_pos; - target_tmp_vars = StrMap.empty; - target_prog; - } + Mast. + { + target_name = (tname, Pos.no_pos); + target_file = None; + target_apps = + StrMap.one prog.prog_app (prog.prog_app, Pos.no_pos); + target_args = []; + target_result = None; + target_tmp_vars = StrMap.empty; + target_prog; + target_nb_tmps = 0; + target_sz_tmps = 0; + target_nb_refs = 0; + } in let prog_targets = StrMap.add tname target prog_targets in let verif_calls = OrdVerifSetMap.add verif_set tname verif_calls in @@ -2163,7 +2569,7 @@ let complete_verif_calls (prog : program) : program = in { prog with prog_targets } -let proceed (p : Mast.program) : program = +let proceed (p : Mast.program) (main_target : string) : program = let app = "iliad" in (* à paramétrer *) let prog = @@ -2178,16 +2584,18 @@ let proceed (p : Mast.program) : program = | Mast.VarCatDecl (decl, pos) -> check_var_category decl pos prog | Mast.VariableDecl var_decl -> check_var_decl var_decl prog | Mast.Error error -> check_error error prog - | Mast.Function -> prog (* unused *) + | Mast.Func -> prog (* unused *) | Mast.Output _ -> prog (* unused *) | Mast.RuleDomDecl decl -> check_rule_dom_decl decl prog | Mast.VerifDomDecl decl -> check_verif_dom_decl decl prog - | Mast.Target t -> check_target t prog + | Mast.Function f -> check_target true f prog + | Mast.Target t -> check_target false t prog | Mast.Rule r -> check_rule r prog | Mast.Verification v -> check_verif v prog) prog source_file) - (empty_program p app) p + (empty_program p app main_target) + p in prog |> complete_rdom_decls |> complete_vdom_decls |> convert_rules |> complete_rule_domains |> complete_chainings |> convert_verifs - |> complete_verif_calls + |> complete_verif_calls |> complete_vars diff --git a/src/mlang/m_frontend/check_validity.mli b/src/mlang/m_frontend/check_validity.mli index 1528aec8e..78f2e20c0 100644 --- a/src/mlang/m_frontend/check_validity.mli +++ b/src/mlang/m_frontend/check_validity.mli @@ -12,49 +12,23 @@ type rule_or_verif = Rule | Verif -type global_variable = { - global_name : string Pos.marked; - global_category : Mir.cat_variable; - global_attrs : int Pos.marked StrMap.t; - global_alias : string Pos.marked option; - global_table : int option; - global_description : string Pos.marked; - global_typ : Mast.value_typ option; -} - -type error = { - name : string Pos.marked; - typ : Mast.error_typ; - kind : string Pos.marked; - major_code : string Pos.marked; - minor_code : string Pos.marked; - isisf : string Pos.marked; - description : string; -} +type syms = Com.DomainId.t Pos.marked Com.DomainIdMap.t -type syms = Mast.DomainId.t Pos.marked Mast.DomainIdMap.t - -type 'a doms = 'a Mir.domain Mast.DomainIdMap.t +type 'a doms = 'a Com.domain Com.DomainIdMap.t type chaining = { chain_name : string Pos.marked; chain_apps : Pos.t StrMap.t; - chain_rules : Mir.rule_domain Pos.marked IntMap.t; -} - -type target = { - target_name : string Pos.marked; - target_file : string option; - target_apps : Pos.t StrMap.t; - target_tmp_vars : int option Pos.marked StrMap.t; - target_prog : Mast.instruction Pos.marked list; + chain_rules : Com.rule_domain Pos.marked IntMap.t; } type rule = { rule_id : int Pos.marked; rule_apps : Pos.t StrMap.t; - rule_domain : Mir.rule_domain; + rule_domain : Com.rule_domain; rule_chain : string option; + rule_tmp_vars : + (string Pos.marked * Mast.table_size Pos.marked option) StrMap.t; rule_instrs : Mast.instruction Pos.marked list; rule_in_vars : StrSet.t; rule_out_vars : StrSet.t; @@ -64,12 +38,12 @@ type rule = { type verif = { verif_id : int Pos.marked; verif_apps : Pos.t StrMap.t; - verif_domain : Mir.verif_domain; + verif_domain : Com.verif_domain; verif_expr : Mast.expression Pos.marked; verif_error : Mast.error_name Pos.marked; verif_var : Mast.variable_name Pos.marked option; verif_is_blocking : bool; - verif_cat_var_stats : int Mir.CatVarMap.t; + verif_cat_var_stats : int Com.CatVar.Map.t; verif_var_stats : int StrMap.t; verif_seq : int; } @@ -80,29 +54,36 @@ type program = { prog_app : string; prog_apps : Pos.t StrMap.t; prog_chainings : chaining StrMap.t; - prog_var_cats : Mir.cat_variable_data Mir.CatVarMap.t; - prog_vars : global_variable StrMap.t; - prog_alias : global_variable StrMap.t; - prog_errors : error StrMap.t; - prog_rdoms : Mir.rule_domain_data doms; + prog_var_cats : Com.CatVar.data Com.CatVar.Map.t; + prog_vars : Com.Var.t StrMap.t; + prog_alias : Com.Var.t StrMap.t; + prog_errors : Com.Error.t StrMap.t; + prog_rdoms : Com.rule_domain_data doms; prog_rdom_syms : syms; - prog_vdoms : Mir.verif_domain_data doms; + prog_vdoms : Com.verif_domain_data doms; prog_vdom_syms : syms; + prog_functions : Mast.target StrMap.t; prog_rules : rule IntMap.t; - prog_rdom_calls : (int Pos.marked * Mast.DomainId.t) StrMap.t; + prog_rdom_calls : (int Pos.marked * Com.DomainId.t) StrMap.t; prog_verifs : verif IntMap.t; prog_vdom_calls : - (int Pos.marked * Mast.DomainId.t * Mast.expression Pos.marked) StrMap.t; - prog_targets : target StrMap.t; + (int Pos.marked * Com.DomainId.t * Mast.expression Pos.marked) StrMap.t; + prog_targets : Mast.target StrMap.t; + prog_main_target : string; + prog_stats : Mir.stats; } val mast_to_catvars : - Mast.var_category_id -> 'a Mir.CatVarMap.t -> Mir.CatVarSet.t + Pos.t Com.CatVar.Map.t -> + Com.CatVar.data Com.CatVar.Map.t -> + Pos.t Com.CatVar.Map.t val cats_variable_from_decl_list : - Mast.var_category_id list -> 'a Mir.CatVarMap.t -> Mir.CatVarSet.t + Mast.var_category_id list -> + Com.CatVar.data Com.CatVar.Map.t -> + Pos.t Com.CatVar.Map.t val check_domain : rule_or_verif -> 'a Mast.domain_decl -> 'b -> 'b doms * syms -> 'b doms * syms -val proceed : Mast.program -> program +val proceed : Mast.program -> string -> program diff --git a/src/mlang/m_frontend/expand_macros.ml b/src/mlang/m_frontend/expand_macros.ml index 2a002937d..35a328359 100644 --- a/src/mlang/m_frontend/expand_macros.ml +++ b/src/mlang/m_frontend/expand_macros.ml @@ -71,6 +71,9 @@ module Err = struct let constant_forbidden_as_lvalue pos = Errors.raise_spanned_error "constant forbidden as lvalue" pos + + let constant_forbidden_as_arg pos = + Errors.raise_spanned_error "constant forbidden as argument" pos end module ConstMap = StrMap @@ -101,15 +104,16 @@ let format_loop_context fmt (ld : loop_context) = ParamsMap.pp format_loop_param_value fmt ld let format_loop_domain fmt (ld : loop_domain) = - ParamsMap.pp (Format_mast.pp_print_list_comma format_loop_param_value) fmt ld + ParamsMap.pp (Pp.list_comma format_loop_param_value) fmt ld let add_const (name, name_pos) (cval, cval_pos) const_map = match ConstMap.find_opt name const_map with | Some (_, old_pos) -> Err.constant_already_defined old_pos name_pos | None -> ( match cval with - | Mast.Float f -> ConstMap.add name (f, name_pos) const_map - | Mast.Variable (Mast.Normal const) -> ( + | Com.AtomLiteral (Com.Float f) -> + ConstMap.add name (f, name_pos) const_map + | Com.AtomVar (Mast.Normal const) -> ( match ConstMap.find_opt const const_map with | Some (value, _) -> ConstMap.add name (value, name_pos) const_map | None -> Err.unknown_constant cval_pos) @@ -132,8 +136,8 @@ let rec expand_variable (const_map : const_context) (loop_map : loop_context) match var with | Mast.Normal name -> ( match ConstMap.find_opt name const_map with - | Some (f, _) -> (Mast.Literal (Float f), var_pos) - | None -> (Mast.Literal (Variable var), var_pos)) + | Some (f, _) -> (Com.Literal (Float f), var_pos) + | None -> (Com.Var var, var_pos)) | Mast.Generic gen_name -> if List.length gen_name.Mast.parameters == 0 then expand_variable const_map loop_map @@ -211,24 +215,24 @@ type var_or_int_index = VarIndex of Mast.variable | IntIndex of int const value in the context if needed. Otherwise, it might be a dynamic index. *) let var_or_int_value (const_map : const_context) - (m_litt : Mast.literal Pos.marked) : var_or_int_index = - match Pos.unmark m_litt with - | Mast.Variable v -> ( + (m_atom : Mast.variable Com.atom Pos.marked) : var_or_int_index = + match Pos.unmark m_atom with + | Com.AtomVar v -> ( let name = Mast.get_variable_name v in match ConstMap.find_opt name const_map with | Some (fvalue, _) -> IntIndex (int_of_float fvalue) | None -> VarIndex v) - | Mast.Float f -> IntIndex (int_of_float f) - | Mast.Undefined -> assert false - -let var_or_int (m_lit : Mast.literal Pos.marked) = - let lit, lit_pos = m_lit in - match lit with - | Mast.Float f -> RangeInt (int_of_float f) - | Mast.Variable (Normal v) -> VarName v - | Mast.Variable (Generic _) -> - Err.generic_variable_not_allowed_in_left_part_of_loop lit_pos - | Mast.Undefined -> assert false + | Com.AtomLiteral (Com.Float f) -> IntIndex (int_of_float f) + | Com.AtomLiteral Com.Undefined -> assert false + +let var_or_int (m_atom : Mast.variable Com.atom Pos.marked) = + let atom, atom_pos = m_atom in + match atom with + | Com.AtomVar (Normal v) -> VarName v + | Com.AtomVar (Generic _) -> + Err.generic_variable_not_allowed_in_left_part_of_loop atom_pos + | Com.AtomLiteral (Com.Float f) -> RangeInt (int_of_float f) + | Com.AtomLiteral Com.Undefined -> assert false let loop_variables_size (lpvl : loop_param_value list) (pos : Pos.t) = let size_err p = Err.loop_variables_have_different_sizes p in @@ -265,8 +269,8 @@ let make_var_range_list (v1 : string) (v2 : string) : loop_param_value list = in aux (Char.code v1.[0]) (Char.code v2.[0]) -let make_range_list (l1 : Mast.literal Pos.marked) - (l2 : Mast.literal Pos.marked) : loop_param_value list = +let make_range_list (l1 : Mast.variable Com.atom Pos.marked) + (l2 : Mast.variable Com.atom Pos.marked) : loop_param_value list = let length_err p = Err.non_numeric_range_bounds_must_be_a_single_character p in @@ -289,7 +293,7 @@ let rec iterate_all_combinations (ld : loop_domain) : loop_context list = | [ hd ] -> let new_ld = ParamsMap.remove param ld in let all_contexts = iterate_all_combinations new_ld in - if List.length all_contexts = 0 then [ ParamsMap.singleton param hd ] + if List.length all_contexts = 0 then [ ParamsMap.one param hd ] else List.map (fun c -> ParamsMap.add param hd c) all_contexts | hd :: tl -> let new_ld = ParamsMap.add param tl ld in @@ -315,11 +319,11 @@ let rec iterate_all_combinations (ld : loop_domain) : loop_context list = merge_loop_ctx} inside [...] before translating the loop body. [lc] is the loop context, [i] the loop sequence index and [ctx] the translation context. *) -let expand_loop_variables (lvs : Mast.loop_variables Pos.marked) +let expand_loop_variables (lvs : Mast.variable Com.loop_variables Pos.marked) (const_map : const_context) : (loop_context -> 'a) -> 'a list = let pos = Pos.get_position lvs in match Pos.unmark lvs with - | Mast.ValueSets lvs | Mast.Ranges lvs -> + | Com.ValueSets lvs | Com.Ranges lvs -> let varying_domain = List.fold_left (fun domain (param, values) -> @@ -328,9 +332,9 @@ let expand_loop_variables (lvs : Mast.loop_variables Pos.marked) (List.map (fun value -> match value with - | Mast.Single l -> [ var_or_int l ] - | Mast.Range (l1, l2) -> make_range_list l1 l2 - | Mast.Interval (l1, l2) -> ( + | Com.Single l -> [ var_or_int l ] + | Com.Range (l1, l2) -> make_range_list l1 l2 + | Com.Interval (l1, l2) -> ( let lb = var_or_int_value const_map l1 in let ub = var_or_int_value const_map l2 in match (lb, ub) with @@ -349,58 +353,47 @@ let expand_loop_variables (lvs : Mast.loop_variables Pos.marked) let loop_map_list = iterate_all_combinations varying_domain in fun translator -> List.map translator loop_map_list -let expand_table_index (const_map : const_context) (loop_map : loop_context) - (m_i : Mast.table_index Pos.marked) : Mast.table_index Pos.marked = - let i, i_pos = m_i in - match i with - | Mast.LiteralIndex _ -> m_i - | Mast.SymbolIndex v -> ( - match expand_variable const_map loop_map (v, i_pos) with - | Mast.Literal (Float f), _ -> (Mast.LiteralIndex (int_of_float f), i_pos) - | Mast.Literal (Variable v'), _ -> (Mast.SymbolIndex v', i_pos) - | _ -> assert false) - let rec expand_expression (const_map : const_context) (loop_map : loop_context) (m_expr : Mast.expression Pos.marked) : Mast.expression Pos.marked = + let open Com in let expr, expr_pos = m_expr in match expr with - | Mast.TestInSet (positive, e, values) -> + | TestInSet (positive, e, values) -> let e' = expand_expression const_map loop_map e in let values' = List.map (fun set_value -> match set_value with - | Mast.VarValue set_var -> ( + | VarValue set_var -> ( match expand_variable const_map loop_map set_var with - | Mast.Literal (Float f), var_pos -> Mast.FloatValue (f, var_pos) - | Mast.Literal (Variable var), var_pos -> - Mast.VarValue (var, var_pos) + | Literal (Float f), var_pos -> FloatValue (f, var_pos) + | Var var, var_pos -> VarValue (var, var_pos) | _ -> assert false) - | Mast.FloatValue _ | Mast.Interval _ -> set_value) + | FloatValue _ | Interval _ -> set_value) values in - (Mast.TestInSet (positive, e', values'), expr_pos) - | Mast.Comparison (op, e1, e2) -> + (TestInSet (positive, e', values'), expr_pos) + | Comparison (op, e1, e2) -> let e1' = expand_expression const_map loop_map e1 in let e2' = expand_expression const_map loop_map e2 in - (Mast.Comparison (op, e1', e2'), expr_pos) - | Mast.Binop (op, e1, e2) -> + (Comparison (op, e1', e2'), expr_pos) + | Binop (op, e1, e2) -> let e1' = expand_expression const_map loop_map e1 in let e2' = expand_expression const_map loop_map e2 in - (Mast.Binop (op, e1', e2'), expr_pos) - | Mast.Unop (op, e) -> + (Binop (op, e1', e2'), expr_pos) + | Unop (op, e) -> let e' = expand_expression const_map loop_map e in - (Mast.Unop (op, e'), expr_pos) - | Mast.Index (t, i) -> + (Unop (op, e'), expr_pos) + | Index (t, i) -> let t' = match expand_variable const_map loop_map t with - | Mast.Literal (Variable v), v_pos -> (v, v_pos) - | Mast.Literal (Float _), v_pos -> Err.constant_forbidden_as_table v_pos + | Var v, v_pos -> (v, v_pos) + | Literal (Float _), v_pos -> Err.constant_forbidden_as_table v_pos | _ -> assert false in - let i' = expand_table_index const_map loop_map i in - (Mast.Index (t', i'), expr_pos) - | Mast.Conditional (e1, e2, e3_opt) -> + let i' = expand_expression const_map loop_map i in + (Index (t', i'), expr_pos) + | Conditional (e1, e2, e3_opt) -> let e1' = expand_expression const_map loop_map e1 in let e2' = expand_expression const_map loop_map e2 in let e3_opt' = @@ -408,15 +401,25 @@ let rec expand_expression (const_map : const_context) (loop_map : loop_context) | Some e3 -> Some (expand_expression const_map loop_map e3) | None -> None in - (Mast.Conditional (e1', e2', e3_opt'), expr_pos) - | Mast.FunctionCall (f_name, args) -> - let args' = expand_func_args const_map loop_map args in - (Mast.FunctionCall (f_name, args'), expr_pos) - | Mast.Literal l -> ( - match l with - | Mast.Variable var -> expand_variable const_map loop_map (var, expr_pos) - | _ -> m_expr) - | Mast.Loop (lvs, e) -> + (Conditional (e1', e2', e3_opt'), expr_pos) + | FuncCall (f_name, args) -> + let args' = + List.map (fun arg -> expand_expression const_map loop_map arg) args + in + (FuncCall (f_name, args'), expr_pos) + | FuncCallLoop (f_name, lvs, e) -> + let loop_context_provider = expand_loop_variables lvs const_map in + let translator lmap = + let loop_map = + merge_loop_context loop_map lmap (Pos.get_position lvs) + in + expand_expression const_map loop_map e + in + let args' = loop_context_provider translator in + (FuncCall (f_name, args'), expr_pos) + | Literal _ -> m_expr + | Var v -> expand_variable const_map loop_map (v, expr_pos) + | Loop (lvs, e) -> let loop_context_provider = expand_loop_variables lvs const_map in let translator lmap = let loop_map = @@ -427,140 +430,125 @@ let rec expand_expression (const_map : const_context) (loop_map : loop_context) let loop_exprs = loop_context_provider translator in List.fold_left (fun res loop_expr -> - (Mast.Binop ((Mast.Or, expr_pos), res, loop_expr), expr_pos)) - (Mast.Literal (Float 0.0), expr_pos) + (Binop ((Or, expr_pos), res, loop_expr), expr_pos)) + (Literal (Float 0.0), expr_pos) loop_exprs - | Mast.Attribut (var, a) -> ( + | Attribut (var, a) -> ( match expand_variable const_map loop_map var with - | Mast.Literal (Variable v), v_pos -> - (Mast.Attribut ((v, v_pos), a), expr_pos) - | Mast.Literal (Float _), v_pos -> - Err.constant_cannot_have_an_attribut v_pos + | Var v, v_pos -> (Attribut ((v, v_pos), a), expr_pos) + | Literal (Float _), v_pos -> Err.constant_cannot_have_an_attribut v_pos | _ -> assert false) - | Mast.Size var -> ( + | Size var -> ( match expand_variable const_map loop_map var with - | Mast.Literal (Variable v), v_pos -> (Mast.Size (v, v_pos), expr_pos) - | Mast.Literal (Float _), v_pos -> Err.constant_cannot_have_a_size v_pos + | Var v, v_pos -> (Size (v, v_pos), expr_pos) + | Literal (Float _), v_pos -> Err.constant_cannot_have_a_size v_pos | _ -> assert false) - | Mast.NbCategory _ | Mast.NbAnomalies | Mast.NbDiscordances - | Mast.NbInformatives | Mast.NbBloquantes -> + | NbCategory _ | NbAnomalies | NbDiscordances | NbInformatives | NbBloquantes + -> m_expr -and expand_func_args (const_map : const_context) (loop_map : loop_context) - (args : Mast.func_args) : Mast.func_args = - match args with - | Mast.ArgList args -> - let args' = - List.map (fun arg -> expand_expression const_map loop_map arg) args - in - Mast.ArgList args' - | Mast.LoopList (lvs, e) -> - let loop_context_provider = expand_loop_variables lvs const_map in - let translator lmap = - let loop_map = - merge_loop_context loop_map lmap (Pos.get_position lvs) - in - expand_expression const_map loop_map e - in - Mast.ArgList (loop_context_provider translator) - -(** Translates lvalues into the assigning variable as well as the type of - assignment *) -let expand_lvalue (const_map : const_context) (loop_map : loop_context) - (m_lval : Mast.lvalue Pos.marked) : Mast.lvalue Pos.marked = - let lval, lval_pos = m_lval in - let var = - match expand_variable const_map loop_map lval.Mast.var with - | Mast.Literal (Variable v), v_pos -> (v, v_pos) - | Mast.Literal (Float _), v_pos -> Err.constant_forbidden_as_lvalue v_pos - | _ -> assert false - in - let index = - match lval.Mast.index with - | Some (ti, ti_pos) -> ( - match ti with - | Mast.LiteralIndex _ -> lval.Mast.index - | Mast.SymbolIndex ivar -> ( - match expand_variable const_map loop_map (ivar, ti_pos) with - | Mast.Literal (Variable v), _ -> Some (Mast.SymbolIndex v, ti_pos) - | Mast.Literal (Float f), _ -> - Some (Mast.LiteralIndex (int_of_float f), ti_pos) - | _ -> assert false)) - | None -> None - in - (Mast.{ var; index }, lval_pos) - let expand_formula (const_map : const_context) - (prev : Mast.formula Pos.marked list) (m_form : Mast.formula Pos.marked) : - Mast.formula Pos.marked list = + (prev : Mast.variable Com.formula Pos.marked list) + (m_form : Mast.variable Com.formula Pos.marked) : + Mast.variable Com.formula Pos.marked list = let form, form_pos = m_form in match form with - | Mast.SingleFormula f -> - let lvalue = expand_lvalue const_map ParamsMap.empty f.Mast.lvalue in - let formula = - expand_expression const_map ParamsMap.empty f.Mast.formula + | Com.SingleFormula (v, idx, e) -> + let v' = + match expand_variable const_map ParamsMap.empty v with + | Com.Var v, v_pos -> (v, v_pos) + | Com.Literal (Com.Float _), v_pos -> + Err.constant_forbidden_as_lvalue v_pos + | _ -> assert false in - (Mast.SingleFormula { lvalue; formula }, form_pos) :: prev - | Mast.MultipleFormulaes (lvs, f) -> - (* Format.eprintf "%a\n\n" Format_mast.format_formula form;*) + let idx' = Option.map (expand_expression const_map ParamsMap.empty) idx in + let e' = expand_expression const_map ParamsMap.empty e in + (Com.SingleFormula (v', idx', e'), form_pos) :: prev + | Com.MultipleFormulaes (lvs, (v, idx, e)) -> let loop_context_provider = expand_loop_variables lvs const_map in let translator loop_map = - let lvalue = expand_lvalue const_map loop_map f.Mast.lvalue in - let formula = expand_expression const_map loop_map f.Mast.formula in - (Mast.SingleFormula { lvalue; formula }, form_pos) + let v' = + match expand_variable const_map loop_map v with + | Com.Var v, v_pos -> (v, v_pos) + | Com.Literal (Com.Float _), v_pos -> + Err.constant_forbidden_as_lvalue v_pos + | _ -> assert false + in + let idx' = Option.map (expand_expression const_map loop_map) idx in + let e' = expand_expression const_map loop_map e in + (Com.SingleFormula (v', idx', e'), form_pos) in let res = loop_context_provider translator in - (* List.iter (fun (f, _) -> Format.eprintf "res %a\n" - Format_mast.format_formula f) res; Format.eprintf "\n";*) List.rev res @ prev -let expand_formulaes (const_map : const_context) - (forms : Mast.formula Pos.marked list) : Mast.formula Pos.marked list = - List.fold_left (expand_formula const_map) [] (List.rev forms) - let rec expand_instruction (const_map : const_context) (prev : Mast.instruction Pos.marked list) (m_instr : Mast.instruction Pos.marked) : Mast.instruction Pos.marked list = let instr, instr_pos = m_instr in match instr with - | Mast.Formula m_form -> + | Com.Affectation m_form -> let m_forms = expand_formula const_map [] m_form in List.fold_left - (fun res f -> (Mast.Formula f, instr_pos) :: res) + (fun res f -> (Com.Affectation f, instr_pos) :: res) prev m_forms - | Mast.IfThenElse (expr, ithen, ielse) -> + | Com.IfThenElse (expr, ithen, ielse) -> let expr' = expand_expression const_map ParamsMap.empty expr in let ithen' = expand_instructions const_map ithen in let ielse' = expand_instructions const_map ielse in - (Mast.IfThenElse (expr', ithen', ielse'), instr_pos) :: prev - | Mast.Print (std, pr_args) -> + (Com.IfThenElse (expr', ithen', ielse'), instr_pos) :: prev + | Com.WhenDoElse (wdl, ed) -> + let map (expr, dl, pos) = + let expr' = expand_expression const_map ParamsMap.empty expr in + let dl' = expand_instructions const_map dl in + (expr', dl', pos) + in + let wdl' = List.map map wdl in + let ed' = Pos.map_under_mark (expand_instructions const_map) ed in + (Com.WhenDoElse (wdl', ed'), instr_pos) :: prev + | Com.Print (std, pr_args) -> let pr_args' = List.map (fun arg -> match Pos.unmark arg with - | Mast.PrintIndent expr -> + | Com.PrintIndent expr -> let expr' = expand_expression const_map ParamsMap.empty expr in - (Mast.PrintIndent expr', Pos.get_position arg) - | Mast.PrintExpr (expr, mi, ma) -> + (Com.PrintIndent expr', Pos.get_position arg) + | Com.PrintExpr (expr, mi, ma) -> let expr' = expand_expression const_map ParamsMap.empty expr in - (Mast.PrintExpr (expr', mi, ma), Pos.get_position arg) - | Mast.PrintString _ | Mast.PrintName _ | Mast.PrintAlias _ -> arg) + (Com.PrintExpr (expr', mi, ma), Pos.get_position arg) + | Com.PrintString _ | Com.PrintName _ | Com.PrintAlias _ -> arg) pr_args in - (Mast.Print (std, pr_args'), instr_pos) :: prev - | Mast.Iterate (name, cats, expr, instrs) -> - let expr' = expand_expression const_map ParamsMap.empty expr in + (Com.Print (std, pr_args'), instr_pos) :: prev + | Com.Iterate (name, vars, var_params, instrs) -> + let var_params' = + List.map + (fun (cats, expr) -> + let expr' = expand_expression const_map ParamsMap.empty expr in + (cats, expr')) + var_params + in let instrs' = expand_instructions const_map instrs in - (Mast.Iterate (name, cats, expr', instrs'), instr_pos) :: prev - | Mast.Restore (vars, instrs) -> + (Com.Iterate (name, vars, var_params', instrs'), instr_pos) :: prev + | Com.Restore (vars, var_params, instrs) -> let instrs' = expand_instructions const_map instrs in - (Mast.Restore (vars, instrs'), instr_pos) :: prev - | Mast.VerifBlock instrs -> + (Com.Restore (vars, var_params, instrs'), instr_pos) :: prev + | Com.VerifBlock instrs -> let instrs' = expand_instructions const_map instrs in - (Mast.VerifBlock instrs', instr_pos) :: prev - | Mast.ComputeVerifs _ | Mast.ComputeDomain _ | Mast.ComputeChaining _ - | Mast.ComputeTarget _ | Mast.RaiseError _ | Mast.CleanErrors - | Mast.ExportErrors | Mast.FinalizeErrors -> + (Com.VerifBlock instrs', instr_pos) :: prev + | Com.ComputeTarget (tn, targs) -> + let map var = + match expand_variable const_map ParamsMap.empty var with + | Com.Var v, v_pos -> (v, v_pos) + | Com.Literal (Com.Float _), v_pos -> + Err.constant_forbidden_as_arg v_pos + | _ -> assert false + in + let targs' = List.map map targs in + (Com.ComputeTarget (tn, targs'), instr_pos) :: prev + | Com.ComputeVerifs _ | Com.ComputeDomain _ | Com.ComputeChaining _ + | Com.RaiseError _ | Com.CleanErrors | Com.ExportErrors | Com.FinalizeErrors + -> (instr, instr_pos) :: prev and expand_instructions (const_map : const_context) @@ -597,10 +585,18 @@ let proceed (p : Mast.program) : Mast.program = (const_map, prog_file) | _ -> (const_map, source_item :: prog_file)) | Mast.Rule rule -> + let rule_tmp_vars = + StrMap.map + (fun (name, tsz) -> + (name, expand_table_size const_map tsz)) + rule.Mast.rule_tmp_vars + in let rule_formulaes = - expand_formulaes const_map rule.Mast.rule_formulaes + expand_instructions const_map rule.Mast.rule_formulaes + in + let rule' = + { rule with Mast.rule_tmp_vars; Mast.rule_formulaes } in - let rule' = { rule with Mast.rule_formulaes } in let prog_file = (Mast.Rule rule', pos_item) :: prog_file in (const_map, prog_file) | Mast.Verification verif -> @@ -621,7 +617,7 @@ let proceed (p : Mast.program) : Mast.program = (const_map, prog_file) | Mast.Target target -> let target_tmp_vars = - List.map + StrMap.map (fun (name, tsz) -> (name, expand_table_size const_map tsz)) target.Mast.target_tmp_vars diff --git a/src/mlang/m_frontend/format_mast.ml b/src/mlang/m_frontend/format_mast.ml index 7d854351e..bac84679b 100644 --- a/src/mlang/m_frontend/format_mast.ml +++ b/src/mlang/m_frontend/format_mast.ml @@ -18,31 +18,12 @@ open Mast -let pp_print_list_comma eldisplay fmt l = - Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.pp_print_string fmt ", ") - eldisplay fmt l - -let pp_unmark f fmt e = f fmt (Pos.unmark e) - -let pp_print_list_space eldisplay fmt l = - Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.pp_print_string fmt " ") - eldisplay fmt l - -let pp_print_list_endline eldisplay fmt l = - Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") - eldisplay fmt l - let format_application fmt (app : application) = Format.fprintf fmt "%s" app let format_chaining fmt (c : chaining) = Format.fprintf fmt "%s" c let format_variable_name fmt (v : variable_name) = Format.fprintf fmt "%s" v -let format_func_name fmt (f : func_name) = Format.fprintf fmt "%s" f - let format_variable_generic_name fmt (v : variable_generic_name) = Format.fprintf fmt "%s" v.base @@ -53,258 +34,28 @@ let format_variable fmt (v : variable) = let format_error_name fmt (e : error_name) = Format.fprintf fmt "%s" e -let format_literal fmt (l : literal) = - match l with - | Variable v -> format_variable fmt v - | Float f -> Format.fprintf fmt "%f" f - | Undefined -> Format.fprintf fmt "indefini" - -let format_table_index fmt (i : table_index) = - match i with - | LiteralIndex i -> Format.fprintf fmt "%d" i - | SymbolIndex v -> format_variable fmt v - -let format_lvalue fmt (lv : lvalue) = - match lv.index with - | Some vi -> - Format.fprintf fmt "%a[%a]" format_variable (Pos.unmark lv.var) - format_table_index (Pos.unmark vi) - | None -> Format.fprintf fmt "%a" format_variable (Pos.unmark lv.var) - -let format_set_value fmt (sv : set_value) = - match sv with - | VarValue v -> format_variable fmt (Pos.unmark v) - | Interval (i1, i2) -> - Format.fprintf fmt "%d..%d" (Pos.unmark i1) (Pos.unmark i2) - | FloatValue i -> Format.fprintf fmt "%f" (Pos.unmark i) - -let format_set_value_loop fmt (sv : set_value_loop) = - match sv with - | Single l -> Format.fprintf fmt "%a" format_literal (Pos.unmark l) - | Range (i1, i2) -> - Format.fprintf fmt "%a..%a" format_literal (Pos.unmark i1) format_literal - (Pos.unmark i2) - | Interval (i1, i2) -> - Format.fprintf fmt "%a-%a" format_literal (Pos.unmark i1) format_literal - (Pos.unmark i2) - -let format_comp_op fmt (op : comp_op) = - Format.pp_print_string fmt - (match op with - | Gt -> ">" - | Gte -> ">=" - | Lt -> "<" - | Lte -> "<=" - | Eq -> "=" - | Neq -> "!=") - -let format_binop fmt (op : binop) = - Format.pp_print_string fmt - (match op with - | And -> "et" - | Or -> "ou" - | Add -> "+" - | Sub -> "-" - | Mul -> "*" - | Div -> "/") - -let format_unop fmt (op : unop) = - Format.pp_print_string fmt (match op with Not -> "non" | Minus -> "-") - -let format_loop_variable_ranges fmt ((v, vs) : loop_variable) = - Format.fprintf fmt "un %c dans %a" (Pos.unmark v) - (pp_print_list_comma format_set_value_loop) - vs - -let format_loop_variable_value_set fmt ((v, vs) : loop_variable) = - Format.fprintf fmt "%c=%a" (Pos.unmark v) - (pp_print_list_comma format_set_value_loop) - vs - -let format_loop_variables fmt (lvs : loop_variables) = - match lvs with - | Ranges vvs -> - Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt " et ") - format_loop_variable_ranges fmt vvs - | ValueSets vvs -> - Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt ";") - format_loop_variable_value_set fmt vvs - -let option_print pp fmt o = match o with None -> () | Some e -> pp fmt e - -let option_bind f o = match o with None -> None | Some e -> Some (f e) - -let rec format_expression fmt (e : expression) = - match e with - | TestInSet (belong, e, values) -> - Format.fprintf fmt "(%a %sdans %a)" format_expression (Pos.unmark e) - (if belong then "" else "non ") - (pp_print_list_comma format_set_value) - values - | Comparison (op, e1, e2) -> - Format.fprintf fmt "(%a %a %a)" format_expression (Pos.unmark e1) - format_comp_op (Pos.unmark op) format_expression (Pos.unmark e2) - | Binop (op, e1, e2) -> - Format.fprintf fmt "(%a %a %a)" format_expression (Pos.unmark e1) - format_binop (Pos.unmark op) format_expression (Pos.unmark e2) - | Unop (op, e) -> - Format.fprintf fmt "%a %a" format_unop op format_expression (Pos.unmark e) - | Index (v, i) -> - Format.fprintf fmt "%a[%a]" format_variable (Pos.unmark v) - format_table_index (Pos.unmark i) - | Conditional (e1, e2, e3) -> - Format.fprintf fmt "(si %a alors %a %afinsi)" format_expression - (Pos.unmark e1) format_expression (Pos.unmark e2) - (option_print format_expression) - (option_bind Pos.unmark e3) - | FunctionCall (f, args) -> - Format.fprintf fmt "%a(%a)" format_func_name (Pos.unmark f) - format_func_args args - | Literal l -> format_literal fmt l - | Loop (lvs, e) -> - Format.fprintf fmt "pour %a%a" format_loop_variables (Pos.unmark lvs) - format_expression (Pos.unmark e) - | NbCategory l -> - Format.fprintf fmt "nb_categorie(%a)" - (pp_print_list_space (pp_unmark Format.pp_print_string)) - (Pos.unmark l) - | Attribut (v, a) -> - Format.fprintf fmt "attribut(%a, %s)" format_variable (Pos.unmark v) - (Pos.unmark a) - | Size v -> Format.fprintf fmt "taille(%a)" format_variable (Pos.unmark v) - | NbAnomalies -> Format.fprintf fmt "nb_anomalies()" - | NbDiscordances -> Format.fprintf fmt "nb_discordances()" - | NbInformatives -> Format.fprintf fmt "nb_informatives()" - | NbBloquantes -> Format.fprintf fmt "nb_bloquantes()" - -and format_func_args fmt (args : func_args) = - match args with - | ArgList args -> pp_print_list_space (pp_unmark format_expression) fmt args - | LoopList (lvs, e) -> - Format.fprintf fmt "%a%a" format_loop_variables (Pos.unmark lvs) - format_expression (Pos.unmark e) - -let format_formula_decl fmt (f : formula_decl) = - Format.fprintf fmt "%a = %a" format_lvalue (Pos.unmark f.lvalue) - format_expression (Pos.unmark f.formula) - -let format_formula fmt (f : formula) = - match f with - | SingleFormula f -> format_formula_decl fmt f - | MultipleFormulaes (lvs, f) -> - Format.fprintf fmt "pour %a\n%a" format_loop_variables (Pos.unmark lvs) - format_formula_decl f - -let format_print_arg fmt = function - | PrintString s -> Format.fprintf fmt "\"%s\"" s - | PrintName v -> Format.fprintf fmt "nom(%a)" format_variable (Pos.unmark v) - | PrintAlias v -> - Format.fprintf fmt "alias(%a)" format_variable (Pos.unmark v) - | PrintIndent e -> - Format.fprintf fmt "indenter(%a)" (pp_unmark format_expression) e - | PrintExpr (e, min, max) -> - if min = max_int then - Format.fprintf fmt "(%a)" (pp_unmark format_expression) e - else if max = max_int then - Format.fprintf fmt "(%a):%d" (pp_unmark format_expression) e min - else - Format.fprintf fmt "(%a):%d..%d" (pp_unmark format_expression) e min max +let format_expression = Com.format_expression format_variable let format_var_category_id fmt (vd : var_category_id) = match Pos.unmark vd with | ("saisie", _) :: l -> - Format.fprintf fmt "saisie %a" - (pp_print_list_space (pp_unmark Format.pp_print_string)) - l + Format.fprintf fmt "saisie %a" (Pp.list_space (Pp.unmark Pp.string)) l | ("calculee", _) :: l -> - Format.fprintf fmt "calculee %a" - (pp_print_list_space (pp_unmark Format.pp_print_string)) - l + Format.fprintf fmt "calculee %a" (Pp.list_space (Pp.unmark Pp.string)) l | [ ("*", _) ] -> Format.fprintf fmt "*" | _ -> assert false -let rec format_instruction fmt (i : instruction) = - match i with - | Formula f -> pp_unmark format_formula fmt f - | IfThenElse (e, il, []) -> - Format.fprintf fmt "si %a alors %a finsi" - (pp_unmark format_expression) - e format_instruction_list il - | IfThenElse (e, ilt, ile) -> - Format.fprintf fmt "si %a alors %a sinon %a finsi" - (pp_unmark format_expression) - e format_instruction_list ilt format_instruction_list ile - | ComputeDomain l -> - Format.fprintf fmt "calculer domaine %a;" - (pp_print_list_space (pp_unmark Format.pp_print_string)) - (Pos.unmark l) - | ComputeChaining ch -> - Format.fprintf fmt "calculer enchaineur %s;" (Pos.unmark ch) - | ComputeTarget tn -> Format.fprintf fmt "calculer cible %s;" (Pos.unmark tn) - | ComputeVerifs (l, expr) -> - Format.fprintf fmt "verifier %a : avec %a;" - (pp_print_list_space (pp_unmark Format.pp_print_string)) - (Pos.unmark l) - (pp_unmark format_expression) - expr - | VerifBlock instrs -> - Format.fprintf fmt "bloc_de_verif ( %a )" format_instruction_list instrs - | Print (std, args) -> - let print_cmd = - match std with StdOut -> "afficher" | StdErr -> "afficher_erreur" - in - Format.fprintf fmt "%s %a;" print_cmd - (pp_print_list_space (pp_unmark format_print_arg)) - args - | Iterate (var, vcats, expr, instrs) -> - Format.fprintf fmt - "iterer : variable %s : categorie %a : avec %a : dans ( %a )" - (Pos.unmark var) - (pp_print_list_comma format_var_category_id) - vcats - (pp_unmark format_expression) - expr format_instruction_list instrs - | Restore (rest_params, instrs) -> - let pp_rest_param fmt = function - | VarList l -> - Format.fprintf fmt ": %a " - (pp_print_list_comma (pp_unmark Format.pp_print_string)) - l - | VarCats (var, vcats, expr) -> - Format.fprintf fmt ": variable %s : categorie %a : avec %a " - (Pos.unmark var) - (pp_print_list_comma format_var_category_id) - vcats - (pp_unmark format_expression) - expr - in - Format.fprintf fmt "restaurer %a : dans ( %a )" - (pp_print_list_space (pp_unmark pp_rest_param)) - rest_params format_instruction_list instrs - | RaiseError (err, var_opt) -> - Format.fprintf fmt "leve_erreur %s%s;" (Pos.unmark err) - (match var_opt with Some var -> " " ^ Pos.unmark var | None -> "") - | CleanErrors -> Format.fprintf fmt "nettoie_erreurs;" - | ExportErrors -> Format.fprintf fmt "exporte_erreurs;" - | FinalizeErrors -> Format.fprintf fmt "finalise_erreurs;" - -and format_instruction_list fmt (il : instruction Pos.marked list) = - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "") - (pp_unmark format_instruction)) - fmt il +let format_instruction fmt i = + Com.format_instruction format_variable Pp.string fmt i + +let format_instruction_list fmt (il : instruction Pos.marked list) = + (Pp.list "" (Pp.unmark format_instruction)) fmt il let format_rule fmt (r : rule) = Format.fprintf fmt "regle %d:\napplication %a;\n%a;\n" (Pos.unmark r.rule_number) - (pp_print_list_comma (pp_unmark Format.pp_print_string)) - r.rule_applications - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt ";\n") - (pp_unmark format_formula)) - r.rule_formulaes + (StrMap.pp ~pp_key:Pp.nil ~sep:"," (Pp.unmark Pp.string)) + r.rule_apps format_instruction_list r.rule_formulaes let format_table_size fmt = function | Some (Mast.LiteralSize i, _) -> Format.fprintf fmt "[%d]" i @@ -319,81 +70,70 @@ let format_target fmt (t : target) = Format.fprintf fmt "cible %s:\napplication %a\n: variables temporaires %a;\n%a;\n" (Pos.unmark t.target_name) - (pp_print_list_comma (pp_unmark Format.pp_print_string)) - t.target_applications - (pp_print_list_comma format_tmp_var) + (StrMap.pp ~pp_key:Pp.nil ~sep:"," (Pp.unmark Pp.string)) + t.target_apps + (StrMap.pp ~pp_key:Pp.nil ~sep:"," format_tmp_var) t.target_tmp_vars format_instruction_list t.target_prog -let format_value_typ fmt (t : value_typ) = - Format.pp_print_string fmt - (match t with - | Boolean -> "BOOLEEN" - | DateYear -> "DATE_AAAA" - | DateDayMonthYear -> "DATE_JJMMAAAA" - | DateMonth -> "DATE_MM" - | Integer -> "ENTIER" - | Real -> "REEL") - let format_input_attribute fmt ((n, v) : variable_attribute) = Format.fprintf fmt "%s = %d" (Pos.unmark n) (Pos.unmark v) let format_input_variable fmt (v : input_variable) = Format.fprintf fmt "%a %s %a %a %a : %s%a;" format_variable_name - (Pos.unmark v.input_name) Mast.input_category - (pp_print_list_space Format.pp_print_string) + (Pos.unmark v.input_name) Mast.input_category (Pp.list_space Pp.string) (List.map Pos.unmark v.input_category) - (pp_print_list_space format_input_attribute) + (Pp.list_space format_input_attribute) v.input_attributes format_variable_name (Pos.unmark v.input_alias) (Pos.unmark v.input_description) - (option_print format_value_typ) - (option_bind Pos.unmark v.input_typ) + (Pp.option (Pp.unmark Com.format_value_typ)) + v.input_typ let format_computed_variable fmt (v : computed_variable) = Format.fprintf fmt "%s%a %s %a : %a%s;" (Pos.unmark v.comp_name) format_table_size v.comp_table computed_category - (pp_print_list_space (pp_unmark Format.pp_print_string)) + (Pp.list_space (Pp.unmark Pp.string)) v.comp_category - (option_print format_value_typ) - (option_bind Pos.unmark v.comp_typ) + (Pp.option (Pp.unmark Com.format_value_typ)) + v.comp_typ (Pos.unmark v.comp_description) +let format_atom = Com.format_atom format_variable + let format_variable_decl fmt (v : variable_decl) = match v with | ComputedVar v -> format_computed_variable fmt (Pos.unmark v) | ConstVar (name, value) -> Format.fprintf fmt "%a : const = %a" format_variable_name - (Pos.unmark name) format_literal (Pos.unmark value) + (Pos.unmark name) format_atom (Pos.unmark value) | InputVar v -> format_input_variable fmt (Pos.unmark v) let format_verification_condition fmt (vc : verification_condition) = Format.fprintf fmt "si %a\n alors erreur %a %a;" format_expression (Pos.unmark vc.verif_cond_expr) - (pp_unmark format_error_name) + (Pp.unmark format_error_name) (fst vc.verif_cond_error) - (Format.pp_print_option (pp_unmark format_variable_name)) + (Pp.option (Pp.unmark format_variable_name)) (snd vc.verif_cond_error) let format_verification fmt (v : verification) = Format.fprintf fmt "verif %d : %a;\n%a" (Pos.unmark v.verif_number) - (pp_print_list_space (pp_unmark format_application)) - v.verif_applications - (pp_print_list_space (pp_unmark format_verification_condition)) + (StrMap.pp ~pp_key:Pp.nil ~sep:"," (Pp.unmark Pp.string)) + v.verif_apps + (Pp.list_space (Pp.unmark format_verification_condition)) v.verif_conditions -let format_error_typ fmt (e : error_typ) = - Format.pp_print_string fmt +let format_error_typ fmt (e : Com.Error.typ) = + Pp.string fmt (match e with - | Anomaly -> "anomalie" - | Discordance -> "discordance" - | Information -> "information") + | Com.Error.Anomaly -> "anomalie" + | Com.Error.Discordance -> "discordance" + | Com.Error.Information -> "information") let format_error_ fmt (e : error_) = Format.fprintf fmt "%a : %a : %a;" format_error_name (Pos.unmark e.error_name) format_error_typ (Pos.unmark e.error_typ) - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt " : ") - (pp_unmark Format.pp_print_string)) + (Pp.list " : " (Pp.unmark Pp.string)) e.error_descr let format_var_type (t : var_type) = @@ -402,9 +142,9 @@ let format_var_type (t : var_type) = let format_var_category fmt (c : var_category_decl) = Format.fprintf fmt "%s %a :@ attributs %a" (format_var_type c.var_type) - (pp_print_list_space (pp_unmark Format.pp_print_string)) + (Pp.list_space (Pp.unmark Pp.string)) c.var_category - (pp_print_list_comma (pp_unmark Format.pp_print_string)) + (Pp.list_comma (Pp.unmark Pp.string)) c.var_attributes let format_specialize_domain fmt (dl : string Pos.marked list Pos.marked list) = @@ -412,8 +152,7 @@ let format_specialize_domain fmt (dl : string Pos.marked list Pos.marked list) = | [] -> () | _ -> Format.fprintf fmt " :@ specialise %a" - (pp_print_list_comma - (pp_unmark (pp_print_list_space (pp_unmark Format.pp_print_string)))) + (Pp.list_comma (Pp.unmark (Pp.list_space (Pp.unmark Pp.string)))) dl let format_domain_attribute attr fmt b = @@ -422,8 +161,7 @@ let format_domain_attribute attr fmt b = let format_domain (pp_data : Format.formatter -> 'a -> unit) fmt (d : 'a domain_decl) = Format.fprintf fmt "%a%a%a%a" - (pp_print_list_comma - (pp_unmark (pp_print_list_space (pp_unmark Format.pp_print_string)))) + (Pp.list_comma (Pp.unmark (Pp.list_space (Pp.unmark Pp.string)))) d.dom_names format_specialize_domain d.dom_parents (format_domain_attribute "par_defaut") d.dom_by_default pp_data d.dom_data @@ -439,7 +177,7 @@ let format_rule_domain fmt (rd : rule_domain_decl) = let format_verif_domain fmt (vd : verif_domain_decl) = let pp_data fmt data = Format.fprintf fmt "%a" - (pp_print_list_comma format_var_category_id) + (Pp.list_comma format_var_category_id) data.vdom_auth in format_domain pp_data fmt vd @@ -450,13 +188,14 @@ let format_source_file_item fmt (i : source_file_item) = Format.fprintf fmt "application %a;" format_application (Pos.unmark app) | Chaining (c, apps) -> Format.fprintf fmt "enchaineur %a %a;" format_chaining (Pos.unmark c) - (pp_print_list_space (pp_unmark format_application)) + (Pp.list_space (Pp.unmark format_application)) apps | VariableDecl vd -> format_variable_decl fmt vd + | Function t -> format_target fmt t | Rule r -> format_rule fmt r | Target t -> format_target fmt t | Verification v -> format_verification fmt v - | Function -> () + | Func -> () | Error e -> format_error_ fmt e | Output o -> Format.fprintf fmt "sortie(%a);" format_variable_name (Pos.unmark o) @@ -468,4 +207,4 @@ let format_source_file_item fmt (i : source_file_item) = Format.fprintf fmt "verif domain %a;" format_verif_domain vd let format_source_file fmt (f : source_file) = - pp_print_list_endline (pp_unmark format_source_file_item) fmt f + Pp.list_endline (Pp.unmark format_source_file_item) fmt f diff --git a/src/mlang/m_frontend/format_mast.mli b/src/mlang/m_frontend/format_mast.mli index b6007cdaf..de4276f6f 100644 --- a/src/mlang/m_frontend/format_mast.mli +++ b/src/mlang/m_frontend/format_mast.mli @@ -14,35 +14,12 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -val format_comp_op : Format.formatter -> Mast.comp_op -> unit - -val format_binop : Format.formatter -> Mast.binop -> unit - -val format_unop : Format.formatter -> Mast.unop -> unit - -val format_value_typ : Format.formatter -> Mast.value_typ -> unit - val format_var_type : Mast.var_type -> string -val format_variable : Format.formatter -> Mast.variable -> unit - -val format_loop_variables : Format.formatter -> Mast.loop_variables -> unit - -val format_formula : Format.formatter -> Mast.formula -> unit - -val format_rule_domain : Format.formatter -> Mast.rule_domain_decl -> unit - -val format_verif_domain : Format.formatter -> Mast.verif_domain_decl -> unit - -val format_source_file : Format.formatter -> Mast.source_file -> unit - -val pp_print_list_endline : - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit +val format_variable : Pp.t -> Mast.variable -> unit -val pp_print_list_comma : - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit +val format_rule_domain : Pp.t -> Mast.rule_domain_decl -> unit -val pp_print_list_space : - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit +val format_verif_domain : Pp.t -> Mast.verif_domain_decl -> unit -val pp_unmark : ('a -> 'b -> 'c) -> 'a -> 'b Pos.marked -> 'c +val format_source_file : Pp.t -> Mast.source_file -> unit diff --git a/src/mlang/m_frontend/mast.ml b/src/mlang/m_frontend/mast.ml index 115006253..edf3dc9c5 100644 --- a/src/mlang/m_frontend/mast.ml +++ b/src/mlang/m_frontend/mast.ml @@ -31,16 +31,9 @@ type application = string - [bareme]: seems to compute the income tax; - [iliad]: usage unkown, much bigger than [bareme]. *) -module DomainId = StrSet -module DomainIdSet = StrSetSet -module DomainIdMap = StrSetMap - type chaining = string (** "enchaineur" in the M source code, utility unknown *) -module ChainingSet = StrSet -module ChainingMap = StrMap - type variable_name = string (** Variables are just strings *) @@ -58,13 +51,7 @@ type error_name = string (** A variable is either generic (with loop parameters) or normal *) type variable = Normal of variable_name | Generic of variable_generic_name -type literal = Variable of variable | Float of float | Undefined - -(** A table index is used in expressions like [TABLE\[X\]], and can be - variables, integer or the special [X] variable that stands for a "generic" - index (to define table values as a function of the index). [X] is contained - here in [SymbolIndex] because there can also be a variable named ["X"]... *) -type table_index = LiteralIndex of int | SymbolIndex of variable +let get_normal_var = function Normal name -> name | Generic _ -> assert false type table_size = LiteralSize of int | SymbolSize of string @@ -77,100 +64,15 @@ let get_table_size_opt = function | None -> None | Some (SymbolSize _, _) -> assert false -type set_value = - | FloatValue of float Pos.marked - | VarValue of variable Pos.marked - | Interval of int Pos.marked * int Pos.marked - -(**{2 Loops}*) - -(** The M language has an extremely odd way to specify looping. Rather than - having first-class local mutable variables whose value change at each loop - iteration, the M language prefers to use the changing loop parameter to - instantiate the variable names inside the loop. For instance, - - {v somme(i=1..10:Xi) v} - - should evaluate to the sum of variables [X1], [X2], etc. Parameters can be - number or characters and there can be multiple of them. We have to store all - this information. *) - -(** Values that can be substituted for loop parameters *) -type set_value_loop = - | Single of literal Pos.marked - | Range of literal Pos.marked * literal Pos.marked - | Interval of literal Pos.marked * literal Pos.marked +(**{2 Expressions}*) -type loop_variable = char Pos.marked * set_value_loop list -(** A loop variable is the character that should be substituted in variable - names inside the loop plus the set of value to substitute. *) +type var_category_id = string Pos.marked list Pos.marked -(** There are two kind of loop variables declaration, but they are semantically - the same though they have different concrete syntax. *) -type loop_variables = - | ValueSets of loop_variable list - | Ranges of loop_variable list +type set_value = variable Com.set_value -(**{2 Expressions}*) +type expression = variable Com.expression -(** Comparison operators *) -type comp_op = Gt | Gte | Lt | Lte | Eq | Neq - -(** Binary operators *) -type binop = And | Or | Add | Sub | Mul | Div - -let precedence = function - | Add -> 2 - | Sub -> 2 - | Mul -> 1 - | Div -> 1 - | And -> 3 - | Or -> 4 - -let has_priority op op' = precedence op' < precedence op - -let is_right_associative = function _ -> false - -let is_left_associative = function Sub | Div -> true | _ -> false - -(** Unary operators *) -type unop = Not | Minus - -(** The main type of the M language *) -type expression = - | TestInSet of bool * expression Pos.marked * set_value list - (** Test if an expression is in a set of value (or not in the set if the - flag is set to [false]) *) - | Comparison of - comp_op Pos.marked * expression Pos.marked * expression Pos.marked - (** Compares two expressions and produce a boolean *) - | Binop of binop Pos.marked * expression Pos.marked * expression Pos.marked - | Unop of unop * expression Pos.marked - | Index of variable Pos.marked * table_index Pos.marked - (** Access a cell in a table *) - | Conditional of - expression Pos.marked - * expression Pos.marked - * expression Pos.marked option - (** Classic conditional with an optional else clause ([None] only for - verification conditions) *) - | FunctionCall of func_name Pos.marked * func_args - | Literal of literal - | Loop of loop_variables Pos.marked * expression Pos.marked - (** The loop is prefixed with the loop variables declarations *) - | NbCategory of string Pos.marked list Pos.marked - | Attribut of variable Pos.marked * string Pos.marked - | Size of variable Pos.marked - | NbAnomalies - | NbDiscordances - | NbInformatives - | NbBloquantes - -(** Functions can take a explicit list of argument or a loop expression that - expands into a list *) -and func_args = - | ArgList of expression Pos.marked list - | LoopList of loop_variables Pos.marked * expression Pos.marked +type m_expression = expression Pos.marked (**{1 Toplevel clauses}*) @@ -179,77 +81,30 @@ and func_args = (** The rule is the main feature of the M language. It defines the expression of one or several variables. *) -type lvalue = { - var : variable Pos.marked; - index : table_index Pos.marked option; (* [None] if not a table *) -} -(** An lvalue (left value) is a variable being assigned. It can be a table or a - non-table variable *) - -type formula_decl = { - lvalue : lvalue Pos.marked; - formula : expression Pos.marked; -} +type instruction = (variable, error_name) Com.instruction -(** In the M language, you can define multiple variables at once. This is the - way they do looping since the definition can depend on the loop variable - value (e.g [Xi] can depend on [i]). *) -type formula = - | SingleFormula of formula_decl - | MultipleFormulaes of loop_variables Pos.marked * formula_decl - -type print_std = StdOut | StdErr - -type print_arg = - | PrintString of string - | PrintName of variable Pos.marked - | PrintAlias of variable Pos.marked - | PrintIndent of expression Pos.marked - | PrintExpr of expression Pos.marked * int * int - -type var_category_id = string Pos.marked list Pos.marked - -type restore_vars = - | VarList of string Pos.marked list - | VarCats of string Pos.marked * var_category_id list * expression Pos.marked - -type instruction = - | Formula of formula Pos.marked - | IfThenElse of - expression Pos.marked - * instruction Pos.marked list - * instruction Pos.marked list - | ComputeDomain of string Pos.marked list Pos.marked - | ComputeChaining of string Pos.marked - | ComputeTarget of string Pos.marked - | ComputeVerifs of string Pos.marked list Pos.marked * expression Pos.marked - | VerifBlock of instruction Pos.marked list - | Print of print_std * print_arg Pos.marked list - | Iterate of - string Pos.marked - * var_category_id list - * expression Pos.marked - * instruction Pos.marked list - | Restore of restore_vars Pos.marked list * instruction Pos.marked list - | RaiseError of error_name Pos.marked * variable_name Pos.marked option - | CleanErrors - | ExportErrors - | FinalizeErrors +type m_instruction = instruction Pos.marked type rule = { rule_number : int Pos.marked; rule_tag_names : string Pos.marked list Pos.marked; - rule_applications : application Pos.marked list; + rule_apps : application Pos.marked StrMap.t; rule_chaining : chaining Pos.marked option; - rule_formulaes : formula Pos.marked list; + rule_tmp_vars : (string Pos.marked * table_size Pos.marked option) StrMap.t; + rule_formulaes : instruction Pos.marked list; (** A rule can contain many variable definitions *) } type target = { target_name : string Pos.marked; target_file : string option; - target_applications : application Pos.marked list; - target_tmp_vars : (string Pos.marked * table_size Pos.marked option) list; + target_apps : application Pos.marked StrMap.t; + target_args : string Pos.marked list; + target_result : string Pos.marked option; + target_tmp_vars : (string Pos.marked * table_size Pos.marked option) StrMap.t; + target_nb_tmps : int; + target_sz_tmps : int; + target_nb_refs : int; target_prog : instruction Pos.marked list; } @@ -276,16 +131,6 @@ type rule_domain_decl = rule_domain_data domain_decl type variable_attribute = string Pos.marked * int Pos.marked -(** Here are all the types a value can have. Date types don't seem to be used at - all though. *) -type value_typ = - | Boolean - | DateYear - | DateDayMonthYear - | DateMonth - | Integer - | Real - type input_variable = { input_name : variable_name Pos.marked; input_category : string Pos.marked list; @@ -293,7 +138,7 @@ type input_variable = { input_alias : variable_name Pos.marked; (** Unused for now *) input_is_givenback : bool; input_description : string Pos.marked; - input_typ : value_typ Pos.marked option; + input_typ : Com.value_typ Pos.marked option; } type computed_variable = { @@ -302,14 +147,14 @@ type computed_variable = { (** size of the table, [None] for non-table variables *) comp_attributes : variable_attribute list; comp_category : string Pos.marked list; - comp_typ : value_typ Pos.marked option; + comp_typ : Com.value_typ Pos.marked option; comp_is_givenback : bool; comp_description : string Pos.marked; } type variable_decl = | ComputedVar of computed_variable Pos.marked - | ConstVar of variable_name Pos.marked * literal Pos.marked + | ConstVar of variable_name Pos.marked * variable Com.atom Pos.marked (** The literal is the constant value *) | InputVar of input_variable Pos.marked @@ -344,7 +189,7 @@ type verification_condition = { type verification = { verif_number : int Pos.marked; verif_tag_names : string Pos.marked list Pos.marked; - verif_applications : application Pos.marked list; + verif_apps : application Pos.marked StrMap.t; (** Verification conditions are application-specific *) verif_conditions : verification_condition Pos.marked list; } @@ -356,19 +201,9 @@ type verif_domain_data = { type verif_domain_decl = verif_domain_data domain_decl -type error_typ = Anomaly | Discordance | Information - -let compare_error_type e1 e2 = - match (e1, e2) with - | Anomaly, (Discordance | Information) -> -1 - | (Discordance | Information), Anomaly -> 1 - | Information, Discordance -> -1 - | Discordance, Information -> 1 - | _ -> 0 - type error_ = { error_name : error_name Pos.marked; - error_typ : error_typ Pos.marked; + error_typ : Com.Error.typ Pos.marked; error_descr : string Pos.marked list; } @@ -378,12 +213,13 @@ type source_file_item = | Application of application Pos.marked (** Declares an application *) | Chaining of chaining Pos.marked * application Pos.marked list | VariableDecl of variable_decl + | Function of target | Rule of rule | Target of target | Verification of verification | Error of error_ (** Declares an error *) | Output of variable_name Pos.marked (** Declares an output variable *) - | Function (** Declares a function, unused *) + | Func (** Declares a function, unused *) | VarCatDecl of var_category_decl Pos.marked | RuleDomDecl of rule_domain_decl | VerifDomDecl of verif_domain_decl diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index be0e39f42..e2e3ce0af 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -20,27 +20,11 @@ (** {2 Variable declarations}*) -type var_decl_data = { - var_decl_typ : Mast.value_typ option; - var_decl_is_table : int option; - var_decl_descr : string option; - var_pos : Pos.t; -} -(** Intermediate container for variable declaration info *) - (** {2 General translation context} *) -type translating_context = { - table_definition : bool; - (** [true] if translating an expression susceptible to contain a generic - table index *) - idmap : Mir.idmap; (** Current string-to-{!type: Mir.Variable.t} mapping *) -} -(** This context will be passed along during the translation *) - -let get_var_from_name (d : Mir.Variable.t Pos.VarNameToID.t) - (name : Mast.variable_name Pos.marked) : Mir.Variable.t = - try Pos.VarNameToID.find (Pos.unmark name) d +let get_var_from_name (var_data : Com.Var.t StrMap.t) + (name : Mast.variable_name Pos.marked) : Com.Var.t = + try StrMap.find (Pos.unmark name) var_data with Not_found -> Errors.raise_spanned_error (Format.asprintf "variable %s has not been declared" (Pos.unmark name)) @@ -56,559 +40,93 @@ let get_var_from_name (d : Mir.Variable.t Pos.VarNameToID.t) replace *inside the string* the loop parameter by its value to produce the new variable. *) -let get_var (d : Mir.Variable.t Pos.VarNameToID.t) +let get_var (var_data : Com.Var.t StrMap.t) (name : Mast.variable_name Pos.marked) : Mir.expression = - Mir.Var (get_var_from_name d name) + Com.Var (get_var_from_name var_data name) (**{2 Preliminary passes}*) -(* hackish way to ignore M rules bound to out-of-scope applications *) -let belongs_to_iliad_app (r : Mast.application Pos.marked list) : bool = - List.exists (fun app -> Pos.unmark app = "iliad") r - -let sort_attributes (attrs : Mast.variable_attribute list) = - List.sort - (fun c1 c2 -> String.compare (Pos.unmark (fst c1)) (Pos.unmark (fst c2))) - attrs - -let get_var_categories (p : Mast.program) = - let categories = - List.fold_left - (fun decls source_file -> - List.fold_left - (fun decls source_file_item -> - match Pos.unmark source_file_item with - | Mast.VarCatDecl (catdecl, pos) -> - let normalized_decl = - { - catdecl with - var_category = - List.sort - (fun c1 c2 -> - String.compare (Pos.unmark c1) (Pos.unmark c2)) - catdecl.var_category; - var_attributes = - List.sort - (fun c1 c2 -> - String.compare (Pos.unmark c1) (Pos.unmark c2)) - catdecl.var_attributes; - } - in - let already_defined = - let decl_l = List.length normalized_decl.var_category in - List.find_opt - (fun (decl, _pos) -> - decl_l = List.length decl.Mast.var_category - && List.for_all2 - (fun a b -> - String.equal (Pos.unmark a) (Pos.unmark b)) - normalized_decl.var_category decl.Mast.var_category) - decls - in - begin - match already_defined with - | None -> () - | Some (_decl, posDecl) -> - Errors.raise_spanned_error - (Format.asprintf - "Category \"%s\" defined more than once:@;\ - Already defined %a" - (String.concat " " - (Format_mast.format_var_type - normalized_decl.var_type - :: List.map Pos.unmark - normalized_decl.var_category)) - Pos.format_position posDecl) - pos - end; - (normalized_decl, pos) :: decls - | _ -> decls) - decls source_file) - [] p - in - let categories = - (* Sorted to match longest category first *) - List.sort - (fun c1 c2 -> - compare - (List.length (Pos.unmark c2).Mast.var_category) - (List.length (Pos.unmark c1).Mast.var_category)) - categories - in - categories - -let check_var_category (categories : Mast.var_category_decl Pos.marked list) - (var : Mast.variable_decl) = - let rec category_included_in cbase ctest = - (* assume sorted lists *) - match (cbase, ctest) with - | [], _ -> true - | _, [] -> false - | chb :: ctb, cht :: ctt -> - if String.equal chb cht then category_included_in ctb ctt - else - (* Allows variables to have more tags than the declared category. - Since the declaration are sorted by tag number, we will match the - most precise one first. We can however have have two declared - categories that fits but are not included in one another. *) - category_included_in cbase ctt - in - let attributes_triaging abase atest = - let rec aux (missing, surplus) abase atest = - match (abase, atest) with - | [], _ -> - (missing, List.map (fun a -> Pos.unmark (fst a)) atest @ surplus) - | _, [] -> (List.map (fun a -> Pos.unmark a) abase @ missing, surplus) - | ahb :: atb, aht :: att -> - let ahb = Pos.unmark ahb in - let aht = Pos.unmark (fst aht) in - let comp = String.compare ahb aht in - if comp = 0 then aux (missing, surplus) atb att - else if comp < 0 then aux (ahb :: missing, surplus) atb atest - else aux (missing, aht :: surplus) abase att - in - aux ([], []) abase atest - in - let var_name, var_pos, var_typ, var_cat, var_attrs = - match var with - | Mast.ConstVar _ -> assert false - | Mast.ComputedVar v -> - let v = Pos.unmark v in - ( Pos.unmark v.comp_name, - snd v.comp_name, - Mast.Computed, - v.comp_category, - v.comp_attributes ) - | Mast.InputVar v -> - let v = Pos.unmark v in - ( Pos.unmark v.input_name, - snd v.input_name, - Mast.Input, - v.input_category, - v.input_attributes ) - in - let var_cat = List.map Pos.unmark var_cat in - let categories = - List.filter (fun cat -> (Pos.unmark cat).Mast.var_type = var_typ) categories - in - let var_cat = List.sort String.compare var_cat in - let var_attrs = sort_attributes var_attrs in - match - List.find_all - (fun cat -> - category_included_in - (List.map Pos.unmark (Pos.unmark cat).Mast.var_category) - var_cat) - categories - with - | [] -> - Errors.raise_spanned_error - "Variable does not fit in any declared categories." var_pos - | [ cat ] -> - let missing, surplus = - attributes_triaging (Pos.unmark cat).var_attributes var_attrs - in - if missing <> [] then - Errors.raise_spanned_error - (Format.sprintf - "Variable %s (category %s) is missing the following attributes: %s" - var_name - (String.concat " " var_cat) - (String.concat " " missing)) - var_pos; - if surplus <> [] then - Errors.raise_spanned_error - (Format.sprintf - "Variable %s (category %s) has some unexpected attributes: %s" - var_name - (String.concat " " var_cat) - (String.concat " " surplus)) - var_pos - | multiple_cats -> - Errors.raise_spanned_error - (Format.asprintf "Variable fits more than one category:@\n%a" - (Format.pp_print_list ~pp_sep:Format.pp_print_newline (fun fmt cat -> - Format.fprintf fmt "- %s" - (String.concat " " - (List.map Pos.unmark (Pos.unmark cat).Mast.var_category)))) - multiple_cats) - var_pos - -(** Retrieves variable declaration data. Done in a separate pass because we - don't want to deal with sorting the dependencies between files or inside - files. *) -let get_variables_decl (p : Mast.program) - (categories : Mast.var_category_decl Pos.marked list) : - var_decl_data Mir.VariableMap.t * Mir.Error.t list * Mir.idmap = - let vars, idmap, errors, out_list = - List.fold_left - (fun (vars, (idmap : Mir.idmap), errors, out_list) source_file -> - List.fold_left - (fun (vars, (idmap : Mir.idmap), errors, out_list) source_file_item -> - match Pos.unmark source_file_item with - | Mast.VariableDecl var_decl -> ( - match var_decl with - | Mast.ConstVar (_, _) -> - (vars, idmap, errors, out_list) (* already treated before *) - | Mast.ComputedVar _ | Mast.InputVar _ -> ( - check_var_category categories var_decl; - let var_name = - match var_decl with - | Mast.ComputedVar v -> (Pos.unmark v).Mast.comp_name - | Mast.InputVar v -> (Pos.unmark v).Mast.input_name - | Mast.ConstVar _ -> assert false - in - (* First we check if the variable has not been declared a - first time *) - try - let old_pos = - Pos.get_position - (Pos.VarNameToID.find (Pos.unmark var_name) idmap) - .Mir.Variable.name - in - Cli.var_info_print - "Dropping declaration of %s %a because variable was \ - previously defined %a" - (Pos.unmark var_name) Pos.format_position - (Pos.get_position var_name) - Pos.format_position old_pos; - (vars, idmap, errors, out_list) - with Not_found -> ( - match var_decl with - | Mast.ComputedVar cvar -> - let cvar = Pos.unmark cvar in - let cat = - let comp_set = - List.fold_left - (fun res (str, pos) -> - let elt = - match str with - | "base" -> Mir.Base - | "restituee" -> Mir.GivenBack - | _ -> - Errors.raise_spanned_error - "unknown computed category (must be \ - \"base\" or \"restituee\")" - pos - in - Mir.CatCompSet.add elt res) - Mir.CatCompSet.empty cvar.comp_category - in - Mir.CatComputed comp_set - in - let new_var = - Mir.Variable.new_var cvar.Mast.comp_name None - cvar.Mast.comp_description - ~attributes:cvar.comp_attributes ~cats:(Some cat) - ~origin:None - ~is_table: - (Pos.unmark_option - (Mast.get_table_size_opt cvar.Mast.comp_table)) - ~is_temp:false ~is_it:false - in - let new_var_data = - { - var_decl_typ = - Pos.unmark_option cvar.Mast.comp_typ; - var_decl_is_table = - Pos.unmark_option - (Mast.get_table_size_opt cvar.Mast.comp_table); - var_decl_descr = - Some (Pos.unmark cvar.Mast.comp_description); - var_pos = Pos.get_position source_file_item; - } - in - let new_vars = - Mir.VariableMap.add new_var new_var_data vars - in - let new_idmap = - Pos.VarNameToID.add - (Pos.unmark cvar.Mast.comp_name) - new_var idmap - in - let new_out_list = - if cvar.Mast.comp_is_givenback then - cvar.Mast.comp_name :: out_list - else out_list - in - (new_vars, new_idmap, errors, new_out_list) - | Mast.InputVar ivar -> - let ivar = Pos.unmark ivar in - let cat = - let input_set = - List.fold_left - (fun res (str, _pos) -> StrSet.add str res) - StrSet.empty ivar.input_category - in - Mir.CatInput input_set - in - let new_var = - Mir.Variable.new_var ivar.Mast.input_name - (Some (Pos.unmark ivar.Mast.input_alias)) - ivar.Mast.input_description - ~attributes:ivar.input_attributes ~origin:None - ~cats:(Some cat) ~is_table:None ~is_temp:false - ~is_it:false - (* Input variables also have a low order *) - in - let new_var_data = - { - var_decl_typ = - Pos.unmark_option ivar.Mast.input_typ; - var_decl_is_table = None; - var_decl_descr = - Some (Pos.unmark ivar.Mast.input_description); - var_pos = Pos.get_position source_file_item; - } - in - let new_vars = - Mir.VariableMap.add new_var new_var_data vars - in - let new_idmap = - Pos.VarNameToID.add - (Pos.unmark ivar.Mast.input_name) - new_var idmap - in - (new_vars, new_idmap, errors, out_list) - | Mast.ConstVar _ -> assert false))) - | Mast.Output out_name -> (vars, idmap, errors, out_name :: out_list) - | Mast.Error err -> - let err = - Mir.Error.new_error err.Mast.error_name err - (Pos.unmark err.error_typ) - in - (vars, idmap, err :: errors, out_list) - | _ -> (vars, idmap, errors, out_list)) - (vars, idmap, errors, out_list) - source_file) - (Mir.VariableMap.empty, Pos.VarNameToID.empty, [], []) - p - in - let vars : var_decl_data Mir.VariableMap.t = - List.fold_left - (fun vars out_name -> - try - let out_var = get_var_from_name idmap out_name in - let data = Mir.VariableMap.find out_var vars in - Mir.VariableMap.add out_var data vars - with Not_found -> assert false - (* should not happen *)) - vars out_list - in - (vars, errors, idmap) - (**{2 SSA construction}*) -let translate_variable (ctx : translating_context) +let translate_variable (var_data : Com.Var.t StrMap.t) (var : Mast.variable Pos.marked) : Mir.expression Pos.marked = match Pos.unmark var with | Mast.Normal name -> - Pos.same_pos_as (get_var ctx.idmap (Pos.same_pos_as name var)) var + Pos.same_pos_as (get_var var_data (Pos.same_pos_as name var)) var | Mast.Generic _ -> assert false -(** Linear pass that fills [idmap] with all the variable assignments along with - their execution number. *) -let get_var_redefinitions (p : Mast.program) (idmap : Mir.idmap) : Mir.idmap = - let idmap = - List.fold_left - (fun (idmap : Mir.idmap) source_file -> - List.fold_left - (fun (idmap : Mir.idmap) source_file_item -> - match Pos.unmark source_file_item with - | Mast.Rule r -> - if not (belongs_to_iliad_app r.Mast.rule_applications) then - idmap - else - fst - (List.fold_left - (fun (idmap, seq_number) formula -> - let ctx = { idmap; table_definition = false } in - match Pos.unmark formula with - | Mast.SingleFormula f -> - let lvar = - match - Pos.unmark - (translate_variable ctx - (Pos.unmark f.Mast.lvalue).Mast.var) - with - | Mir.Var var -> var - | _ -> assert false - (* should not happen *) - in - let new_idmap = - Pos.VarNameToID.add - (Pos.unmark lvar.Mir.Variable.name) - (Pos.VarNameToID.find - (Pos.unmark lvar.Mir.Variable.name) - idmap) - idmap - in - (new_idmap, seq_number + 1) - | Mast.MultipleFormulaes _ -> assert false) - (idmap, 0) r.Mast.rule_formulaes) - | _ -> idmap) - idmap source_file) - (idmap : Mir.idmap) - p - in - idmap - (** {2 Translation of expressions}*) -let translate_table_index (ctx : translating_context) - (i : Mast.table_index Pos.marked) : Mir.expression Pos.marked = - match Pos.unmark i with - | Mast.LiteralIndex i' -> - Pos.same_pos_as (Mir.Literal (Mir.Float (float_of_int i'))) i - | Mast.SymbolIndex v -> - let var = translate_variable ctx (Pos.same_pos_as v i) in - var - -(** Only accepts functions in {!type: Mir.func}*) -let translate_function_name (f_name : string Pos.marked) = - match Pos.unmark f_name with - | "somme" -> Mir.SumFunc - | "min" -> Mir.MinFunc - | "max" -> Mir.MaxFunc - | "abs" -> Mir.AbsFunc - | "positif" -> Mir.GtzFunc - | "positif_ou_nul" -> Mir.GtezFunc - | "null" -> Mir.NullFunc - | "arr" -> Mir.ArrFunc - | "inf" -> Mir.InfFunc - | "present" -> Mir.PresentFunc - | "multimax" -> Mir.Multimax - | "supzero" -> Mir.Supzero - | "numero_verif" -> Mir.VerifNumber - | "numero_compl" -> Mir.ComplNumber - | x -> - Errors.raise_spanned_error - (Format.asprintf "unknown function %s" x) - (Pos.get_position f_name) - -let rec translate_expression (cats : Mir.cat_variable_data Mir.CatVarMap.t) - (idmap : Mir.idmap) (ctx : translating_context) - (f : Mast.expression Pos.marked) : Mir.expression Pos.marked = +let rec translate_expression (cats : Com.CatVar.data Com.CatVar.Map.t) + (var_data : Com.Var.t StrMap.t) (f : Mast.expression Pos.marked) : + Mir.expression Pos.marked = + let open Com in let expr = match Pos.unmark f with - | Mast.TestInSet (positive, e, values) -> - let new_e = translate_expression cats idmap ctx e in - let local_var = Mir.LocalVariable.new_var () in - let local_var_expr = Mir.LocalVar local_var in - let or_chain = - List.fold_left - (fun or_chain set_value -> - let equal_test = - match set_value with - | Mast.VarValue set_var -> - Mir.Comparison - ( Pos.same_pos_as Mast.Eq set_var, - Pos.same_pos_as local_var_expr e, - translate_variable ctx set_var ) - | Mast.FloatValue i -> - Mir.Comparison - ( Pos.same_pos_as Mast.Eq i, - Pos.same_pos_as local_var_expr e, - Pos.same_pos_as - (Mir.Literal (Mir.Float (Pos.unmark i))) - i ) - | Mast.Interval (bn, en) -> - if Pos.unmark bn > Pos.unmark en then - Errors.raise_spanned_error "wrong interval bounds" - (Pos.get_position bn) - else - Mir.Binop - ( Pos.same_pos_as Mast.And bn, - Pos.same_pos_as - (Mir.Comparison - ( Pos.same_pos_as Mast.Gte bn, - Pos.same_pos_as local_var_expr e, - Pos.same_pos_as - (Mir.Literal - (Mir.Float (float_of_int (Pos.unmark bn)))) - bn )) - bn, - Pos.same_pos_as - (Mir.Comparison - ( Pos.same_pos_as Mast.Lte en, - Pos.same_pos_as local_var_expr e, - Pos.same_pos_as - (Mir.Literal - (Mir.Float (float_of_int (Pos.unmark en)))) - en )) - en ) - in - Pos.same_pos_as - (Mir.Binop - ( Pos.same_pos_as Mast.Or f, - or_chain, - Pos.same_pos_as equal_test f )) - f) - (Pos.same_pos_as (Mir.Literal Mir.Undefined) f) + | TestInSet (positive, e, values) -> + let new_e = translate_expression cats var_data e in + let new_set_values = + List.map + (function + | FloatValue f -> FloatValue f + | VarValue (v, pos) -> + let new_v = + match v with + | Mast.Normal name -> StrMap.find name var_data + | Mast.Generic _ -> assert false + in + VarValue (new_v, pos) + | Interval (bv, ev) -> Interval (bv, ev)) values in - let or_chain = - if not positive then - Pos.same_pos_as (Mir.Unop (Mast.Not, or_chain)) or_chain - else or_chain - in - Mir.LocalLet (local_var, new_e, or_chain) - | Mast.Comparison (op, e1, e2) -> - let new_e1 = translate_expression cats idmap ctx e1 in - let new_e2 = translate_expression cats idmap ctx e2 in - Mir.Comparison (op, new_e1, new_e2) - | Mast.Binop (op, e1, e2) -> - if - Pos.unmark op = Mast.Mul - && (Pos.unmark e1 = Mast.Literal (Float 0.) - || Pos.unmark e2 = Mast.Literal (Float 0.)) - then - (* It is difficult to do a broader or deeper analysis because of - constant substitutions that could wrongly trigger the warning *) - Errors.print_spanned_warning - "Nullifying constant multiplication found." (Pos.get_position f); - let new_e1 = translate_expression cats idmap ctx e1 in - let new_e2 = translate_expression cats idmap ctx e2 in - Mir.Binop (op, new_e1, new_e2) - | Mast.Unop (op, e) -> - let new_e = translate_expression cats idmap ctx e in - Mir.Unop (op, new_e) - | Mast.Index (t, i) -> - let t_var = translate_variable ctx t in - let new_i = translate_table_index ctx i in - Mir.Index + TestInSet (positive, new_e, new_set_values) + | Comparison (op, e1, e2) -> + let new_e1 = translate_expression cats var_data e1 in + let new_e2 = translate_expression cats var_data e2 in + Comparison (op, new_e1, new_e2) + | Binop (op, e1, e2) -> + (* if + Pos.unmark op = Mast.Mul + && (Pos.unmark e1 = Mast.Literal (Float 0.) + || Pos.unmark e2 = Mast.Literal (Float 0.)) + then + (* It is difficult to do a broader or deeper analysis because of + constant substitutions that could wrongly trigger the warning *) + Errors.print_spanned_warning + "Nullifying constant multiplication found." (Pos.get_position f);*) + let new_e1 = translate_expression cats var_data e1 in + let new_e2 = translate_expression cats var_data e2 in + Binop (op, new_e1, new_e2) + | Unop (op, e) -> + let new_e = translate_expression cats var_data e in + Unop (op, new_e) + | Index (t, i) -> + let t_var = translate_variable var_data t in + let new_i = translate_expression cats var_data i in + Index ( (match Pos.unmark t_var with - | Mir.Var v -> Pos.same_pos_as v t_var + | Var v -> (v, Pos.get_position f) | _ -> assert false (* should not happen *)), new_i ) - | Mast.Conditional (e1, e2, e3) -> - let new_e1 = translate_expression cats idmap ctx e1 in - let new_e2 = translate_expression cats idmap ctx e2 in - let new_e3 = - match e3 with - | Some e3 -> translate_expression cats idmap ctx e3 - | None -> Pos.same_pos_as (Mir.Literal Mir.Undefined) e2 - (* the absence of a else branch for a ternary operators can yield an - undefined term *) + | Conditional (e1, e2, e3) -> + let new_e1 = translate_expression cats var_data e1 in + let new_e2 = translate_expression cats var_data e2 in + let new_e3 = Option.map (translate_expression cats var_data) e3 in + Conditional (new_e1, new_e2, new_e3) + | FuncCall (f_name, args) -> + let new_args = + List.map (fun arg -> translate_expression cats var_data arg) args in - Mir.Conditional (new_e1, new_e2, new_e3) - | Mast.FunctionCall (f_name, args) -> - let f_correct = translate_function_name f_name in - let new_args = translate_func_args cats idmap ctx args in - Mir.FunctionCall (f_correct, new_args) - | Mast.Literal l -> ( - match l with - | Mast.Variable var -> - let new_var = translate_variable ctx (Pos.same_pos_as var f) in - Pos.unmark new_var - | Mast.Float f -> Mir.Literal (Mir.Float f) - | Mast.Undefined -> Mir.Literal Mir.Undefined) - | Mast.NbCategory l -> - Mir.NbCategory (Check_validity.mast_to_catvars l cats) - | Mast.Attribut (v, a) -> ( + FuncCall (f_name, new_args) + | Literal l -> Literal l + | Var var -> + let new_var = translate_variable var_data (Pos.same_pos_as var f) in + Pos.unmark new_var + | NbCategory cs -> NbCategory (Check_validity.mast_to_catvars cs cats) + | Attribut (v, a) -> ( if - Mir.CatVarMap.fold - (fun _ { Mir.attributs; _ } res -> + CatVar.Map.fold + (fun _ CatVar.{ attributs; _ } res -> res && StrMap.fold (fun attr _ res -> res && attr <> Pos.unmark a) @@ -620,262 +138,139 @@ let rec translate_expression (cats : Mir.cat_variable_data Mir.CatVarMap.t) | Mast.Normal v_name -> v_name | _ -> assert false in - match Pos.VarNameToID.find_opt v_name idmap with + match StrMap.find_opt v_name var_data with | Some var -> ( - if var.is_it then Mir.Attribut (Pos.same_pos_as v_name v, var, a) + if Com.Var.is_ref var then Attribut (Pos.same_pos_as var v, a) else - match - List.find_opt - (fun (attr, _) -> Pos.unmark a = Pos.unmark attr) - var.attributes - with - | Some (_, l) -> Mir.Literal (Mir.Float (float (Pos.unmark l))) - | None -> Mir.Literal Mir.Undefined) + match StrMap.find_opt (Pos.unmark a) (Com.Var.attrs var) with + | Some l -> Literal (Float (float (Pos.unmark l))) + | None -> Literal Undefined) | _ -> let msg = Format.sprintf "unknown variable %s" v_name in Errors.raise_spanned_error msg (Pos.get_position v)) - | Mast.Size v -> ( + | Size v -> ( let v_name = match Pos.unmark v with | Mast.Normal v_name -> v_name | _ -> assert false in - match Pos.VarNameToID.find_opt v_name idmap with - | Some var -> ( - if var.is_it then Mir.Size var - else - match var.is_table with - | Some i -> Mir.Literal (Mir.Float (float_of_int i)) - | None -> Mir.Literal (Mir.Float 1.0)) - | _ -> - let msg = Format.sprintf "unknown variable %s" v_name in - Errors.raise_spanned_error msg (Pos.get_position v)) - | Mast.NbAnomalies -> Mir.NbAnomalies - | Mast.NbDiscordances -> Mir.NbDiscordances - | Mast.NbInformatives -> Mir.NbInformatives - | Mast.NbBloquantes -> Mir.NbBloquantes - | Mast.Loop _ -> assert false + let var = StrMap.find v_name var_data in + if Com.Var.is_ref var then Size (Pos.same_pos_as var v) + else + match Com.Var.is_table var with + | Some i -> Literal (Float (float_of_int i)) + | None -> Literal (Float 1.0)) + | NbAnomalies -> NbAnomalies + | NbDiscordances -> NbDiscordances + | NbInformatives -> NbInformatives + | NbBloquantes -> NbBloquantes + | FuncCallLoop _ | Loop _ -> assert false in Pos.same_pos_as expr f -(** Mutually recursive with {!val: translate_expression} *) -and translate_func_args (cats : Mir.cat_variable_data Mir.CatVarMap.t) - (idmap : Mir.idmap) (ctx : translating_context) (args : Mast.func_args) : - Mir.expression Pos.marked list = - match args with - | Mast.ArgList args -> - List.map (fun arg -> translate_expression cats idmap ctx arg) args - | Mast.LoopList _ -> assert false - (** {2 Translation of source file items}*) -(** Helper type to indicate the kind of variable assignment *) -type index_def = NoIndex | ConstIndex of int | DynamicIndex of Mir.variable - -let translate_index_def (ctx : translating_context) - ((v, pos) : Mast.variable Pos.marked) : translating_context * index_def = - match translate_variable ctx (v, pos) with - | Mir.Var v, _ -> (ctx, DynamicIndex v) - | _ -> assert false - -(** Translates lvalues into the assigning variable as well as the type of - assignment *) -let translate_lvalue (ctx : translating_context) (lval : Mast.lvalue Pos.marked) - : translating_context * Mir.Variable.t * index_def = - let var = - match Pos.unmark (translate_variable ctx (Pos.unmark lval).Mast.var) with - | Mir.Var (var : Mir.Variable.t) -> var - | _ -> assert false - (* should not happen *) - in - match (Pos.unmark lval).Mast.index with - | Some ti -> ( - match Pos.unmark ti with - | Mast.LiteralIndex i -> (ctx, var, ConstIndex i) - | Mast.SymbolIndex (Mast.Normal _ as v) -> - let ctx, index_def = translate_index_def ctx (Pos.same_pos_as v ti) in - (ctx, var, index_def) - | Mast.SymbolIndex (Mast.Generic _) -> assert false) - | None -> (ctx, var, NoIndex) - -(** Date types are not supported *) -let translate_value_typ (typ : Mast.value_typ Pos.marked option) : - Mir.typ option = - match typ with - | Some (Mast.Boolean, _) -> Some Mir.Real - (* Indeed, the BOOLEEN annotations are useless because they feed it to - functions that expect reals *) - | Some (Mast.Real, _) -> Some Mir.Real - | Some (_, _) -> Some Mir.Real - | None -> None - -let create_var_def (var_lvalue : Mir.Variable.t) - (var_expr : Mir.expression Pos.marked) (def_kind : index_def) - (var_decl_data : var_decl_data Mir.VariableMap.t) (idmap : Mir.idmap) : - Mir.variable_data = - let var_at_declaration = - Pos.VarNameToID.find (Pos.unmark var_lvalue.name) idmap - in - let decl_data = - try Mir.VariableMap.find var_at_declaration var_decl_data - with Not_found -> assert false - (* should not happen *) - in - let var_typ = - translate_value_typ - (Option.map (fun x -> (x, decl_data.var_pos)) decl_data.var_decl_typ) - in - match decl_data.var_decl_is_table with - | Some size -> ( - match def_kind with - | NoIndex -> assert false (* should not happen *) - | ConstIndex i -> - { - Mir.var_definition = - Mir.TableVar - (size, Mir.IndexTable (Mir.IndexMap.singleton i var_expr)); - Mir.var_typ; - } - | DynamicIndex v -> - { - Mir.var_definition = - Mir.TableVar (size, Mir.IndexGeneric (v, var_expr)); - Mir.var_typ; - }) - | None -> - if def_kind = NoIndex then - { Mir.var_definition = Mir.SimpleVar var_expr; Mir.var_typ } - else - Errors.raise_multispanned_error - (Format.asprintf - "variable %s is defined as a table but has been declared as a \ - non-table" - (Pos.unmark var_lvalue.Mir.Variable.name)) - [ - (Some "variable definition", Pos.get_position var_expr); - ( Some "variable declaration", - try (Mir.VariableMap.find var_lvalue var_decl_data).var_pos - with Not_found -> assert false - (* should not happen since we already looked into idmap to get the - var value from its name *) ); - ] - -(** At this point [var_data] contains the definition data for all the times a - variable is defined. However the M language deals with undefined variable, - so for each variable we have to insert a dummy definition corresponding to - the declaration and whose value and whose value is found in the TGV at the - beginning of the execution *) -let add_dummy_definitions_for_variable_declarations - (var_data : Mir.variable_data Mir.VariableMap.t) - (var_decl_data : var_decl_data Mir.VariableMap.t) : - Mir.variable_data Mir.VariableMap.t = - Mir.VariableMap.fold - (fun var decl (var_data : Mir.variable_data Mir.VariableMap.t) -> - Mir.VariableMap.add var - { - Mir.var_definition = Mir.InputVar; - Mir.var_typ = - translate_value_typ - (match decl.var_decl_typ with - | None -> None - | Some typ -> Some (Pos.same_pos_as typ var.name)); - } - var_data) - var_decl_data var_data - -let rec translate_prog (error_decls : Mir.Error.t list) - (cats : Mir.cat_variable_data Mir.CatVarMap.t) - (var_data : Mir.VariableDict.t) idmap var_decl_data prog = - let new_ctx = { idmap; table_definition = false } in - let rec aux (res, var_data) = function - | [] -> (List.rev res, var_data) - | (Mast.Formula f, pos) :: il -> begin - let ctx = new_ctx in - match f with - | Mast.SingleFormula sf, _ -> - let ctx, var_lvalue, def_kind = - translate_lvalue ctx sf.Mast.lvalue - in - let var_e = translate_expression cats idmap ctx sf.Mast.formula in - let var_d = - create_var_def var_lvalue var_e def_kind var_decl_data idmap - in - aux - ( (Mir.Affectation (var_lvalue.Mir.Variable.id, var_d), pos) :: res, - var_data ) - il - | Mast.MultipleFormulaes _, _ -> assert false - end - | (Mast.IfThenElse (e, ilt, ile), pos) :: il -> - let ctx = new_ctx in - let expr, _ = translate_expression cats idmap ctx e in - let prog_then, var_data = aux ([], var_data) ilt in - let prog_else, var_data = aux ([], var_data) ile in - aux - ((Mir.IfThenElse (expr, prog_then, prog_else), pos) :: res, var_data) - il - | (Mast.ComputeTarget tn, pos) :: il -> - aux ((Mir.ComputeTarget tn, pos) :: res, var_data) il - | (Mast.VerifBlock instrs, pos) :: il -> - let instrs', var_data = aux ([], var_data) instrs in - aux ((Mir.VerifBlock instrs', pos) :: res, var_data) il - | (Mast.Print (std, args), pos) :: il -> - let ctx = new_ctx in +let rec translate_prog (error_decls : Com.Error.t StrMap.t) + (cats : Com.CatVar.data Com.CatVar.Map.t) (var_data : Com.Var.t StrMap.t) + (it_depth : int) prog = + let rec aux res = function + | [] -> List.rev res + | (Com.Affectation (Com.SingleFormula (v, idx, e), _), pos) :: il -> + let var = + match Pos.unmark (translate_variable var_data v) with + | Com.Var var -> Pos.same_pos_as var v + | _ -> assert false + (* should not happen *) + in + let var_idx = Option.map (translate_expression cats var_data) idx in + let var_e = translate_expression cats var_data e in + let m_form = (Com.SingleFormula (var, var_idx, var_e), pos) in + aux ((Com.Affectation m_form, pos) :: res) il + | (Com.Affectation _, _) :: _ -> assert false + | (Com.IfThenElse (e, ilt, ile), pos) :: il -> + let expr = translate_expression cats var_data e in + let prog_then = aux [] ilt in + let prog_else = aux [] ile in + aux ((Com.IfThenElse (expr, prog_then, prog_else), pos) :: res) il + | (Com.WhenDoElse (wdl, ed), pos) :: il -> + let map_wdl (expr, dl, pos) = + let expr' = translate_expression cats var_data expr in + let dl' = aux [] dl in + (expr', dl', pos) + in + let wdl' = List.map map_wdl wdl in + let ed' = Pos.same_pos_as (aux [] (Pos.unmark ed)) ed in + aux ((Com.WhenDoElse (wdl', ed'), pos) :: res) il + | (Com.ComputeTarget (tn, targs), pos) :: il -> + let map v = + match Pos.unmark (translate_variable var_data v) with + | Com.Var var -> Pos.same_pos_as var v + | _ -> assert false + (* should not happen *) + in + let targs' = List.map map targs in + aux ((Com.ComputeTarget (tn, targs'), pos) :: res) il + | (Com.VerifBlock instrs, pos) :: il -> + let instrs' = aux [] instrs in + aux ((Com.VerifBlock instrs', pos) :: res) il + | (Com.Print (std, args), pos) :: il -> let mir_args = List.rev (List.fold_left (fun res arg -> let mir_arg = match Pos.unmark arg with - | Mast.PrintString s -> Mir.PrintString s - | Mast.PrintName v -> ( + | Com.PrintString s -> Com.PrintString s + | Com.PrintName v -> ( let name = match Pos.unmark v with | Mast.Normal name -> name | Mast.Generic _ -> assert false in - match Pos.VarNameToID.find_opt name idmap with + match StrMap.find_opt name var_data with | Some var -> - if var.is_it then - Mir.PrintName (Pos.same_pos_as name v, var) - else Mir.PrintString (Pos.unmark var.name) + if Com.Var.is_ref var then + Com.PrintName (Pos.same_pos_as var v) + else Com.PrintString (Pos.unmark var.name) | _ -> let msg = Format.sprintf "unknown variable %s" name in Errors.raise_spanned_error msg (Pos.get_position v)) - | Mast.PrintAlias v -> ( + | Com.PrintAlias v -> ( let name = match Pos.unmark v with | Mast.Normal name -> name | Mast.Generic _ -> assert false in - match Pos.VarNameToID.find_opt name idmap with + match StrMap.find_opt name var_data with | Some var -> - if var.is_it then - Mir.PrintAlias (Pos.same_pos_as name v, var) - else - Mir.PrintString - (match var.alias with Some a -> a | None -> "") + if Com.Var.is_ref var then + Com.PrintAlias (Pos.same_pos_as var v) + else Com.PrintString (Com.Var.alias_str var) | _ -> let msg = Format.sprintf "unknown variable %s" name in Errors.raise_spanned_error msg (Pos.get_position v)) - | Mast.PrintIndent e -> - Mir.PrintIndent (translate_expression cats idmap ctx e) - | Mast.PrintExpr (e, min, max) -> - Mir.PrintExpr - (translate_expression cats idmap ctx e, min, max) + | Com.PrintIndent e -> + Com.PrintIndent (translate_expression cats var_data e) + | Com.PrintExpr (e, min, max) -> + Com.PrintExpr + (translate_expression cats var_data e, min, max) in Pos.same_pos_as mir_arg arg :: res) [] args) in - aux ((Mir.Print (std, mir_args), pos) :: res, var_data) il - | (Mast.Iterate (vn, vcats, expr, instrs), pos) :: il -> - let var_name = Pos.unmark vn in + aux ((Com.Print (std, mir_args), pos) :: res) il + | (Com.Iterate (vn, vars, var_params, instrs), pos) :: il -> let var_pos = Pos.get_position vn in - (match Pos.VarNameToID.find_opt var_name idmap with + let var_name = + match Pos.unmark vn with + | Mast.Normal name -> name + | Mast.Generic _ -> assert false + in + (match StrMap.find_opt var_name var_data with | Some v -> let msg = Format.asprintf "variable already declared %a" Pos.format_position @@ -883,387 +278,180 @@ let rec translate_prog (error_decls : Mir.Error.t list) in Errors.raise_spanned_error msg pos | _ -> ()); - let var = - Mir.Variable.new_var (var_name, var_pos) None ("iterator", var_pos) - ~attributes:[] ~origin:None ~cats:None ~is_table:None ~is_temp:false - ~is_it:true + let var = Com.Var.new_ref ~name:(var_name, var_pos) ~loc_int:it_depth in + let var_data = StrMap.add var_name var var_data in + let vars' = + List.map + (fun vn -> + Pos.same_pos_as + (StrMap.find (Mast.get_normal_var (Pos.unmark vn)) var_data) + vn) + vars in - let var_data = Mir.VariableDict.add var var_data in - let idmap = Pos.VarNameToID.add var_name var idmap in - let var_decl = - { - var_decl_typ = None; - var_decl_is_table = None; - var_decl_descr = None; - var_pos; - } + let var_params' = + List.map + (fun (vcats, expr) -> + let catSet = Check_validity.mast_to_catvars vcats cats in + let mir_expr = translate_expression cats var_data expr in + (catSet, mir_expr)) + var_params in - let var_decl_data = Mir.VariableMap.add var var_decl var_decl_data in - let catSet = Check_validity.cats_variable_from_decl_list vcats cats in - let ctx = new_ctx in - let ctx = { ctx with idmap } in - let mir_expr = translate_expression cats idmap ctx expr in - let prog_it, var_data = - translate_prog error_decls cats var_data idmap var_decl_data instrs + let prog_it = + translate_prog error_decls cats var_data (it_depth + 1) instrs in - aux - ( (Mir.Iterate (var.Mir.id, catSet, mir_expr, prog_it), pos) :: res, - var_data ) - il - | (Mast.Restore (rest_params, instrs), pos) :: il -> - let vars, var_params, var_data = - List.fold_left - (fun (vars, var_params, var_data) rest_param -> - match Pos.unmark rest_param with - | Mast.VarList vl -> - let vars = - List.fold_left - (fun vars vn -> - let var_name = Pos.unmark vn in - let var_pos = Pos.get_position vn in - match Pos.VarNameToID.find_opt var_name idmap with - | Some v -> begin - match Mir.VariableMap.find_opt v vars with - | None -> Mir.VariableMap.add v var_pos vars - | Some old_pos -> - Errors.raise_spanned_error - (Format.asprintf - "variable already specified %a" - Pos.format_position old_pos) - var_pos - end - | None -> - Errors.raise_spanned_error "unknown variable" - var_pos) - vars vl - in - (vars, var_params, var_data) - | Mast.VarCats (vn, vcats, expr) -> - let var_name = Pos.unmark vn in - let var_pos = Pos.get_position vn in - (match Pos.VarNameToID.find_opt var_name idmap with - | Some v -> - let msg = - Format.asprintf "variable already declared %a" - Pos.format_position (Pos.get_position v.name) - in - Errors.raise_spanned_error msg pos - | _ -> ()); - let var = - Mir.Variable.new_var (var_name, var_pos) None - ("iterator", var_pos) ~attributes:[] ~origin:None - ~cats:None ~is_table:None ~is_temp:false ~is_it:true - in - let var_data = Mir.VariableDict.add var var_data in - let idmap = Pos.VarNameToID.add var_name var idmap in - let catSet = - Check_validity.cats_variable_from_decl_list vcats cats - in - let ctx = new_ctx in - let ctx = { ctx with idmap } in - let mir_expr = translate_expression cats idmap ctx expr in - let var_params = (var, catSet, mir_expr) :: var_params in - (vars, var_params, var_data)) - (Mir.VariableMap.empty, [], var_data) - rest_params + let m_var = Pos.same_pos_as var vn in + aux ((Com.Iterate (m_var, vars', var_params', prog_it), pos) :: res) il + | (Com.Restore (vars, var_params, instrs), pos) :: il -> + let vars' = + List.map + (fun vn -> + Pos.same_pos_as + (StrMap.find (Mast.get_normal_var (Pos.unmark vn)) var_data) + vn) + vars in - let prog_rest, var_data = - translate_prog error_decls cats var_data idmap var_decl_data instrs + let var_params' = + List.map + (fun (vn, vcats, expr) -> + let var_pos = Pos.get_position vn in + let var_name = Mast.get_normal_var (Pos.unmark vn) in + let var = + Com.Var.new_ref ~name:(var_name, var_pos) ~loc_int:it_depth + in + let var_data = StrMap.add var_name var var_data in + let catSet = Check_validity.mast_to_catvars vcats cats in + let mir_expr = translate_expression cats var_data expr in + (Pos.mark var_pos var, catSet, mir_expr)) + var_params in - aux - ((Mir.Restore (vars, var_params, prog_rest), pos) :: res, var_data) - il - | (Mast.RaiseError (err_name, var_opt), pos) :: il -> - let err_decl = - try - List.find - (fun e -> - String.equal (Pos.unmark e.Mir.Error.name) (Pos.unmark err_name)) - error_decls - with Not_found -> - Errors.raise_error - (Format.asprintf "undeclared error %s %a" (Pos.unmark err_name) - Pos.format_position - (Pos.get_position err_name)) + let prog_rest = + translate_prog error_decls cats var_data it_depth instrs in - let var_res = Option.map Pos.unmark var_opt in - aux ((Mir.RaiseError (err_decl, var_res), pos) :: res, var_data) il - | (Mast.CleanErrors, pos) :: il -> - aux ((Mir.CleanErrors, pos) :: res, var_data) il - | (Mast.ExportErrors, pos) :: il -> - aux ((Mir.ExportErrors, pos) :: res, var_data) il - | (Mast.FinalizeErrors, pos) :: il -> - aux ((Mir.FinalizeErrors, pos) :: res, var_data) il - | (Mast.ComputeDomain _, _) :: _ - | (Mast.ComputeChaining _, _) :: _ - | (Mast.ComputeVerifs (_, _), _) :: _ -> + aux ((Com.Restore (vars', var_params', prog_rest), pos) :: res) il + | (Com.RaiseError (err_name, var_opt), pos) :: il -> + let err_decl = StrMap.find (Pos.unmark err_name) error_decls in + let m_err_decl = Pos.same_pos_as err_decl err_name in + aux ((Com.RaiseError (m_err_decl, var_opt), pos) :: res) il + | (Com.CleanErrors, pos) :: il -> aux ((Com.CleanErrors, pos) :: res) il + | (Com.ExportErrors, pos) :: il -> aux ((Com.ExportErrors, pos) :: res) il + | (Com.FinalizeErrors, pos) :: il -> + aux ((Com.FinalizeErrors, pos) :: res) il + | (Com.ComputeDomain _, _) :: _ + | (Com.ComputeChaining _, _) :: _ + | (Com.ComputeVerifs (_, _), _) :: _ -> assert false in - aux ([], var_data) prog - -let get_targets (error_decls : Mir.Error.t list) - (cats : Mir.cat_variable_data Mir.CatVarMap.t) (apps : Pos.t StrMap.t) - (var_data : Mir.VariableDict.t) (idmap : Mir.variable Pos.VarNameToID.t) - (var_decl_data : var_decl_data Mir.VariableMap.t) (p : Mast.program) : - Mir.target_data Mir.TargetMap.t * Mir.VariableDict.t = - List.fold_left - (fun (targets, var_data) source_file -> - List.fold_left - (fun (targets, var_data) (item, pos_item) -> - match item with - | Mast.Target t -> - let target_name = t.Mast.target_name in - let name = Pos.unmark target_name in - (match Mir.TargetMap.find_opt name targets with - | Some data -> - let old_pos = Pos.get_position data.Mir.target_name in - let msg = - Format.asprintf "target %s already defined %a" name - Pos.format_position old_pos - in - Errors.raise_spanned_error msg pos_item - | None -> ()); - let target_file = t.Mast.target_file in - let target_apps = t.Mast.target_applications in - List.iter - (fun (app, pos) -> - if not (StrMap.mem app apps) then - Errors.raise_spanned_error "unknown application" pos) - target_apps; - let target_tmp_vars = - List.fold_left - (fun vars ((var, pos), size) -> - match Pos.VarNameToID.find_opt var idmap with - | Some v -> - let msg = - Format.asprintf "variable already declared %a" - Pos.format_position (Pos.get_position v.name) - in - Errors.raise_spanned_error msg pos - | _ -> begin - match StrMap.find_opt var vars with - | Some (old_pos, _) -> - let msg = - Format.asprintf "variable already declared %a" - Pos.format_position old_pos - in - Errors.raise_spanned_error msg pos - | None -> StrMap.add var (pos, size) vars - end) - StrMap.empty t.Mast.target_tmp_vars - in - let var_data, tmp_idmap, tmp_var_decl_data = - StrMap.fold - (fun name (pos, size) (var_data, map, decls) -> - let size' = - Pos.unmark_option (Mast.get_table_size_opt size) - in - let var = - Mir.Variable.new_var (name, pos) None ("temporary", pos) - ~attributes:[] ~origin:None ~cats:None ~is_table:size' - ~is_temp:true ~is_it:false - in - let var_data = Mir.VariableDict.add var var_data in - let map = Pos.VarNameToID.add name var map in - let var_decl = - { - var_decl_typ = None; - var_decl_is_table = size'; - var_decl_descr = None; - var_pos = pos; - } - in - let decls = Mir.VariableMap.add var var_decl decls in - (var_data, map, decls)) - target_tmp_vars - (var_data, idmap, var_decl_data) - in - let target_tmp_vars = - StrMap.mapi - (fun vn (pos, size) -> - let var = Pos.VarNameToID.find vn tmp_idmap in - let size' = - Pos.unmark_option (Mast.get_table_size_opt size) - in - (var, pos, size')) - target_tmp_vars - in - let target_prog, var_data = - translate_prog error_decls cats var_data tmp_idmap - tmp_var_decl_data t.Mast.target_prog - in - let target_data = - Mir. - { - target_name; - target_file; - target_apps; - target_tmp_vars; - target_prog; - } - in - ( Mir.TargetMap.add (Pos.unmark target_name) target_data targets, - var_data ) - | _ -> (targets, var_data)) - (targets, var_data) source_file) - (Mir.TargetMap.empty, var_data) - p - -let get_conds (verif_domains : Mir.verif_domain Mast.DomainIdMap.t) - (cats : Mir.cat_variable_data Mir.CatVarMap.t) - (error_decls : Mir.Error.t list) (idmap : Mir.idmap) (p : Mast.program) : - Mir.condition_data Mir.RuleMap.t = - List.fold_left - (fun conds source_file -> - List.fold_left - (fun conds source_file_item -> - match Pos.unmark source_file_item with - | Mast.Verification verif - when belongs_to_iliad_app verif.Mast.verif_applications -> - let rule_number = Pos.unmark verif.verif_number in - let conds, _ = - List.fold_left - (fun (conds, id_offset) verif_cond -> - let rule_number = rule_number + id_offset in - let cond_domain = - let vdom_id = - Mast.DomainId.from_marked_list - (Pos.unmark verif.verif_tag_names) - in - match Mast.DomainIdMap.find_opt vdom_id verif_domains with - | Some vdom -> vdom - | None -> - Errors.raise_spanned_error "Unknown verif domain" - (Pos.get_position verif.verif_tag_names) - in - let e = - translate_expression cats idmap - { idmap; table_definition = false } - (Pos.unmark verif_cond).Mast.verif_cond_expr - in - let cond_cats = - Mir.fold_expr_var - (fun subtypes (var : Mir.variable) -> - match var.Mir.cats with - | None -> subtypes - | Some c -> - Mir.CatVarMap.add c - (1 + Mir.CatVarMap.find c subtypes) - subtypes) - (Mir.CatVarMap.map (fun _ -> 0) cats) - (Pos.unmark e) - in - let err = - let err_name, err_var = - (Pos.unmark verif_cond).Mast.verif_cond_error - in - try - ( List.find - (fun e -> - String.equal - (Pos.unmark e.Mir.Error.name) - (Pos.unmark err_name)) - error_decls, - Option.map - (fun v -> Mir.get_var (Pos.unmark v) idmap) - err_var ) - with Not_found -> - Errors.raise_error - (Format.asprintf "undeclared error %s %a" - (Pos.unmark err_name) Pos.format_position - (Pos.get_position err_name)) - in - let cond_seq_id = Mir.Variable.fresh_id () in - let rov = Mir.VerifID rule_number in - match Mir.RuleMap.find_opt rov conds with - | Some c -> - Errors.raise_spanned_error - (Format.asprintf "verif number %d already defined: %a" - rule_number Pos.format_position - (Pos.get_position c.Mir.cond_number)) - (Pos.get_position verif.verif_number) - | None -> - ( Mir.RuleMap.add rov - Mir. - { - cond_seq_id; - cond_number = - Pos.same_pos_as rov verif.verif_number; - cond_domain; - cond_expr = e; - cond_error = err; - cond_cats; - } - conds, - id_offset + 1 )) - (conds, 0) verif.Mast.verif_conditions - in - conds - | _ -> conds) - conds (List.rev source_file)) (* Order important for DGFiP *) - Mir.RuleMap.empty p + aux [] prog + +let get_targets (is_function : bool) (error_decls : Com.Error.t StrMap.t) + (cats : Com.CatVar.data Com.CatVar.Map.t) (var_data : Com.Var.t StrMap.t) + (ts : Mast.target StrMap.t) : Mir.target_data Com.TargetMap.t = + StrMap.fold + (fun _ (t : Mast.target) targets -> + let target_name = t.target_name in + let target_file = t.target_file in + let target_apps = t.target_apps in + let target_nb_refs = t.target_nb_refs in + let tmp_var_data, _ = + if is_function then + List.fold_left + (fun (tmp_var_data, n) (name, pos) -> + let var = Com.Var.new_arg ~name:(name, pos) ~loc_int:n in + let tmp_var_data = StrMap.add name var tmp_var_data in + (tmp_var_data, n + 1)) + (var_data, 0) t.target_args + else + List.fold_left + (fun (tmp_var_data, n) (name, pos) -> + let var = Com.Var.new_ref ~name:(name, pos) ~loc_int:n in + let tmp_var_data = StrMap.add name var tmp_var_data in + (tmp_var_data, n + 1)) + (var_data, -target_nb_refs) + t.target_args + in + let target_sz_tmps = t.target_sz_tmps in + let tmp_var_data, _ = + StrMap.fold + (fun name ((_, pos), size) (tmp_var_data, n) -> + let size' = Pos.unmark_option (Mast.get_table_size_opt size) in + let var = + Com.Var.new_temp ~name:(name, pos) ~is_table:size' ~loc_int:n + in + let tmp_var_data = StrMap.add name var tmp_var_data in + (tmp_var_data, n + Com.Var.size var)) + t.target_tmp_vars + (tmp_var_data, -target_sz_tmps) + in + let tmp_var_data = + if is_function then + let vn, vpos = Option.get t.target_result in + let var = Com.Var.new_res ~name:(vn, vpos) in + StrMap.add vn var tmp_var_data + else tmp_var_data + in + let target_args = + List.map + (fun (vn, pos) -> (StrMap.find vn tmp_var_data, pos)) + t.target_args + in + let target_tmp_vars = + StrMap.mapi + (fun vn ((_, pos), size) -> + let var = StrMap.find vn tmp_var_data in + let size' = Pos.unmark_option (Mast.get_table_size_opt size) in + (var, pos, size')) + t.target_tmp_vars + in + let target_result = + match t.target_result with + | Some (vn, vpos) -> Some (StrMap.find vn tmp_var_data, vpos) + | None -> None + in + let target_prog = + translate_prog error_decls cats tmp_var_data + (List.length target_args - target_nb_refs) + t.target_prog + in + let target_data = + Mir. + { + target_name; + target_file; + target_apps; + target_args; + target_result; + target_tmp_vars; + target_prog; + target_nb_tmps = t.target_nb_tmps; + target_sz_tmps; + target_nb_refs; + } + in + Com.TargetMap.add (Pos.unmark target_name) target_data targets) + ts Com.TargetMap.empty -let translate (p : Mast.program) : Mir.program = +let translate (p : Mast.program) (main_target : string) : Mir.program = let p = Expand_macros.proceed p in - let prog = Check_validity.proceed p in - let prog_targets = - let targets = - StrMap.fold - (fun tname t prog_targets -> - let target_applications = [ (prog.prog_app, Pos.no_pos) ] in - let target_tmp_vars = - StrMap.fold - (fun vn (sz_opt, pos) tmp_vars -> - let size = - Option.map (fun i -> (Mast.LiteralSize i, pos)) sz_opt - in - ((vn, pos), size) :: tmp_vars) - t.Check_validity.target_tmp_vars [] - in - let target = - Mast. - { - target_name = (tname, Pos.no_pos); - target_file = t.Check_validity.target_file; - target_applications; - target_tmp_vars; - target_prog = t.Check_validity.target_prog; - } - in - (Mast.Target target, Pos.no_pos) :: prog_targets) - prog.prog_targets [] - in - [ targets ] - in - let apps = prog.Check_validity.prog_apps in - let var_category_decls = get_var_categories p in - let var_category_map = prog.Check_validity.prog_var_cats in - let var_decl_data, error_decls, idmap = - get_variables_decl p var_category_decls - in - let idmap = get_var_redefinitions p idmap in - let var_data = - add_dummy_definitions_for_variable_declarations Mir.VariableMap.empty - var_decl_data - in - let var_data = - Mir.VariableMap.fold - (fun var _data var_dict -> Mir.VariableDict.add var var_dict) - var_data Mir.VariableDict.empty - in - let targets, var_data = - get_targets error_decls var_category_map apps var_data idmap var_decl_data - prog_targets + let prog = Check_validity.proceed p main_target in + let prog_functions = prog.prog_functions in + let prog_targets = prog.prog_targets in + let var_category_map = prog.prog_var_cats in + let var_data = prog.prog_vars in + let errs = prog.prog_errors in + let functions = + get_targets true errs var_category_map var_data prog_functions in + let targets = get_targets false errs var_category_map var_data prog_targets in Mir. { program_safe_prefix = prog.prog_prefix; - program_applications = apps; + program_applications = prog.prog_apps; program_var_categories = var_category_map; - program_rule_domains = prog.Check_validity.prog_rdoms; - program_verif_domains = prog.Check_validity.prog_vdoms; - program_chainings = Mast.ChainingMap.empty; + program_rule_domains = prog.prog_rdoms; + program_verif_domains = prog.prog_vdoms; program_vars = var_data; + program_functions = functions; program_targets = targets; - program_idmap = idmap; + program_main_target = prog.prog_main_target; + program_stats = prog.prog_stats; } diff --git a/src/mlang/m_frontend/mast_to_mir.mli b/src/mlang/m_frontend/mast_to_mir.mli index b2da3ecc7..a7b0cc6cf 100644 --- a/src/mlang/m_frontend/mast_to_mir.mli +++ b/src/mlang/m_frontend/mast_to_mir.mli @@ -16,49 +16,20 @@ (** {!module: Mast} to {!module: Mir} translation of M programs. *) -(** {1 Translation context}*) - -(** {2 General translation context} *) - -type translating_context = { - table_definition : bool; - (** [true] if translating an expression susceptible to contain a generic - table index *) - idmap : Mir.idmap; (** Current string-to-{!type: Mir.Variable.t} mapping *) -} - (** {1 Translation helpers} *) val get_var_from_name : - Mir.idmap -> + Com.Var.t StrMap.t -> (* name of the variable to query *) string Pos.marked -> - Mir.Variable.t + Com.Var.t (** Queries a [type: Mir.variable.t] from an [type:idmap] mapping, the name of a variable and the rule number from which the variable is requested. Returns the variable with the same name and highest rule number that is below the current rule number from where this variable is requested *) -val translate_expression : - Mir.cat_variable_data Mir.CatVarMap.t -> - Mir.idmap -> - translating_context -> - Mast.expression Pos.marked -> - Mir.expression Pos.marked -(** Main translation function for expressions *) - -val get_conds : - Mir.verif_domain Mast.DomainIdMap.t -> - Mir.cat_variable_data Mir.CatVarMap.t -> - Mir.Error.t list -> - Mir.idmap -> - Mast.program -> - Mir.condition_data Mir.RuleMap.t -(** Returns a map whose keys are dummy variables and whose values are the - verification conditions. *) - (** {1 Main translation function}*) -val translate : Mast.program -> Mir.program +val translate : Mast.program -> string -> Mir.program (** Main translation function from the M AST to the M Variable Graph. This function performs 6 linear passes on the input code: diff --git a/src/mlang/m_frontend/mlexer.mll b/src/mlang/m_frontend/mlexer.mll index 016890d76..e48162414 100644 --- a/src/mlang/m_frontend/mlexer.mll +++ b/src/mlang/m_frontend/mlexer.mll @@ -67,6 +67,7 @@ rule token = parse | "anomalie" -> ANOMALY | "application" -> APPLICATION | "apres" -> AFTER + | "argument" -> INPUT_ARG | "attribut" -> ATTRIBUT | "autorise" -> AUTHORIZE | "avec" -> WITH @@ -84,7 +85,10 @@ rule token = parse | "erreur" -> ERROR | "et" -> AND | "exporte_erreurs" -> EXPORT_ERRORS + | "faire" -> DO | "finalise_erreurs" -> FINALIZE_ERRORS + | "finquand" -> ENDWHEN + | "finsi" -> ENDIF | "fonction" -> FONCTION | "indefini" -> UNDEFINED | "indenter" -> INDENT @@ -96,6 +100,7 @@ rule token = parse | "nb_anomalies" -> NB_ANOMALIES | "nb_discordances" -> NB_DISCORDANCES | "nb_informatives" -> NB_INFORMATIVES + | "neant" -> NOTHING | "nettoie_erreurs" -> CLEAN_ERRORS | "nom" -> NAME | "non" -> NOT @@ -104,14 +109,17 @@ rule token = parse | "ou" -> OR | "par_defaut" -> BY_DEFAULT | "pour" -> FOR + | "puis_quand" -> THEN_WHEN + | "quand" -> WHEN | "regle" -> RULE | "restaurer" -> RESTORE | "restituee" -> GIVEN_BACK + | "resultat" -> RESULT | "saisie" -> INPUT | "si" -> IF - | "sinon_si" -> ELSEIF | "sinon" -> ELSE - | "finsi" -> ENDIF + | "sinon_faire" -> ELSE_DO + | "sinon_si" -> ELSEIF | "sortie" -> OUTPUT | "specialise" -> SPECIALIZE | "tableau" -> TABLE diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 809af86e9..b561413c2 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -25,9 +25,10 @@ along with this program. If not, see . | CompSubTyp of string Pos.marked | Attr of variable_attribute - let parse_to_literal (v: parse_val) : literal = match v with - | ParseVar v -> Variable v - | ParseInt v -> Float (float_of_int v) + let parse_to_atom (v: parse_val) : variable Com.atom = + match v with + | ParseVar v -> AtomVar v + | ParseInt v -> AtomLiteral (Float (float_of_int v)) (** Module generated automaticcaly by Menhir, the parser generator *) %} @@ -46,8 +47,9 @@ along with this program. If not, see . %token BOOLEAN DATE_YEAR DATE_DAY_MONTH_YEAR DATE_MONTH INTEGER REAL %token ONE IN APPLICATION CHAINING TYPE TABLE %token COMPUTED CONST ALIAS INPUT FOR -%token RULE VERIFICATION TARGET TEMPORARY SIZE +%token RULE VERIFICATION TARGET INPUT_ARG TEMPORARY SIZE RESULT %token IF THEN ELSEIF ELSE ENDIF PRINT PRINT_ERR NAME INDENT +%token WHEN DO THEN_WHEN ELSE_DO ENDWHEN NOTHING %token COMPUTE VERIFY WITH VERIF_NUMBER COMPL_NUMBER NB_CATEGORY %token NB_ANOMALIES NB_DISCORDANCES NB_INFORMATIVES NB_BLOCKING %token RAISE_ERROR EXPORT_ERRORS CLEAN_ERRORS FINALIZE_ERRORS @@ -80,6 +82,9 @@ symbol_with_pos: symbol_list_with_pos: | sl = with_pos(symbol_with_pos+) { sl } +variable_name: +| s = SYMBOL { parse_variable_name $sloc s } + source_file: | vl = with_pos(symbol_colon_etc)* is = source_file_rev EOF { List.flatten (vl :: List.rev is) @@ -88,7 +93,7 @@ source_file: symbol_colon_etc: | v = variable_decl { v } | e = error_ { e } -| fonction { Function } +| fonction { Func } source_file_rev: | is = source_file_rev i = source_file_item { i :: is } @@ -104,6 +109,7 @@ source_file_item: | rl = rule_etc { rl } | vl = verification_etc { vl } | tl = target_etc { tl } +| fl = function_etc { fl } var_typ: | INPUT { Input } @@ -214,15 +220,12 @@ verif_domain_decl: VerifDomDecl decl } -var_comp_category: -| BASE { "base" } -| GIVEN_BACK { "restituee" } -| TIMES { "*" } - var_category_id: | INPUT TIMES { ["saisie", Pos.no_pos; "*", Pos.no_pos] } | INPUT l = symbol_with_pos+ { ("saisie", Pos.no_pos) :: l } -| COMPUTED l = with_pos(var_comp_category)* { ("calculee", Pos.no_pos) :: l } +| COMPUTED TIMES { ["calculee", Pos.no_pos; "*", Pos.no_pos] } +| COMPUTED BASE { ["calculee", Pos.no_pos; "*", Pos.no_pos] } +| COMPUTED { ["calculee", Pos.no_pos] } | TIMES { ["*", Pos.no_pos] } vdom_param: @@ -257,9 +260,6 @@ chaining: Chaining (s, aps) } -chaining_reference: -| CHAINING COLON c = with_pos(SYMBOL) SEMICOLON { c } - variable_decl: | v = with_pos(comp_variable) { VariableDecl (ComputedVar v) } | cv = const_variable { let n, v = cv in VariableDecl (ConstVar (n, v)) } @@ -269,7 +269,7 @@ const_variable_name: | name = SYMBOL COLON CONST { parse_variable_name $sloc name } const_value: -| value = SYMBOL { parse_const_value value } +| value = SYMBOL { parse_atom $sloc value } const_variable: | name = with_pos(const_variable_name) EQUALS value = with_pos(const_value) @@ -304,7 +304,7 @@ comp_variable: in let comp_category = subtyp - |> List.filter (function CompSubTyp _ -> true | _ -> false) + |> List.filter (function CompSubTyp ("base", _) -> true | _ -> false) |> List.map (function CompSubTyp x -> x | _ -> assert false) in let comp_is_givenback = @@ -345,12 +345,12 @@ variable_attribute: { (attr, lit) } value_type_prim: -| BOOLEAN { Boolean } -| DATE_YEAR { DateYear } -| DATE_DAY_MONTH_YEAR { DateDayMonthYear } -| DATE_MONTH { DateMonth } -| INTEGER { Integer } -| REAL { Real } +| BOOLEAN { Com.Boolean } +| DATE_YEAR { Com.DateYear } +| DATE_DAY_MONTH_YEAR { Com.DateDayMonthYear } +| DATE_MONTH { Com.DateMonth } +| INTEGER { Com.Integer } +| REAL { Com.Real } value_type: | TYPE typ = with_pos(value_type_prim) { typ } @@ -383,9 +383,9 @@ input_variable: } rule_etc: -| RULE name = symbol_list_with_pos COLON apps = application_reference - SEMICOLON c = chaining_reference? - formulaes_etc = formula_list_etc +| RULE name = symbol_list_with_pos COLON + header = nonempty_list(with_pos(rule_header_elt)) + formulaes_etc = instruction_list_etc { let num, rule_tag_names = let uname = Pos.unmark name in @@ -410,125 +410,278 @@ rule_etc: "this rule doesn't have an execution number" (Pos.get_position num) in - let formulaes, l = formulaes_etc in + let rule_apps, rule_chaining, rule_tmp_vars = + let rec aux apps_opt ch_opt vars_opt = function + | (`Applications apps', pos) :: h -> + let apps_opt' = + match apps_opt with + | None -> Some (apps', pos) + | Some (_, old_pos) -> + Errors.raise_spanned_error + (Format.asprintf + "application list already declared %a" + Pos.format_position old_pos) + pos + in + aux apps_opt' ch_opt vars_opt h + | (`Chaining ch', pos) :: h -> + let ch_opt' = + match ch_opt with + | None -> Some ch' + | Some ch -> + Errors.raise_spanned_error + (Format.asprintf + "this rule already belong to chaining %s %a" + (Pos.unmark ch) + Pos.format_position (Pos.get_position ch)) + pos + in + aux apps_opt ch_opt' vars_opt h + | (`TmpVars vars', pos) :: h -> + let vars_opt' = + match vars_opt with + | None -> Some (vars', pos) + | Some (_, old_pos) -> + Errors.raise_spanned_error + (Format.asprintf + "temporary variables already declared %a" + Pos.format_position old_pos) + pos + in + aux apps_opt ch_opt vars_opt' h + | [] -> + let apps = + match apps_opt with + | Some (apps, _) -> + List.fold_left + (fun res (app, pos) -> + match StrMap.find_opt app res with + | Some (_, old_pos) -> + let msg = + Format.asprintf "application %s already declared %a" + app + Pos.format_position old_pos + in + Errors.raise_spanned_error msg pos + | None -> StrMap.add app (app, pos) res) + StrMap.empty + apps + | None -> + Errors.raise_spanned_error + "this rule doesn't belong to an application" + (Pos.get_position num) + in + let vars = + List.fold_left + (fun res (vnm, vt) -> + let vn, pos = vnm in + match StrMap.find_opt vn res with + | Some ((_, old_pos), _) -> + let msg = + Format.asprintf + "temporary variable %s already declared %a" + vn + Pos.format_position old_pos + in + Errors.raise_spanned_error msg pos + | None -> StrMap.add vn (vnm, vt) res) + StrMap.empty + (match vars_opt with None -> [] | Some (l, _) -> l) + in + apps, ch_opt, vars + in + aux None None None header + in + let rule_formulaes, l = formulaes_etc in let rule = { rule_number; rule_tag_names; - rule_applications = apps; - rule_chaining = c; - rule_formulaes = formulaes; + rule_apps; + rule_chaining; + rule_tmp_vars; + rule_formulaes; } in Pos.same_pos_as (Rule rule) name :: l } +rule_header_elt: +| APPLICATION COLON apps = symbol_enumeration SEMICOLON { `Applications apps } +| CHAINING COLON ch = with_pos(SYMBOL) SEMICOLON { `Chaining ch } +| VARIABLE TEMPORARY COLON + tmp_vars = separated_nonempty_list(COMMA, temporary_variable_name) SEMICOLON + { `TmpVars tmp_vars } + target_etc: | TARGET name = symbol_with_pos COLON - apps = application_reference SEMICOLON - tmp_vars = temporary_variables_decl? + header = nonempty_list(with_pos(target_header_elt)) prog_etc = instruction_list_etc { let target_prog, l = prog_etc in + let target_apps, target_args, target_tmp_vars, _ = + parse_target_or_function_header name false header + in let target = { target_name = name; target_file = None; - target_applications = apps; - target_tmp_vars = (match tmp_vars with None -> [] | Some l -> l); + target_apps; + target_args; + target_result = None; + target_tmp_vars; + target_nb_tmps = -1; + target_sz_tmps = -1; + target_nb_refs = -1; target_prog; } in Pos.same_pos_as (Target target) name :: l } +target_header_elt: +| APPLICATION COLON apps = symbol_enumeration SEMICOLON { Target_apps apps } +| INPUT_ARG COLON + inputs = separated_nonempty_list(COMMA, with_pos(variable_name)) SEMICOLON + { Target_input_arg inputs } +| VARIABLE TEMPORARY COLON + tmp_vars = separated_nonempty_list(COMMA, temporary_variable_name) SEMICOLON + { Target_tmp_vars tmp_vars } + +function_etc: +| FONCTION name = symbol_with_pos COLON + header = nonempty_list(with_pos(function_header_elt)) + prog_etc = instruction_list_etc + { + let target_prog, l = prog_etc in + let target_apps, target_args, target_tmp_vars, target_result = + parse_target_or_function_header name true header + in + let target = { + target_name = name; + target_file = None; + target_apps; + target_args; + target_result; + target_tmp_vars; + target_nb_tmps = -1; + target_sz_tmps = -1; + target_nb_refs = -1; + target_prog; + } in + Pos.same_pos_as (Function target) name :: l + } + +function_header_elt: +| APPLICATION COLON apps = symbol_enumeration SEMICOLON { Target_apps apps } +| INPUT_ARG COLON + inputs = separated_nonempty_list(COMMA, with_pos(variable_name)) SEMICOLON + { Target_input_arg inputs } +| VARIABLE TEMPORARY COLON + tmp_vars = separated_nonempty_list(COMMA, temporary_variable_name) SEMICOLON + { Target_tmp_vars tmp_vars } +| RESULT COLON res = with_pos(variable_name) SEMICOLON { Function_result res } + temporary_variable_name: | name = symbol_with_pos size = with_pos(comp_variable_table)? { let name_str, name_pos = name in (parse_variable_name $sloc name_str, name_pos), size } -temporary_variables_decl: -| VARIABLE TEMPORARY COLON - tmp_vars = separated_nonempty_list(COMMA, temporary_variable_name) SEMICOLON - { tmp_vars } - instruction_list_etc: -| i = with_pos(instruction) l = with_pos(symbol_colon_etc)* { [i], l } -| i = with_pos(instruction) il_etc = instruction_list_etc { - let il, l = il_etc in - i :: il, l +| i_opt = with_pos(instruction) l = with_pos(symbol_colon_etc)* { + match Pos.unmark i_opt with + | None -> [], l + | Some i -> [Pos.same_pos_as i i_opt], l + } +| i_opt = with_pos(instruction) il_etc = instruction_list_etc { + match Pos.unmark i_opt with + | None -> il_etc + | Some i -> + let il, l = il_etc in + (Pos.same_pos_as i i_opt) :: il, l } instruction_list_rev: -| i = with_pos(instruction) { [i] } -| il = instruction_list_rev i = with_pos(instruction) { i :: il } +| i_opt = with_pos(instruction) { + match Pos.unmark i_opt with + | None -> [] + | Some i -> [Pos.same_pos_as i i_opt] + } +| il = instruction_list_rev i_opt = with_pos(instruction) { + match Pos.unmark i_opt with + | None -> il + | Some i -> (Pos.same_pos_as i i_opt) :: il + } instruction: -| f = with_pos(formula_kind) SEMICOLON { Formula f } +| NOTHING SEMICOLON { None } +| f = with_pos(formula_kind) SEMICOLON { Some (Affectation f) } | IF e = with_pos(expression) THEN ilt = instruction_list_rev ilel = instruction_else_branch { - let ilite = (Some e, List.rev ilt, Pos.no_pos) :: ilel in - parse_if_then_etc ilite + let ilite = (Some e, List.rev ilt, mk_position $sloc) :: ilel in + Some (parse_if_then_etc ilite) + } +| WHEN e = with_pos(expression) + DO ild = instruction_list_rev + iltwe = instruction_then_when_branch { + let iltwl, ed = iltwe in + Some (parse_when_do_etc ((e, List.rev ild, mk_position $sloc) :: iltwl, ed)) + } +| COMPUTE DOMAIN dom = symbol_list_with_pos SEMICOLON { Some (ComputeDomain dom) } +| COMPUTE CHAINING chain = symbol_with_pos SEMICOLON { Some (ComputeChaining chain) } +| COMPUTE TARGET target = symbol_with_pos args = target_args? SEMICOLON { + let args_list = match args with None -> [] | Some l -> l in + Some (ComputeTarget (target, args_list)) + } +| VERIFY DOMAIN dom = symbol_list_with_pos SEMICOLON { + let expr = Com.Literal (Com.Float 1.0), Pos.no_pos in + Some (ComputeVerifs (dom, expr)) } -| COMPUTE DOMAIN dom = symbol_list_with_pos SEMICOLON { ComputeDomain dom } -| COMPUTE CHAINING chain = symbol_with_pos SEMICOLON { ComputeChaining chain } -| COMPUTE TARGET target = symbol_with_pos SEMICOLON { ComputeTarget target } -| VERIFY DOMAIN dom = symbol_list_with_pos SEMICOLON - { - let expr = Mast.Literal (Mast.Float 1.0), Pos.no_pos in - ComputeVerifs (dom, expr) - } | VERIFY DOMAIN dom = symbol_list_with_pos COLON WITH expr = with_pos(expression) SEMICOLON { - ComputeVerifs (dom, expr) - } -| PRINT args = with_pos(print_argument)* SEMICOLON - { Print (StdOut, args) } -| PRINT_ERR args = with_pos(print_argument)* SEMICOLON - { Print (StdErr, args) } -| ITERATE COLON it_params = nonempty_list(with_pos(it_param)) - IN LPAREN instrs = instruction_list_rev RPAREN - { - let err msg pos = Errors.raise_spanned_error msg pos in - let fold (vno, vco, exo) = function - | (Some vn, _, _), pos -> - if vno = None then Some vn, vco, exo - else err "iterator variable is already defined" pos - | (_, Some vc, _), pos -> - if vco = None then vno, Some vc, exo - else err "variable category is already specified" pos - | (_, _, Some ex), pos -> - if exo = None then vno, vco, Some ex - else err "iterator filter is already defined" pos - | (_, _, _), _ -> assert false - in - let init = None, None, None in - let vno, vco, exo = List.fold_left fold init it_params in - let var = - match vno with - | Some var -> var - | None -> err "iterator variable must be defined" (mk_position $sloc) - in - let vcats = - match vco with - | Some vcats -> vcats - | None -> err "variable category must be defined" (mk_position $sloc) - in - let expr = - match exo with - | Some expr -> expr - | None -> Mast.Literal (Mast.Float 1.0), Pos.no_pos + Some (ComputeVerifs (dom, expr)) + } +| PRINT args = with_pos(print_argument)* SEMICOLON { + Some (Print (StdOut, args)) + } +| PRINT_ERR args = with_pos(print_argument)* SEMICOLON { + Some (Print (StdErr, args)) + } +| ITERATE COLON + VARIABLE vn = symbol_with_pos COLON + it_params = nonempty_list(it_param) + IN LPAREN instrs = instruction_list_rev RPAREN { + let var = Pos.same_pos_as (Normal (Pos.unmark vn)) vn in + let var_list, var_cats = + let fold (var_list, var_cats) = function + | `VarList vl -> (List.rev vl) @ var_list, var_cats + | `VarCatsIt vc -> var_list, vc :: var_cats in - Iterate (var, vcats, expr, List.rev instrs) - } -| RESTORE COLON rest_params = with_pos(rest_param)* + List.fold_left fold ([], []) it_params + in + Some (Iterate (var, List.rev var_list, List.rev var_cats, List.rev instrs)) + } +| RESTORE COLON rest_params = nonempty_list(rest_param) AFTER LPAREN instrs = instruction_list_rev RPAREN { - Restore (rest_params, List.rev instrs) + let var_list, var_cats = + let fold (var_list, var_cats) = function + | `VarList vl -> (List.rev vl) @ var_list, var_cats + | `VarCatsRest vc -> var_list, vc @ var_cats + in + List.fold_left fold ([], []) rest_params + in + Some (Restore (List.rev var_list, List.rev var_cats, List.rev instrs)) } -| RAISE_ERROR e_name = symbol_with_pos var = with_pos(output_name)? SEMICOLON { - RaiseError (e_name, var) +| RAISE_ERROR e_name = symbol_with_pos var = with_pos(variable_name)? SEMICOLON { + Some (RaiseError (e_name, var)) } -| CLEAN_ERRORS SEMICOLON { CleanErrors } -| EXPORT_ERRORS SEMICOLON { ExportErrors } -| FINALIZE_ERRORS SEMICOLON { FinalizeErrors } +| CLEAN_ERRORS SEMICOLON { Some CleanErrors } +| EXPORT_ERRORS SEMICOLON { Some ExportErrors } +| FINALIZE_ERRORS SEMICOLON { Some FinalizeErrors } + +target_args: +| COLON WITH args = separated_nonempty_list(COMMA, arg_variable) { args } + +arg_variable: +| s = with_pos(SYMBOL) { parse_variable $sloc (fst s), snd s } instruction_else_branch: | ELSEIF e = with_pos(expression) @@ -541,21 +694,33 @@ instruction_else_branch: } | ENDIF { [] } +instruction_then_when_branch: +| THEN_WHEN e = with_pos(expression) + DO ild = instruction_list_rev + iltwe = instruction_then_when_branch { + let iltwl, ed = iltwe in + ((e, List.rev ild, mk_position $sloc) :: iltwl, ed) + } +| ELSE_DO il = instruction_list_rev ENDWHEN { + ([], (List.rev il, mk_position $sloc)) + } +| ENDWHEN { ([], ([], Pos.no_pos)) } + print_argument: -| s = STRING { PrintString (parse_string s) } +| s = STRING { Com.PrintString (parse_string s) } | f = with_pos(print_function) LPAREN v = symbol_with_pos RPAREN { match Pos.unmark f with - | "nom" -> PrintName (parse_variable $sloc (fst v), snd v) - | "alias" -> PrintAlias (parse_variable $sloc (fst v), snd v) + | "nom" -> Com.PrintName (parse_variable $sloc (fst v), snd v) + | "alias" -> Com.PrintAlias (parse_variable $sloc (fst v), snd v) | _ -> assert false } -| INDENT LPAREN e = with_pos(expression) RPAREN { PrintIndent e } +| INDENT LPAREN e = with_pos(expression) RPAREN { Com.PrintIndent e } | LPAREN e = with_pos(expression) RPAREN prec = print_precision? { match prec with - | Some (min, max) -> PrintExpr (e, min, max) - | None -> PrintExpr (e, 0, 20) + | Some (min, max) -> Com.PrintExpr (e, min, max) + | None -> Com.PrintExpr (e, 0, 20) } print_function: @@ -598,38 +763,67 @@ print_precision: } it_param: -| VARIABLE var = symbol_with_pos COLON - { Some var, None, None } -| CATEGORY vcats = separated_nonempty_list(COMMA, with_pos(var_category_id)) - COLON { - None, Some vcats, None +| vars = separated_nonempty_list(COMMA, symbol_with_pos) COLON { + let vl = + List.map (fun vn -> Pos.same_pos_as (Normal (Pos.unmark vn)) vn) vars + in + `VarList vl } -| WITH expr = with_pos(expression) COLON - { None, None, Some expr } +| CATEGORY vcat_list = separated_nonempty_list(COMMA, with_pos(var_category_id)) + COLON expr_opt = it_param_with_expr? { + let vcats = + let fold res vc = + let vcm = Com.CatVar.Map.from_string_list vc in + Com.CatVar.Map.union (fun _ p _ -> Some p) vcm res + in + List.fold_left fold Com.CatVar.Map.empty vcat_list + in + let expr = + match expr_opt with + | Some expr -> expr + | None -> Com.Literal (Com.Float 1.0), Pos.no_pos + in + `VarCatsIt (vcats, expr) + } + +it_param_with_expr: +| WITH expr = with_pos(expression) COLON { expr } rest_param: -| vars = separated_nonempty_list(COMMA, symbol_with_pos) COLON { VarList vars } -| VARIABLE var = symbol_with_pos COLON - CATEGORY vcats = separated_nonempty_list(COMMA, with_pos(var_category_id)) - COLON expr_opt = rest_param_with_expr? { +| vars = separated_nonempty_list(COMMA, symbol_with_pos) COLON { + let vl = + List.map (fun vn -> Pos.same_pos_as (Normal (Pos.unmark vn)) vn) vars + in + `VarList vl + } +| VARIABLE vn = symbol_with_pos COLON + vparams = nonempty_list(rest_param_category) { + let var = Pos.same_pos_as (Normal (Pos.unmark vn)) vn in + let filters = List.map (fun (vcats, expr) -> (var, vcats, expr)) vparams in + `VarCatsRest filters + } + +rest_param_category: +| CATEGORY vcat_list = separated_nonempty_list(COMMA, with_pos(var_category_id)) + COLON expr_opt = rest_param_with_expr? { + let vcats = + let fold res vc = + let vcm = Com.CatVar.Map.from_string_list vc in + Com.CatVar.Map.union (fun _ p _ -> Some p) vcm res + in + List.fold_left fold Com.CatVar.Map.empty vcat_list + in let expr = match expr_opt with | Some expr -> expr - | None -> Mast.Literal (Mast.Float 1.0), Pos.no_pos + | None -> Com.Literal (Com.Float 1.0), Pos.no_pos in - VarCats (var, vcats, expr) + (vcats, expr) } rest_param_with_expr: | WITH expr = with_pos(expression) COLON { expr } -formula_list_etc: -| f = with_pos(formula_kind) SEMICOLON l = with_pos(symbol_colon_etc)* { [f], l } -| f = with_pos(formula_kind) SEMICOLON fs = formula_list_etc { - let fl, l = fs in - f :: fl, l - } - formula_kind: | f = formula { SingleFormula f } | fs = for_formula { let (lv, ft) = fs in MultipleFormulaes (lv, ft) } @@ -641,19 +835,20 @@ lvalue_name: | s = SYMBOL { parse_variable $sloc s } lvalue: -| s = with_pos(lvalue_name) i = with_pos(brackets)? { { var = s; index = i} } +| s = with_pos(lvalue_name) i = with_pos(brackets)? { (s, i) } formula: -| lvalue = with_pos(lvalue) EQUALS formula = with_pos(expression) { - { lvalue; formula } +| lvalue = lvalue EQUALS e = with_pos(expression) { + let v, idx = lvalue in + (v, idx, e) } verification_etc: | v = with_pos(verification) l = with_pos(symbol_colon_etc)* { v :: l } verification: -| VERIFICATION name = symbol_list_with_pos - COLON verif_applications = application_reference SEMICOLON +| VERIFICATION name = symbol_list_with_pos COLON + APPLICATION COLON apps = symbol_enumeration SEMICOLON verif_conditions = with_pos(verification_condition)+ { let num, verif_tag_names = let uname = Pos.unmark name in @@ -678,10 +873,31 @@ verification: "this verification doesn't have an execution number" (Pos.get_position num) in + let verif_apps = + match apps with + | [] -> + Errors.raise_spanned_error + "this verification doesn't belong to an application" + (Pos.get_position verif_number) + | _ -> + List.fold_left + (fun res (app, pos) -> + match StrMap.find_opt app res with + | Some (_, old_pos) -> + let msg = + Format.asprintf "application %s already declared %a" + app + Pos.format_position old_pos + in + Errors.raise_spanned_error msg pos + | None -> StrMap.add app (app, pos) res) + StrMap.empty + apps + in let verif = { verif_number; verif_tag_names; - verif_applications; + verif_apps; verif_conditions } in Verification verif @@ -689,7 +905,7 @@ verification: verification_condition: | IF e = with_pos(expression) THEN - ERROR e_name = symbol_with_pos var = with_pos(output_name)? SEMICOLON { + ERROR e_name = symbol_with_pos var = with_pos(variable_name)? SEMICOLON { { verif_cond_expr = e; verif_cond_error = e_name, var; @@ -723,26 +939,23 @@ error_: } type_error: -| ANOMALY { Anomaly } -| DISCORDANCE { Discordance } -| INFORMATIVE { Information } +| ANOMALY { Com.Error.Anomaly } +| DISCORDANCE { Com.Error.Discordance } +| INFORMATIVE { Com.Error.Information } output_etc: | o = with_pos(output) l = with_pos(symbol_colon_etc)* { o :: l } output: -| OUTPUT LPAREN s = with_pos(output_name) RPAREN SEMICOLON { Output s } - -output_name: -| s = SYMBOL { parse_variable_name $sloc s } +| OUTPUT LPAREN s = with_pos(variable_name) RPAREN SEMICOLON { Output s } brackets: -| LBRACKET i = SYMBOL RBRACKET { parse_table_index $sloc i } +| LBRACKET i = expression RBRACKET { i } loop_variables: -| lrs = loop_variables_ranges { Ranges lrs } -| lvs = loop_variables_values { ValueSets lvs } +| lrs = loop_variables_ranges { Com.Ranges lrs } +| lvs = loop_variables_values { Com.ValueSets lvs } loop_variables_values: | lvs = separated_nonempty_list(SEMICOLON, loop_variables_value) { lvs } @@ -772,7 +985,7 @@ enumeration_loop_item: | bounds = interval_loop { bounds } | s = SYMBOL { let pos = mk_position $sloc in - Single (parse_to_literal (parse_variable_or_int $sloc s), pos) + Com.Single (parse_to_atom (parse_variable_or_int $sloc s), pos) } range_or_minus: @@ -782,11 +995,11 @@ range_or_minus: interval_loop: | i1 = SYMBOL rm = range_or_minus i2 = SYMBOL { let pos = mk_position $sloc in - let l1 = parse_to_literal (parse_variable_or_int $sloc i1), pos in - let l2 = parse_to_literal (parse_variable_or_int $sloc i2), pos in + let l1 = parse_to_atom (parse_variable_or_int $sloc i1), pos in + let l2 = parse_to_atom (parse_variable_or_int $sloc i2), pos in match rm with - | `Range -> Range (l1, l2) - | `Minus -> Interval (l1, l2) + | `Range -> Com.Range (l1, l2) + | `Minus -> Com.Interval (l1, l2) } enumeration: @@ -798,8 +1011,8 @@ enumeration_item: | s = SYMBOL { let pos = mk_position $sloc in match parse_variable_or_int $sloc s with - | ParseVar v -> VarValue (v, pos) - | ParseInt i -> FloatValue (float_of_int i, pos) + | ParseVar v -> Com.VarValue (v, pos) + | ParseInt i -> Com.FloatValue (float_of_int i, pos) } interval: @@ -807,7 +1020,7 @@ interval: let pos = mk_position $sloc in let ir1 = parse_int $sloc i1, pos in let ir2 = parse_int $sloc i2, pos in - Interval (ir1, ir2) : set_value + Com.Interval (ir1, ir2) : set_value } (* Some intervals are "03..06" so we must keep the prefix "0" *) @@ -833,42 +1046,46 @@ expression: | NOT e = with_pos(expression) { Unop (Not, e) } %inline logical_binop: -| AND { And } -| OR { Or } +| AND { Com.And } +| OR { Com.Or } sum_expression: | e = product_expression { e } | e1 = with_pos(sum_expression) op = with_pos(sum_operator) e2 = with_pos(product_expression) { - Binop (op, e1, e2) + Com.Binop (op, e1, e2) } %inline sum_operator: -| PLUS { Add } -| MINUS { Sub } +| PLUS { Com.Add } +| MINUS { Com.Sub } product_expression: | e = factor { e } | e1 = with_pos(product_expression) op = with_pos(product_operator) e2 = with_pos(factor) { - Binop (op, e1, e2) + Com.Binop (op, e1, e2) } %inline product_operator: -| TIMES { Mul } -| DIV { Div } +| TIMES { Com.Mul } +| DIV { Com.Div } table_index_name: s = SYMBOL { parse_variable $sloc s } factor: -| MINUS e = with_pos(factor) { Unop (Minus, e) } +| MINUS e = with_pos(factor) { Com.Unop (Minus, e) } | e = ternary_operator { e } | e = function_call { e } -| s = with_pos(table_index_name) i = with_pos(brackets) { Index (s, i) } -| l = factor_literal { Literal l } +| s = with_pos(table_index_name) i = with_pos(brackets) { Com.Index (s, i) } +| a = with_pos(factor_atom) { + match Pos.unmark a with + | Com.AtomVar v -> Com.Var v + | Com.AtomLiteral l -> Com.Literal l + } | LPAREN e = expression RPAREN { e } loop_expression: @@ -881,15 +1098,15 @@ ternary_operator: THEN e2 = with_pos(expression) e3 = else_branch? ENDIF { - Conditional (e1, e2, e3) + Com.Conditional (e1, e2, e3) } else_branch: | ELSE e = with_pos(expression) { e } -factor_literal: -| UNDEFINED { Mast.Undefined } -| s = SYMBOL { parse_literal $sloc s }(* +factor_atom: +| UNDEFINED { AtomLiteral Undefined } +| s = SYMBOL { parse_atom $sloc s }(* Some symbols start with a digit and make it hard to parse with (float / integer / symbol) *) @@ -899,7 +1116,9 @@ function_name: | s = SYMBOL { parse_func_name $sloc s } function_call: -| NB_CATEGORY LPAREN cats = with_pos(var_category_id) RPAREN { NbCategory cats } +| NB_CATEGORY LPAREN cats = with_pos(var_category_id) RPAREN { + NbCategory (Com.CatVar.Map.from_string_list cats) + } | ATTRIBUT LPAREN var = symbol_with_pos COMMA attr = symbol_with_pos RPAREN { Attribut ((parse_variable $sloc (fst var), snd var), attr) } @@ -911,27 +1130,30 @@ function_call: | NB_INFORMATIVES LPAREN RPAREN { NbInformatives } | NB_BLOCKING LPAREN RPAREN { NbBloquantes } | s = with_pos(function_name) LPAREN RPAREN { - FunctionCall (s, Mast.ArgList []) + FuncCall (parse_function_name s, []) } -| s = with_pos(function_name) LPAREN args = function_call_args RPAREN { - FunctionCall (s, args) +| s = with_pos(function_name) LPAREN call_args = function_call_args RPAREN { + let f_name = parse_function_name s in + match call_args with + | `CallArgs args -> Com.FuncCall (f_name, args) + | `CallLoop (l1, l2) -> Com.FuncCallLoop (f_name, l1, l2) } function_call_args: -| l = loop_expression { let l1, l2 = l in LoopList (l1, l2) } -| args = function_arguments { ArgList (args) } +| l = loop_expression { let l1, l2 = l in `CallLoop (l1, l2) } +| args = function_arguments { `CallArgs args } function_arguments: | e = with_pos(sum_expression) { [e] } | e = with_pos(sum_expression) COMMA es = function_arguments { e :: es } %inline comparison_op: -| GTE { Gte } -| LTE { Lte } -| LT { Lt } -| GT { Gt } -| NEQ { Neq } -| EQUALS { Eq } +| GTE { Com.Gte } +| LTE { Com.Lte } +| LT { Com.Lt } +| GT { Com.Gt } +| NEQ { Com.Neq } +| EQUALS { Com.Eq } symbol_enumeration: | ss = separated_nonempty_list(COMMA, symbol_with_pos) { ss } diff --git a/src/mlang/m_frontend/parse_utils.ml b/src/mlang/m_frontend/parse_utils.ml index 38640b0ad..3cbb37d78 100644 --- a/src/mlang/m_frontend/parse_utils.ml +++ b/src/mlang/m_frontend/parse_utils.ml @@ -78,26 +78,18 @@ let parse_variable_or_int sloc (s : string) : parse_val = with E.StructuredError _ -> E.raise_spanned_error "invalid variable name" (mk_position sloc))) -let parse_table_index sloc (s : string) : Mast.table_index = - try Mast.LiteralIndex (int_of_string s) - with Failure _ -> ( - try Mast.SymbolIndex (parse_variable sloc s) - with E.StructuredError _ -> - E.raise_spanned_error "table index should be an integer" - (mk_position sloc)) - let parse_table_size (s : string) : Mast.table_size = try Mast.LiteralSize (int_of_string s) with Failure _ -> Mast.SymbolSize s (**{1 Literal parsing}*) -let parse_literal sloc (s : string) : Mast.literal = - try Mast.Float (float_of_string s) - with Failure _ -> Mast.Variable (parse_variable sloc s) +let parse_literal sloc (s : string) : Com.literal = + try Com.Float (float_of_string s) + with Failure _ -> E.raise_spanned_error "invalid literal" (mk_position sloc) -let parse_const_value (s : string) : Mast.literal = - try Mast.Float (float_of_string s) - with Failure _ -> Mast.Variable (Mast.Normal s) +let parse_atom sloc (s : string) : Mast.variable Com.atom = + try Com.AtomLiteral (Com.Float (float_of_string s)) + with Failure _ -> Com.AtomVar (parse_variable sloc s) let parse_func_name _ (s : string) : Mast.func_name = s @@ -106,6 +98,28 @@ let parse_int sloc (s : string) : int = with Failure _ -> E.raise_spanned_error "should be an integer" (mk_position sloc) +(** Parse function name *) +let parse_function_name f_name = + let open Com in + let map = function + | "somme" -> SumFunc + | "min" -> MinFunc + | "max" -> MaxFunc + | "abs" -> AbsFunc + | "positif" -> GtzFunc + | "positif_ou_nul" -> GtezFunc + | "null" -> NullFunc + | "arr" -> ArrFunc + | "inf" -> InfFunc + | "present" -> PresentFunc + | "multimax" -> Multimax + | "supzero" -> Supzero + | "numero_verif" -> VerifNumber + | "numero_compl" -> ComplNumber + | fn -> Func fn + in + Pos.map_under_mark map f_name + (* # parse_string # * Takes a litteral string and produces a String.t of the corresponding chars *) @@ -166,9 +180,116 @@ let parse_string (s : string) : string = let parse_if_then_etc l = let rec aux = function - | [ (Some e, ilt, pos) ] -> [ (Mast.IfThenElse (e, ilt, []), pos) ] + | [ (Some e, ilt, pos) ] -> [ (Com.IfThenElse (e, ilt, []), pos) ] | [ (None, ile, _pos) ] -> ile - | (Some e, ilt, pos) :: le -> [ (Mast.IfThenElse (e, ilt, aux le), pos) ] + | (Some e, ilt, pos) :: le -> [ (Com.IfThenElse (e, ilt, aux le), pos) ] | _ -> assert false in match aux l with [ (i, _pos) ] -> i | _ -> assert false + +let parse_when_do_etc (twl, ed) = Com.WhenDoElse (twl, ed) + +type target_header = + | Target_apps of Mast.application Pos.marked list + | Target_input_arg of string Pos.marked list + | Target_tmp_vars of + (string Pos.marked * Mast.table_size Pos.marked option) list + | Function_result of string Pos.marked + +let parse_target_or_function_header name is_function header = + let rec aux apps_opt args_opt vars_opt res_opt = function + | (Target_apps apps', pos) :: h -> + let apps_opt' = + match apps_opt with + | None -> Some (apps', pos) + | Some (_, old_pos) -> + Errors.raise_spanned_error + (Format.asprintf "application list already declared %a" + Pos.format_position old_pos) + pos + in + aux apps_opt' args_opt vars_opt res_opt h + | (Target_input_arg vars', pos) :: h -> + let args_opt = + match args_opt with + | None -> Some (vars', pos) + | Some (_, old_pos) -> + Errors.raise_spanned_error + (Format.asprintf "argument list already declared %a" + Pos.format_position old_pos) + pos + in + aux apps_opt args_opt vars_opt res_opt h + | (Target_tmp_vars vars', pos) :: h -> + let vars_opt' = + match vars_opt with + | None -> Some (vars', pos) + | Some (_, old_pos) -> + Errors.raise_spanned_error + (Format.asprintf "temporary variable list already declared %a" + Pos.format_position old_pos) + pos + in + aux apps_opt args_opt vars_opt' res_opt h + | (Function_result res', pos) :: h -> + if is_function then + let res_opt' = + match res_opt with + | None -> Some (res', pos) + | Some (_, old_pos) -> + Errors.raise_spanned_error + (Format.asprintf "result variable already declared %a" + Pos.format_position old_pos) + pos + in + aux apps_opt args_opt vars_opt res_opt' h + else aux apps_opt args_opt vars_opt res_opt h + | [] -> + let apps = + match apps_opt with + | Some (apps, _) -> + List.fold_left + (fun res (app, pos) -> + match StrMap.find_opt app res with + | Some (_, old_pos) -> + let msg = + Format.asprintf "application %s already declared %a" app + Pos.format_position old_pos + in + Errors.raise_spanned_error msg pos + | None -> StrMap.add app (app, pos) res) + StrMap.empty apps + | None -> + let ty = if is_function then "function" else "target" in + Errors.raise_spanned_error + (Format.sprintf "this %s doesn't belong to an application" ty) + (Pos.get_position name) + in + let args = match args_opt with None -> [] | Some (l, _) -> l in + let vars = + List.fold_left + (fun res (vnm, vt) -> + let vn, pos = vnm in + match StrMap.find_opt vn res with + | Some ((_, old_pos), _) -> + let msg = + Format.asprintf "temporary variable %s already declared %a" + vn Pos.format_position old_pos + in + Errors.raise_spanned_error msg pos + | None -> StrMap.add vn (vnm, vt) res) + StrMap.empty + (match vars_opt with None -> [] | Some (l, _) -> l) + in + let res = + match res_opt with + | None -> + if is_function then + Errors.raise_spanned_error "this function doesn't have a result" + (Pos.get_position name) + else None + | Some (rvar, _) -> Some rvar + in + (apps, args, vars, res) + in + aux None None None None header diff --git a/src/mlang/m_frontend/parse_utils.mli b/src/mlang/m_frontend/parse_utils.mli index f878911a7..57c0dc0e5 100644 --- a/src/mlang/m_frontend/parse_utils.mli +++ b/src/mlang/m_frontend/parse_utils.mli @@ -38,10 +38,6 @@ val parse_string : string -> string val parse_variable_or_int : Lexing.position * Lexing.position -> string -> parse_val -val parse_table_index : - Lexing.position * Lexing.position -> string -> Mast.table_index -(** Table index can be integer or [X], the generic table index variable *) - val parse_table_size : string -> Mast.table_size val parse_func_name : 'a -> string -> string @@ -51,11 +47,35 @@ val parse_func_name : 'a -> string -> string val parse_int : Lexing.position * Lexing.position -> string -> int (** Checks whether is it actually an integer*) -val parse_literal : Lexing.position * Lexing.position -> string -> Mast.literal +val parse_literal : Lexing.position * Lexing.position -> string -> Com.literal + +val parse_atom : + Lexing.position * Lexing.position -> string -> Mast.variable Com.atom -val parse_const_value : string -> Mast.literal +val parse_function_name : string Pos.marked -> Com.func Pos.marked val parse_if_then_etc : (Mast.expression Pos.marked option * Mast.instruction Pos.marked list * Pos.t) list -> Mast.instruction + +val parse_when_do_etc : + (Mast.expression Pos.marked * Mast.instruction Pos.marked list * Pos.t) list + * Mast.instruction Pos.marked list Pos.marked -> + Mast.instruction + +type target_header = + | Target_apps of Mast.application Pos.marked list + | Target_input_arg of string Pos.marked list + | Target_tmp_vars of + (string Pos.marked * Mast.table_size Pos.marked option) list + | Function_result of string Pos.marked + +val parse_target_or_function_header : + string Pos.marked -> + bool -> + target_header Pos.marked list -> + Mast.application Pos.marked StrMap.t + * string Pos.marked list + * (string Pos.marked * Mast.table_size Pos.marked option) StrMap.t + * string Pos.marked option diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml new file mode 100644 index 000000000..131083e7c --- /dev/null +++ b/src/mlang/m_ir/com.ml @@ -0,0 +1,792 @@ +module CatVar = struct + type t = Input of StrSet.t | Computed of { is_base : bool } + + let pp fmt = function + | Input id -> + let pp fmt set = StrSet.iter (Format.fprintf fmt " %s") set in + Format.fprintf fmt "saisie%a" pp id + | Computed id -> + Format.fprintf fmt "calculee%s" (if id.is_base then " base" else "") + + let compare a b = + match (a, b) with + | Input _, Computed _ -> 1 + | Computed _, Input _ -> -1 + | Input id0, Input id1 -> StrSet.compare id0 id1 + | Computed c0, Computed c1 -> compare c0.is_base c1.is_base + + type cat_var_t = t + + let cat_var_pp = pp + + let cat_var_compare = compare + + module Set = struct + include SetExt.Make (struct + type t = cat_var_t + + let compare = cat_var_compare + end) + + let pp ?(sep = ", ") ?(pp_elt = cat_var_pp) (_ : unit) + (fmt : Format.formatter) (set : t) : unit = + pp ~sep ~pp_elt () fmt set + end + + module Map = struct + include MapExt.Make (struct + type t = cat_var_t + + let compare = cat_var_compare + end) + + let pp ?(sep = "; ") ?(pp_key = cat_var_pp) ?(assoc = " => ") + (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (map : 'a t) : unit = + pp ~sep ~pp_key ~assoc pp_val fmt map + + let from_string_list = function + | [ ("*", _) ], id_pos -> + one (Input (StrSet.one "*")) id_pos + |> add (Computed { is_base = false }) id_pos + |> add (Computed { is_base = true }) id_pos + | [ ("saisie", _); ("*", _) ], id_pos -> + one (Input (StrSet.one "*")) id_pos + | ("saisie", _) :: id, id_pos -> + one (Input (StrSet.from_marked_list id)) id_pos + | ("calculee", _) :: id, id_pos -> ( + match id with + | [] -> one (Computed { is_base = false }) id_pos + | [ ("base", _) ] -> one (Computed { is_base = true }) id_pos + | [ ("*", _) ] -> + one (Computed { is_base = false }) id_pos + |> add (Computed { is_base = true }) id_pos + | _ -> Errors.raise_spanned_error "invalid variable category" id_pos) + | _, id_pos -> + Errors.raise_spanned_error "invalid variable category" id_pos + end + + type loc = LocComputed | LocBase | LocInput + + type data = { + id : t; + id_str : string; + id_int : int; + loc : loc; + pos : Pos.t; + attributs : Pos.t StrMap.t; + } +end + +(** Here are all the types a value can have. Date types don't seem to be used at + all though. *) +type value_typ = + | Boolean + | DateYear + | DateDayMonthYear + | DateMonth + | Integer + | Real + +type loc_tgv = { + loc_id : string; + loc_cat : CatVar.loc; + loc_idx : int; + loc_cat_id : CatVar.t; + loc_cat_str : string; + loc_cat_idx : int; + loc_int : int; +} + +type loc = + | LocTgv of string * loc_tgv + | LocTmp of string * int + | LocRef of string * int + | LocArg of string * int + | LocRes of string + +module Var = struct + type id = int + + let id_cpt = ref 0 + + let new_id () = + let id = !id_cpt in + incr id_cpt; + id + + type tgv = { + is_table : int option; + alias : string Pos.marked option; (** Input variable have an alias *) + descr : string Pos.marked; + (** Description taken from the variable declaration *) + attrs : int Pos.marked StrMap.t; + cat : CatVar.t; + is_given_back : bool; + typ : value_typ option; + } + + type scope = Tgv of tgv | Temp of int option | Ref | Arg | Res + + type t = { + name : string Pos.marked; (** The position is the variable declaration *) + id : id; + loc : loc; + scope : scope; + } + + let tgv v = + match v.scope with + | Tgv s -> s + | _ -> + Errors.raise_error + (Format.sprintf "%s is not a TGV variable" (Pos.unmark v.name)) + + let name v = v.name + + let name_str v = Pos.unmark v.name + + let is_table v = + match v.scope with + | Tgv tgv -> tgv.is_table + | Temp is_table -> is_table + | Ref | Arg | Res -> None + + let cat_var_loc v = + match v.scope with + | Tgv tgv -> ( + match tgv.cat with + | CatVar.Input _ -> Some CatVar.LocInput + | Computed { is_base } when is_base -> Some CatVar.LocBase + | Computed _ -> Some CatVar.LocComputed) + | Temp _ | Ref | Arg | Res -> None + + let size v = match is_table v with None -> 1 | Some sz -> sz + + let alias v = (tgv v).alias + + let alias_str v = Option.fold ~none:"" ~some:Pos.unmark (tgv v).alias + + let descr v = (tgv v).descr + + let descr_str v = Pos.unmark (tgv v).descr + + let attrs v = (tgv v).attrs + + let cat v = (tgv v).cat + + let is_given_back v = (tgv v).is_given_back + + let loc_tgv v = + match v.loc with + | LocTgv (_, l) -> l + | _ -> + Errors.raise_error + (Format.sprintf "%s is not a TGV variable" (Pos.unmark v.name)) + + let loc_int v = + match v.loc with + | LocTgv (_, tgv) -> tgv.loc_int + | LocTmp (_, li) | LocRef (_, li) | LocArg (_, li) -> li + | LocRes id -> + Errors.raise_error + (Format.sprintf "variable %s doesn't have an index" id) + + let is_temp v = match v.scope with Temp _ -> true | _ -> false + + let is_ref v = v.scope = Ref + + let is_arg v = v.scope = Arg + + let is_res v = v.scope = Res + + let init_loc loc_cat_id = + { + loc_id = ""; + loc_cat = CatVar.LocInput; + loc_idx = 0; + loc_cat_id; + loc_cat_str = ""; + loc_cat_idx = 0; + loc_int = 0; + } + + let new_tgv ~(name : string Pos.marked) ~(is_table : int option) + ~(is_given_back : bool) ~(alias : string Pos.marked option) + ~(descr : string Pos.marked) ~(attrs : int Pos.marked StrMap.t) + ~(cat : CatVar.t) ~(typ : value_typ option) : t = + { + name; + id = new_id (); + loc = LocTgv (Pos.unmark name, init_loc cat); + scope = Tgv { is_table; alias; descr; attrs; cat; is_given_back; typ }; + } + + let new_temp ~(name : string Pos.marked) ~(is_table : int option) + ~(loc_int : int) : t = + let loc = LocTmp (Pos.unmark name, loc_int) in + { name; id = new_id (); loc; scope = Temp is_table } + + let new_ref ~(name : string Pos.marked) ~(loc_int : int) : t = + let loc = LocRef (Pos.unmark name, loc_int) in + { name; id = new_id (); loc; scope = Ref } + + let new_arg ~(name : string Pos.marked) ~(loc_int : int) : t = + let loc = LocArg (Pos.unmark name, loc_int) in + { name; id = new_id (); loc; scope = Arg } + + let new_res ~(name : string Pos.marked) : t = + let loc = LocRes (Pos.unmark name) in + { name; id = new_id (); loc; scope = Res } + + let int_of_scope = function + | Tgv _ -> 0 + | Temp _ -> 1 + | Ref -> 2 + | Arg -> 3 + | Res -> 4 + + let compare (var1 : t) (var2 : t) = + let c = compare (int_of_scope var1.scope) (int_of_scope var2.scope) in + if c <> 0 then c + else + let c = compare (Pos.unmark var1.name) (Pos.unmark var2.name) in + if c <> 0 then c else compare var1.id var2.id + + let pp fmt (v : t) = Format.fprintf fmt "(%d)%s" v.id (Pos.unmark v.name) + + type t_var = t + + let pp_var = pp + + let compare_var v0 v1 = Int.compare v0.id v1.id + + module Set = struct + include SetExt.Make (struct + type t = t_var + + let compare = compare_var + end) + + let pp ?(sep = ", ") ?(pp_elt = pp_var) (_ : unit) (fmt : Format.formatter) + (set : t) : unit = + pp ~sep ~pp_elt () fmt set + end + + module Map = struct + include MapExt.Make (struct + type t = t_var + + let compare = compare_var + end) + + let pp ?(sep = "; ") ?(pp_key = pp_var) ?(assoc = " => ") + (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (map : 'a t) : unit = + pp ~sep ~pp_key ~assoc pp_val fmt map + end + + (* let compare_name_ref = ref (fun _ _ -> assert false) + + let compare_name n0 n1 = !compare_name_ref n0 n1*) +end + +module DomainId = StrSet + +module DomainIdSet = struct + include SetSetExt.Make (DomainId) + + module type T = + SetSetExt.T with type base_elt = string and type elt = DomainId.t + + let pp ?(sep1 = ", ") ?(sep2 = " ") ?(pp_elt = Format.pp_print_string) + (_ : unit) (fmt : Format.formatter) (setSet : t) : unit = + pp ~sep1 ~sep2 ~pp_elt () fmt setSet +end + +module DomainIdMap = struct + include MapExt.Make (DomainId) + + module type T = MapExt.T with type key = DomainId.t + + let pp ?(sep = ", ") ?(pp_key = DomainId.pp ()) ?(assoc = " => ") + (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) + (map : 'a t) : unit = + pp ~sep ~pp_key ~assoc pp_val fmt map +end + +type 'a domain = { + dom_id : DomainId.t Pos.marked; + dom_names : Pos.t DomainIdMap.t; + dom_by_default : bool; + dom_min : DomainIdSet.t; + dom_max : DomainIdSet.t; + dom_rov : IntSet.t; + dom_data : 'a; + dom_used : int Pos.marked option; +} + +type rule_domain_data = { rdom_computable : bool } + +type rule_domain = rule_domain_data domain + +type verif_domain_data = { + vdom_auth : Pos.t CatVar.Map.t; + vdom_verifiable : bool; +} + +type verif_domain = verif_domain_data domain + +module TargetMap = StrMap + +type literal = Float of float | Undefined + +type 'v atom = AtomVar of 'v | AtomLiteral of literal + +type 'v set_value_loop = + | Single of 'v atom Pos.marked + | Range of 'v atom Pos.marked * 'v atom Pos.marked + | Interval of 'v atom Pos.marked * 'v atom Pos.marked + +type 'v loop_variable = char Pos.marked * 'v set_value_loop list + +type 'v loop_variables = + | ValueSets of 'v loop_variable list + | Ranges of 'v loop_variable list + +(** Unary operators *) +type unop = Not | Minus + +(** Binary operators *) +type binop = And | Or | Add | Sub | Mul | Div + +(** Comparison operators *) +type comp_op = Gt | Gte | Lt | Lte | Eq | Neq + +type 'v set_value = + | FloatValue of float Pos.marked + | VarValue of 'v Pos.marked + | Interval of int Pos.marked * int Pos.marked + +type func = + | SumFunc (** Sums the arguments *) + | AbsFunc (** Absolute value *) + | MinFunc (** Minimum of a list of values *) + | MaxFunc (** Maximum of a list of values *) + | GtzFunc (** Greater than zero (strict) ? *) + | GtezFunc (** Greater or equal than zero ? *) + | NullFunc (** Equal to zero ? *) + | ArrFunc (** Round to nearest integer *) + | InfFunc (** Truncate to integer *) + | PresentFunc (** Different than zero ? *) + | Multimax (** ??? *) + | Supzero (** ??? *) + | VerifNumber + | ComplNumber + | Func of string + +type 'v expression = + | TestInSet of bool * 'v m_expression * 'v set_value list + (** Test if an expression is in a set of value (or not in the set if the + flag is set to [false]) *) + | Unop of unop * 'v m_expression + | Comparison of comp_op Pos.marked * 'v m_expression * 'v m_expression + | Binop of binop Pos.marked * 'v m_expression * 'v m_expression + | Index of 'v Pos.marked * 'v m_expression + | Conditional of 'v m_expression * 'v m_expression * 'v m_expression option + | FuncCall of func Pos.marked * 'v m_expression list + | FuncCallLoop of + func Pos.marked * 'v loop_variables Pos.marked * 'v m_expression + | Literal of literal + | Var of 'v + | Loop of 'v loop_variables Pos.marked * 'v m_expression + (** The loop is prefixed with the loop variables declarations *) + | NbCategory of Pos.t CatVar.Map.t + | Attribut of 'v Pos.marked * string Pos.marked + | Size of 'v Pos.marked + | NbAnomalies + | NbDiscordances + | NbInformatives + | NbBloquantes + +and 'v m_expression = 'v expression Pos.marked + +module Error = struct + type typ = Anomaly | Discordance | Information + + let compare_typ e1 e2 = + match (e1, e2) with + | Anomaly, (Discordance | Information) -> -1 + | (Discordance | Information), Anomaly -> 1 + | Information, Discordance -> -1 + | Discordance, Information -> 1 + | _ -> 0 + + type t = { + name : string Pos.marked; + kind : string Pos.marked; + major_code : string Pos.marked; + minor_code : string Pos.marked; + description : string Pos.marked; + isisf : string Pos.marked; + typ : typ; + } + + let pp_descr fmt err = + Format.fprintf fmt "%s:%s:%s:%s:%s" (Pos.unmark err.kind) + (Pos.unmark err.major_code) + (Pos.unmark err.minor_code) + (Pos.unmark err.description) + (Pos.unmark err.isisf) + + let compare (var1 : t) (var2 : t) = compare var1.name var2.name +end + +type print_std = StdOut | StdErr + +type 'v print_arg = + | PrintString of string + | PrintName of 'v Pos.marked + | PrintAlias of 'v Pos.marked + | PrintIndent of 'v m_expression + | PrintExpr of 'v m_expression * int * int + +type 'v formula_loop = 'v loop_variables Pos.marked + +type 'v formula_decl = 'v Pos.marked * 'v m_expression option * 'v m_expression + +type 'v formula = + | SingleFormula of 'v formula_decl + | MultipleFormulaes of 'v formula_loop * 'v formula_decl + +type ('v, 'e) instruction = + | Affectation of 'v formula Pos.marked + | IfThenElse of + 'v m_expression + * ('v, 'e) m_instruction list + * ('v, 'e) m_instruction list + | WhenDoElse of + ('v m_expression * ('v, 'e) m_instruction list * Pos.t) list + * ('v, 'e) m_instruction list Pos.marked + | ComputeDomain of string Pos.marked list Pos.marked + | ComputeChaining of string Pos.marked + | ComputeVerifs of string Pos.marked list Pos.marked * 'v m_expression + | ComputeTarget of string Pos.marked * 'v Pos.marked list + | VerifBlock of ('v, 'e) m_instruction list + | Print of print_std * 'v print_arg Pos.marked list + | Iterate of + 'v Pos.marked + * 'v Pos.marked list + * (Pos.t CatVar.Map.t * 'v m_expression) list + * ('v, 'e) m_instruction list + | Restore of + 'v Pos.marked list + * ('v Pos.marked * Pos.t CatVar.Map.t * 'v m_expression) list + * ('v, 'e) m_instruction list + | RaiseError of 'e Pos.marked * string Pos.marked option + | CleanErrors + | ExportErrors + | FinalizeErrors + +and ('v, 'e) m_instruction = ('v, 'e) instruction Pos.marked + +let set_loc_int loc loc_int = + match loc with + | LocTgv (id, tgv) -> LocTgv (id, { tgv with loc_int }) + | LocTmp (id, _) -> LocTmp (id, loc_int) + | LocRef (id, _) -> LocRef (id, loc_int) + | LocArg (id, _) -> LocArg (id, loc_int) + | LocRes id -> + Errors.raise_error (Format.sprintf "variable %s doesn't have an index" id) + +let set_loc_tgv_cat loc loc_cat loc_cat_str loc_cat_idx = + match loc with + | LocTgv (id, tgv) -> + LocTgv (id, { tgv with loc_cat; loc_cat_str; loc_cat_idx }) + | LocTmp (id, _) | LocRef (id, _) | LocArg (id, _) | LocRes id -> + Errors.raise_error (Format.sprintf "%s has not a TGV location" id) + +let set_loc_tgv_idx loc loc_idx = + match loc with + | LocTgv (id, tgv) -> LocTgv (id, { tgv with loc_idx }) + | LocTmp (id, _) | LocRef (id, _) | LocArg (id, _) | LocRes id -> + Errors.raise_error (Format.sprintf "%s has not a TGV location" id) + +let format_value_typ fmt t = + Pp.string fmt + (match t with + | Boolean -> "BOOLEEN" + | DateYear -> "DATE_AAAA" + | DateDayMonthYear -> "DATE_JJMMAAAA" + | DateMonth -> "DATE_MM" + | Integer -> "ENTIER" + | Real -> "REEL") + +let format_literal fmt l = + Format.pp_print_string fmt + (match l with Float f -> string_of_float f | Undefined -> "indefini") + +let format_atom form_var fmt vl = + match vl with + | AtomVar v -> form_var fmt v + | AtomLiteral l -> format_literal fmt l + +let format_set_value_loop form_var fmt sv = + let form_atom = format_atom form_var in + match sv with + | Single l -> Format.fprintf fmt "%a" form_atom (Pos.unmark l) + | Range (i1, i2) -> + Format.fprintf fmt "%a..%a" form_atom (Pos.unmark i1) form_atom + (Pos.unmark i2) + | Interval (i1, i2) -> + Format.fprintf fmt "%a-%a" form_atom (Pos.unmark i1) form_atom + (Pos.unmark i2) + +let format_loop_variable_ranges form_var fmt (v, vs) = + Format.fprintf fmt "un %c dans %a" (Pos.unmark v) + (Pp.list_comma (format_set_value_loop form_var)) + vs + +let format_loop_variable_value_set form_var fmt (v, vs) = + Format.fprintf fmt "%c=%a" (Pos.unmark v) + (Pp.list_comma (format_set_value_loop form_var)) + vs + +let format_loop_variables form_var fmt lvs = + match lvs with + | ValueSets vvs -> + Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ";") + (format_loop_variable_value_set form_var) + fmt vvs + | Ranges vvs -> + Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt " et ") + (format_loop_variable_ranges form_var) + fmt vvs + +let format_unop fmt op = + Format.pp_print_string fmt (match op with Not -> "non" | Minus -> "-") + +let format_binop fmt op = + Format.pp_print_string fmt + (match op with + | And -> "et" + | Or -> "ou" + | Add -> "+" + | Sub -> "-" + | Mul -> "*" + | Div -> "/") + +let format_comp_op fmt op = + Format.pp_print_string fmt + (match op with + | Gt -> ">" + | Gte -> ">=" + | Lt -> "<" + | Lte -> "<=" + | Eq -> "=" + | Neq -> "!=") + +let format_set_value format_variable fmt sv = + let open Format in + match sv with + | VarValue v -> format_variable fmt (Pos.unmark v) + | Interval (i1, i2) -> fprintf fmt "%d..%d" (Pos.unmark i1) (Pos.unmark i2) + | FloatValue i -> fprintf fmt "%f" (Pos.unmark i) + +let format_func fmt f = + Format.pp_print_string fmt + (match f with + | SumFunc -> "somme" + | AbsFunc -> "abs" + | MinFunc -> "min" + | MaxFunc -> "max" + | GtzFunc -> "positif" + | GtezFunc -> "positif_ou_nul" + | NullFunc -> "null" + | ArrFunc -> "arr" + | InfFunc -> "inf" + | PresentFunc -> "present" + | Multimax -> "multimax" + | Supzero -> "supzero" + | VerifNumber -> "numero_verif" + | ComplNumber -> "numero_compl" + | Func fn -> fn) + +let rec format_expression form_var fmt = + let form_expr = format_expression form_var in + function + | TestInSet (belong, e, values) -> + Format.fprintf fmt "(%a %sdans %a)" form_expr (Pos.unmark e) + (if belong then "" else "non ") + (Pp.list_comma (format_set_value form_var)) + values + | Comparison (op, e1, e2) -> + Format.fprintf fmt "(%a %a %a)" form_expr (Pos.unmark e1) format_comp_op + (Pos.unmark op) form_expr (Pos.unmark e2) + | Binop (op, e1, e2) -> + Format.fprintf fmt "(%a %a %a)" form_expr (Pos.unmark e1) format_binop + (Pos.unmark op) form_expr (Pos.unmark e2) + | Unop (op, e) -> + Format.fprintf fmt "%a %a" format_unop op form_expr (Pos.unmark e) + | Index (v, i) -> + Format.fprintf fmt "%a[%a]" form_var (Pos.unmark v) form_expr + (Pos.unmark i) + | Conditional (e1, e2, e3) -> + let pp_sinon fmt e = Format.fprintf fmt " sinon %a" form_expr e in + Format.fprintf fmt "(si %a alors %a%a finsi)" form_expr (Pos.unmark e1) + form_expr (Pos.unmark e2) + (Pp.option (Pp.unmark pp_sinon)) + e3 + | FuncCall (f, args) -> + Format.fprintf fmt "%a(%a)" format_func (Pos.unmark f) + (Pp.list_space (Pp.unmark form_expr)) + args + | FuncCallLoop (f, lvs, e) -> + Format.fprintf fmt "%a(%a%a)" format_func (Pos.unmark f) + (format_loop_variables form_var) + (Pos.unmark lvs) form_expr (Pos.unmark e) + | Literal l -> format_literal fmt l + | Var v -> form_var fmt v + | Loop (lvs, e) -> + Format.fprintf fmt "pour %a%a" + (format_loop_variables form_var) + (Pos.unmark lvs) form_expr (Pos.unmark e) + | NbCategory cs -> + Format.fprintf fmt "nb_categorie(%a)" (CatVar.Map.pp_keys ()) cs + | Attribut (v, a) -> + Format.fprintf fmt "attribut(%a, %s)" form_var (Pos.unmark v) + (Pos.unmark a) + | Size v -> Format.fprintf fmt "taille(%a)" form_var (Pos.unmark v) + | NbAnomalies -> Format.fprintf fmt "nb_anomalies()" + | NbDiscordances -> Format.fprintf fmt "nb_discordances()" + | NbInformatives -> Format.fprintf fmt "nb_informatives()" + | NbBloquantes -> Format.fprintf fmt "nb_bloquantes()" + +let format_print_arg form_var fmt = function + | PrintString s -> Format.fprintf fmt "\"%s\"" s + | PrintName v -> Format.fprintf fmt "nom(%a)" (Pp.unmark form_var) v + | PrintAlias v -> Format.fprintf fmt "alias(%a)" (Pp.unmark form_var) v + | PrintIndent e -> + Format.fprintf fmt "indenter(%a)" + (Pp.unmark (format_expression form_var)) + e + | PrintExpr (e, min, max) -> + if min = max_int then + Format.fprintf fmt "(%a)" (Pp.unmark (format_expression form_var)) e + else if max = max_int then + Format.fprintf fmt "(%a):%d" + (Pp.unmark (format_expression form_var)) + e min + else + Format.fprintf fmt "(%a):%d..%d" + (Pp.unmark (format_expression form_var)) + e min max + +let format_formula_decl form_var fmt (v, idx, e) = + Format.fprintf fmt "%a" form_var (Pos.unmark v); + (match idx with + | Some vi -> + Format.fprintf fmt "[%a]" (format_expression form_var) (Pos.unmark vi) + | None -> ()); + Format.fprintf fmt " = %a" (format_expression form_var) (Pos.unmark e) + +let format_formula form_var fmt f = + match f with + | SingleFormula f -> format_formula_decl form_var fmt f + | MultipleFormulaes (lvs, f) -> + Format.fprintf fmt "pour %a\n%a" + (format_loop_variables form_var) + (Pos.unmark lvs) + (format_formula_decl form_var) + f + +let rec format_instruction form_var form_err = + let form_expr = format_expression form_var in + let form_instrs = format_instructions form_var form_err in + fun fmt instr -> + match instr with + | Affectation f -> Pp.unmark (format_formula form_var) fmt f + | IfThenElse (cond, t, []) -> + Format.fprintf fmt "if(%a):@\n@[ %a@]@\n" form_expr + (Pos.unmark cond) form_instrs t + | IfThenElse (cond, t, f) -> + Format.fprintf fmt "if(%a):@\n@[ %a@]else:@\n@[ %a@]@\n" + form_expr (Pos.unmark cond) form_instrs t form_instrs f + | WhenDoElse (wdl, ed) -> + let pp_wd th fmt (expr, dl, _) = + Format.fprintf fmt "@[%swhen (%a) do@\n%a@;@]" th form_expr + (Pos.unmark expr) form_instrs dl + in + let pp_wdl fmt wdl = + let rec aux th = function + | wd :: l -> + pp_wd th fmt wd; + aux "then_" l + | [] -> () + in + aux "" wdl + in + let pp_ed fmt (dl, _) = + Format.fprintf fmt "@[else_do@\n%a@;@]endwhen@;" form_instrs dl + in + Format.fprintf fmt "%a%a@\n" pp_wdl wdl pp_ed ed + | VerifBlock vb -> + Format.fprintf fmt + "@[# debut verif block@\n%a@]@\n# fin verif block@\n" form_instrs + vb + | ComputeDomain l -> + Format.fprintf fmt "calculer domaine %a;" + (Pp.list_space (Pp.unmark Pp.string)) + (Pos.unmark l) + | ComputeChaining ch -> + Format.fprintf fmt "calculer enchaineur %s;" (Pos.unmark ch) + | ComputeVerifs (l, expr) -> + Format.fprintf fmt "verifier %a : avec %a;" + (Pp.list_space (Pp.unmark Pp.string)) + (Pos.unmark l) (Pp.unmark form_expr) expr + | ComputeTarget (tname, targs) -> + Format.fprintf fmt "calculer cible %s : avec %a@," (Pos.unmark tname) + (Pp.list_comma (Pp.unmark form_var)) + targs + | Print (std, args) -> + let print_cmd = + match std with StdOut -> "afficher" | StdErr -> "afficher_erreur" + in + Format.fprintf fmt "%s %a;" print_cmd + (Pp.list_space (Pp.unmark (format_print_arg form_var))) + args + | Iterate (var, vars, var_params, itb) -> + let format_var_param fmt (vcs, expr) = + Format.fprintf fmt ": categorie %a : avec %a@\n" + (CatVar.Map.pp_keys ()) vcs form_expr (Pos.unmark expr) + in + Format.fprintf fmt "iterate variable %a@;: %a@;: %a@;: dans (" form_var + (Pos.unmark var) + (Pp.list_comma (Pp.unmark form_var)) + vars + (Pp.list_space format_var_param) + var_params; + Format.fprintf fmt "@[ %a@]@\n)@\n" form_instrs itb + | Restore (vars, var_params, rb) -> + let format_var_param fmt (var, vcs, expr) = + Format.fprintf fmt ": variable %a : categorie %a : avec %a@\n" + (Pp.unmark form_var) var (CatVar.Map.pp_keys ()) vcs form_expr + (Pos.unmark expr) + in + Format.fprintf fmt "restaure@;: %a@;: %a@;: apres (" + (Pp.list_comma (Pp.unmark form_var)) + vars + (Pp.list_space format_var_param) + var_params; + Format.fprintf fmt "@[ %a@]@\n)@\n" form_instrs rb + | RaiseError (err, var_opt) -> + Format.fprintf fmt "leve_erreur %a %s\n" form_err (Pos.unmark err) + (match var_opt with Some var -> " " ^ Pos.unmark var | None -> "") + | CleanErrors -> Format.fprintf fmt "nettoie_erreurs\n" + | ExportErrors -> Format.fprintf fmt "exporte_erreurs\n" + | FinalizeErrors -> Format.fprintf fmt "finalise_erreurs\n" + +and format_instructions form_var form_err fmt instrs = + Pp.list "" (Pp.unmark (format_instruction form_var form_err)) fmt instrs diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli new file mode 100644 index 000000000..4328537c4 --- /dev/null +++ b/src/mlang/m_ir/com.mli @@ -0,0 +1,387 @@ +module CatVar : sig + type t = Input of StrSet.t | Computed of { is_base : bool } + + val pp : Format.formatter -> t -> unit + + val compare : t -> t -> int + + module Set : SetExt.T with type elt = t + + module Map : sig + include MapExt.T with type key = t + + val from_string_list : string Pos.marked list Pos.marked -> Pos.t t + end + + type loc = LocComputed | LocBase | LocInput + + type data = { + id : t; + id_str : string; + id_int : int; + loc : loc; + pos : Pos.t; + attributs : Pos.t StrMap.t; + } +end + +(** Here are all the types a value can have. Date types don't seem to be used at + all though. *) +type value_typ = + | Boolean + | DateYear + | DateDayMonthYear + | DateMonth + | Integer + | Real + +type loc_tgv = { + loc_id : string; + loc_cat : CatVar.loc; + loc_idx : int; + loc_cat_id : CatVar.t; + loc_cat_str : string; + loc_cat_idx : int; + loc_int : int; +} + +type loc = + | LocTgv of string * loc_tgv + | LocTmp of string * int + | LocRef of string * int + | LocArg of string * int + | LocRes of string + +module Var : sig + type id = int + + type tgv = { + is_table : int option; + alias : string Pos.marked option; (** Input variable have an alias *) + descr : string Pos.marked; + (** Description taken from the variable declaration *) + attrs : int Pos.marked StrMap.t; + cat : CatVar.t; + is_given_back : bool; + typ : value_typ option; + } + + type scope = Tgv of tgv | Temp of int option | Ref | Arg | Res + + type t = { + name : string Pos.marked; (** The position is the variable declaration *) + id : id; + loc : loc; + scope : scope; + } + + val tgv : t -> tgv + + val name : t -> string Pos.marked + + val name_str : t -> string + + val is_table : t -> int option + + val cat_var_loc : t -> CatVar.loc option + + val size : t -> int + + val alias : t -> string Pos.marked option + + val alias_str : t -> string + + val descr : t -> string Pos.marked + + val descr_str : t -> string + + val attrs : t -> int Pos.marked StrMap.t + + val cat : t -> CatVar.t + + val is_given_back : t -> bool + + val loc_tgv : t -> loc_tgv + + val loc_int : t -> int + + val is_temp : t -> bool + + val is_ref : t -> bool + + val is_arg : t -> bool + + val is_res : t -> bool + + val init_loc : CatVar.t -> loc_tgv + + val new_tgv : + name:string Pos.marked -> + is_table:int option -> + is_given_back:bool -> + alias:string Pos.marked option -> + descr:string Pos.marked -> + attrs:int Pos.marked StrMap.t -> + cat:CatVar.t -> + typ:value_typ option -> + t + + val new_temp : + name:string Pos.marked -> is_table:int option -> loc_int:int -> t + + val new_ref : name:string Pos.marked -> loc_int:int -> t + + val new_arg : name:string Pos.marked -> loc_int:int -> t + + val new_res : name:string Pos.marked -> t + + val pp : Format.formatter -> t -> unit + + val compare : t -> t -> int + + module Set : SetExt.T with type elt = t + + module Map : sig + include MapExt.T with type key = t + end + + (* val compare_name_ref : (string -> string -> int) ref + + val compare_name : string -> string -> int*) +end + +module DomainId : StrSet.T + +module DomainIdSet : + SetSetExt.T with type base_elt = string and type elt = DomainId.t + +module DomainIdMap : MapExt.T with type key = DomainId.t + +type 'a domain = { + dom_id : DomainId.t Pos.marked; + dom_names : Pos.t DomainIdMap.t; + dom_by_default : bool; + dom_min : DomainIdSet.t; + dom_max : DomainIdSet.t; + dom_rov : IntSet.t; + dom_data : 'a; + dom_used : int Pos.marked option; +} + +type rule_domain_data = { rdom_computable : bool } + +type rule_domain = rule_domain_data domain + +type verif_domain_data = { + vdom_auth : Pos.t CatVar.Map.t; + vdom_verifiable : bool; +} + +type verif_domain = verif_domain_data domain + +module TargetMap : StrMap.T + +type literal = Float of float | Undefined + +(** The M language has an extremely odd way to specify looping. Rather than + having first-class local mutable variables whose value change at each loop + iteration, the M language prefers to use the changing loop parameter to + instantiate the variable names inside the loop. For instance, + + {v somme(i=1..10:Xi) v} + + should evaluate to the sum of variables [X1], [X2], etc. Parameters can be + number or characters and there can be multiple of them. We have to store all + this information. *) + +(** Values that can be substituted for loop parameters *) +type 'v atom = AtomVar of 'v | AtomLiteral of literal + +type 'v set_value_loop = + | Single of 'v atom Pos.marked + | Range of 'v atom Pos.marked * 'v atom Pos.marked + | Interval of 'v atom Pos.marked * 'v atom Pos.marked + +type 'v loop_variable = char Pos.marked * 'v set_value_loop list +(** A loop variable is the character that should be substituted in variable + names inside the loop plus the set of value to substitute. *) + +(** There are two kind of loop variables declaration, but they are semantically + the same though they have different concrete syntax. *) +type 'v loop_variables = + | ValueSets of 'v loop_variable list + | Ranges of 'v loop_variable list + +(** Unary operators *) +type unop = Not | Minus + +(** Binary operators *) +type binop = And | Or | Add | Sub | Mul | Div + +(** Comparison operators *) +type comp_op = Gt | Gte | Lt | Lte | Eq | Neq + +type 'v set_value = + | FloatValue of float Pos.marked + | VarValue of 'v Pos.marked + | Interval of int Pos.marked * int Pos.marked + +type func = + | SumFunc (** Sums the arguments *) + | AbsFunc (** Absolute value *) + | MinFunc (** Minimum of a list of values *) + | MaxFunc (** Maximum of a list of values *) + | GtzFunc (** Greater than zero (strict) ? *) + | GtezFunc (** Greater or equal than zero ? *) + | NullFunc (** Equal to zero ? *) + | ArrFunc (** Round to nearest integer *) + | InfFunc (** Truncate to integer *) + | PresentFunc (** Different than zero ? *) + | Multimax (** ??? *) + | Supzero (** ??? *) + | VerifNumber + | ComplNumber + | Func of string + +type 'v expression = + | TestInSet of bool * 'v m_expression * 'v set_value list + (** Test if an expression is in a set of value (or not in the set if the + flag is set to [false]) *) + | Unop of unop * 'v m_expression + | Comparison of comp_op Pos.marked * 'v m_expression * 'v m_expression + | Binop of binop Pos.marked * 'v m_expression * 'v m_expression + | Index of 'v Pos.marked * 'v m_expression + | Conditional of 'v m_expression * 'v m_expression * 'v m_expression option + | FuncCall of func Pos.marked * 'v m_expression list + | FuncCallLoop of + func Pos.marked * 'v loop_variables Pos.marked * 'v m_expression + | Literal of literal + | Var of 'v + | Loop of 'v loop_variables Pos.marked * 'v m_expression + (** The loop is prefixed with the loop variables declarations *) + | NbCategory of Pos.t CatVar.Map.t + | Attribut of 'v Pos.marked * string Pos.marked + | Size of 'v Pos.marked + | NbAnomalies + | NbDiscordances + | NbInformatives + | NbBloquantes + +and 'v m_expression = 'v expression Pos.marked + +module Error : sig + type typ = Anomaly | Discordance | Information + + val compare_typ : typ -> typ -> int + + type t = { + name : string Pos.marked; (** The position is the variable declaration *) + kind : string Pos.marked; + major_code : string Pos.marked; + minor_code : string Pos.marked; + description : string Pos.marked; + isisf : string Pos.marked; + typ : typ; + } + + val pp_descr : Pp.t -> t -> unit + + val compare : t -> t -> int +end + +type print_std = StdOut | StdErr + +type 'v print_arg = + | PrintString of string + | PrintName of 'v Pos.marked + | PrintAlias of 'v Pos.marked + | PrintIndent of 'v m_expression + | PrintExpr of 'v m_expression * int * int + +(** In the M language, you can define multiple variables at once. This is the + way they do looping since the definition can depend on the loop variable + value (e.g [Xi] can depend on [i]). *) + +type 'v formula_loop = 'v loop_variables Pos.marked + +type 'v formula_decl = 'v Pos.marked * 'v m_expression option * 'v m_expression + +type 'v formula = + | SingleFormula of 'v formula_decl + | MultipleFormulaes of 'v formula_loop * 'v formula_decl + +type ('v, 'e) instruction = + | Affectation of 'v formula Pos.marked + | IfThenElse of + 'v m_expression + * ('v, 'e) m_instruction list + * ('v, 'e) m_instruction list + | WhenDoElse of + ('v m_expression * ('v, 'e) m_instruction list * Pos.t) list + * ('v, 'e) m_instruction list Pos.marked + | ComputeDomain of string Pos.marked list Pos.marked + | ComputeChaining of string Pos.marked + | ComputeVerifs of string Pos.marked list Pos.marked * 'v m_expression + | ComputeTarget of string Pos.marked * 'v Pos.marked list + | VerifBlock of ('v, 'e) m_instruction list + | Print of print_std * 'v print_arg Pos.marked list + | Iterate of + 'v Pos.marked + * 'v Pos.marked list + * (Pos.t CatVar.Map.t * 'v m_expression) list + * ('v, 'e) m_instruction list + | Restore of + 'v Pos.marked list + * ('v Pos.marked * Pos.t CatVar.Map.t * 'v m_expression) list + * ('v, 'e) m_instruction list + | RaiseError of 'e Pos.marked * string Pos.marked option + | CleanErrors + | ExportErrors + | FinalizeErrors + +and ('v, 'e) m_instruction = ('v, 'e) instruction Pos.marked + +val set_loc_int : loc -> int -> loc + +val set_loc_tgv_cat : loc -> CatVar.loc -> string -> int -> loc + +val set_loc_tgv_idx : loc -> int -> loc + +val format_value_typ : Pp.t -> value_typ -> unit + +val format_literal : Pp.t -> literal -> unit + +val format_atom : (Pp.t -> 'v -> unit) -> Pp.t -> 'v atom -> unit + +val format_loop_variables : + (Pp.t -> 'v -> unit) -> Pp.t -> 'v loop_variables -> unit + +val format_unop : Pp.t -> unop -> unit + +val format_binop : Pp.t -> binop -> unit + +val format_comp_op : Pp.t -> comp_op -> unit + +val format_set_value : (Pp.t -> 'v -> unit) -> Pp.t -> 'v set_value -> unit + +val format_func : Pp.t -> func -> unit + +val format_expression : (Pp.t -> 'v -> unit) -> Pp.t -> 'v expression -> unit + +val format_print_arg : (Pp.t -> 'v -> unit) -> Pp.t -> 'v print_arg -> unit + +val format_formula : (Pp.t -> 'v -> unit) -> Pp.t -> 'v formula -> unit + +val format_instruction : + (Pp.t -> 'v -> unit) -> + (Pp.t -> 'e -> unit) -> + Pp.t -> + ('v, 'e) instruction -> + unit + +val format_instructions : + (Pp.t -> 'v -> unit) -> + (Pp.t -> 'e -> unit) -> + Pp.t -> + ('v, 'e) m_instruction list -> + unit diff --git a/src/mlang/m_ir/format_mir.ml b/src/mlang/m_ir/format_mir.ml index 8260d95a8..55c1c855a 100644 --- a/src/mlang/m_ir/format_mir.ml +++ b/src/mlang/m_ir/format_mir.ml @@ -14,126 +14,14 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -open Mir +let format_variable fmt (var : Com.Var.t) = + Format.fprintf fmt "%s" (Pos.unmark var.name) -let format_typ fmt (t : typ) = - Format.pp_print_string fmt (match t with Real -> "real") +let format_expression = Com.format_expression format_variable -let format_func fmt (f : func) = - Format.pp_print_string fmt - (match f with - | SumFunc -> "somme" - | AbsFunc -> "abs" - | MinFunc -> "min" - | MaxFunc -> "max" - | GtzFunc -> "positif" - | GtezFunc -> "positif_ou_nul" - | NullFunc -> "null" - | ArrFunc -> "arr" - | InfFunc -> "inf" - | PresentFunc -> "present" - | Multimax -> "multimax" - | Supzero -> "supzero" - | VerifNumber -> "numero_verif" - | ComplNumber -> "numero_compl") +let format_error fmt (err : Com.Error.t) = + Format.fprintf fmt "erreur %s (%a)" (Pos.unmark err.name) Com.Error.pp_descr + err -let format_literal fmt (l : literal) = - Format.pp_print_string fmt - (match l with Float f -> string_of_float f | Undefined -> "indéfini") - -let rec format_expression fmt (e : expression) = - match e with - | Comparison ((op, _), (e1, _), (e2, _)) -> - Format.fprintf fmt "(%a %a %a)" format_expression e1 - Format_mast.format_comp_op op format_expression e2 - | Binop ((op, _), (e1, _), (e2, _)) -> - Format.fprintf fmt "(%a %a %a)" format_expression e1 - Format_mast.format_binop op format_expression e2 - | Unop (op, (e, _)) -> - Format.fprintf fmt "%a %a" Format_mast.format_unop op format_expression e - | Conditional ((e1, _), (e2, _), (e3, _)) -> - Format.fprintf fmt "(si %a alors %a sinon %a)" format_expression e1 - format_expression e2 format_expression e3 - | FunctionCall (f, args) -> - Format.fprintf fmt "%a(%a)" format_func f - (Format_mast.pp_print_list_comma - (Format_mast.pp_unmark format_expression)) - args - | Literal lit -> format_literal fmt lit - | Var var -> Format.fprintf fmt "%s" (Pos.unmark var.Variable.name) - | LocalVar lvar -> Format.fprintf fmt "t%d" lvar.LocalVariable.id - | LocalLet (lvar, (e1, _), (e2, _)) -> - Format.fprintf fmt "soit t%d = (%a) dans %a" lvar.LocalVariable.id - format_expression e1 format_expression e2 - | Index (var, i) -> - Format.fprintf fmt "%s[%a]" - (Pos.unmark (Pos.unmark var).Variable.name) - format_expression (Pos.unmark i) - | NbCategory cats -> - Format.fprintf fmt "nb_categorie(%a)" (Mir.CatVarSet.pp ()) cats - | Attribut (v, _, a) -> - Format.fprintf fmt "attribut(%s, %s)" (Pos.unmark v) (Pos.unmark a) - | Size var -> Format.fprintf fmt "taille(%s)" (Pos.unmark var.name) - | NbAnomalies -> Format.fprintf fmt "nb_anomalies()" - | NbDiscordances -> Format.fprintf fmt "nb_discordances()" - | NbInformatives -> Format.fprintf fmt "nb_informatives()" - | NbBloquantes -> Format.fprintf fmt "nb_bloquantes()" - -let format_variable_def fmt (def : variable_def) = - match def with - | SimpleVar e -> Format.fprintf fmt "%a@\n" format_expression (Pos.unmark e) - | InputVar -> Format.fprintf fmt "[User input]@\n" - | TableVar (_, IndexGeneric (v, e)) -> - Format.fprintf fmt "%s -> %a@\n" - (Pos.unmark v.Variable.name) - format_expression (Pos.unmark e) - | TableVar (_, IndexTable defs) -> - IndexMap.pp (Format_mast.pp_unmark format_expression) fmt defs - -let format_variable_data fmt (def : variable_data) = - Format.fprintf fmt "type %a:\n%a" - (fun fmt () -> - match def.var_typ with - | None -> Format.fprintf fmt "unknown" - | Some t -> format_typ fmt t) - () format_variable_def def.var_definition - -let format_variables fmt (p : variable_data VariableMap.t) = - VariableMap.pp format_variable_data fmt p - -let format_error fmt (e : Error.t) = - Format.fprintf fmt "erreur %s (%s)" (Pos.unmark e.Error.name) - (Error.err_descr_string e |> Pos.unmark) - -let format_precondition fmt (precond : condition_data) = - Format.fprintf fmt "Précondition : %a\nSinon %a%a" format_expression - (Pos.unmark precond.cond_expr) - format_error (fst precond.cond_error) - (Format.pp_print_option (fun fmt v -> - Format.fprintf fmt " (%s)" (Pos.unmark v.Variable.name))) - (snd precond.cond_error) - -let format_program_rules fmt (vars : VariableDict.t) - (rules : rule_data RuleMap.t) = - RuleMap.iter - (fun _ { rule_vars; rule_number; _ } -> - let var_defs = - List.fold_left - (fun var_defs instr -> - match Pos.unmark instr with - | Mir.Affectation (vid, def) -> - let var = VariableDict.find vid vars in - VariableMap.add var def var_defs - | _ -> assert false - (* never used *)) - VariableMap.empty rule_vars - in - Format.fprintf fmt "Regle %d\n%a\n" - (num_of_rule_or_verif_id (Pos.unmark rule_number)) - format_variables var_defs) - rules - -let format_variable fmt (v : Variable.t) = - Format.fprintf fmt "%s: %s" - (Pos.unmark v.Variable.name) - (Pos.unmark v.Variable.descr) +let format_variable fmt (v : Com.Var.t) = + Format.fprintf fmt "%s: %s" (Pos.unmark v.name) (Com.Var.descr_str v) diff --git a/src/mlang/m_ir/format_mir.mli b/src/mlang/m_ir/format_mir.mli index ccc64033f..c74ce230a 100644 --- a/src/mlang/m_ir/format_mir.mli +++ b/src/mlang/m_ir/format_mir.mli @@ -14,26 +14,8 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -val format_typ : Format.formatter -> Mir.typ -> unit +val format_expression : Pp.t -> Mir.expression -> unit -val format_func : Format.formatter -> Mir.func -> unit +val format_error : Pp.t -> Com.Error.t -> unit -val format_literal : Format.formatter -> Mir.literal -> unit - -val format_expression : Format.formatter -> Mir.expression -> unit - -val format_variable_def : Format.formatter -> Mir.variable_def -> unit - -val format_variable_data : Format.formatter -> Mir.variable_data -> unit - -val format_variables : - Format.formatter -> Mir.variable_data Mir.VariableMap.t -> unit - -val format_error : Format.formatter -> Mir.Error.t -> unit - -val format_precondition : Format.formatter -> Mir.condition_data -> unit - -val format_program_rules : - Format.formatter -> Mir.VariableDict.t -> Mir.rule_data Mir.RuleMap.t -> unit - -val format_variable : Format.formatter -> Mir.Variable.t -> unit +val format_variable : Pp.t -> Com.Var.t -> unit diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index 469fa02bf..c58b70058 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -20,576 +20,58 @@ (** Variables are first-class objects *) -type cat_computed = Base | GivenBack +type set_value = Com.Var.t Com.set_value -let pp_cat_computed fmt = function - | Base -> Format.fprintf fmt "base" - | GivenBack -> Format.fprintf fmt "restituee" - -module CatCompSet = struct - include SetExt.Make (struct - type t = cat_computed - - let compare = compare - end) - - let pp ?(sep = " ") ?(pp_elt = pp_cat_computed) (_ : unit) - (fmt : Format.formatter) (set : t) : unit = - pp ~sep ~pp_elt () fmt set -end - -type cat_variable = CatInput of StrSet.t | CatComputed of CatCompSet.t - -let pp_cat_variable fmt = function - | CatInput id -> - let pp fmt set = StrSet.iter (Format.fprintf fmt " %s") set in - Format.fprintf fmt "saisie%a" pp id - | CatComputed id -> - let pp fmt set = - CatCompSet.iter (Format.fprintf fmt " %a" pp_cat_computed) set - in - Format.fprintf fmt "calculee%a" pp id - -let compare_cat_variable a b = - match (a, b) with - | CatInput _, CatComputed _ -> 1 - | CatComputed _, CatInput _ -> -1 - | CatInput id0, CatInput id1 -> StrSet.compare id0 id1 - | CatComputed c0, CatComputed c1 -> CatCompSet.compare c0 c1 - -module CatVarSet = struct - include SetExt.Make (struct - type t = cat_variable - - let compare = compare_cat_variable - end) - - let pp ?(sep = ", ") ?(pp_elt = pp_cat_variable) (_ : unit) - (fmt : Format.formatter) (set : t) : unit = - pp ~sep ~pp_elt () fmt set -end - -module CatVarMap = struct - include MapExt.Make (struct - type t = cat_variable - - let compare = compare_cat_variable - end) - - let pp ?(sep = "; ") ?(pp_key = pp_cat_variable) ?(assoc = " => ") - (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) - (map : 'a t) : unit = - pp ~sep ~pp_key ~assoc pp_val fmt map -end - -type cat_variable_loc = LocCalculated | LocBase | LocInput - -type cat_variable_data = { - id : cat_variable; - id_str : string; - id_int : int; - loc : cat_variable_loc; - pos : Pos.t; - attributs : Pos.t StrMap.t; -} - -type variable_id = int -(** Each variable has an unique ID *) - -type variable = { - name : string Pos.marked; (** The position is the variable declaration *) - alias : string option; (** Input variable have an alias *) - id : variable_id; - descr : string Pos.marked; - (** Description taken from the variable declaration *) - attributes : Mast.variable_attribute list; - origin : variable option; - (** If the variable is an SSA duplication, refers to the original - (declared) variable *) - cats : cat_variable option; - is_table : int option; - is_temp : bool; - is_it : bool; -} - -module Variable = struct - type id = variable_id - - type t = variable = { - name : string Pos.marked; (** The position is the variable declaration *) - alias : string option; (** Input variable have an alias *) - id : variable_id; - descr : string Pos.marked; - (** Description taken from the variable declaration *) - attributes : Mast.variable_attribute list; - origin : variable option; - (** If the variable is an SSA duplication, refers to the original - (declared) variable *) - cats : cat_variable option; - is_table : int option; - is_temp : bool; - is_it : bool; - } - - let fresh_id : unit -> id = - let counter : int ref = ref 0 in - fun () -> - let v = !counter in - counter := !counter + 1; - v - - let new_var (name : string Pos.marked) (alias : string option) - (descr : string Pos.marked) ~(attributes : Mast.variable_attribute list) - ~(origin : t option) ~(cats : cat_variable option) - ~(is_table : int option) ~(is_temp : bool) ~(is_it : bool) : t = - { - name; - id = fresh_id (); - descr; - alias; - attributes; - origin; - cats; - is_table; - is_temp; - is_it; - } - - let compare (var1 : t) (var2 : t) = compare var1.id var2.id -end - -(** Local variables don't appear in the M source program but can be introduced - by let bindings when translating to MIR. They should be De Bruijn indices - but instead are unique globals identifiers out of laziness. *) - -type local_variable = { id : int } - -module LocalVariable = struct - type t = local_variable = { id : int } - - let counter : int ref = ref 0 - - let fresh_id () : int = - let v = !counter in - counter := !counter + 1; - v - - let new_var () : t = { id = fresh_id () } - - let compare (var1 : t) (var2 : t) = compare var1.id var2.id -end - -(** Type of MIR values *) -type typ = Real - -type literal = Float of float | Undefined - -let false_literal = Float 0. - -let true_literal = Float 1. - -(** MIR only supports a restricted set of functions *) -type func = - | SumFunc (** Sums the arguments *) - | AbsFunc (** Absolute value *) - | MinFunc (** Minimum of a list of values *) - | MaxFunc (** Maximum of a list of values *) - | GtzFunc (** Greater than zero (strict) ? *) - | GtezFunc (** Greater or equal than zero ? *) - | NullFunc (** Equal to zero ? *) - | ArrFunc (** Round to nearest integer *) - | InfFunc (** Truncate to integer *) - | PresentFunc (** Different than zero ? *) - | Multimax (** ??? *) - | Supzero (** ??? *) - | VerifNumber - | ComplNumber - -(** MIR expressions are simpler than M; there are no loops or syntaxtic sugars. - Because M lets you define conditional without an else branch although it is - an expression-based language, we include an [Error] constructor to which the - missing else branch is translated to. - - Because translating to MIR requires a lot of unrolling and expansion, we - introduce a [LocalLet] construct to avoid code duplication. *) - -type 'variable expression_ = - | Unop of (Mast.unop[@opaque]) * 'variable expression_ Pos.marked - | Comparison of - (Mast.comp_op[@opaque]) Pos.marked - * 'variable expression_ Pos.marked - * 'variable expression_ Pos.marked - | Binop of - (Mast.binop[@opaque]) Pos.marked - * 'variable expression_ Pos.marked - * 'variable expression_ Pos.marked - | Index of 'variable Pos.marked * 'variable expression_ Pos.marked - | Conditional of - 'variable expression_ Pos.marked - * 'variable expression_ Pos.marked - * 'variable expression_ Pos.marked - | FunctionCall of (func[@opaque]) * 'variable expression_ Pos.marked list - | Literal of (literal[@opaque]) - | Var of 'variable - | LocalVar of (LocalVariable.t[@opaque]) - | LocalLet of - (LocalVariable.t[@opaque]) - * 'variable expression_ Pos.marked - * 'variable expression_ Pos.marked - | NbCategory of CatVarSet.t - | Attribut of string Pos.marked * 'variable * string Pos.marked - | Size of 'variable - | NbAnomalies - | NbDiscordances - | NbInformatives - | NbBloquantes - -type expression = variable expression_ - -let rec map_expr_var (f : 'v -> 'v2) (e : 'v expression_) : 'v2 expression_ = - let map = Pos.map_under_mark (map_expr_var f) in - match (e :> 'v expression_) with - | Unop (op, e) -> Unop (op, map e) - | Comparison (op, e1, e2) -> Comparison (op, map e1, map e2) - | Binop (op, e1, e2) -> Binop (op, map e1, map e2) - | Index ((v, pos), e) -> Index ((f v, pos), map e) - | Conditional (e1, e2, e3) -> Conditional (map e1, map e2, map e3) - | FunctionCall (func, es) -> FunctionCall (func, List.map map es) - | Var v -> Var (f v) - | LocalLet (v, e1, e2) -> LocalLet (v, map e1, map e2) - | Literal l -> Literal l - | LocalVar v -> LocalVar v - | NbCategory l -> NbCategory l - | Attribut (v, var, a) -> Attribut (v, f var, a) - | Size var -> Size (f var) - | NbAnomalies -> NbAnomalies - | NbDiscordances -> NbDiscordances - | NbInformatives -> NbInformatives - | NbBloquantes -> NbBloquantes - -let rec fold_expr_var (f : 'a -> 'v -> 'a) (acc : 'a) (e : 'v expression_) : 'a - = - let fold acc e = fold_expr_var f acc (Pos.unmark e) in - match (e :> 'v expression_) with - | Unop (_, e) -> fold acc e - | Comparison (_, e1, e2) | Binop (_, e1, e2) | LocalLet (_, e1, e2) -> - fold (fold acc e1) e2 - | Index ((v, _), e) -> fold (f acc v) e - | Conditional (e1, e2, e3) -> fold (fold (fold acc e1) e2) e3 - | FunctionCall (_, es) -> List.fold_left fold acc es - | Var v -> f acc v - | Literal _ | LocalVar _ | NbCategory _ | Attribut _ | Size _ | NbAnomalies - | NbDiscordances | NbInformatives | NbBloquantes -> - acc - -(** MIR programs are just mapping from variables to their definitions, and make - a massive use of [VariableMap]. *) -module VariableMap = struct - include MapExt.Make (Variable) - - let pp_key fmt key = - Format.fprintf fmt "Variable %s%s" - (Pos.unmark key.Variable.name) - (match key.Variable.alias with - | Some x -> " (alias " ^ x ^ ")" - | None -> "") - - let pp ?(sep = ", ") ?(pp_key = pp_key) ?(assoc = " -> ") - (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) - (map : 'a t) : unit = - pp ~sep ~pp_key ~assoc pp_val fmt map -end - -(* module VariableDictMap = MapExt.Make (struct - * type t = Variable.id - * - * let compare = compare - * end) - * - * type variable_dict = variable VariableDictMap.t *) - -(** Variable dictionary, act as a set but refered by keys *) -module VariableDict = Dict.Make (struct - type t = Variable.id - - type elt = Variable.t - - let key_of_elt v = v.Variable.id - - let compare = compare -end) - -module VariableSet = SetExt.Make (Variable) - -module LocalVariableMap = struct - include MapExt.Make (LocalVariable) - - let pp_key fmt key = Format.fprintf fmt "%d" key.id - - let pp ?(sep = ", ") ?(pp_key = pp_key) ?(assoc = " -> ") - (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) - (map : 'a t) : unit = - pp ~sep ~pp_key ~assoc pp_val fmt map -end - -(** This map is used to store the definitions of all the cells of a table - variable that is not not defined generically *) -module IndexMap = struct - include IntMap - - let pp ?(sep = ", ") ?(pp_key = Format.pp_print_int) ?(assoc = " -> ") - (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) - (map : 'a t) : unit = - pp ~sep ~pp_key ~assoc pp_val fmt map -end - -type 'variable index_def = - | IndexTable of - ('variable expression_ Pos.marked IndexMap.t[@name "index_map"]) - | IndexGeneric of 'variable * 'variable expression_ Pos.marked +type expression = Com.Var.t Com.expression (** The definitions here are modeled closely to the source M language. One could also adopt a more lambda-calculus-compatible model with functions used to model tables. *) -type 'variable variable_def_ = - | SimpleVar of 'variable expression_ Pos.marked - | TableVar of int * 'variable index_def - | InputVar - -let map_var_def_var (f : 'v -> 'v2) (vdef : 'v variable_def_) : - 'v2 variable_def_ = - let map_expr = Pos.map_under_mark (map_expr_var f) in - match vdef with - | InputVar -> InputVar - | SimpleVar e -> SimpleVar (map_expr e) - | TableVar (i, idef) -> - let idef = - match idef with - | IndexTable idx_map -> IndexTable (IndexMap.map map_expr idx_map) - | IndexGeneric (v, e) -> IndexGeneric (f v, map_expr e) - in - TableVar (i, idef) - -type variable_def = variable variable_def_ - -type 'variable variable_data_ = { - var_definition : 'variable variable_def_; - var_typ : typ option; - (** The typing info here comes from the variable declaration in the source - program *) -} - -type variable_data = variable variable_data_ - -type rov_id = RuleID of int | VerifID of int - -let num_of_rule_or_verif_id = function RuleID n | VerifID n -> n - -let fresh_rule_num = - let count = ref 0 in - fun () -> - let n = !count in - incr count; - n - -(** Special rule id for initial definition of variables *) -let initial_undef_rule_id = RuleID (-1) - -type 'a domain = { - dom_id : Mast.DomainId.t Pos.marked; - dom_names : Pos.t Mast.DomainIdMap.t; - dom_by_default : bool; - dom_min : Mast.DomainIdSet.t; - dom_max : Mast.DomainIdSet.t; - dom_rov : IntSet.t; - dom_data : 'a; - dom_used : int Pos.marked option; -} - -type rule_domain_data = { rdom_computable : bool } -type rule_domain = rule_domain_data domain +type instruction = (Com.Var.t, Com.Error.t) Com.instruction -type 'variable print_arg = - | PrintString of string - | PrintName of string Pos.marked * variable - | PrintAlias of string Pos.marked * variable - | PrintIndent of 'variable expression_ Pos.marked - | PrintExpr of 'variable expression_ Pos.marked * int * int - -type error_descr = { - kind : string Pos.marked; - major_code : string Pos.marked; - minor_code : string Pos.marked; - description : string Pos.marked; - isisf : string Pos.marked; -} -(** Errors are first-class objects *) - -type error = { - name : string Pos.marked; (** The position is the variable declaration *) - id : int; (** Each variable has an unique ID *) - descr : error_descr; (** Description taken from the variable declaration *) - typ : Mast.error_typ; -} - -module Error = struct - type descr = error_descr = { - kind : string Pos.marked; - major_code : string Pos.marked; - minor_code : string Pos.marked; - description : string Pos.marked; - isisf : string Pos.marked; - } - - type t = error = { - name : string Pos.marked; (** The position is the variable declaration *) - id : int; (** Each variable has an unique ID *) - descr : error_descr; (** Description taken from the variable declaration *) - typ : Mast.error_typ; - } - - let counter : int ref = ref 0 - - let fresh_id () : int = - let v = !counter in - counter := !counter + 1; - v - - let mast_error_desc_to_ErrorDesc (error : Mast.error_) = - { - kind = List.nth error.error_descr 0; - major_code = List.nth error.error_descr 1; - minor_code = List.nth error.error_descr 2; - description = List.nth error.error_descr 3; - isisf = - (match List.nth_opt error.error_descr 4 with - | Some s -> s - | None -> ("", Pos.no_pos)); - } - - let new_error (name : string Pos.marked) (error : Mast.error_) - (error_typ : Mast.error_typ) : t = - { - name; - id = fresh_id (); - descr = error |> mast_error_desc_to_ErrorDesc; - typ = error_typ; - } - - let err_descr_string (err : t) = - Pos.same_pos_as - (String.concat ":" - [ - err.descr.kind |> Pos.unmark; - err.descr.major_code |> Pos.unmark; - err.descr.minor_code |> Pos.unmark; - err.descr.description |> Pos.unmark; - err.descr.isisf |> Pos.unmark; - ]) - err.name - - let compare (var1 : t) (var2 : t) = compare var1.id var2.id -end - -type instruction = - | Affectation of variable_id * variable_data - | IfThenElse of - expression * instruction Pos.marked list * instruction Pos.marked list - | ComputeTarget of string Pos.marked - | VerifBlock of instruction Pos.marked list - | Print of Mast.print_std * variable print_arg Pos.marked list - | Iterate of - variable_id - * CatVarSet.t - * expression Pos.marked - * instruction Pos.marked list - | Restore of - Pos.t VariableMap.t - * (variable * CatVarSet.t * expression Pos.marked) list - * instruction Pos.marked list - | RaiseError of error * string option - | CleanErrors - | ExportErrors - | FinalizeErrors - -type rule_data = { - rule_apps : Pos.t StrMap.t; - rule_domain : rule_domain; - rule_chain : (string * rule_domain) option; - rule_vars : instruction Pos.marked list; - rule_number : rov_id Pos.marked; -} - -module RuleMap = MapExt.Make (struct - type t = rov_id - - let compare = compare -end) - -module TargetMap = StrMap +type m_instruction = instruction Pos.marked type target_data = { target_name : string Pos.marked; target_file : string option; - target_apps : string Pos.marked list; - target_tmp_vars : (variable * Pos.t * int option) StrMap.t; - target_prog : instruction Pos.marked list; + target_apps : string Pos.marked StrMap.t; + target_args : (Com.Var.t * Pos.t) list; + target_result : (Com.Var.t * Pos.t) option; + target_tmp_vars : (Com.Var.t * Pos.t * int option) StrMap.t; + target_nb_tmps : int; + target_sz_tmps : int; + target_nb_refs : int; + target_prog : m_instruction list; } -(**{1 Verification conditions}*) - -type verif_domain_data = { vdom_auth : CatVarSet.t; vdom_verifiable : bool } - -type verif_domain = verif_domain_data domain - -type 'variable condition_data_ = { - cond_seq_id : int; - cond_number : rov_id Pos.marked; - cond_domain : verif_domain; - cond_expr : 'variable expression_ Pos.marked; - cond_error : (Error.t[@opaque]) * 'variable option; - cond_cats : int CatVarMap.t; +type stats = { + nb_calculated : int; + nb_base : int; + nb_input : int; + nb_vars : int; + nb_all_tmps : int; + nb_all_refs : int; + sz_calculated : int; + sz_base : int; + sz_input : int; + sz_vars : int; + sz_all_tmps : int; } -let map_cond_data_var (f : 'v -> 'v2) (cond : 'v condition_data_) : - 'v2 condition_data_ = - { - cond_seq_id = cond.cond_seq_id; - cond_number = cond.cond_number; - cond_domain = cond.cond_domain; - cond_expr = Pos.map_under_mark (map_expr_var f) cond.cond_expr; - cond_error = - (let e, v = cond.cond_error in - (e, Option.map f v)); - cond_cats = cond.cond_cats; - } - -let cond_cats_to_set cats = - CatVarMap.fold - (fun cv nb res -> if nb > 0 then CatVarSet.add cv res else res) - cats CatVarSet.empty - -type condition_data = variable condition_data_ - -type idmap = Variable.t Pos.VarNameToID.t -(** We translate string variables into first-class unique {!type: - Mir.Variable.t}, so we need to keep a mapping between the two. A name is - mapped to a list of variables because variables can be redefined in - different rules *) - type program = { program_safe_prefix : string; program_applications : Pos.t StrMap.t; - program_var_categories : cat_variable_data CatVarMap.t; - program_rule_domains : rule_domain Mast.DomainIdMap.t; - program_verif_domains : verif_domain Mast.DomainIdMap.t; - program_chainings : rule_domain Mast.ChainingMap.t; - program_vars : VariableDict.t; + program_var_categories : Com.CatVar.data Com.CatVar.Map.t; + program_rule_domains : Com.rule_domain Com.DomainIdMap.t; + program_verif_domains : Com.verif_domain Com.DomainIdMap.t; + program_vars : Com.Var.t StrMap.t; (** A static register of all variables that can be used during a calculation *) - program_targets : target_data TargetMap.t; - program_idmap : idmap; + program_functions : target_data Com.TargetMap.t; + program_targets : target_data Com.TargetMap.t; + program_main_target : string; + program_stats : stats; } (** {1 Helpers}*) @@ -597,12 +79,13 @@ type program = { (** Throws an error in case of alias not found *) let find_var_name_by_alias (p : program) (alias : string Pos.marked) : string = let v = - VariableDict.fold - (fun v acc -> - match (acc, v.Variable.alias) with + StrMap.fold + (fun _ v acc -> + match (acc, Com.Var.alias v) with | Some _, _ | None, None -> acc | None, Some v_alias -> - if v_alias = Pos.unmark alias then Some (Pos.unmark v.Variable.name) + if Pos.unmark v_alias = Pos.unmark alias then + Some (Pos.unmark v.name) else None) p.program_vars None in @@ -613,45 +96,18 @@ let find_var_name_by_alias (p : program) (alias : string Pos.marked) : string = (Format.asprintf "alias not found: %s" (Pos.unmark alias)) (Pos.get_position alias) -let get_var (name : string) (idmap : _ Pos.VarNameToID.t) : Variable.t = - Pos.VarNameToID.find name idmap - -let find_var_by_name (p : program) (name : string Pos.marked) : Variable.t = - try get_var (Pos.unmark name) p.program_idmap +let find_var_by_name (p : program) (name : string Pos.marked) : Com.Var.t = + try StrMap.find (Pos.unmark name) p.program_vars with Not_found -> ( try let name = find_var_name_by_alias p name in - get_var name p.program_idmap + StrMap.find name p.program_vars with Not_found -> Errors.raise_spanned_error "unknown variable" (Pos.get_position name)) -(** Explores the rules to find rule and variable data *) -let find_var_definition (_p : program) (_var : Variable.t) : - rule_data * variable_data = - raise Not_found - -let mast_to_catvar (cats : 'a CatVarMap.t) - (l : string Pos.marked list Pos.marked) : cat_variable = - match l with - | ("saisie", _) :: id, pos -> - let vcat = CatInput (StrSet.from_marked_list id) in - if CatVarMap.mem vcat cats then vcat - else Errors.raise_spanned_error "unknown variable category" pos - | ("calculee", _) :: id, id_pos -> begin - match id with - | [] -> CatComputed CatCompSet.empty - | [ ("base", _) ] -> CatComputed (CatCompSet.singleton Base) - | [ ("restituee", _) ] -> CatComputed (CatCompSet.singleton GivenBack) - | [ ("base", _); ("restituee", _) ] | [ ("restituee", _); ("base", _) ] -> - CatComputed (CatCompSet.singleton Base |> CatCompSet.add GivenBack) - | _ -> - Errors.raise_spanned_error "unlnown calculated variable category" - id_pos - end - | _, pos -> Errors.raise_spanned_error "unknown variable category" pos - -let rec expand_functions_expr (e : 'var expression_ Pos.marked) : - 'var expression_ Pos.marked = +let rec expand_functions_expr (e : 'var Com.expression Pos.marked) : + 'var Com.expression Pos.marked = + let open Com in match Pos.unmark e with | Comparison (op, e1, e2) -> let new_e1 = expand_functions_expr e1 in @@ -667,19 +123,14 @@ let rec expand_functions_expr (e : 'var expression_ Pos.marked) : | Conditional (e1, e2, e3) -> let new_e1 = expand_functions_expr e1 in let new_e2 = expand_functions_expr e2 in - let new_e3 = expand_functions_expr e3 in + let new_e3 = Option.map expand_functions_expr e3 in Pos.same_pos_as (Conditional (new_e1, new_e2, new_e3)) e | Index (var, e1) -> let new_e1 = expand_functions_expr e1 in Pos.same_pos_as (Index (var, new_e1)) e | Literal _ -> e | Var _ -> e - | LocalVar _ -> e - | LocalLet (lvar, e1, e2) -> - let new_e1 = expand_functions_expr e1 in - let new_e2 = expand_functions_expr e2 in - Pos.same_pos_as (LocalLet (lvar, new_e1, new_e2)) e - | FunctionCall (SumFunc, args) -> + | FuncCall ((SumFunc, _), args) -> let expr_opt = List.fold_left (fun acc_opt arg -> @@ -688,7 +139,7 @@ let rec expand_functions_expr (e : 'var expression_ Pos.marked) : | Some acc -> Some (Binop - ( Pos.same_pos_as Mast.Add e, + ( Pos.same_pos_as Com.Add e, Pos.same_pos_as acc e, expand_functions_expr arg ))) None args @@ -697,82 +148,82 @@ let rec expand_functions_expr (e : 'var expression_ Pos.marked) : match expr_opt with None -> Literal (Float 0.0) | Some expr -> expr in Pos.same_pos_as expr e - | FunctionCall (GtzFunc, [ arg ]) -> + | FuncCall ((GtzFunc, _), [ arg ]) -> Pos.same_pos_as (Comparison - ( Pos.same_pos_as Mast.Gt e, + ( Pos.same_pos_as Com.Gt e, expand_functions_expr arg, Pos.same_pos_as (Literal (Float 0.0)) e )) e - | FunctionCall (GtezFunc, [ arg ]) -> + | FuncCall ((GtezFunc, _), [ arg ]) -> Pos.same_pos_as (Comparison - ( Pos.same_pos_as Mast.Gte e, + ( Pos.same_pos_as Com.Gte e, expand_functions_expr arg, Pos.same_pos_as (Literal (Float 0.0)) e )) e - | FunctionCall (((MinFunc | MaxFunc) as f), [ arg1; arg2 ]) -> + | FuncCall ((((MinFunc | MaxFunc) as f), pos), [ arg1; arg2 ]) -> let earg1 = expand_functions_expr arg1 in let earg2 = expand_functions_expr arg2 in - Pos.same_pos_as (FunctionCall (f, [ earg1; earg2 ])) e - | FunctionCall (AbsFunc, [ arg ]) -> - Pos.same_pos_as (FunctionCall (AbsFunc, [ expand_functions_expr arg ])) e - | FunctionCall (NullFunc, [ arg ]) -> + Pos.same_pos_as (FuncCall ((f, pos), [ earg1; earg2 ])) e + | FuncCall ((AbsFunc, pos), [ arg ]) -> + Pos.same_pos_as + (FuncCall ((AbsFunc, pos), [ expand_functions_expr arg ])) + e + | FuncCall ((NullFunc, _), [ arg ]) -> Pos.same_pos_as (Comparison - ( Pos.same_pos_as Mast.Eq e, + ( Pos.same_pos_as Com.Eq e, expand_functions_expr arg, Pos.same_pos_as (Literal (Float 0.0)) e )) e - | FunctionCall (PresentFunc, [ arg ]) -> + | FuncCall ((PresentFunc, pos), [ arg ]) -> (* we do not expand this function as it deals specifically with undefined variables *) Pos.same_pos_as - (FunctionCall (PresentFunc, [ expand_functions_expr arg ])) + (FuncCall ((PresentFunc, pos), [ expand_functions_expr arg ])) e - | FunctionCall (ArrFunc, [ arg ]) -> + | FuncCall ((ArrFunc, pos), [ arg ]) -> (* we do not expand this function as it requires modulo or modf *) - Pos.same_pos_as (FunctionCall (ArrFunc, [ expand_functions_expr arg ])) e - | FunctionCall (InfFunc, [ arg ]) -> + Pos.same_pos_as + (FuncCall ((ArrFunc, pos), [ expand_functions_expr arg ])) + e + | FuncCall ((InfFunc, pos), [ arg ]) -> (* we do not expand this function as it requires modulo or modf *) - Pos.same_pos_as (FunctionCall (InfFunc, [ expand_functions_expr arg ])) e + Pos.same_pos_as + (FuncCall ((InfFunc, pos), [ expand_functions_expr arg ])) + e | _ -> e let expand_functions (p : program) : program = - let map_var _var def = - match def.var_definition with - | InputVar -> def - | SimpleVar e -> - { def with var_definition = SimpleVar (expand_functions_expr e) } - | TableVar (size, defg) -> ( - match defg with - | IndexGeneric (v, e) -> - { - def with - var_definition = - TableVar (size, IndexGeneric (v, expand_functions_expr e)); - } - | IndexTable es -> - { - def with - var_definition = - TableVar - ( size, - IndexTable - (IndexMap.map (fun e -> expand_functions_expr e) es) ); - }) - in + let open Com in let program_targets = let rec map_instr m_instr = let instr, instr_pos = m_instr in match instr with - | Affectation (v_id, v_data) -> - (Affectation (v_id, map_var v_id v_data), instr_pos) + | Affectation (SingleFormula (v_id, v_idx_opt, v_expr), pos) -> + let m_idx_opt = + match v_idx_opt with + | Some v_idx -> Some (expand_functions_expr v_idx) + | None -> None + in + let m_expr = expand_functions_expr v_expr in + (Affectation (SingleFormula (v_id, m_idx_opt, m_expr), pos), instr_pos) + | Affectation _ -> assert false | IfThenElse (i, t, e) -> - let i' = Pos.unmark (expand_functions_expr (i, Pos.no_pos)) in + let i' = expand_functions_expr i in let t' = List.map map_instr t in let e' = List.map map_instr e in (IfThenElse (i', t', e'), instr_pos) + | WhenDoElse (wdl, ed) -> + let map_wdl (expr, dl, pos) = + let expr' = expand_functions_expr expr in + let dl' = List.map map_instr dl in + (expr', dl', pos) + in + let wdl' = List.map map_wdl wdl in + let ed' = Pos.map_under_mark (List.map map_instr) ed in + (WhenDoElse (wdl', ed'), instr_pos) | ComputeTarget _ -> m_instr | VerifBlock instrs -> let instrs' = List.map map_instr instrs in @@ -783,20 +234,27 @@ let expand_functions (p : program) : program = (fun m_arg -> let arg, arg_pos = m_arg in match arg with - | PrintIndent e -> + | Com.PrintIndent e -> let e' = expand_functions_expr e in - (PrintIndent e', arg_pos) - | PrintExpr (e, mi, ma) -> + (Com.PrintIndent e', arg_pos) + | Com.PrintExpr (e, mi, ma) -> let e' = expand_functions_expr e in - (PrintExpr (e', mi, ma), arg_pos) - | PrintString _ | PrintName _ | PrintAlias _ -> m_arg) + (Com.PrintExpr (e', mi, ma), arg_pos) + | Com.PrintString _ | Com.PrintName _ | Com.PrintAlias _ -> + m_arg) pr_args in (Print (out, pr_args'), instr_pos) - | Iterate (v_id, cats, e, instrs) -> - let e' = expand_functions_expr e in + | Iterate (v_id, vars, var_params, instrs) -> + let var_params' = + List.map + (fun (cats, e) -> + let e' = expand_functions_expr e in + (cats, e')) + var_params + in let instrs' = List.map map_instr instrs in - (Iterate (v_id, cats, e', instrs'), instr_pos) + (Iterate (v_id, vars, var_params', instrs'), instr_pos) | Restore (vars, filters, instrs) -> let filters' = List.map @@ -806,8 +264,9 @@ let expand_functions (p : program) : program = let instrs' = List.map map_instr instrs in (Restore (vars, filters', instrs'), instr_pos) | RaiseError _ | CleanErrors | ExportErrors | FinalizeErrors -> m_instr + | ComputeDomain _ | ComputeChaining _ | ComputeVerifs _ -> assert false in - TargetMap.map + Com.TargetMap.map (fun t -> let target_prog = List.map map_instr t.target_prog in { t with target_prog }) diff --git a/src/mlang/m_ir/mir.mli b/src/mlang/m_ir/mir.mli index 7a5f71359..e52f98980 100644 --- a/src/mlang/m_ir/mir.mli +++ b/src/mlang/m_ir/mir.mli @@ -14,367 +14,63 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -type cat_computed = Base | GivenBack +type set_value = Com.Var.t Com.set_value -module CatCompSet : SetExt.T with type elt = cat_computed +type expression = Com.Var.t Com.expression -type cat_variable = CatInput of StrSet.t | CatComputed of CatCompSet.t +type instruction = (Com.Var.t, Com.Error.t) Com.instruction -val pp_cat_variable : Format.formatter -> cat_variable -> unit - -val compare_cat_variable : cat_variable -> cat_variable -> int - -module CatVarSet : SetExt.T with type elt = cat_variable - -module CatVarMap : MapExt.T with type key = cat_variable - -type cat_variable_loc = LocCalculated | LocBase | LocInput - -type cat_variable_data = { - id : cat_variable; - id_str : string; - id_int : int; - loc : cat_variable_loc; - pos : Pos.t; - attributs : Pos.t StrMap.t; -} - -type variable_id = int -(** Each variable has an unique ID *) - -type variable = { - name : string Pos.marked; (** The position is the variable declaration *) - alias : string option; (** Input variable have an alias *) - id : variable_id; - descr : string Pos.marked; - (** Description taken from the variable declaration *) - attributes : Mast.variable_attribute list; - origin : variable option; - (** If the variable is an SSA duplication, refers to the original - (declared) variable *) - cats : cat_variable option; - is_table : int option; - is_temp : bool; - is_it : bool; -} - -type local_variable = { id : int } - -(** Type of MIR values *) -type typ = Real - -type literal = Float of float | Undefined - -(** MIR only supports a restricted set of functions *) -type func = - | SumFunc (** Sums the arguments *) - | AbsFunc (** Absolute value *) - | MinFunc (** Minimum of a list of values *) - | MaxFunc (** Maximum of a list of values *) - | GtzFunc (** Greater than zero (strict) ? *) - | GtezFunc (** Greater or equal than zero ? *) - | NullFunc (** Equal to zero ? *) - | ArrFunc (** Round to nearest integer *) - | InfFunc (** Truncate to integer *) - | PresentFunc (** Different than zero ? *) - | Multimax (** ??? *) - | Supzero (** ??? *) - | VerifNumber - | ComplNumber - -(** MIR expressions are simpler than M; there are no loops or syntaxtic sugars. - - Because translating to MIR requires a lot of unrolling and expansion, we - introduce a [LocalLet] construct to avoid code duplication. *) - -type 'variable expression_ = - | Unop of (Mast.unop[@opaque]) * 'variable expression_ Pos.marked - | Comparison of - (Mast.comp_op[@opaque]) Pos.marked - * 'variable expression_ Pos.marked - * 'variable expression_ Pos.marked - | Binop of - (Mast.binop[@opaque]) Pos.marked - * 'variable expression_ Pos.marked - * 'variable expression_ Pos.marked - | Index of 'variable Pos.marked * 'variable expression_ Pos.marked - | Conditional of - 'variable expression_ Pos.marked - * 'variable expression_ Pos.marked - * 'variable expression_ Pos.marked - | FunctionCall of (func[@opaque]) * 'variable expression_ Pos.marked list - | Literal of (literal[@opaque]) - | Var of 'variable - | LocalVar of local_variable - | LocalLet of - local_variable - * 'variable expression_ Pos.marked - * 'variable expression_ Pos.marked - | NbCategory of CatVarSet.t - | Attribut of string Pos.marked * 'variable * string Pos.marked - | Size of 'variable - | NbAnomalies - | NbDiscordances - | NbInformatives - | NbBloquantes - -type expression = variable expression_ - -module VariableMap : MapExt.T with type key = variable -(** MIR programs are just mapping from variables to their definitions, and make - a massive use of [VariableMap]. *) - -module VariableDict : Dict.S with type key = variable_id and type elt = variable - -module VariableSet : SetExt.T with type elt = variable - -module LocalVariableMap : sig - include MapExt.T with type key = local_variable -end - -module IndexMap : IntMap.T - -type 'variable index_def = - | IndexTable of - ('variable expression_ Pos.marked IndexMap.t[@name "index_map"]) - | IndexGeneric of 'variable * 'variable expression_ Pos.marked - -type 'variable variable_def_ = - | SimpleVar of 'variable expression_ Pos.marked - | TableVar of int * 'variable index_def - | InputVar - -type variable_def = variable variable_def_ - -type 'variable variable_data_ = { - var_definition : 'variable variable_def_; - var_typ : typ option; - (** The typing info here comes from the variable declaration in the source - program *) -} - -type variable_data = variable variable_data_ - -type rov_id = RuleID of int | VerifID of int - -module RuleMap : MapExt.T with type key = rov_id - -module TargetMap : StrMap.T - -type 'a domain = { - dom_id : Mast.DomainId.t Pos.marked; - dom_names : Pos.t Mast.DomainIdMap.t; - dom_by_default : bool; - dom_min : Mast.DomainIdSet.t; - dom_max : Mast.DomainIdSet.t; - dom_rov : IntSet.t; - dom_data : 'a; - dom_used : int Pos.marked option; -} - -type rule_domain_data = { rdom_computable : bool } - -type rule_domain = rule_domain_data domain - -type 'variable print_arg = - | PrintString of string - | PrintName of string Pos.marked * variable - | PrintAlias of string Pos.marked * variable - | PrintIndent of 'variable expression_ Pos.marked - | PrintExpr of 'variable expression_ Pos.marked * int * int - -type error_descr = { - kind : string Pos.marked; - major_code : string Pos.marked; - minor_code : string Pos.marked; - description : string Pos.marked; - isisf : string Pos.marked; -} - -(** Errors are first-class objects *) - -type error = { - name : string Pos.marked; (** The position is the variable declaration *) - id : int; (** Each variable has an unique ID *) - descr : error_descr; (** Description taken from the variable declaration *) - typ : Mast.error_typ; -} - -module Error : sig - type descr = error_descr = { - kind : string Pos.marked; - major_code : string Pos.marked; - minor_code : string Pos.marked; - description : string Pos.marked; - isisf : string Pos.marked; - } - - type t = error = { - name : string Pos.marked; (** The position is the variable declaration *) - id : int; (** Each variable has an unique ID *) - descr : error_descr; (** Description taken from the variable declaration *) - typ : Mast.error_typ; - } - - val new_error : string Pos.marked -> Mast.error_ -> Mast.error_typ -> error - - val err_descr_string : t -> string Pos.marked - - val compare : t -> t -> int -end - -type instruction = - | Affectation of variable_id * variable_data - | IfThenElse of - expression * instruction Pos.marked list * instruction Pos.marked list - | ComputeTarget of string Pos.marked - | VerifBlock of instruction Pos.marked list - | Print of Mast.print_std * variable print_arg Pos.marked list - | Iterate of - variable_id - * CatVarSet.t - * expression Pos.marked - * instruction Pos.marked list - | Restore of - Pos.t VariableMap.t - * (variable * CatVarSet.t * expression Pos.marked) list - * instruction Pos.marked list - | RaiseError of error * string option - | CleanErrors - | ExportErrors - | FinalizeErrors - -type rule_data = { - rule_apps : Pos.t StrMap.t; - rule_domain : rule_domain; - rule_chain : (string * rule_domain) option; - rule_vars : instruction Pos.marked list; - rule_number : rov_id Pos.marked; -} +type m_instruction = instruction Pos.marked type target_data = { target_name : string Pos.marked; target_file : string option; - target_apps : string Pos.marked list; - target_tmp_vars : (variable * Pos.t * int option) StrMap.t; - target_prog : instruction Pos.marked list; + target_apps : string Pos.marked StrMap.t; + target_args : (Com.Var.t * Pos.t) list; + target_result : (Com.Var.t * Pos.t) option; + target_tmp_vars : (Com.Var.t * Pos.t * int option) StrMap.t; + target_nb_tmps : int; + target_sz_tmps : int; + target_nb_refs : int; + target_prog : m_instruction list; } -type verif_domain_data = { vdom_auth : CatVarSet.t; vdom_verifiable : bool } - -type verif_domain = verif_domain_data domain - -type 'variable condition_data_ = { - cond_seq_id : int; - cond_number : rov_id Pos.marked; - cond_domain : verif_domain; - cond_expr : 'variable expression_ Pos.marked; - cond_error : error * 'variable option; - cond_cats : int CatVarMap.t; +type stats = { + nb_calculated : int; + nb_base : int; + nb_input : int; + nb_vars : int; + nb_all_tmps : int; + nb_all_refs : int; + sz_calculated : int; + sz_base : int; + sz_input : int; + sz_vars : int; + sz_all_tmps : int; } -type condition_data = variable condition_data_ - -type idmap = variable Pos.VarNameToID.t -(** We translate string variables into first-class unique {!type: Mir.variable}, - so we need to keep a mapping between the two. A name is mapped to a list of - variables because variables can be redefined in different rules *) - type program = { program_safe_prefix : string; program_applications : Pos.t StrMap.t; - program_var_categories : cat_variable_data CatVarMap.t; - program_rule_domains : rule_domain Mast.DomainIdMap.t; - program_verif_domains : verif_domain Mast.DomainIdMap.t; - program_chainings : rule_domain Mast.ChainingMap.t; - program_vars : VariableDict.t; + program_var_categories : Com.CatVar.data Com.CatVar.Map.t; + program_rule_domains : Com.rule_domain Com.DomainIdMap.t; + program_verif_domains : Com.verif_domain Com.DomainIdMap.t; + program_vars : Com.Var.t StrMap.t; (** A static register of all variables that can be used during a calculation *) - program_targets : target_data TargetMap.t; - program_idmap : idmap; + program_functions : target_data Com.TargetMap.t; + program_targets : target_data Com.TargetMap.t; + program_main_target : string; + program_stats : stats; } -module Variable : sig - type id = variable_id - - type t = variable = { - name : string Pos.marked; (** The position is the variable declaration *) - alias : string option; (** Input variable have an alias *) - id : variable_id; - descr : string Pos.marked; - (** Description taken from the variable declaration *) - attributes : Mast.variable_attribute list; - origin : variable option; - (** If the variable is an SSA duplication, refers to the original - (declared) variable *) - cats : cat_variable option; - is_table : int option; - is_temp : bool; - is_it : bool; - } - - val fresh_id : unit -> id - - val new_var : - string Pos.marked -> - string option -> - string Pos.marked -> - attributes:Mast.variable_attribute list -> - origin:variable option -> - cats:cat_variable option -> - is_table:int option -> - is_temp:bool -> - is_it:bool -> - variable - - val compare : t -> t -> int -end - -(** Local variables don't appear in the M source program but can be introduced - by let bindings when translating to MIR. They should be De Bruijn indices - but instead are unique globals identifiers out of laziness. *) -module LocalVariable : sig - type t = local_variable = { id : int } - - val new_var : unit -> t - - val compare : t -> t -> int -end - -val false_literal : literal - -val true_literal : literal - -val num_of_rule_or_verif_id : rov_id -> int - val find_var_name_by_alias : program -> string Pos.marked -> string -val map_expr_var : ('v -> 'v2) -> 'v expression_ -> 'v2 expression_ - -val fold_expr_var : ('a -> 'v -> 'a) -> 'a -> 'v expression_ -> 'a - -val map_var_def_var : ('v -> 'v2) -> 'v variable_def_ -> 'v2 variable_def_ - -val map_cond_data_var : ('v -> 'v2) -> 'v condition_data_ -> 'v2 condition_data_ - -val cond_cats_to_set : int CatVarMap.t -> CatVarSet.t - -val find_var_definition : program -> variable -> rule_data * variable_data - -val get_var : string -> Variable.t Pos.VarNameToID.t -> Variable.t - -val fresh_rule_num : unit -> int - -val initial_undef_rule_id : rov_id - -val find_var_by_name : program -> string Pos.marked -> variable +val find_var_by_name : program -> string Pos.marked -> Com.Var.t (** Get a variable for a given name or alias, because of SSA multiple variables share a name or alias. If an alias is provided, the variable returned is that with the lowest execution number. When a name is provided, then the variable with the highest execution number is returned. *) -val mast_to_catvar : - 'a CatVarMap.t -> string Pos.marked list Pos.marked -> cat_variable - val expand_functions : program -> program (** Calls [expand_functions_expr] on the whole program *) diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml new file mode 100644 index 000000000..43358aa94 --- /dev/null +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -0,0 +1,894 @@ +(* Copyright (C) 2019-2021 Inria, contributor: Denis Merigoux + + + 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 . *) + +let exit_on_rte = ref true + +let repl_debug = ref false + +module type S = sig + type custom_float + + type value = Number of custom_float | Undefined + + val format_value : Format.formatter -> value -> unit + + val format_value_prec : int -> int -> Format.formatter -> value -> unit + + type print_ctx = { mutable indent : int; mutable is_newline : bool } + + type ctx = { + ctx_tgv : value Array.t; + ctx_tmps : value Array.t; + mutable ctx_tmps_org : int; + ctx_ref : (Com.Var.t * int) Array.t; + mutable ctx_ref_org : int; + mutable ctx_args : value Array.t list; + mutable ctx_res : value list; + ctx_pr_out : print_ctx; + ctx_pr_err : print_ctx; + mutable ctx_anos : (Com.Error.t * string option) list; + mutable ctx_old_anos : StrSet.t; + mutable ctx_nb_anos : int; + mutable ctx_nb_discos : int; + mutable ctx_nb_infos : int; + mutable ctx_nb_bloquantes : int; + mutable ctx_finalized_anos : (Com.Error.t * string option) list; + mutable ctx_exported_anos : (Com.Error.t * string option) list; + } + + val empty_ctx : Mir.program -> ctx + + val literal_to_value : Com.literal -> value + + val value_to_literal : value -> Com.literal + + val update_ctx_with_inputs : ctx -> Com.literal Com.Var.Map.t -> unit + + type run_error = + | NanOrInf of string * Mir.expression Pos.marked + | StructuredError of + (string * (string option * Pos.t) list * (unit -> unit) option) + + exception RuntimeError of run_error * ctx + + val raise_runtime_as_structured : run_error -> 'a + + val compare_numbers : Com.comp_op -> custom_float -> custom_float -> bool + + val evaluate_expr : ctx -> Mir.program -> Mir.expression Pos.marked -> value + + val evaluate_program : Mir.program -> ctx -> unit +end + +module Make (N : Mir_number.NumberInterface) (RF : Mir_roundops.RoundOpsFunctor) = +struct + (* Careful : this behavior mimics the one imposed by the original Mlang + compiler... *) + + module R = RF (N) + + type custom_float = N.t + + let truncatef (x : N.t) : N.t = R.truncatef x + + let roundf (x : N.t) = R.roundf x + + type value = Number of N.t | Undefined + + let false_value () = Number (N.zero ()) + + let true_value () = Number (N.one ()) + + let format_value (fmt : Format.formatter) (x : value) = + match x with + | Undefined -> Com.format_literal fmt Com.Undefined + | Number x -> N.format_t fmt x + + let format_value_prec (mi : int) (ma : int) (fmt : Format.formatter) + (x : value) = + match x with + | Undefined -> Com.format_literal fmt Com.Undefined + | Number x -> N.format_prec_t mi ma fmt x + + type print_ctx = { mutable indent : int; mutable is_newline : bool } + + type ctx = { + ctx_tgv : value Array.t; + ctx_tmps : value Array.t; + mutable ctx_tmps_org : int; + ctx_ref : (Com.Var.t * int) Array.t; + mutable ctx_ref_org : int; + mutable ctx_args : value Array.t list; + mutable ctx_res : value list; + ctx_pr_out : print_ctx; + ctx_pr_err : print_ctx; + mutable ctx_anos : (Com.Error.t * string option) list; + mutable ctx_old_anos : StrSet.t; + mutable ctx_nb_anos : int; + mutable ctx_nb_discos : int; + mutable ctx_nb_infos : int; + mutable ctx_nb_bloquantes : int; + mutable ctx_finalized_anos : (Com.Error.t * string option) list; + mutable ctx_exported_anos : (Com.Error.t * string option) list; + } + + let empty_ctx (p : Mir.program) : ctx = + let dummy_ref = + (Com.Var.new_ref ~name:("", Pos.no_pos) ~loc_int:(-1), -1) + in + { + ctx_tgv = Array.make p.program_stats.sz_vars Undefined; + ctx_tmps = Array.make p.program_stats.sz_all_tmps Undefined; + ctx_tmps_org = 0; + ctx_ref = Array.make p.program_stats.nb_all_refs dummy_ref; + ctx_ref_org = 0; + ctx_args = []; + ctx_res = []; + ctx_pr_out = { indent = 0; is_newline = true }; + ctx_pr_err = { indent = 0; is_newline = true }; + ctx_anos = []; + ctx_old_anos = StrSet.empty; + ctx_nb_anos = 0; + ctx_nb_discos = 0; + ctx_nb_infos = 0; + ctx_nb_bloquantes = 0; + ctx_finalized_anos = []; + ctx_exported_anos = []; + } + + let literal_to_value (l : Com.literal) : value = + match l with + | Com.Undefined -> Undefined + | Com.Float f -> Number (N.of_float f) + + let value_to_literal (l : value) : Com.literal = + match l with + | Undefined -> Com.Undefined + | Number f -> Com.Float (N.to_float f) + + let update_ctx_with_inputs (ctx : ctx) (inputs : Com.literal Com.Var.Map.t) : + unit = + let value_inputs = + Com.Var.Map.mapi + (fun v l -> + match l with + | Com.Undefined -> Undefined + | Com.Float f -> Number (N.of_float_input v f)) + inputs + in + Com.Var.Map.iter + (fun (var : Com.Var.t) value -> + ctx.ctx_tgv.(Com.Var.loc_int var) <- value) + value_inputs + + type run_error = + | NanOrInf of string * Mir.expression Pos.marked + | StructuredError of + (string * (string option * Pos.t) list * (unit -> unit) option) + + exception RuntimeError of run_error * ctx + + let raise_runtime_as_structured (e : run_error) = + match e with + | NanOrInf (v, e) -> + Errors.raise_spanned_error + (Format.asprintf "Expression evaluated to %s: %a" v + Format_mir.format_expression (Pos.unmark e)) + (Pos.get_position e) + | StructuredError (msg, pos, kont) -> + raise (Errors.StructuredError (msg, pos, kont)) + + let is_zero (l : value) : bool = + match l with Number z -> N.is_zero z | _ -> false + + let real_of_bool (b : bool) = if b then N.one () else N.zero () + + let bool_of_real (f : N.t) : bool = not N.(f =. zero ()) + + let compare_numbers op i1 i2 = + let epsilon = N.of_float !Cli.comparison_error_margin in + let open Com in + match op with + | Gt -> N.(i1 >. i2 +. epsilon) + | Gte -> N.(i1 >. i2 -. epsilon) + | Lt -> N.(i1 +. epsilon <. i2) + | Lte -> N.(i1 -. epsilon <. i2) + | Eq -> N.(N.abs (i1 -. i2) <. epsilon) + | Neq -> N.(N.abs (i1 -. i2) >=. epsilon) + + let get_var ctx (var : Com.Var.t) = + match var.loc with + | LocRef (_, i) -> ctx.ctx_ref.(ctx.ctx_ref_org + i) + | LocTgv (_, { loc_int; _ }) -> (var, loc_int) + | LocTmp (_, i) -> (var, ctx.ctx_tmps_org + i) + | LocArg (_, i) -> (var, i) + | LocRes _ -> (var, -1) + + let get_var_value ctx (var : Com.Var.t) (i : int) = + let var, vi = get_var ctx var in + match var.scope with + | Com.Var.Tgv _ -> ctx.ctx_tgv.(vi + i) + | Com.Var.Temp _ -> ctx.ctx_tmps.(vi + i) + | Com.Var.Ref -> assert false + | Com.Var.Arg -> (List.hd ctx.ctx_args).(vi) + | Com.Var.Res -> List.hd ctx.ctx_res + + let get_var_tab ctx var idx = + match idx with + | Undefined -> Undefined + | Number f -> + let var, _vi = get_var ctx (Pos.unmark var) in + let idx_f = roundf f in + let sz = Com.Var.size var in + if N.(idx_f >=. N.of_int (Int64.of_int sz)) then Undefined + else if N.(idx_f <. N.zero ()) then Number (N.zero ()) + else + let i = Int64.to_int (N.to_int idx_f) in + get_var_value ctx var i + + exception BlockingError + + let rec evaluate_expr (ctx : ctx) (p : Mir.program) + (e : Mir.expression Pos.marked) : value = + let comparison op new_e1 new_e2 = + match (op, new_e1, new_e2) with + | Com.Gt, _, Undefined | Com.Gt, Undefined, _ -> Undefined + | Com.Gte, _, Undefined | Com.Gte, Undefined, _ -> Undefined + | Com.Lt, _, Undefined | Com.Lt, Undefined, _ -> Undefined + | Com.Lte, _, Undefined | Com.Lte, Undefined, _ -> Undefined + | Com.Eq, _, Undefined | Com.Eq, Undefined, _ -> Undefined + | Com.Neq, _, Undefined | Com.Neq, Undefined, _ -> Undefined + | op, Number i1, Number i2 -> + Number (real_of_bool (compare_numbers op i1 i2)) + in + let unop op new_e1 = + let open Com in + match (op, new_e1) with + | Not, Number b1 -> Number (real_of_bool (not (bool_of_real b1))) + | Minus, Number f1 -> Number N.(zero () -. f1) + | Not, Undefined -> Undefined + | Minus, Undefined -> Undefined + in + let binop op new_e1 new_e2 = + let open Com in + match (op, new_e1, new_e2) with + | Add, Number i1, Number i2 -> Number N.(i1 +. i2) + | Add, Number i1, Undefined -> Number N.(i1 +. zero ()) + | Add, Undefined, Number i2 -> Number N.(zero () +. i2) + | Add, Undefined, Undefined -> Undefined + | Sub, Number i1, Number i2 -> Number N.(i1 -. i2) + | Sub, Number i1, Undefined -> Number N.(i1 -. zero ()) + | Sub, Undefined, Number i2 -> Number N.(zero () -. i2) + | Sub, Undefined, Undefined -> Undefined + | Mul, _, Undefined | Mul, Undefined, _ -> Undefined + | Mul, Number i1, Number i2 -> Number N.(i1 *. i2) + | Div, Undefined, _ | Div, _, Undefined -> Undefined (* yes... *) + | Div, _, l2 when is_zero l2 -> Number (N.zero ()) + | Div, Number i1, Number i2 -> Number N.(i1 /. i2) + | And, Undefined, _ | And, _, Undefined -> Undefined + | Or, Undefined, Undefined -> Undefined + | Or, Undefined, Number i | Or, Number i, Undefined -> Number i + | And, Number i1, Number i2 -> + Number (real_of_bool (bool_of_real i1 && bool_of_real i2)) + | Or, Number i1, Number i2 -> + Number (real_of_bool (bool_of_real i1 || bool_of_real i2)) + in + let out = + try + match Pos.unmark e with + | Com.TestInSet (positive, e0, values) -> + let new_e0 = evaluate_expr ctx p e0 in + let or_chain = + List.fold_left + (fun or_chain set_value -> + let equal_test = + match set_value with + | Com.VarValue set_var -> + let new_set_var = + get_var_value ctx (Pos.unmark set_var) 0 + in + comparison Com.Eq new_e0 new_set_var + | Com.FloatValue i -> + let val_i = Number (N.of_float (Pos.unmark i)) in + comparison Com.Eq new_e0 val_i + | Com.Interval (bn, en) -> + let val_bn = + Number (N.of_float (float_of_int (Pos.unmark bn))) + in + let val_en = + Number (N.of_float (float_of_int (Pos.unmark en))) + in + binop Com.And + (comparison Com.Gte new_e0 val_bn) + (comparison Com.Lte new_e0 val_en) + in + binop Com.Or or_chain equal_test) + Undefined values + in + if positive then or_chain else unop Com.Not or_chain + | Comparison (op, e1, e2) -> + let new_e1 = evaluate_expr ctx p e1 in + let new_e2 = evaluate_expr ctx p e2 in + comparison (Pos.unmark op) new_e1 new_e2 + | Binop (op, e1, e2) -> + let new_e1 = evaluate_expr ctx p e1 in + let new_e2 = evaluate_expr ctx p e2 in + binop (Pos.unmark op) new_e1 new_e2 + | Unop (op, e1) -> + let new_e1 = evaluate_expr ctx p e1 in + unop op new_e1 + | Conditional (e1, e2, e3_opt) -> ( + let new_e1 = evaluate_expr ctx p e1 in + match new_e1 with + | Number z when N.(z =. zero ()) -> ( + match e3_opt with + | None -> Undefined + | Some e3 -> evaluate_expr ctx p e3) + | Number _ -> evaluate_expr ctx p e2 (* the float is not zero *) + | Undefined -> Undefined) + | Literal Undefined -> Undefined + | Literal (Float f) -> Number (N.of_float f) + | Index (var, e1) -> + let idx = evaluate_expr ctx p e1 in + get_var_tab ctx var idx + | Var var -> get_var_value ctx var 0 + | FuncCall ((ArrFunc, _), [ arg ]) -> ( + let new_arg = evaluate_expr ctx p arg in + match new_arg with + | Number x -> Number (roundf x) + | Undefined -> Undefined + (*nope:Float 0.*)) + | FuncCall ((InfFunc, _), [ arg ]) -> ( + let new_arg = evaluate_expr ctx p arg in + match new_arg with + | Number x -> Number (truncatef x) + | Undefined -> Undefined + (*Float 0.*)) + | FuncCall ((PresentFunc, _), [ arg ]) -> ( + match evaluate_expr ctx p arg with + | Undefined -> false_value () + | _ -> true_value ()) + | FuncCall ((Supzero, _), [ arg ]) -> ( + match evaluate_expr ctx p arg with + | Undefined -> Undefined + | Number f as n -> + if compare_numbers Com.Lte f (N.zero ()) then Undefined else n) + | FuncCall ((AbsFunc, _), [ arg ]) -> ( + match evaluate_expr ctx p arg with + | Undefined -> Undefined + | Number f -> Number (N.abs f)) + | FuncCall ((MinFunc, _), [ arg1; arg2 ]) -> ( + match (evaluate_expr ctx p arg1, evaluate_expr ctx p arg2) with + | Undefined, Undefined -> Undefined + | Undefined, Number f | Number f, Undefined -> + Number (N.min (N.zero ()) f) + | Number fl, Number fr -> Number (N.min fl fr)) + | FuncCall ((MaxFunc, _), [ arg1; arg2 ]) -> ( + match (evaluate_expr ctx p arg1, evaluate_expr ctx p arg2) with + | Undefined, Undefined -> Undefined + | Undefined, Number f | Number f, Undefined -> + Number (N.max (N.zero ()) f) + | Number fl, Number fr -> Number (N.max fl fr)) + | FuncCall ((Multimax, _), [ arg1; arg2 ]) -> ( + match evaluate_expr ctx p arg1 with + | Undefined -> Undefined + | Number f -> ( + let up = N.to_int (roundf f) in + let var_arg2 = + match Pos.unmark arg2 with + | Var v -> (v, Pos.get_position e) + | _ -> assert false + (* todo: rte *) + in + let cast_to_int (v : value) : Int64.t option = + match v with + | Number f -> Some (N.to_int (roundf f)) + | Undefined -> None + in + let pos = Pos.get_position arg2 in + let access_index (i : int) : Int64.t option = + cast_to_int + @@ evaluate_expr ctx p + ( Index + (var_arg2, (Literal (Float (float_of_int i)), pos)), + pos ) + in + let maxi = ref (access_index 0) in + for i = 0 to Int64.to_int up do + match access_index i with + | None -> () + | Some n -> + maxi := + Option.fold ~none:(Some n) + ~some:(fun m -> Some (max n m)) + !maxi + done; + match !maxi with + | None -> Undefined + | Some f -> Number (N.of_int f))) + | FuncCall ((Func fn, _), args) -> + let fd = Com.TargetMap.find fn p.program_functions in + let atab = Array.of_list (List.map (evaluate_expr ctx p) args) in + ctx.ctx_args <- atab :: ctx.ctx_args; + ctx.ctx_res <- Undefined :: ctx.ctx_res; + evaluate_target false p ctx fn fd; + ctx.ctx_args <- List.tl ctx.ctx_args; + let res = List.hd ctx.ctx_res in + ctx.ctx_res <- List.tl ctx.ctx_res; + res + | FuncCall (_, _) -> assert false + | Attribut (var, a) -> ( + let var, _ = get_var ctx (Pos.unmark var) in + match StrMap.find_opt (Pos.unmark a) (Com.Var.attrs var) with + | Some l -> Number (N.of_float (float (Pos.unmark l))) + | None -> Undefined) + | Size var -> ( + let var, _ = get_var ctx (Pos.unmark var) in + match Com.Var.is_table var with + | Some i -> Number (N.of_float (float_of_int i)) + | None -> Number (N.of_float 1.0)) + | NbAnomalies -> Number (N.of_float (float ctx.ctx_nb_anos)) + | NbDiscordances -> Number (N.of_float (float ctx.ctx_nb_discos)) + | NbInformatives -> Number (N.of_float (float ctx.ctx_nb_infos)) + | NbBloquantes -> Number (N.of_float (float ctx.ctx_nb_bloquantes)) + | NbCategory _ -> assert false + | FuncCallLoop _ | Loop _ -> assert false + with + | RuntimeError (e, ctx) -> + if !exit_on_rte then raise_runtime_as_structured e + else raise (RuntimeError (e, ctx)) + | Errors.StructuredError (msg, pos, kont) -> + if !exit_on_rte then + raise + (Errors.StructuredError + ( msg, + pos + @ [ + (Some "Expression raising the error:", Pos.get_position e); + ], + kont )) + else raise (RuntimeError (StructuredError (msg, pos, kont), ctx)) + in + if match out with Undefined -> false | Number out -> N.is_nan_or_inf out + then + let e = + NanOrInf + ( (match out with + | Undefined -> assert false + | Number out -> Format.asprintf "%a" N.format_t out), + e ) + in + if !exit_on_rte then raise_runtime_as_structured e + else raise (RuntimeError (e, ctx)) + else out + + and set_var_value (p : Mir.program) (ctx : ctx) ((var, vi) : Com.Var.t * int) + (vexpr : Mir.expression Pos.marked) : unit = + let value = evaluate_expr ctx p vexpr in + match Com.Var.is_table var with + | None -> ( + match var.scope with + | Com.Var.Tgv _ -> ctx.ctx_tgv.(vi) <- value + | Com.Var.Temp _ -> ctx.ctx_tmps.(vi) <- value + | Com.Var.Ref -> assert false + | Com.Var.Arg -> (List.hd ctx.ctx_args).(vi) <- value + | Com.Var.Res -> ctx.ctx_res <- value :: List.tl ctx.ctx_res) + | Some sz -> ( + match var.scope with + | Com.Var.Tgv _ -> + for i = 0 to sz - 1 do + ctx.ctx_tgv.(vi + i) <- value + done + | Com.Var.Temp _ -> + for i = 0 to sz - 1 do + ctx.ctx_tmps.(vi + i) <- value + done + | Com.Var.Ref -> assert false + | Com.Var.Arg -> (List.hd ctx.ctx_args).(vi) <- value + | Com.Var.Res -> ctx.ctx_res <- value :: List.tl ctx.ctx_res) + + and set_var_value_tab (p : Mir.program) (ctx : ctx) + ((var, vi) : Com.Var.t * int) (ei : Mir.expression Pos.marked) + (vexpr : Mir.expression Pos.marked) : unit = + match evaluate_expr ctx p ei with + | Undefined -> () + | Number f -> ( + let i = int_of_float (N.to_float f) in + let sz = Com.Var.size var in + if 0 <= i && i < sz then + let value = evaluate_expr ctx p vexpr in + match var.scope with + | Com.Var.Tgv _ -> ctx.ctx_tgv.(vi + i) <- value + | Com.Var.Temp _ -> ctx.ctx_tmps.(vi + i) <- value + | Com.Var.Ref -> assert false + | Com.Var.Arg -> (List.hd ctx.ctx_args).(vi) <- value + | Com.Var.Res -> ctx.ctx_res <- value :: List.tl ctx.ctx_res) + + and evaluate_stmt (canBlock : bool) (p : Mir.program) (ctx : ctx) + (stmt : Mir.m_instruction) : unit = + match Pos.unmark stmt with + | Com.Affectation (Com.SingleFormula (m_var, vidx_opt, vexpr), _) -> ( + let vari = get_var ctx (Pos.unmark m_var) in + match vidx_opt with + | None -> set_var_value p ctx vari vexpr + | Some ei -> set_var_value_tab p ctx vari ei vexpr) + | Com.Affectation _ -> assert false + | Com.IfThenElse (b, t, f) -> ( + match evaluate_expr ctx p b with + | Number z when N.(z =. zero ()) -> evaluate_stmts canBlock p ctx f + | Number _ -> evaluate_stmts canBlock p ctx t + | Undefined -> ()) + | Com.WhenDoElse (wdl, ed) -> + let rec aux = function + | (expr, dl, _) :: l -> ( + match evaluate_expr ctx p expr with + | Number z when N.(z =. zero ()) -> + evaluate_stmts canBlock p ctx (Pos.unmark ed) + | Number _ -> + evaluate_stmts canBlock p ctx dl; + aux l + | Undefined -> aux l) + | [] -> () + in + aux wdl + | Com.VerifBlock stmts -> evaluate_stmts true p ctx stmts + | Com.ComputeTarget ((tn, _), args) -> + let tf = Com.TargetMap.find tn p.program_targets in + let rec set_args n = function + | [] -> () + | m_a :: al' -> + let a = m_a |> Pos.unmark |> get_var ctx in + ctx.ctx_ref.(ctx.ctx_ref_org + n) <- a; + set_args (n + 1) al' + in + set_args 0 args; + evaluate_target canBlock p ctx tn tf + | Com.Print (std, args) -> begin + let std_fmt, ctx_pr = + match std with + | Com.StdOut -> (Format.std_formatter, ctx.ctx_pr_out) + | Com.StdErr -> (Format.err_formatter, ctx.ctx_pr_err) + in + let pr_indent ctx_pr = + if ctx_pr.is_newline then ( + for _i = 1 to ctx_pr.indent do + Format.fprintf std_fmt " " + done; + ctx_pr.is_newline <- false) + in + let pr_raw ctx_pr s = + let len = String.length s in + let rec aux = function + | n when n >= len -> () + | n -> ( + match s.[n] with + | '\n' -> + Format.fprintf std_fmt "\n"; + ctx_pr.is_newline <- true; + aux (n + 1) + | c -> + pr_indent ctx_pr; + Format.fprintf std_fmt "%c" c; + aux (n + 1)) + in + aux 0 + in + List.iter + (fun (arg : Com.Var.t Com.print_arg Pos.marked) -> + match Pos.unmark arg with + | PrintString s -> pr_raw ctx_pr s + | PrintName (var, _) -> + let var, _ = get_var ctx var in + pr_raw ctx_pr (Pos.unmark var.name) + | PrintAlias (var, _) -> + let var, _ = get_var ctx var in + pr_raw ctx_pr (Com.Var.alias_str var) + | PrintIndent e -> + let diff = + match evaluate_expr ctx p e with + | Undefined -> 0 + | Number x -> Int64.to_int (N.to_int (roundf x)) + in + ctx_pr.indent <- max 0 (ctx_pr.indent + diff) + | PrintExpr (e, mi, ma) -> + let value = evaluate_expr ctx p e in + pr_indent ctx_pr; + format_value_prec mi ma std_fmt value) + args; + match std with + | Com.StdOut -> () + | Com.StdErr -> Format.pp_print_flush Format.err_formatter () + end + | Com.Iterate ((m_var : Com.Var.t Pos.marked), vars, var_params, stmts) -> + let var = Pos.unmark m_var in + let var_i = + match var.loc with LocRef (_, i) -> i | _ -> assert false + in + List.iter + (fun (v, _) -> + ctx.ctx_ref.(ctx.ctx_ref_org + var_i) <- get_var ctx v; + evaluate_stmts canBlock p ctx stmts) + vars; + List.iter + (fun (vcs, expr) -> + let eval vc _ = + StrMap.iter + (fun _ v -> + if Com.CatVar.compare (Com.Var.cat v) vc = 0 then ( + ctx.ctx_ref.(ctx.ctx_ref_org + var_i) <- get_var ctx v; + match evaluate_expr ctx p expr with + | Number z when N.(z =. one ()) -> + evaluate_stmts canBlock p ctx stmts + | _ -> ())) + p.program_vars + in + Com.CatVar.Map.iter eval vcs) + var_params + | Com.Restore (vars, var_params, stmts) -> + let backup = + List.fold_left + (fun backup (m_v : Com.Var.t Pos.marked) -> + let v, vi = m_v |> Pos.unmark |> get_var ctx in + let rec aux backup i = + if i = Com.Var.size v then backup + else + let value = get_var_value ctx v i in + aux ((v, vi + i, value) :: backup) (i + 1) + in + aux backup 0) + [] vars + in + let backup = + List.fold_left + (fun backup ((m_var : Com.Var.t Pos.marked), vcs, expr) -> + let var = Pos.unmark m_var in + let var_i = + match var.loc with LocRef (_, i) -> i | _ -> assert false + in + Com.CatVar.Map.fold + (fun vc _ backup -> + StrMap.fold + (fun _ v backup -> + if Com.CatVar.compare (Com.Var.cat v) vc = 0 then ( + let var, vi = get_var ctx v in + ctx.ctx_ref.(ctx.ctx_ref_org + var_i) <- (var, vi); + match evaluate_expr ctx p expr with + | Number z when N.(z =. one ()) -> + let rec aux backup i = + if i = Com.Var.size var then backup + else + let value = get_var_value ctx var i in + aux ((v, vi + i, value) :: backup) (i + 1) + in + aux backup 0 + | _ -> backup) + else backup) + p.program_vars backup) + vcs backup) + backup var_params + in + evaluate_stmts canBlock p ctx stmts; + List.iter + (fun ((v : Com.Var.t), i, value) -> + match v.scope with + | Com.Var.Tgv _ -> ctx.ctx_tgv.(i) <- value + | Com.Var.Temp _ -> ctx.ctx_tmps.(i) <- value + | Com.Var.Ref -> assert false + | Com.Var.Arg -> (List.hd ctx.ctx_args).(i) <- value + | Com.Var.Res -> ctx.ctx_res <- value :: List.tl ctx.ctx_res) + backup + | Com.RaiseError (m_err, var_opt) -> + let err = Pos.unmark m_err in + (match err.typ with + | Com.Error.Anomaly -> ctx.ctx_nb_anos <- ctx.ctx_nb_anos + 1 + | Com.Error.Discordance -> ctx.ctx_nb_discos <- ctx.ctx_nb_discos + 1 + | Com.Error.Information -> ctx.ctx_nb_infos <- ctx.ctx_nb_infos + 1); + let is_blocking = + err.typ = Com.Error.Anomaly && Pos.unmark err.isisf = "N" + in + ctx.ctx_nb_bloquantes <- + (ctx.ctx_nb_bloquantes + if is_blocking then 1 else 0); + let v_opt = Option.map Pos.unmark var_opt in + ctx.ctx_anos <- ctx.ctx_anos @ [ (err, v_opt) ]; + if is_blocking && ctx.ctx_nb_bloquantes >= 4 && canBlock then + raise BlockingError + | Com.CleanErrors -> + ctx.ctx_anos <- []; + ctx.ctx_nb_anos <- 0; + ctx.ctx_nb_discos <- 0; + ctx.ctx_nb_infos <- 0; + ctx.ctx_nb_bloquantes <- 0 + | Com.FinalizeErrors -> + let not_in_old_anos (err, _) = + let name = Pos.unmark err.Com.Error.name in + not (StrSet.mem name ctx.ctx_old_anos) + in + ctx.ctx_finalized_anos <- + (let rec merge_anos old_anos new_anos = + match (old_anos, new_anos) with + | [], anos | anos, [] -> anos + | _ :: old_tl, a :: new_tl -> a :: merge_anos old_tl new_tl + in + let new_anos = List.filter not_in_old_anos ctx.ctx_anos in + merge_anos ctx.ctx_finalized_anos new_anos); + let add_ano res (err, _) = + StrSet.add (Pos.unmark err.Com.Error.name) res + in + ctx.ctx_old_anos <- List.fold_left add_ano ctx.ctx_old_anos ctx.ctx_anos + | Com.ExportErrors -> + ctx.ctx_exported_anos <- ctx.ctx_exported_anos @ ctx.ctx_finalized_anos; + ctx.ctx_finalized_anos <- [] + | Com.ComputeDomain _ | Com.ComputeChaining _ | Com.ComputeVerifs _ -> + assert false + + and evaluate_stmts canBlock (p : Mir.program) (ctx : ctx) + (stmts : Mir.m_instruction list) : unit = + try List.iter (evaluate_stmt canBlock p ctx) stmts + with BlockingError as b_err -> if canBlock then raise b_err + + and evaluate_target canBlock (p : Mir.program) (ctx : ctx) (_tn : string) + (tf : Mir.target_data) : unit = + for i = 0 to tf.target_sz_tmps - 1 do + ctx.ctx_tmps.(ctx.ctx_tmps_org + i) <- Undefined + done; + ctx.ctx_tmps_org <- ctx.ctx_tmps_org + tf.target_sz_tmps; + ctx.ctx_ref_org <- ctx.ctx_ref_org + tf.target_nb_refs; + evaluate_stmts canBlock p ctx tf.target_prog; + ctx.ctx_ref_org <- ctx.ctx_ref_org - tf.target_nb_refs; + ctx.ctx_tmps_org <- ctx.ctx_tmps_org - tf.target_sz_tmps + + let evaluate_program (p : Mir.program) (ctx : ctx) : unit = + try + let main_target = + match + Com.TargetMap.find_opt p.program_main_target p.program_targets + with + | Some t -> t + | None -> + Errors.raise_error "Unable to find main function of Bir program" + in + evaluate_target false p ctx p.program_main_target main_target; + evaluate_stmt false p ctx (Com.ExportErrors, Pos.no_pos) + with RuntimeError (e, ctx) -> + if !exit_on_rte then raise_runtime_as_structured e + else raise (RuntimeError (e, ctx)) +end + +module BigIntPrecision = struct + let scaling_factor_bits = ref 64 +end + +module MainframeLongSize = struct + let max_long = ref Int64.max_int +end + +module FloatDefInterp = + Make (Mir_number.RegularFloatNumber) (Mir_roundops.DefaultRoundOps) +module FloatMultInterp = + Make (Mir_number.RegularFloatNumber) (Mir_roundops.MultiRoundOps) +module FloatMfInterp = + Make + (Mir_number.RegularFloatNumber) + (Mir_roundops.MainframeRoundOps (MainframeLongSize)) +module MPFRDefInterp = + Make (Mir_number.MPFRNumber) (Mir_roundops.DefaultRoundOps) +module MPFRMultInterp = + Make (Mir_number.MPFRNumber) (Mir_roundops.MultiRoundOps) +module MPFRMfInterp = + Make + (Mir_number.MPFRNumber) + (Mir_roundops.MainframeRoundOps (MainframeLongSize)) +module BigIntDefInterp = + Make + (Mir_number.BigIntFixedPointNumber + (BigIntPrecision)) + (Mir_roundops.DefaultRoundOps) +module BigIntMultInterp = + Make + (Mir_number.BigIntFixedPointNumber + (BigIntPrecision)) + (Mir_roundops.MultiRoundOps) +module BigIntMfInterp = + Make + (Mir_number.BigIntFixedPointNumber + (BigIntPrecision)) + (Mir_roundops.MainframeRoundOps (MainframeLongSize)) +module IntvDefInterp = + Make (Mir_number.IntervalNumber) (Mir_roundops.DefaultRoundOps) +module IntvMultInterp = + Make (Mir_number.IntervalNumber) (Mir_roundops.MultiRoundOps) +module IntvMfInterp = + Make + (Mir_number.IntervalNumber) + (Mir_roundops.MainframeRoundOps (MainframeLongSize)) +module RatDefInterp = + Make (Mir_number.RationalNumber) (Mir_roundops.DefaultRoundOps) +module RatMultInterp = + Make (Mir_number.RationalNumber) (Mir_roundops.MultiRoundOps) +module RatMfInterp = + Make + (Mir_number.RationalNumber) + (Mir_roundops.MainframeRoundOps (MainframeLongSize)) + +let get_interp (sort : Cli.value_sort) (roundops : Cli.round_ops) : (module S) = + match (sort, roundops) with + | RegularFloat, RODefault -> (module FloatDefInterp) + | RegularFloat, ROMulti -> (module FloatMultInterp) + | RegularFloat, ROMainframe _ -> (module FloatMfInterp) + | MPFR _, RODefault -> (module MPFRDefInterp) + | MPFR _, ROMulti -> (module MPFRMultInterp) + | MPFR _, ROMainframe _ -> (module MPFRMfInterp) + | BigInt _, RODefault -> (module BigIntDefInterp) + | BigInt _, ROMulti -> (module BigIntMultInterp) + | BigInt _, ROMainframe _ -> (module BigIntMfInterp) + | Interval, RODefault -> (module IntvDefInterp) + | Interval, ROMulti -> (module IntvMultInterp) + | Interval, ROMainframe _ -> (module IntvMfInterp) + | Rational, RODefault -> (module RatDefInterp) + | Rational, ROMulti -> (module RatMultInterp) + | Rational, ROMainframe _ -> (module RatMfInterp) + +let prepare_interp (sort : Cli.value_sort) (roundops : Cli.round_ops) : unit = + begin + match sort with + | MPFR prec -> Mpfr.set_default_prec prec + | BigInt prec -> BigIntPrecision.scaling_factor_bits := prec + | Interval -> Mpfr.set_default_prec 64 + | _ -> () + end; + match roundops with + | ROMainframe long_size -> + let max_long = + if long_size = 32 then Int64.of_int32 Int32.max_int + else if long_size = 64 then Int64.max_int + else assert false + (* checked when parsing command line *) + in + MainframeLongSize.max_long := max_long + | _ -> () + +let evaluate_program (p : Mir.program) (inputs : Com.literal Com.Var.Map.t) + (sort : Cli.value_sort) (roundops : Cli.round_ops) : + float option StrMap.t * StrSet.t = + prepare_interp sort roundops; + let module Interp = (val get_interp sort roundops : S) in + let ctx = Interp.empty_ctx p in + Interp.update_ctx_with_inputs ctx inputs; + Interp.evaluate_program p ctx; + let varMap = + let fold name (var : Com.Var.t) res = + if Com.Var.is_given_back var then + let fVal = + let litt = ctx.ctx_tgv.(Com.Var.loc_int var) in + match Interp.value_to_literal litt with + | Com.Float f -> Some f + | Com.Undefined -> None + in + StrMap.add name fVal res + else res + in + StrMap.fold fold p.program_vars StrMap.empty + in + let anoSet = + let fold res (e, _) = StrSet.add (Pos.unmark e.Com.Error.name) res in + List.fold_left fold StrSet.empty ctx.ctx_exported_anos + in + (varMap, anoSet) + +let evaluate_expr (p : Mir.program) (e : Mir.expression Pos.marked) + (sort : Cli.value_sort) (roundops : Cli.round_ops) : Com.literal = + let module Interp = (val get_interp sort roundops : S) in + Interp.value_to_literal (Interp.evaluate_expr (Interp.empty_ctx p) p e) diff --git a/src/mlang/backend_ir/bir_interpreter.mli b/src/mlang/m_ir/mir_interpreter.mli similarity index 53% rename from src/mlang/backend_ir/bir_interpreter.mli rename to src/mlang/m_ir/mir_interpreter.mli index 037682519..8a087b81c 100644 --- a/src/mlang/backend_ir/bir_interpreter.mli +++ b/src/mlang/m_ir/mir_interpreter.mli @@ -18,38 +18,11 @@ (**{1 Program values}*) -(* Type of the values being passed around in the interpreter **) -type var_literal = - | SimpleVar of Mir.literal - | TableVar of int * Mir.literal array - (**{1 Instrumentation of the interpreter}*) (** The BIR interpreter can be instrumented to record which program locations have been executed. *) -(** Representation of each program location segment *) -type code_location_segment = - | InsideBlock of int - | ConditionalBranch of bool - | InsideRule of Bir.rov_id - | InsideFunction of Bir.function_name - | InsideIterate of Bir.variable - -val format_code_location_segment : - Format.formatter -> code_location_segment -> unit - -type code_location = code_location_segment list -(** A program location is simply the path inside the program *) - -val format_code_location : Format.formatter -> code_location -> unit - -val assign_hook : - (Bir.variable -> (unit -> var_literal) -> code_location -> unit) ref -(** The instrumentation of the interpreter is done through this reference. The - function that you assign to this reference will be called each time a - variable assignment is executed *) - val exit_on_rte : bool ref (** If set to true, the interpreter exits the whole process in case of runtime error *) @@ -75,53 +48,40 @@ module type S = sig val format_value_prec : int -> int -> Format.formatter -> value -> unit - (** Functor-specific variable values *) - type var_value = SimpleVar of value | TableVar of int * value array - - val format_var_value : Format.formatter -> var_value -> unit - - val format_var_value_prec : - int -> int -> Format.formatter -> var_value -> unit - - val format_var_value_with_var : - Format.formatter -> Bir.variable * var_value -> unit - - type print_ctx = { indent : int; is_newline : bool } + type print_ctx = { mutable indent : int; mutable is_newline : bool } type ctx = { - ctx_local_vars : value Pos.marked Mir.LocalVariableMap.t; - ctx_vars : var_value Bir.VariableMap.t; - ctx_it : Mir.variable IntMap.t; + ctx_tgv : value Array.t; + ctx_tmps : value Array.t; + mutable ctx_tmps_org : int; + ctx_ref : (Com.Var.t * int) Array.t; + mutable ctx_ref_org : int; + mutable ctx_args : value Array.t list; + mutable ctx_res : value list; ctx_pr_out : print_ctx; ctx_pr_err : print_ctx; - ctx_anos : (Mir.error * string option) list; - ctx_old_anos : StrSet.t; - ctx_nb_anos : int; - ctx_nb_discos : int; - ctx_nb_infos : int; - ctx_nb_bloquantes : int; - ctx_finalized_anos : (Mir.error * string option) list; - ctx_exported_anos : (Mir.error * string option) list; + mutable ctx_anos : (Com.Error.t * string option) list; + mutable ctx_old_anos : StrSet.t; + mutable ctx_nb_anos : int; + mutable ctx_nb_discos : int; + mutable ctx_nb_infos : int; + mutable ctx_nb_bloquantes : int; + mutable ctx_finalized_anos : (Com.Error.t * string option) list; + mutable ctx_exported_anos : (Com.Error.t * string option) list; } (** Interpretation context *) - val empty_ctx : ctx - - val literal_to_value : Mir.literal -> value + val empty_ctx : Mir.program -> ctx - val var_literal_to_var_value : var_literal -> var_value + val literal_to_value : Com.literal -> value - val value_to_literal : value -> Mir.literal + val value_to_literal : value -> Com.literal - val var_value_to_var_literal : var_value -> var_literal - - val update_ctx_with_inputs : ctx -> Mir.literal Bir.VariableMap.t -> ctx - - val complete_ctx : ctx -> Mir.VariableDict.t -> ctx + val update_ctx_with_inputs : ctx -> Com.literal Com.Var.Map.t -> unit (** Interpreter runtime errors *) type run_error = - | NanOrInf of string * Bir.expression Pos.marked + | NanOrInf of string * Mir.expression Pos.marked | StructuredError of (string * (string option * Pos.t) list * (unit -> unit) option) @@ -130,17 +90,17 @@ module type S = sig val raise_runtime_as_structured : run_error -> 'a (** Raises a runtime error with a formatted error message and context *) - val compare_numbers : Mast.comp_op -> custom_float -> custom_float -> bool + val compare_numbers : Com.comp_op -> custom_float -> custom_float -> bool (** Returns the comparison between two numbers in the rounding and precision context of the interpreter. *) - val evaluate_expr : ctx -> Mir.program -> Bir.expression Pos.marked -> value + val evaluate_expr : ctx -> Mir.program -> Mir.expression Pos.marked -> value - val evaluate_program : Bir.program -> ctx -> int -> ctx + val evaluate_program : Mir.program -> ctx -> unit end module FloatDefInterp : - S with type custom_float = Bir_number.RegularFloatNumber.t + S with type custom_float = Mir_number.RegularFloatNumber.t (** The different interpreters, which combine a representation of numbers and rounding operations. The first part of the name corresponds to the representation of numbers, and is one of the following: @@ -160,16 +120,16 @@ module FloatDefInterp : - Mf: use the rounding operations of the mainframe context *) module FloatMultInterp : - S with type custom_float = Bir_number.RegularFloatNumber.t + S with type custom_float = Mir_number.RegularFloatNumber.t module FloatMfInterp : - S with type custom_float = Bir_number.RegularFloatNumber.t + S with type custom_float = Mir_number.RegularFloatNumber.t -module MPFRDefInterp : S with type custom_float = Bir_number.MPFRNumber.t +module MPFRDefInterp : S with type custom_float = Mir_number.MPFRNumber.t -module MPFRMultInterp : S with type custom_float = Bir_number.MPFRNumber.t +module MPFRMultInterp : S with type custom_float = Mir_number.MPFRNumber.t -module MPFRMfInterp : S with type custom_float = Bir_number.MPFRNumber.t +module MPFRMfInterp : S with type custom_float = Mir_number.MPFRNumber.t module BigIntDefInterp : S @@ -177,25 +137,25 @@ module BigIntMultInterp : S module BigIntMfInterp : S -module IntvDefInterp : S with type custom_float = Bir_number.IntervalNumber.t +module IntvDefInterp : S with type custom_float = Mir_number.IntervalNumber.t -module IntvMultInterp : S with type custom_float = Bir_number.IntervalNumber.t +module IntvMultInterp : S with type custom_float = Mir_number.IntervalNumber.t -module IntvMfInterp : S with type custom_float = Bir_number.IntervalNumber.t +module IntvMfInterp : S with type custom_float = Mir_number.IntervalNumber.t -module RatDefInterp : S with type custom_float = Bir_number.RationalNumber.t +module RatDefInterp : S with type custom_float = Mir_number.RationalNumber.t -module RatMultInterp : S with type custom_float = Bir_number.RationalNumber.t +module RatMultInterp : S with type custom_float = Mir_number.RationalNumber.t -module RatMfInterp : S with type custom_float = Bir_number.RationalNumber.t +module RatMfInterp : S with type custom_float = Mir_number.RationalNumber.t (** {1 Generic interpretation API}*) val get_interp : Cli.value_sort -> Cli.round_ops -> (module S) val evaluate_program : - Bir.program -> - Mir.literal Bir.VariableMap.t -> + Mir.program -> + Com.literal Com.Var.Map.t -> Cli.value_sort -> Cli.round_ops -> float option StrMap.t * StrSet.t @@ -203,8 +163,8 @@ val evaluate_program : val evaluate_expr : Mir.program -> - Bir.expression Pos.marked -> + Mir.expression Pos.marked -> Cli.value_sort -> Cli.round_ops -> - Mir.literal + Com.literal (** Interprets only an expression *) diff --git a/src/mlang/backend_ir/bir_number.ml b/src/mlang/m_ir/mir_number.ml similarity index 99% rename from src/mlang/backend_ir/bir_number.ml rename to src/mlang/m_ir/mir_number.ml index 610dac8f7..5a3342699 100644 --- a/src/mlang/backend_ir/bir_number.ml +++ b/src/mlang/m_ir/mir_number.ml @@ -34,7 +34,7 @@ module type NumberInterface = sig val of_float : float -> t - val of_float_input : Mir.Variable.t -> float -> t + val of_float_input : Com.Var.t -> float -> t val to_float : t -> float (** Warning: lossy *) @@ -237,7 +237,7 @@ module IntervalNumber : NumberInterface = struct let of_float (f : float) = v (Mpfrf.of_float f Down) (Mpfrf.of_float f Up) - let of_float_input (_v : Mir.Variable.t) (f : float) = + let of_float_input (_v : Com.Var.t) (f : float) = v (Mpfrf.of_float f Down) (Mpfrf.of_float f Up) let to_float (f : t) : float = diff --git a/src/mlang/backend_ir/bir_number.mli b/src/mlang/m_ir/mir_number.mli similarity index 97% rename from src/mlang/backend_ir/bir_number.mli rename to src/mlang/m_ir/mir_number.mli index 894d0be67..d9ce279f7 100644 --- a/src/mlang/backend_ir/bir_number.mli +++ b/src/mlang/m_ir/mir_number.mli @@ -33,7 +33,7 @@ module type NumberInterface = sig val of_float : float -> t - val of_float_input : Mir.Variable.t -> float -> t + val of_float_input : Com.Var.t -> float -> t val to_float : t -> float diff --git a/src/mlang/backend_ir/bir_roundops.ml b/src/mlang/m_ir/mir_roundops.ml similarity index 91% rename from src/mlang/backend_ir/bir_roundops.ml rename to src/mlang/m_ir/mir_roundops.ml index 53b64c4bf..f39fad3ca 100644 --- a/src/mlang/backend_ir/bir_roundops.ml +++ b/src/mlang/m_ir/mir_roundops.ml @@ -22,10 +22,10 @@ module type RoundOpsInterface = sig val roundf : t -> t end -module type RoundOpsFunctor = functor (N : Bir_number.NumberInterface) -> +module type RoundOpsFunctor = functor (N : Mir_number.NumberInterface) -> RoundOpsInterface with type t = N.t -module DefaultRoundOps (N : Bir_number.NumberInterface) : +module DefaultRoundOps (N : Mir_number.NumberInterface) : RoundOpsInterface with type t = N.t = struct type t = N.t @@ -41,7 +41,7 @@ module DefaultRoundOps (N : Bir_number.NumberInterface) : if N.(x < zero ()) then N.ceil N.(x -. e) else N.floor N.(x +. e) end -module MultiRoundOps (N : Bir_number.NumberInterface) : +module MultiRoundOps (N : Mir_number.NumberInterface) : RoundOpsInterface with type t = N.t = struct type t = N.t @@ -57,7 +57,7 @@ end module MainframeRoundOps (L : sig val max_long : Int64.t ref end) -(N : Bir_number.NumberInterface) : RoundOpsInterface with type t = N.t = struct +(N : Mir_number.NumberInterface) : RoundOpsInterface with type t = N.t = struct type t = N.t let epsilon = !Cli.comparison_error_margin diff --git a/src/mlang/backend_ir/bir_roundops.mli b/src/mlang/m_ir/mir_roundops.mli similarity index 96% rename from src/mlang/backend_ir/bir_roundops.mli rename to src/mlang/m_ir/mir_roundops.mli index d05d865e9..304131bc8 100644 --- a/src/mlang/backend_ir/bir_roundops.mli +++ b/src/mlang/m_ir/mir_roundops.mli @@ -25,7 +25,7 @@ end (** The actual implementation of rounding operations depends on the chosen representation of numbers, hence we need a functor *) -module type RoundOpsFunctor = functor (N : Bir_number.NumberInterface) -> +module type RoundOpsFunctor = functor (N : Mir_number.NumberInterface) -> RoundOpsInterface with type t = N.t module DefaultRoundOps : RoundOpsFunctor diff --git a/src/mlang/test_framework/test_interpreter.ml b/src/mlang/test_framework/test_interpreter.ml index d7b301d46..0f2cae124 100644 --- a/src/mlang/test_framework/test_interpreter.ml +++ b/src/mlang/test_framework/test_interpreter.ml @@ -13,36 +13,29 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . *) -let find_var_of_name (p : Mir.program) (name : string Pos.marked) : - Mir.Variable.t = - try Pos.VarNameToID.find (Pos.unmark name) p.program_idmap +let find_var_of_name (p : Mir.program) (name : string Pos.marked) : Com.Var.t = + try StrMap.find (Pos.unmark name) p.program_vars with Not_found -> let name = Mir.find_var_name_by_alias p name in - Pos.VarNameToID.find name p.program_idmap + StrMap.find name p.program_vars -let to_MIR_function_and_inputs (program : Bir.program) (t : Irj_ast.irj_file) : - float StrMap.t * StrSet.t * Mir.literal Bir.VariableMap.t = +let to_MIR_function_and_inputs (program : Mir.program) (t : Irj_ast.irj_file) : + float StrMap.t * StrSet.t * Com.literal Com.Var.Map.t = let input_file = - let ancsded = - find_var_of_name program.mir_program ("V_ANCSDED", Pos.no_pos) - |> Bir.(var_from_mir default_tgv) - in + let ancsded = find_var_of_name program ("V_ANCSDED", Pos.no_pos) in let ancsded_val = - Mir.Float (float_of_int (Option.get !Cli.income_year + 1)) + Com.Float (float_of_int (Option.get !Cli.income_year + 1)) in List.fold_left (fun in_f ((var, var_pos), (value, _value_pos)) -> - let var = - find_var_of_name program.mir_program (var, var_pos) - |> Bir.(var_from_mir default_tgv) - in + let var = find_var_of_name program (var, var_pos) in let lit = match value with - | Irj_ast.I i -> Mir.Float (float_of_int i) - | F f -> Float f + | Irj_ast.I i -> Com.Float (float_of_int i) + | F f -> Com.Float f in - Bir.VariableMap.add var lit in_f) - (Bir.VariableMap.singleton ancsded ancsded_val) + Com.Var.Map.add var lit in_f) + (Com.Var.Map.one ancsded ancsded_val) t.prim.entrees in let expectedVars = @@ -60,22 +53,17 @@ let to_MIR_function_and_inputs (program : Bir.program) (t : Irj_ast.irj_file) : exception InterpError of int -let check_test (combined_program : Bir.program) (test_name : string) - (code_coverage : bool) (value_sort : Cli.value_sort) - (round_ops : Cli.round_ops) : Bir_instrumentation.code_coverage_result = +let check_test (program : Mir.program) (test_name : string) + (value_sort : Cli.value_sort) (round_ops : Cli.round_ops) : unit = Cli.debug_print "Parsing %s..." test_name; let t = Irj_file.parse_file test_name in Cli.debug_print "Running test %s..." t.nom; - let expVars, expAnos, input_file = - to_MIR_function_and_inputs combined_program t - in + let expVars, expAnos, input_file = to_MIR_function_and_inputs program t in Cli.debug_print "Executing program"; (* Cli.debug_print "Combined Program (w/o verif conds):@.%a@." - Format_bir.format_program combined_program; *) - if code_coverage then Bir_instrumentation.code_coverage_init (); + Format_bir.format_program program; *) let varMap, anoSet = - Bir_interpreter.evaluate_program combined_program input_file value_sort - round_ops + Mir_interpreter.evaluate_program program input_file value_sort round_ops in let check_vars exp vars = let test_error_margin = 0.01 in @@ -98,25 +86,13 @@ let check_test (combined_program : Bir.program) (test_name : string) StrSet.cardinal missAnos + StrSet.cardinal unexAnos in let nbErrs = check_vars expVars varMap + check_anos expAnos anoSet in - if nbErrs > 0 then raise (InterpError nbErrs); - if code_coverage then Bir_instrumentation.code_coverage_result () - else Bir_instrumentation.empty_code_coverage_result - -type process_acc = - string list * int StrMap.t * Bir_instrumentation.code_coverage_acc + if nbErrs > 0 then raise (InterpError nbErrs) -type coverage_kind = - | NotCovered - | Covered of int (** The int is the number of different values *) +type process_acc = string list * int StrMap.t -let incr_int_key (m : int IntMap.t) (key : int) : int IntMap.t = - match IntMap.find_opt key m with - | None -> IntMap.add key 0 m - | Some i -> IntMap.add key (i + 1) m - -let check_all_tests (p : Bir.program) (test_dir : string) - (code_coverage_activated : bool) (value_sort : Cli.value_sort) - (round_ops : Cli.round_ops) (filter_function : string -> bool) = +let check_all_tests (p : Mir.program) (test_dir : string) + (value_sort : Cli.value_sort) (round_ops : Cli.round_ops) + (filter_function : string -> bool) = let arr = Sys.readdir test_dir in let arr = Array.of_list @@ -125,62 +101,49 @@ let check_all_tests (p : Bir.program) (test_dir : string) (fun x -> not @@ Sys.is_directory (test_dir ^ "/" ^ x)) (Array.to_list arr) in - Bir_interpreter.exit_on_rte := false; + Mir_interpreter.exit_on_rte := false; (* sort by increasing size, hoping that small files = simple tests *) Array.sort compare arr; Cli.warning_flag := false; Cli.display_time := false; (* let _, finish = Cli.create_progress_bar "Testing files" in*) - let process (name : string) - ((successes, failures, code_coverage_acc) : process_acc) : process_acc = - let module Interp = (val Bir_interpreter.get_interp value_sort round_ops - : Bir_interpreter.S) + let process (name : string) ((successes, failures) : process_acc) : + process_acc = + let module Interp = (val Mir_interpreter.get_interp value_sort round_ops + : Mir_interpreter.S) in try Cli.debug_flag := false; - let code_coverage_result = - check_test p (test_dir ^ name) code_coverage_activated value_sort - round_ops - in + check_test p (test_dir ^ name) value_sort round_ops; Cli.debug_flag := true; - let code_coverage_acc = - Bir_instrumentation.merge_code_coverage_single_results_with_acc - code_coverage_result code_coverage_acc - in Cli.result_print "%s" name; - (name :: successes, failures, code_coverage_acc) + (name :: successes, failures) with - | InterpError nbErr -> - (successes, StrMap.add name nbErr failures, code_coverage_acc) + | InterpError nbErr -> (successes, StrMap.add name nbErr failures) | Errors.StructuredError (msg, pos, kont) -> Cli.error_print "Error in test %s: %a" name Errors.format_structured_error (msg, pos); (match kont with None -> () | Some kont -> kont ()); - (successes, failures, code_coverage_acc) + (successes, failures) | Interp.RuntimeError (run_error, _) -> ( match run_error with | Interp.StructuredError (msg, pos, kont) -> Cli.error_print "Error in test %s: %a" name Errors.format_structured_error (msg, pos); (match kont with None -> () | Some kont -> kont ()); - (successes, failures, code_coverage_acc) + (successes, failures) | Interp.NanOrInf (msg, (_, pos)) -> Cli.error_print "Runtime error in test %s: NanOrInf (%s, %a)" name msg Pos.format_position pos; - (successes, failures, code_coverage_acc)) + (successes, failures)) | e -> Cli.error_print "Uncatched exception: %s" (Printexc.to_string e); raise e in - let s, f, code_coverage = - Parmap.parfold ~chunksize:5 process (Parmap.A arr) - ([], StrMap.empty, Bir.VariableMap.empty) - (fun (old_s, old_f, old_code_coverage) (new_s, new_f, new_code_coverage) - -> - ( new_s @ old_s, - StrMap.union (fun _ x1 x2 -> Some (x1 + x2)) old_f new_f, - Bir_instrumentation.merge_code_coverage_acc old_code_coverage - new_code_coverage )) + let s, f = + Parmap.parfold ~chunksize:5 process (Parmap.A arr) ([], StrMap.empty) + (fun (old_s, old_f) (new_s, new_f) -> + (new_s @ old_s, StrMap.union (fun _ x1 x2 -> Some (x1 + x2)) old_f new_f)) in (* finish "done!"; *) Cli.warning_flag := true; @@ -192,77 +155,4 @@ let check_all_tests (p : Bir.program) (test_dir : string) Cli.warning_print "Failures:"; StrMap.iter (fun name nbErr -> Cli.error_print "\t%d errors in files %s" nbErr name) - f); - if code_coverage_activated then begin - let all_code_locs = Bir_instrumentation.get_code_locs p in - let all_code_locs_with_coverage = - Bir_instrumentation.CodeLocationMap.mapi - (fun code_loc var -> - match Bir.VariableMap.find_opt var code_coverage with - | None -> NotCovered - | Some used_code_locs -> ( - match - Bir_instrumentation.CodeLocationMap.find_opt code_loc - used_code_locs - with - | None -> NotCovered - | Some def -> - Covered (Bir_instrumentation.VarLiteralSet.cardinal def))) - all_code_locs - in - let all_code_locs_num = - Bir_instrumentation.CodeLocationMap.cardinal all_code_locs_with_coverage - in - let number_of_values_to_number_of_statements = - Bir_instrumentation.CodeLocationMap.fold - (fun _ cov number_of_values_to_number_of_statements -> - match cov with - | NotCovered -> - incr_int_key number_of_values_to_number_of_statements 0 - | Covered i -> incr_int_key number_of_values_to_number_of_statements i) - all_code_locs_with_coverage IntMap.empty - in - Cli.result_print - "Here is the estimated code coverage of this set of test runs, broke down"; - Cli.result_print "by the number of values statements are covered with:"; - let number_of_values_to_number_of_statements = - List.sort - (fun x y -> compare (fst x) (fst y)) - (IntMap.bindings number_of_values_to_number_of_statements) - in - let number_of_values_to_number_of_statements = - let rec build_list (i : int) (input : (int * int) list) = - match input with - | [] -> [] - | (i', n) :: tl -> - if i' = i then (i', n) :: build_list (i + 1) tl - else (i, 0) :: build_list (i + 1) input - in - build_list 0 number_of_values_to_number_of_statements - in - let number_zero, number_one, number_two_or_more = - match number_of_values_to_number_of_statements with - | (0, number_zero) :: (1, number_one) :: rest -> - ( number_zero, - number_one, - List.fold_left (fun acc (_, n) -> acc + n) 0 rest ) - | _ -> assert false - in - let number_of_values_to_number_of_statements = - [ - ("zero", number_zero); - ("one", number_one); - ("two or more", number_two_or_more); - ] - in - List.iter - (fun (number_of_values, number_of_statements) -> - Cli.result_print "%s values → %d (%s of statements)" - (ANSITerminal.sprintf [ ANSITerminal.blue ] "%s" number_of_values) - number_of_statements - (ANSITerminal.sprintf [ ANSITerminal.blue ] "%.4f%%" - (float_of_int number_of_statements - /. float_of_int all_code_locs_num - *. 100.))) - number_of_values_to_number_of_statements - end + f) diff --git a/src/mlang/test_framework/test_interpreter.mli b/src/mlang/test_framework/test_interpreter.mli index 355024c7c..ab00f3b43 100644 --- a/src/mlang/test_framework/test_interpreter.mli +++ b/src/mlang/test_framework/test_interpreter.mli @@ -14,22 +14,15 @@ this program. If not, see . *) val check_test : - Bir.program -> + Mir.program -> (* test file name *) string -> - (* code coverage *) bool -> Cli.value_sort -> Cli.round_ops -> - Bir_instrumentation.code_coverage_result -(** [check_test test_file optimize code_coverage value_sort round_ops] runs the - BIR interpreter using float kind [value_sort] and rounding operations - [round_ops] on a given [test_file]. [optimize] and [code_coverage] are flags - that trigger respectively compiler optimizations and code coverage - instrumentation for the interpreter run. *) + unit val check_all_tests : - Bir.program -> + Mir.program -> string -> - bool -> Cli.value_sort -> Cli.round_ops -> (string -> bool) -> diff --git a/src/mlang/utils/cli.ml b/src/mlang/utils/cli.ml index 4ca2fcf9b..778218e44 100644 --- a/src/mlang/utils/cli.ml +++ b/src/mlang/utils/cli.ml @@ -112,14 +112,6 @@ let run_test = & info [ "run_test"; "r" ] ~docv:"TESTS" ~doc:"Run specific test passed as argument") -let code_coverage = - Arg.( - value & flag - & info [ "code_coverage" ] - ~doc: - "Instruments the interpreter to retrieve the code coverage (use with \ - --run_all_tests)") - let precision = Arg.( value @@ -191,8 +183,8 @@ let mlang_t f = const f $ files $ without_dgfip_m $ debug $ var_info_debug $ display_time $ dep_graph_file $ no_print_cycles $ backend $ output $ run_all_tests $ dgfip_test_filter $ run_test $ mpp_function $ optimize_unsafe_float - $ code_coverage $ precision $ roundops $ comparison_error_margin_cli - $ income_year_cli $ m_clean_calls $ dgfip_options) + $ precision $ roundops $ comparison_error_margin_cli $ income_year_cli + $ m_clean_calls $ dgfip_options) let info = let doc = diff --git a/src/mlang/utils/cli.mli b/src/mlang/utils/cli.mli index 9986204ee..6ad7694a9 100644 --- a/src/mlang/utils/cli.mli +++ b/src/mlang/utils/cli.mli @@ -33,7 +33,6 @@ val mlang_t : string option -> string -> bool -> - bool -> string option -> string option -> float option -> diff --git a/src/mlang/utils/dgfip_options.ml b/src/mlang/utils/dgfip_options.ml index 28d07c40d..7cdecf96c 100644 --- a/src/mlang/utils/dgfip_options.ml +++ b/src/mlang/utils/dgfip_options.ml @@ -44,9 +44,6 @@ let immediate_controls = let overlays = Arg.(value & flag & info [ "o" ] ~doc:"Generate overlays") -let multithread = - Arg.(value & flag & info [ "M" ] ~doc:"Generate multithread compatible code") - let optim_min_max = Arg.( value & flag @@ -81,8 +78,8 @@ let dgfip_t f = Term.( const f $ income_year $ application_name $ iliad_pro $ cfir $ batch $ primitive_only $ extraction $ separate_controls $ immediate_controls - $ overlays $ multithread $ optim_min_max $ register $ short $ output_labels - $ debug $ nb_debug_c $ trace $ ticket $ colored_output $ cross_references) + $ overlays $ optim_min_max $ register $ short $ output_labels $ debug + $ nb_debug_c $ trace $ ticket $ colored_output $ cross_references) let info = let doc = "DGFiP-specific options for Mlang." in @@ -120,7 +117,6 @@ type flags = { (* -b0 and -b1 ; disabled by -U and -R *) (* -b *) flg_tri_ebcdic : bool; (* -b1 only *) - (* -M *) flg_multithread : bool; (* -s *) flg_short : bool; (* -r *) flg_register : bool; (* -O *) flg_optim_min_max : bool; @@ -141,8 +137,8 @@ type flags = { (* Flags to deal with in a particular way : -c compilation mode -l link mode -v specify the variable file (tgv.m) -e specify the error file (err.m) *) - (* Other flags, not used in makefiles -h dir_var_h -i flg_ident -C - flg_compact -K flg_optim_cte -G flg_listing (+genere_cre = FALSE) -p + (* Other flags, not used in makefiles -h dir_var_h -i flg_ident + -K flg_optim_cte -G flg_listing (+genere_cre = FALSE) -p flag_phase -f flg_ench_init -E cvt_file -g flg_debug -a flg_api -T flg_trace_irdata *) } @@ -157,7 +153,6 @@ let default_flags = flg_cfir = false; flg_gcos = false; flg_tri_ebcdic = false; - flg_multithread = false; flg_short = false; flg_register = false; flg_optim_min_max = false; @@ -177,10 +172,9 @@ let default_flags = let handler (income_year : int) (application_name : string) (iliad_pro : bool) (cfir : bool) (batch : int option) (primitive_only : bool) (extraction : bool) (separate_controls : bool) (immediate_controls : bool) - (overlays : bool) (multithread : bool) (optim_min_max : bool) - (register : bool) (short : bool) (output_labels : bool) (debug : bool) - (nb_debug_c : int) (trace : bool) (ticket : bool) (colored_output : bool) - (cross_references : bool) : flags = + (overlays : bool) (optim_min_max : bool) (register : bool) (short : bool) + (output_labels : bool) (debug : bool) (nb_debug_c : int) (trace : bool) + (ticket : bool) (colored_output : bool) (cross_references : bool) : flags = { nom_application = application_name; (* iliad, pro, (GP) *) @@ -193,7 +187,6 @@ let handler (income_year : int) (application_name : string) (iliad_pro : bool) flg_cfir = cfir && not iliad_pro; flg_gcos = Option.is_some batch && (not iliad_pro) && not cfir; flg_tri_ebcdic = (match batch with Some 1 -> true | _ -> false); - flg_multithread = multithread; flg_short = short; flg_register = register; flg_optim_min_max = optim_min_max; diff --git a/src/mlang/utils/mapExt.ml b/src/mlang/utils/mapExt.ml index c7068f320..f3a7bea64 100644 --- a/src/mlang/utils/mapExt.ml +++ b/src/mlang/utils/mapExt.ml @@ -1,16 +1,23 @@ module type T = sig include Map.S + val card : 'a t -> int + + val one : key -> 'a -> 'a t + val from_assoc_list : (key * 'a) list -> 'a t val pp : ?sep:string -> - ?pp_key:(Format.formatter -> key -> unit) -> + ?pp_key:(Pp.t -> key -> unit) -> ?assoc:string -> - (Format.formatter -> 'a -> unit) -> - Format.formatter -> + (Pp.t -> 'a -> unit) -> + Pp.t -> 'a t -> unit + + val pp_keys : + ?sep:string -> ?pp_key:(Pp.t -> key -> unit) -> unit -> Pp.t -> 'a t -> unit end module Make = @@ -20,15 +27,16 @@ functor struct include Map.Make (Ord) + let card = cardinal + + let one = singleton + let from_assoc_list (l : (key * 'a) list) : 'a t = let fold map (k, v) = add k v map in List.fold_left fold empty l - let pp_nil (_ : Format.formatter) (_ : 'b) = () - - let pp ?(sep = "; ") ?(pp_key = pp_nil) ?(assoc = " => ") - (pp_val : Format.formatter -> 'a -> unit) (fmt : Format.formatter) - (map : 'a t) : unit = + let pp ?(sep = "; ") ?(pp_key = Pp.nil) ?(assoc = " => ") + (pp_val : Pp.t -> 'a -> unit) (fmt : Pp.t) (map : 'a t) : unit = let pp_content fmt map = let foldMap k v first = let _ = @@ -40,4 +48,8 @@ functor ignore (fold foldMap map true) in Format.fprintf fmt "{ %a }" pp_content map + + let pp_keys ?(sep = "; ") ?(pp_key = Pp.nil) (_ : unit) (fmt : Pp.t) + (map : 'a t) : unit = + pp ~sep ~pp_key ~assoc:"" Pp.nil fmt map end diff --git a/src/mlang/utils/mapExt.mli b/src/mlang/utils/mapExt.mli index 3ec1cec6e..018e291f5 100644 --- a/src/mlang/utils/mapExt.mli +++ b/src/mlang/utils/mapExt.mli @@ -1,16 +1,23 @@ module type T = sig include Map.S + val card : 'a t -> int + + val one : key -> 'a -> 'a t + val from_assoc_list : (key * 'a) list -> 'a t val pp : ?sep:string -> - ?pp_key:(Format.formatter -> key -> unit) -> + ?pp_key:(Pp.t -> key -> unit) -> ?assoc:string -> - (Format.formatter -> 'a -> unit) -> - Format.formatter -> + (Pp.t -> 'a -> unit) -> + Pp.t -> 'a t -> unit + + val pp_keys : + ?sep:string -> ?pp_key:(Pp.t -> key -> unit) -> unit -> Pp.t -> 'a t -> unit end module Make : functor (Ord : Set.OrderedType) -> T with type key = Ord.t diff --git a/src/mlang/utils/pos.ml b/src/mlang/utils/pos.ml index e2a97bc6a..a64b8bd1d 100644 --- a/src/mlang/utils/pos.ml +++ b/src/mlang/utils/pos.ml @@ -92,6 +92,8 @@ let no_pos : t = in { pos_filename = "unknown t"; pos_loc = (zero_pos, zero_pos) } +let mark pos value = (value, pos) + let unmark ((x, _) : 'a marked) : 'a = x let get_position ((_, x) : 'a marked) : t = x @@ -103,8 +105,6 @@ let same_pos_as (x : 'a) ((_, y) : 'b marked) : 'a marked = (x, y) let unmark_option (x : 'a marked option) : 'a option = match x with Some x -> Some (unmark x) | None -> None -module VarNameToID = StrMap - let get_start_line (pos : t) : int = let s, _ = pos.pos_loc in s.Lexing.pos_lnum diff --git a/src/mlang/utils/pos.mli b/src/mlang/utils/pos.mli index 73a98e756..c81b68d69 100644 --- a/src/mlang/utils/pos.mli +++ b/src/mlang/utils/pos.mli @@ -38,6 +38,8 @@ type 'a marked = 'a * t val no_pos : t (** Placeholder t *) +val mark : t -> 'a -> 'a marked + val unmark : 'a marked -> 'a val get_position : 'a marked -> t @@ -48,8 +50,6 @@ val same_pos_as : 'a -> 'b marked -> 'a marked val unmark_option : 'a marked option -> 'a option -module VarNameToID : StrMap.T - val get_start_line : t -> int val get_start_column : t -> int diff --git a/src/mlang/utils/pp.ml b/src/mlang/utils/pp.ml new file mode 100644 index 000000000..4a62ef722 --- /dev/null +++ b/src/mlang/utils/pp.ml @@ -0,0 +1,29 @@ +type t = Format.formatter + +let fpr fmt form_str = Format.fprintf fmt form_str + +let spr form_str = Format.asprintf form_str + +let pr form_str = Format.printf form_str + +let epr form_str = + let cont fmt = Format.fprintf fmt "@?" in + Format.kfprintf cont Format.err_formatter form_str + +let nil _ _ = () + +let string = Format.pp_print_string + +let option pp_elt fmt opt = Format.pp_print_option pp_elt fmt opt + +let list sep pp_elt fmt l = + let pp_sep fmt () = Format.fprintf fmt sep in + Format.pp_print_list ~pp_sep pp_elt fmt l + +let list_endline pp_elt fmt l = list "@\n" pp_elt fmt l + +let list_comma pp_elt fmt l = list ", " pp_elt fmt l + +let list_space pp_elt fmt l = list " " pp_elt fmt l + +let unmark pp_elt fmt e = pp_elt fmt (Pos.unmark e) diff --git a/src/mlang/utils/pp.mli b/src/mlang/utils/pp.mli new file mode 100644 index 000000000..894618f2a --- /dev/null +++ b/src/mlang/utils/pp.mli @@ -0,0 +1,27 @@ +open Format + +type t = formatter + +val fpr : t -> ('a, t, unit) format -> 'a + +val spr : ('a, t, unit, string) format4 -> 'a + +val pr : ('a, t, unit) format -> 'a + +val epr : ('a, t, unit) format -> 'a + +val nil : t -> 'a -> unit + +val string : t -> string -> unit + +val option : (t -> 'a -> unit) -> t -> 'a option -> unit + +val list : (unit, t, unit) format -> (t -> 'a -> unit) -> t -> 'a list -> unit + +val list_endline : (t -> 'a -> unit) -> t -> 'a list -> unit + +val list_comma : (t -> 'a -> unit) -> t -> 'a list -> unit + +val list_space : (t -> 'a -> unit) -> t -> 'a list -> unit + +val unmark : (t -> 'a -> unit) -> t -> 'a Pos.marked -> unit diff --git a/src/mlang/utils/setExt.ml b/src/mlang/utils/setExt.ml index f6690d8f9..497815943 100644 --- a/src/mlang/utils/setExt.ml +++ b/src/mlang/utils/setExt.ml @@ -1,6 +1,10 @@ module type T = sig include Set.S + val card : t -> int + + val one : elt -> t + val from_list : elt list -> t val from_marked_list : elt Pos.marked list -> t @@ -21,6 +25,10 @@ functor struct include Set.Make (Ord) + let card = cardinal + + let one = singleton + let from_list (l : elt list) : t = let fold set elt = add elt set in List.fold_left fold empty l @@ -29,10 +37,8 @@ functor let fold set elt = add (Pos.unmark elt) set in List.fold_left fold empty l - let pp_nil (_ : Format.formatter) (_ : elt) = () - - let pp ?(sep = " ") ?(pp_elt = pp_nil) (_ : unit) (fmt : Format.formatter) - (set : t) : unit = + let pp ?(sep = " ") ?(pp_elt = Pp.nil) (_ : unit) (fmt : Pp.t) (set : t) : + unit = let foldSet elt first = let _ = if first then Format.fprintf fmt "%a" pp_elt elt diff --git a/src/mlang/utils/setExt.mli b/src/mlang/utils/setExt.mli index 4b6996648..3ba0d8981 100644 --- a/src/mlang/utils/setExt.mli +++ b/src/mlang/utils/setExt.mli @@ -1,17 +1,16 @@ module type T = sig include Set.S + val card : t -> int + + val one : elt -> t + val from_list : elt list -> t val from_marked_list : elt Pos.marked list -> t val pp : - ?sep:string -> - ?pp_elt:(Format.formatter -> elt -> unit) -> - unit -> - Format.formatter -> - t -> - unit + ?sep:string -> ?pp_elt:(Pp.t -> elt -> unit) -> unit -> Pp.t -> t -> unit end module Make : functor (Ord : Set.OrderedType) -> T with type elt = Ord.t diff --git a/src/mlang/utils/strings.ml b/src/mlang/utils/strings.ml index e2d7b43c3..8428d5585 100644 --- a/src/mlang/utils/strings.ml +++ b/src/mlang/utils/strings.ml @@ -25,3 +25,31 @@ let sanitize_str (s, p) = ' ' else c) s + +let compare_default = String.compare + +let ascii_to_ebcdic = + [| + 0; 1; 2; 3; 55; 45; 46; 47; 22; 5; 37; 11; 12; 13; 14; 15; + 16; 17; 18; 19; 60; 61; 50; 38; 24; 25; 63; 39; 28; 29; 30; 31; + 64; 79; 127; 123; 91; 108; 80; 125; 77; 93; 92; 78; 107; 96; 75; 97; + 240; 241; 242; 243; 244; 245; 246; 247; 248; 249; 122; 94; 76; 126; 110; 111; + 124; 193; 194; 195; 196; 197; 198; 199; 200; 201; 209; 210; 211; 212; 213; 214; + 215; 216; 217; 226; 227; 228; 229; 230; 231; 232; 233; 74; 224; 90; 95; 109; + 121; 129; 130; 131; 132; 133; 134; 135; 136; 137; 145; 146; 147; 148; 149; 150; + 151; 152; 153; 162; 163; 164; 165; 166; 167; 168; 169; 192; 106; 208; 161; + |][@@ocamlformat "disable"] + +let compare_ebcdic str1 str2 = + let rec ebcdic_compare_aux i = + if String.length str1 <= i || String.length str2 <= i then + Stdlib.compare (String.length str1) (String.length str2) + else + let r = + Stdlib.compare + ascii_to_ebcdic.(Char.code str1.[i]) + ascii_to_ebcdic.(Char.code str2.[i]) + in + if r <> 0 then r else ebcdic_compare_aux (i + 1) + in + ebcdic_compare_aux 0 diff --git a/src/mlang/utils/strings.mli b/src/mlang/utils/strings.mli index 88ff69fb3..26d73cb5a 100644 --- a/src/mlang/utils/strings.mli +++ b/src/mlang/utils/strings.mli @@ -18,3 +18,7 @@ val sanitize_str : string * Pos.t -> string (** DGFiP sources are encoded in iso-8859-1 which is not compatible with some backend compilers such as Java and Python, this function transforms illegal characters with a space. *) + +val compare_default : string -> string -> int + +val compare_ebcdic : string -> string -> int