diff --git a/Makefile.in b/Makefile.in
index d22ebb2e453b5e9d9b2f1692eff910cbe8e05917..a2227bdbc24528d542d7a61c9cf17226aab9b1e2 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -1,9 +1,7 @@
-OCAMLBUILD=@OCAMLBUILD@ -classic-display -no-links
-
prefix=@prefix@
exec_prefix=@exec_prefix@
bindir=@bindir@
-datadir = ${prefix}/share
+datarootdir = ${prefix}/share
includedir = ${prefix}/include
LUSI_LIBS=include/math.lusi include/conv.lusi
@@ -11,11 +9,15 @@ LUSI_MPFR_LIB=include/mpfr_lustre.lusi
LOCAL_BINDIR=bin
LOCAL_DOCDIR=doc/manual
-$(LOCAL_BINDIR)/lustrec: configure Makefile
+all: lustrec lustret
+
+lustrec:
@echo Compiling binary lustrec
- @$(OCAMLBUILD) -cflags -I,@OCAMLGRAPH_PATH@ -lflag @OCAMLGRAPH_PATH@/graph.cmxa -lflag nums.cmxa -I src -I src/backends/C -I src/plugins/scopes src/main_lustre_compiler.native
- @mkdir -p $(LOCAL_BINDIR)
- @mv _build/src/main_lustre_compiler.native $(LOCAL_BINDIR)/lustrec
+ @make -C src lustrec
+
+lustret:
+ @echo Compiling binary lustret
+ @make -C src lustret
configure: configure.ac
@echo configure.ac has changed relaunching autoconf
@@ -27,20 +29,17 @@ Makefile: Makefile.in config.status configure
doc:
@echo Generating doc
- @$(OCAMLBUILD) lustrec.docdir/index.html
- @rm -rf $(LOCAL_DOCDIR)
- @cp -rf _build/lustrec.docdir $(LOCAL_DOCDIR)
+ @make -C src doc
dot: doc
- $(OCAMLBUILD) lustrec.docdir/lustrec.dot
- dot -T ps -o lustrec.dot _build/lustrec.docdir/lustrec.dot
- mv _build/lustrec.docdir/lustrec.dot $(LOCAL_DOCDIR)
+ @make -C src dot
-clean:
- $(OCAMLBUILD) -clean
+clean: clean-lusic
+ @make -C src clean
dist-src-clean: clean
@rm -f config.log config.status include/*.lusic include/math.h include/conv.h include/mpfr_lustre.h
+ @rm -f Makefile ./src/Makefile ./src/pluginList.ml ./src/version.ml ./src/_tags
DIST_ARCHIVE_NAME=lustrec-$(shell $(LOCAL_BINDIR)/lustrec -version | grep version | cut -d, -f 2 | sed -e "s/ version //" -e "s/ (/-/" -e "s/ /-/" -e "s/\//-/" -e "s/)//")-src.tar.gz
@@ -50,7 +49,7 @@ dist-gzip: $(LOCAL_BINDIR)/lustrec dist-src-clean
@echo "Source distribution built: ../$(DIST_ARCHIVE_NAME)"
dist-clean: dist-src-clean
- @rm -f myocamlbuild.ml configure Makefile
+ @rm -f configure Makefile
%.lusic: %.lusi
@echo Compiling $<
@@ -71,8 +70,34 @@ install: clean-lusic compile-lusi compile-mpfr-lusi
install -m 0755 $(LOCAL_BINDIR)/* ${bindir}
mkdir -p ${includedir}/lustrec
cp include/* ${includedir}/lustrec
- mkdir -p ${datadir}
- install -m 0655 share/FindLustre.cmake ${datadir}
+ mkdir -p ${datarootdir}
+ install -m 0655 share/FindLustre.cmake ${datarootdir}
+
+test-config: ${bindir}/lustrec
+ if @PATH_TO_TESTS_DEFINED@; then \
+ mkdir -p test; \
+ cd test; \
+ cmake -DLUSTRE_PATH_HINT=${bindir} -DSUBPROJ=@GITBRANCH@ ../@PATH_TO_TESTS@; \
+ fi
+
+test-no-submit: test-config
+ cd test; ctest -M Experimental -T Start -T Update -T Configure -T Build -T Test -R COMPIL_LUSTRE
+
+test-submit: test-config
+ cd test; ctest -M Experimental -T Submit -R COMPIL_LUSTRE
+
+test: test-config
+ cd test; ctest -D Experimental -R COMPIL_LUSTRE
+
+test-full-no-submit: test-config
+ cd test; ctest -M Experimental -T Start -T Update -T Configure -T Build -T Test
+
+test-full-submit: test-config
+ cd test; ctest -M Experimental -T Submit
+
+test-full: test-config
+ cd test; ctest -D Experimental
+
-.PHONY: compile-lusi doc dot lustrec lustrec.odocl clean install dist-clean
+.PHONY: all compile-lusi doc dot lustrec lustrec.odocl clean install dist-clean
diff --git a/TODO.org b/TODO.org
index 1966774dc596123f5ed50eb909882432e8c3a8a5..e4480718fe1e888b76ab3b620ec995af62bf5a2b 100644
--- a/TODO.org
+++ b/TODO.org
@@ -29,3 +29,37 @@
** clock calculus
*** extension from named clocks to valued clocks ?
*** static inputs should be polymorphic, as global constants are: done
+
+* Horn backend
+** enum types for automaton
+ - issues with MBranches and clocks
+ - control-on-clock generates a "if cond then expr else nothing
+ - it has to be expressed in a functional way to enable its expression as
+ horn
+
+
+- The issue seems mainly to lie in the out = f(in) every cond
+ this generates the follwoingg imperative statements
+ if cond then f_reset(*mem) else {(nothing, ie. not reset)}
+ f_step(in,*put,*mem)
+
+ In the machine code, this is done by generating the sequence of 2 instructions
+ 1. if cond then MReset() else {} (* creation of a conditional statement *)
+ 2. MStep()
+
+- For Xavier: Syntactically, how could you "reset" an arrow? When we see an
+ Expr_arrow, we introduce a MReset instance to the set of instruction on the
+ reset function of the current node, but is there any mean to do it with
+ "every" ?
+
+
+
+
+x = expr when c
+
+if c then
+ x= expr
+
+else {}
+
+x = if c then expr else x
diff --git a/configure.ac b/configure.ac
index f66eaa5ec10d9d5aa402166aa32088868d3b9ed7..069c3c27e5135c79935260193c7dd656285cb281 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1,55 +1,84 @@
define([gitversion], esyscmd([sh -c "git log --oneline | wc -l | tr -d '\n'"]))
-
-AC_INIT([lustrec], [1.4-gitversion], [ploc@garoche.net])
+define([gitbranch], esyscmd([sh -c "git branch | grep \* | cut -d ' ' -f2"]))
+AC_INIT([lustrec], 1.4-gitversion, [ploc@garoche.net])
AC_SUBST(VERSION_CODENAME, "Xia/Xiang-dev")
+AC_SUBST(GITBRANCH, gitbranch)
# Next release will be
#AC_INIT([lustrec], [1.5], [ploc@garoche.net])
#AC_SUBST(VERSION_CODENAME, "Xia/Shao Kang")
AC_CONFIG_SRCDIR([src/main_lustre_compiler.ml])
-
-# default prefix is /usr/local
-AC_PREFIX_DEFAULT(/usr/local)
-
-AC_ARG_WITH([ocamlgraph-path],
- [AS_HELP_STRING([--ocamlgraph-path],
- [specify the path of ocamlgraph library. graph.cmxa should be in ocamlgraph-path @<:@default=$(ocamlfind query ocamlgraph)@:>@])],
- [AS_IF([test "x$ocamlgraph_path" = xno],
- [AC_MSG_ERROR([ocamlgraph library is needed])],
- [test "x$ocamlgraph_path" = xyes],
- [OCAMLGRAPH_PATH=$(ocamlfind query ocamlgraph)],
- [OCAMLGRAPH_PATH=$ocamlgraph_path]
- )],
- [OCAMLGRAPH_PATH=$(ocamlfind query ocamlgraph)]
-)
-AC_SUBST(OCAMLGRAPH_PATH)
-
-AC_SUBST(SRC_PATH, esyscmd([sh -c "pwd" | tr -d '\n']))
+AC_CONFIG_SRCDIR([src/main_lustre_testgen.ml])
AC_PATH_PROG([OCAMLC],[ocamlc],[:])
AC_MSG_CHECKING(OCaml version)
ocamlc_version=`$OCAMLC -v | grep version | rev| cut -d \ -f 1 | rev`
major=`echo $ocamlc_version | cut -d . -f 1`
minor=`echo $ocamlc_version | cut -d . -f 2`
-if (test "$major" -lt 4 -a "$minor" -lt 0 ); then
- AC_MSG_ERROR([Ocaml version must be at least 4.0. You have version $ocamlc_version])
+if (test "$major" -lt 3 -a "$minor" -lt 11 ); then
+ AC_MSG_ERROR([Ocaml version must be at least 3.11. You have version $ocamlc_version])
fi
AC_MSG_RESULT(valid ocaml version detected: $ocamlc_version)
AC_PATH_PROG([OCAMLBUILD],[ocamlbuild],[:])
+# default prefix is /usr/local
+AC_PREFIX_DEFAULT(/usr/local)
+
+dnl AC_ARG_WITH([ocamlgraph-path],
+dnl [AS_HELP_STRING([--ocamlgraph-path],
+dnl [specify the path of ocamlgraph library. graph.cmxa should be in ocamlgraph-path @<:@default=$(ocamlfind query ocamlgraph)@:>@])],
+dnl [AS_IF([test "x$ocamlgraph_path" = xno],
+dnl [AC_MSG_ERROR([ocamlgraph library is needed])],
+dnl [test "x$ocamlgraph_path" = xyes],
+dnl [OCAMLGRAPH_PATH=$(ocamlfind query ocamlgraph)],
+dnl [OCAMLGRAPH_PATH=$ocamlgraph_path]
+dnl )],
+dnl [OCAMLGRAPH_PATH=$(ocamlfind query ocamlgraph)]
+dnl )
+dnl AC_SUBST(OCAMLGRAPH_PATH)
+
+
# Checking libs
+AC_CHECK_PROG(FINDLIB_CHECK,ocamlfind,yes)
+if test x"$FINDLIB_CHECK" != x"yes" ; then
+ AC_MSG_ERROR(ocamlfind required!)
+fi
+dnl AC_MSG_RESULT(Hourrah: ocamlfind found!)
# Checks for libraries. OCamlgraph
AC_MSG_CHECKING(ocamlgraph library)
- ocamlgraph_lib=`find $OCAMLGRAPH_PATH -iname graph.cmxa | grep -m 1 -o "graph.cmxa"`
- if (test "x$ocamlgraph_lib" = xgraph.cmxa ); then
- ocamlgraph_lib_full=`find $OCAMLGRAPH_PATH -iname graph.cmxa | grep -m 1 "graph.cmxa"`
- AC_MSG_RESULT(library detected: $ocamlgraph_lib_full )
- else
- AC_MSG_ERROR([ocamlgraph library not installed in $OCAMLGRAPH_PATH])
- fi
+AS_IF([ocamlfind query ocamlgraph >/dev/null 2>&1],
+ [],[AC_MSG_ERROR(ocamlgraph required. opam install ocamlgraph should solve the issue)],
+)
+AC_MSG_RESULT(yes)
+
+
+AC_ARG_ENABLE(salsa, [AS_HELP_STRING([--disable-salsa],
+ [disable Salsa plugin. Enabled by default if available.])])
+
+
+AC_MSG_CHECKING(salsa library)
+AS_IF([ocamlfind query salsa >/dev/null 2>&1],
+ [salsa=yes; AC_MSG_RESULT(yes)],[salsa=no; AC_MSG_WARN(no)]
+)
+
+
+AS_IF([test "x$enable_salsa" != "xno"], [
+ if (test "x$salsa" = xyes ); then
+ AC_SUBST(SALSA, "(module Salsa_plugin.Plugin : PluginType.PluginType);")
+ AC_SUBST(SALSA_TAG, "<**/*.native> or <plugins/salsa/*.cm?> : package(salsa)")
+ fi
+])
+
+
+
+
+
+
+
+
AC_CHECK_LIB(gmp, __gmpz_init,
[gmp=yes],
@@ -62,19 +91,27 @@ AC_CHECK_LIB(mpfr, mpfr_add, [mpfr=yes],
mpfr=no])
-# Workaround to solve an issue with ocamlbuild and C libraries.
-# oCFLAGS="$CFLAGS"
-# CFLAGS="$FLAGS -Wl,--no-as-needed"
-# AC_MSG_CHECKING([whether we need to add --no-as-needed linking option])
-# AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]],
-# [[
-# int main(){ return 0; }
-# ]])],
-# [AC_MSG_RESULT([yes]); CC_NOASNEEDED="true"],
-# [AC_MSG_RESULT([no]); CC_NOASNEEDED="false"])
-# CFLAGS=$oCFLAGS
-# AC_SUBST(CC_NOASNEEDED)
-
+# Checking availability of path to regression tests
+tests_path="../lustrec-tests/regression_tests"
+
+AC_ARG_WITH([tests-path],
+ [AS_HELP_STRING([--with-tests-path],
+ [provides path to test suite (default is ../lustrec-test if available)])],
+ [tests_path="$withval";
+ if (test "x$tests_path" = xyes); then
+ AC_MSG_ERROR(Option --with-tests-path requires a parameter: eg. --with-tests-path=value);
+ fi],
+ )
+AC_MSG_NOTICE($tests_path)
+AC_CHECK_FILE(${tests_path}/CMakeLists.txt,
+ [
+ valid_test_path=true
+ ],
+ [
+ valid_test_path=false
+ AC_SUBST(PATH_TO_TESTS, $tests_path) ])
+AC_SUBST(PATH_TO_TESTS_DEFINED, $valid_test_path)
+AC_SUBST(PATH_TO_TESTS, $tests_path)
# End of config
@@ -99,7 +136,8 @@ AC_DEFINE_DIR([abs_datadir], [datadir])
AC_CONFIG_FILES([Makefile
src/Makefile
src/version.ml
- test/test-compile.sh
+ src/pluginList.ml
+ src/_tags
])
AC_OUTPUT
@@ -112,13 +150,21 @@ AC_MSG_NOTICE(include path: $prefix/include)
AC_MSG_NOTICE(******** Plugins ********)
if (test "x$gmp" = xyes -a "x$mpfr" = xyes ); then
- AC_MSG_NOTICE([-mpfr option enable])
-
- else
- AC_MSG_WARN([MPFR option cannot be activated. Requires GMP and MPFR libs])
-
- fi
-
-AC_MSG_NOTICE
+ AC_MSG_NOTICE([MPFR option enabled])
+ else
+ AC_MSG_WARN([MPFR option cannot be activated. Requires GMP and MPFR libs])
+ fi
+
+ if (test "x$salsa" = xyes -a "x$enable_salsa" != xno); then
+ AC_MSG_NOTICE([Salsa plugin enabled])
+ else
+ AC_MSG_NOTICE([Salsa plugin disabled])
+ fi
+AC_MSG_NOTICE(****** Regression Tests ******)
+if (test "x$valid_test_path" = xfalse); then
+ AC_MSG_NOTICE(no valid tests path provided ($tests_path))
+else
+AC_MSG_NOTICE(tests path: $tests_path)
+fi
AC_MSG_NOTICE(******** Configuration ********)
-
+AC_MSG_NOTICE(Execute "make; make install" now)
diff --git a/include/arrow.c b/include/arrow.c
index 551cee5d2750c3db774798f5d9db25c21aa7a966..93ae5979ef6e434c2cec0f7fb55be14ed8ae3455 100644
--- a/include/arrow.c
+++ b/include/arrow.c
@@ -2,9 +2,13 @@
#include <assert.h>
#include "arrow.h"
-struct _arrow_mem *_arrow_alloc() {
+struct _arrow_mem * _arrow_alloc () {
struct _arrow_mem *_alloc;
_alloc = (struct _arrow_mem *) malloc(sizeof(struct _arrow_mem *));
assert (_alloc);
return _alloc;
}
+
+void _arrow_dealloc (struct _arrow_mem * _alloc) {
+ free (_alloc);
+}
diff --git a/include/arrow.cpp b/include/arrow.cpp
new file mode 100644
index 0000000000000000000000000000000000000000..75fe2f4eed227ad234eed966c8049aa83ab032ca
--- /dev/null
+++ b/include/arrow.cpp
@@ -0,0 +1,9 @@
+#include <stdlib.h>
+#include "arrow.hpp"
+
+struct _arrow_mem *_arrow_alloc() {
+ struct _arrow_mem *_alloc;
+ _alloc = (struct _arrow_mem *) malloc(sizeof(struct _arrow_mem *));
+ assert (_alloc);
+ return _alloc;
+}
diff --git a/include/arrow.h b/include/arrow.h
index 1c6284d2f031f4470d358abe8084be9a142058c3..802057dac7df8167ed2f6a4040a6edbf8bd5a34f 100644
--- a/include/arrow.h
+++ b/include/arrow.h
@@ -6,6 +6,8 @@ struct _arrow_mem {struct _arrow_reg {_Bool _first; } _reg; };
extern struct _arrow_mem *_arrow_alloc ();
+extern void _arrow_dealloc (struct _arrow_mem *);
+
#define _arrow_DECLARE(attr, inst)\
attr struct _arrow_mem inst;
diff --git a/include/arrow.hpp b/include/arrow.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..e8e04500400b898494713dada860999b1167ea93
--- /dev/null
+++ b/include/arrow.hpp
@@ -0,0 +1,39 @@
+
+#ifndef _ARROW_CPP
+#define _ARROW_CPP
+
+#include <stdint.h>
+#include <stdlib.h>
+
+struct _arrow_mem {
+ struct _arrow_reg {
+ bool _first;
+ } _reg;
+};
+
+extern struct _arrow_mem *_arrow_alloc ();
+
+#define _arrow_DECLARE(attr, inst)\
+ attr struct _arrow_mem inst;
+
+#define _arrow_LINK(inst) do {\
+ ;\
+} while (0)
+
+#define _arrow_ALLOC(attr, inst)\
+ _arrow_DECLARE(attr, inst);\
+ _arrow_LINK(inst)
+
+#define _arrow_init(self) {}
+
+#define _arrow_clear(self) {}
+
+#define _arrow_step(x,y,output,self) ((self)->_reg._first?((self)->_reg._first=0,(*output = x)):(*output = y))
+
+#define _arrow_reset(self) {(self)->_reg._first = 1;}
+
+/* Step macro for specialized arrows of the form: (true -> false) */
+
+#define _once_step(output,self) { *output = (self)->_reg._first; if ((self)->_reg._first) { (self)->_reg._first=0; }; }
+
+#endif
diff --git a/include/io_frontend.h b/include/io_frontend.h
index 0d5153868abf41f16662e00fdf566ee1f5d3fac4..01a93d737f3c918e9e17ee788f9e51d9de0cf44a 100644
--- a/include/io_frontend.h
+++ b/include/io_frontend.h
@@ -1,7 +1,7 @@
#ifndef _IO_FRONTEND
#define _IO_FRONTEND
-/* Print a promt ? ************************/
+/* Print a prompt ? ************************/
extern int ISATTY;
/* Standard Input procedures **************/
diff --git a/include/io_frontend.hpp b/include/io_frontend.hpp
new file mode 100644
index 0000000000000000000000000000000000000000..0450f44dde9ccf4e80817f6b0071eae6cc517dcb
--- /dev/null
+++ b/include/io_frontend.hpp
@@ -0,0 +1,94 @@
+#ifndef _IO_FRONTEND_HPP
+#define _IO_FRONTEND_HPP
+
+#include <stdlib.h> /* Provides exit */
+#include <stdio.h> /* Provides printf, scanf, sscanf */
+#include <unistd.h> /* Provides isatty */
+
+int ISATTY;
+
+/* Standard Input procedures **************/
+bool _get_bool(FILE* file, char* n){
+ char b[512];
+ bool r = 0;
+ int s = 1;
+ char c;
+ do {
+ if(ISATTY) {
+ if((s != 1)||(r == -1)) printf("\a");
+ printf("%s (1,t,T/0,f,F) ? ", n);
+ }
+ if(scanf("%s", b)==EOF) exit(0);
+ s = sscanf(b, "%c", &c);
+ r = -1;
+ if((c == '0') || (c == 'f') || (c == 'F')) r = 0;
+ if((c == '1') || (c == 't') || (c == 'T')) r = 1;
+ } while((s != 1) || (r == -1));
+ fprintf(file, "%i\n",r);
+ return r;
+}
+
+int _get_int(FILE* file, char* n){
+ char b[512];
+ int r;
+ int s = 1;
+ do {
+ if(ISATTY) {
+ if(s != 1) printf("\a");
+ printf("%s (integer) ? ", n);
+ }
+ if(scanf("%s", b)==EOF) exit(0);
+ s = sscanf(b, "%d", &r);
+ } while(s != 1);
+ fprintf(file, "%d\n", r);
+ return r;
+}
+
+double _get_double(FILE* file, char* n){
+ char b[512];
+ double r;
+ int s = 1;
+ do {
+ if(ISATTY) {
+ if(s != 1) printf("\a");
+ printf("%s (double) ? ", n);
+ }
+ if(scanf("%s", b)==EOF) exit(0);
+ s = sscanf(b, "%lf", &r);
+ } while(s != 1);
+ fprintf(file, "%f\n", r);
+ return r;
+}
+/* Standard Output procedures **************/
+void _put_bool(FILE* file, char* n, bool _V){
+ if(ISATTY) {
+ printf("%s = ", n);
+ } else {
+ printf("'%s': ", n);
+ };
+ printf("'%i' ", (_V)? 1 : 0);
+ printf("\n");
+ fprintf(file, "%i\n", _V);
+}
+void _put_int(FILE* file, char* n, int _V){
+ if(ISATTY) {
+ printf("%s = ", n);
+ } else {
+ printf("'%s': ", n);
+ };
+ printf("'%d' ", _V);
+ printf("\n");
+ fprintf(file, "%d\n", _V);
+}
+void _put_double(FILE* file, char* n, double _V){
+ if(ISATTY) {
+ printf("%s = ", n);
+ } else {
+ printf("'%s': ", n);
+ };
+ printf("'%f' ", _V);
+ printf("\n");
+ fprintf(file, "%f\n", _V);
+}
+
+#endif
diff --git a/setup.ml b/setup.ml
deleted file mode 100644
index f192265d2744d36167a03eaa71b3e9e65b9d052b..0000000000000000000000000000000000000000
--- a/setup.ml
+++ /dev/null
@@ -1,5884 +0,0 @@
-(* setup.ml generated for the first time by OASIS v0.2.0 *)
-
-(* OASIS_START *)
-(* DO NOT EDIT (digest: cbef9780a942e499729218b6c22c21f0) *)
-(*
- Regenerated by OASIS v0.3.0
- Visit http://oasis.forge.ocamlcore.org for more information and
- documentation about functions used in this file.
-*)
-module OASISGettext = struct
-(* # 21 "src/oasis/OASISGettext.ml" *)
-
- let ns_ str =
- str
-
- let s_ str =
- str
-
- let f_ (str : ('a, 'b, 'c, 'd) format4) =
- str
-
- let fn_ fmt1 fmt2 n =
- if n = 1 then
- fmt1^^""
- else
- fmt2^^""
-
- let init =
- []
-
-end
-
-module OASISContext = struct
-(* # 21 "src/oasis/OASISContext.ml" *)
-
- open OASISGettext
-
- type level =
- [ `Debug
- | `Info
- | `Warning
- | `Error]
-
- type t =
- {
- quiet: bool;
- info: bool;
- debug: bool;
- ignore_plugins: bool;
- ignore_unknown_fields: bool;
- printf: level -> string -> unit;
- }
-
- let printf lvl str =
- let beg =
- match lvl with
- | `Error -> s_ "E: "
- | `Warning -> s_ "W: "
- | `Info -> s_ "I: "
- | `Debug -> s_ "D: "
- in
- prerr_endline (beg^str)
-
- let default =
- ref
- {
- quiet = false;
- info = false;
- debug = false;
- ignore_plugins = false;
- ignore_unknown_fields = false;
- printf = printf;
- }
-
- let quiet =
- {!default with quiet = true}
-
-
- let args () =
- ["-quiet",
- Arg.Unit (fun () -> default := {!default with quiet = true}),
- (s_ " Run quietly");
-
- "-info",
- Arg.Unit (fun () -> default := {!default with info = true}),
- (s_ " Display information message");
-
-
- "-debug",
- Arg.Unit (fun () -> default := {!default with debug = true}),
- (s_ " Output debug message")]
-end
-
-module OASISString = struct
-(* # 1 "src/oasis/OASISString.ml" *)
-
-
-
- (** Various string utilities.
-
- Mostly inspired by extlib and batteries ExtString and BatString libraries.
-
- @author Sylvain Le Gall
- *)
-
- let nsplitf str f =
- if str = "" then
- []
- else
- let buf = Buffer.create 13 in
- let lst = ref [] in
- let push () =
- lst := Buffer.contents buf :: !lst;
- Buffer.clear buf
- in
- let str_len = String.length str in
- for i = 0 to str_len - 1 do
- if f str.[i] then
- push ()
- else
- Buffer.add_char buf str.[i]
- done;
- push ();
- List.rev !lst
-
- (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the
- separator.
- *)
- let nsplit str c =
- nsplitf str ((=) c)
-
- let find ~what ?(offset=0) str =
- let what_idx = ref 0 in
- let str_idx = ref offset in
- while !str_idx < String.length str &&
- !what_idx < String.length what do
- if str.[!str_idx] = what.[!what_idx] then
- incr what_idx
- else
- what_idx := 0;
- incr str_idx
- done;
- if !what_idx <> String.length what then
- raise Not_found
- else
- !str_idx - !what_idx
-
- let sub_start str len =
- let str_len = String.length str in
- if len >= str_len then
- ""
- else
- String.sub str len (str_len - len)
-
- let sub_end ?(offset=0) str len =
- let str_len = String.length str in
- if len >= str_len then
- ""
- else
- String.sub str 0 (str_len - len)
-
- let starts_with ~what ?(offset=0) str =
- let what_idx = ref 0 in
- let str_idx = ref offset in
- let ok = ref true in
- while !ok &&
- !str_idx < String.length str &&
- !what_idx < String.length what do
- if str.[!str_idx] = what.[!what_idx] then
- incr what_idx
- else
- ok := false;
- incr str_idx
- done;
- if !what_idx = String.length what then
- true
- else
- false
-
- let strip_starts_with ~what str =
- if starts_with ~what str then
- sub_start str (String.length what)
- else
- raise Not_found
-
- let ends_with ~what ?(offset=0) str =
- let what_idx = ref ((String.length what) - 1) in
- let str_idx = ref ((String.length str) - 1) in
- let ok = ref true in
- while !ok &&
- offset <= !str_idx &&
- 0 <= !what_idx do
- if str.[!str_idx] = what.[!what_idx] then
- decr what_idx
- else
- ok := false;
- decr str_idx
- done;
- if !what_idx = -1 then
- true
- else
- false
-
- let strip_ends_with ~what str =
- if ends_with ~what str then
- sub_end str (String.length what)
- else
- raise Not_found
-
- let replace_chars f s =
- let buf = String.make (String.length s) 'X' in
- for i = 0 to String.length s - 1 do
- buf.[i] <- f s.[i]
- done;
- buf
-
-end
-
-module OASISUtils = struct
-(* # 21 "src/oasis/OASISUtils.ml" *)
-
- open OASISGettext
-
- module MapString = Map.Make(String)
-
- let map_string_of_assoc assoc =
- List.fold_left
- (fun acc (k, v) -> MapString.add k v acc)
- MapString.empty
- assoc
-
- module SetString = Set.Make(String)
-
- let set_string_add_list st lst =
- List.fold_left
- (fun acc e -> SetString.add e acc)
- st
- lst
-
- let set_string_of_list =
- set_string_add_list
- SetString.empty
-
-
- let compare_csl s1 s2 =
- String.compare (String.lowercase s1) (String.lowercase s2)
-
- module HashStringCsl =
- Hashtbl.Make
- (struct
- type t = string
-
- let equal s1 s2 =
- (String.lowercase s1) = (String.lowercase s2)
-
- let hash s =
- Hashtbl.hash (String.lowercase s)
- end)
-
- let varname_of_string ?(hyphen='_') s =
- if String.length s = 0 then
- begin
- invalid_arg "varname_of_string"
- end
- else
- begin
- let buf =
- OASISString.replace_chars
- (fun c ->
- if ('a' <= c && c <= 'z')
- ||
- ('A' <= c && c <= 'Z')
- ||
- ('0' <= c && c <= '9') then
- c
- else
- hyphen)
- s;
- in
- let buf =
- (* Start with a _ if digit *)
- if '0' <= s.[0] && s.[0] <= '9' then
- "_"^buf
- else
- buf
- in
- String.lowercase buf
- end
-
- let varname_concat ?(hyphen='_') p s =
- let what = String.make 1 hyphen in
- let p =
- try
- OASISString.strip_ends_with ~what p
- with Not_found ->
- p
- in
- let s =
- try
- OASISString.strip_starts_with ~what s
- with Not_found ->
- s
- in
- p^what^s
-
-
- let is_varname str =
- str = varname_of_string str
-
- let failwithf fmt = Printf.ksprintf failwith fmt
-
-end
-
-module PropList = struct
-(* # 21 "src/oasis/PropList.ml" *)
-
- open OASISGettext
-
- type name = string
-
- exception Not_set of name * string option
- exception No_printer of name
- exception Unknown_field of name * name
-
- let () =
- Printexc.register_printer
- (function
- | Not_set (nm, Some rsn) ->
- Some
- (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn)
- | Not_set (nm, None) ->
- Some
- (Printf.sprintf (f_ "Field '%s' is not set") nm)
- | No_printer nm ->
- Some
- (Printf.sprintf (f_ "No default printer for value %s") nm)
- | Unknown_field (nm, schm) ->
- Some
- (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm)
- | _ ->
- None)
-
- module Data =
- struct
-
- type t =
- (name, unit -> unit) Hashtbl.t
-
- let create () =
- Hashtbl.create 13
-
- let clear t =
- Hashtbl.clear t
-
-(* # 71 "src/oasis/PropList.ml" *)
- end
-
- module Schema =
- struct
-
- type ('ctxt, 'extra) value =
- {
- get: Data.t -> string;
- set: Data.t -> ?context:'ctxt -> string -> unit;
- help: (unit -> string) option;
- extra: 'extra;
- }
-
- type ('ctxt, 'extra) t =
- {
- name: name;
- fields: (name, ('ctxt, 'extra) value) Hashtbl.t;
- order: name Queue.t;
- name_norm: string -> string;
- }
-
- let create ?(case_insensitive=false) nm =
- {
- name = nm;
- fields = Hashtbl.create 13;
- order = Queue.create ();
- name_norm =
- (if case_insensitive then
- String.lowercase
- else
- fun s -> s);
- }
-
- let add t nm set get extra help =
- let key =
- t.name_norm nm
- in
-
- if Hashtbl.mem t.fields key then
- failwith
- (Printf.sprintf
- (f_ "Field '%s' is already defined in schema '%s'")
- nm t.name);
- Hashtbl.add
- t.fields
- key
- {
- set = set;
- get = get;
- help = help;
- extra = extra;
- };
- Queue.add nm t.order
-
- let mem t nm =
- Hashtbl.mem t.fields nm
-
- let find t nm =
- try
- Hashtbl.find t.fields (t.name_norm nm)
- with Not_found ->
- raise (Unknown_field (nm, t.name))
-
- let get t data nm =
- (find t nm).get data
-
- let set t data nm ?context x =
- (find t nm).set
- data
- ?context
- x
-
- let fold f acc t =
- Queue.fold
- (fun acc k ->
- let v =
- find t k
- in
- f acc k v.extra v.help)
- acc
- t.order
-
- let iter f t =
- fold
- (fun () -> f)
- ()
- t
-
- let name t =
- t.name
- end
-
- module Field =
- struct
-
- type ('ctxt, 'value, 'extra) t =
- {
- set: Data.t -> ?context:'ctxt -> 'value -> unit;
- get: Data.t -> 'value;
- sets: Data.t -> ?context:'ctxt -> string -> unit;
- gets: Data.t -> string;
- help: (unit -> string) option;
- extra: 'extra;
- }
-
- let new_id =
- let last_id =
- ref 0
- in
- fun () -> incr last_id; !last_id
-
- let create ?schema ?name ?parse ?print ?default ?update ?help extra =
- (* Default value container *)
- let v =
- ref None
- in
-
- (* If name is not given, create unique one *)
- let nm =
- match name with
- | Some s -> s
- | None -> Printf.sprintf "_anon_%d" (new_id ())
- in
-
- (* Last chance to get a value: the default *)
- let default () =
- match default with
- | Some d -> d
- | None -> raise (Not_set (nm, Some (s_ "no default value")))
- in
-
- (* Get data *)
- let get data =
- (* Get value *)
- try
- (Hashtbl.find data nm) ();
- match !v with
- | Some x -> x
- | None -> default ()
- with Not_found ->
- default ()
- in
-
- (* Set data *)
- let set data ?context x =
- let x =
- match update with
- | Some f ->
- begin
- try
- f ?context (get data) x
- with Not_set _ ->
- x
- end
- | None ->
- x
- in
- Hashtbl.replace
- data
- nm
- (fun () -> v := Some x)
- in
-
- (* Parse string value, if possible *)
- let parse =
- match parse with
- | Some f ->
- f
- | None ->
- fun ?context s ->
- failwith
- (Printf.sprintf
- (f_ "Cannot parse field '%s' when setting value %S")
- nm
- s)
- in
-
- (* Set data, from string *)
- let sets data ?context s =
- set ?context data (parse ?context s)
- in
-
- (* Output value as string, if possible *)
- let print =
- match print with
- | Some f ->
- f
- | None ->
- fun _ -> raise (No_printer nm)
- in
-
- (* Get data, as a string *)
- let gets data =
- print (get data)
- in
-
- begin
- match schema with
- | Some t ->
- Schema.add t nm sets gets extra help
- | None ->
- ()
- end;
-
- {
- set = set;
- get = get;
- sets = sets;
- gets = gets;
- help = help;
- extra = extra;
- }
-
- let fset data t ?context x =
- t.set data ?context x
-
- let fget data t =
- t.get data
-
- let fsets data t ?context s =
- t.sets data ?context s
-
- let fgets data t =
- t.gets data
-
- end
-
- module FieldRO =
- struct
-
- let create ?schema ?name ?parse ?print ?default ?update ?help extra =
- let fld =
- Field.create ?schema ?name ?parse ?print ?default ?update ?help extra
- in
- fun data -> Field.fget data fld
-
- end
-end
-
-module OASISMessage = struct
-(* # 21 "src/oasis/OASISMessage.ml" *)
-
-
- open OASISGettext
- open OASISContext
-
- let generic_message ~ctxt lvl fmt =
- let cond =
- if ctxt.quiet then
- false
- else
- match lvl with
- | `Debug -> ctxt.debug
- | `Info -> ctxt.info
- | _ -> true
- in
- Printf.ksprintf
- (fun str ->
- if cond then
- begin
- ctxt.printf lvl str
- end)
- fmt
-
- let debug ~ctxt fmt =
- generic_message ~ctxt `Debug fmt
-
- let info ~ctxt fmt =
- generic_message ~ctxt `Info fmt
-
- let warning ~ctxt fmt =
- generic_message ~ctxt `Warning fmt
-
- let error ~ctxt fmt =
- generic_message ~ctxt `Error fmt
-
-end
-
-module OASISVersion = struct
-(* # 21 "src/oasis/OASISVersion.ml" *)
-
- open OASISGettext
-
-
-
- type s = string
-
- type t = string
-
- type comparator =
- | VGreater of t
- | VGreaterEqual of t
- | VEqual of t
- | VLesser of t
- | VLesserEqual of t
- | VOr of comparator * comparator
- | VAnd of comparator * comparator
-
-
- (* Range of allowed characters *)
- let is_digit c =
- '0' <= c && c <= '9'
-
- let is_alpha c =
- ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z')
-
- let is_special =
- function
- | '.' | '+' | '-' | '~' -> true
- | _ -> false
-
- let rec version_compare v1 v2 =
- if v1 <> "" || v2 <> "" then
- begin
- (* Compare ascii string, using special meaning for version
- * related char
- *)
- let val_ascii c =
- if c = '~' then -1
- else if is_digit c then 0
- else if c = '\000' then 0
- else if is_alpha c then Char.code c
- else (Char.code c) + 256
- in
-
- let len1 = String.length v1 in
- let len2 = String.length v2 in
-
- let p = ref 0 in
-
- (** Compare ascii part *)
- let compare_vascii () =
- let cmp = ref 0 in
- while !cmp = 0 &&
- !p < len1 && !p < len2 &&
- not (is_digit v1.[!p] && is_digit v2.[!p]) do
- cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]);
- incr p
- done;
- if !cmp = 0 && !p < len1 && !p = len2 then
- val_ascii v1.[!p]
- else if !cmp = 0 && !p = len1 && !p < len2 then
- - (val_ascii v2.[!p])
- else
- !cmp
- in
-
- (** Compare digit part *)
- let compare_digit () =
- let extract_int v p =
- let start_p = !p in
- while !p < String.length v && is_digit v.[!p] do
- incr p
- done;
- let substr =
- String.sub v !p ((String.length v) - !p)
- in
- let res =
- match String.sub v start_p (!p - start_p) with
- | "" -> 0
- | s -> int_of_string s
- in
- res, substr
- in
- let i1, tl1 = extract_int v1 (ref !p) in
- let i2, tl2 = extract_int v2 (ref !p) in
- i1 - i2, tl1, tl2
- in
-
- match compare_vascii () with
- | 0 ->
- begin
- match compare_digit () with
- | 0, tl1, tl2 ->
- if tl1 <> "" && is_digit tl1.[0] then
- 1
- else if tl2 <> "" && is_digit tl2.[0] then
- -1
- else
- version_compare tl1 tl2
- | n, _, _ ->
- n
- end
- | n ->
- n
- end
- else
- begin
- 0
- end
-
-
- let version_of_string str = str
-
- let string_of_version t = t
-
- let chop t =
- try
- let pos =
- String.rindex t '.'
- in
- String.sub t 0 pos
- with Not_found ->
- t
-
- let rec comparator_apply v op =
- match op with
- | VGreater cv ->
- (version_compare v cv) > 0
- | VGreaterEqual cv ->
- (version_compare v cv) >= 0
- | VLesser cv ->
- (version_compare v cv) < 0
- | VLesserEqual cv ->
- (version_compare v cv) <= 0
- | VEqual cv ->
- (version_compare v cv) = 0
- | VOr (op1, op2) ->
- (comparator_apply v op1) || (comparator_apply v op2)
- | VAnd (op1, op2) ->
- (comparator_apply v op1) && (comparator_apply v op2)
-
- let rec string_of_comparator =
- function
- | VGreater v -> "> "^(string_of_version v)
- | VEqual v -> "= "^(string_of_version v)
- | VLesser v -> "< "^(string_of_version v)
- | VGreaterEqual v -> ">= "^(string_of_version v)
- | VLesserEqual v -> "<= "^(string_of_version v)
- | VOr (c1, c2) ->
- (string_of_comparator c1)^" || "^(string_of_comparator c2)
- | VAnd (c1, c2) ->
- (string_of_comparator c1)^" && "^(string_of_comparator c2)
-
- let rec varname_of_comparator =
- let concat p v =
- OASISUtils.varname_concat
- p
- (OASISUtils.varname_of_string
- (string_of_version v))
- in
- function
- | VGreater v -> concat "gt" v
- | VLesser v -> concat "lt" v
- | VEqual v -> concat "eq" v
- | VGreaterEqual v -> concat "ge" v
- | VLesserEqual v -> concat "le" v
- | VOr (c1, c2) ->
- (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2)
- | VAnd (c1, c2) ->
- (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2)
-
- let version_0_3_or_after t =
- comparator_apply t (VGreaterEqual (string_of_version "0.3"))
-
-end
-
-module OASISLicense = struct
-(* # 21 "src/oasis/OASISLicense.ml" *)
-
- (** License for _oasis fields
- @author Sylvain Le Gall
- *)
-
-
-
- type license = string
-
- type license_exception = string
-
- type license_version =
- | Version of OASISVersion.t
- | VersionOrLater of OASISVersion.t
- | NoVersion
-
-
- type license_dep_5_unit =
- {
- license: license;
- excption: license_exception option;
- version: license_version;
- }
-
-
- type license_dep_5 =
- | DEP5Unit of license_dep_5_unit
- | DEP5Or of license_dep_5 list
- | DEP5And of license_dep_5 list
-
-
- type t =
- | DEP5License of license_dep_5
- | OtherLicense of string (* URL *)
-
-
-end
-
-module OASISExpr = struct
-(* # 21 "src/oasis/OASISExpr.ml" *)
-
-
-
- open OASISGettext
-
- type test = string
-
- type flag = string
-
- type t =
- | EBool of bool
- | ENot of t
- | EAnd of t * t
- | EOr of t * t
- | EFlag of flag
- | ETest of test * string
-
-
- type 'a choices = (t * 'a) list
-
- let eval var_get t =
- let rec eval' =
- function
- | EBool b ->
- b
-
- | ENot e ->
- not (eval' e)
-
- | EAnd (e1, e2) ->
- (eval' e1) && (eval' e2)
-
- | EOr (e1, e2) ->
- (eval' e1) || (eval' e2)
-
- | EFlag nm ->
- let v =
- var_get nm
- in
- assert(v = "true" || v = "false");
- (v = "true")
-
- | ETest (nm, vl) ->
- let v =
- var_get nm
- in
- (v = vl)
- in
- eval' t
-
- let choose ?printer ?name var_get lst =
- let rec choose_aux =
- function
- | (cond, vl) :: tl ->
- if eval var_get cond then
- vl
- else
- choose_aux tl
- | [] ->
- let str_lst =
- if lst = [] then
- s_ "<empty>"
- else
- String.concat
- (s_ ", ")
- (List.map
- (fun (cond, vl) ->
- match printer with
- | Some p -> p vl
- | None -> s_ "<no printer>")
- lst)
- in
- match name with
- | Some nm ->
- failwith
- (Printf.sprintf
- (f_ "No result for the choice list '%s': %s")
- nm str_lst)
- | None ->
- failwith
- (Printf.sprintf
- (f_ "No result for a choice list: %s")
- str_lst)
- in
- choose_aux (List.rev lst)
-
-end
-
-module OASISTypes = struct
-(* # 21 "src/oasis/OASISTypes.ml" *)
-
-
-
-
- type name = string
- type package_name = string
- type url = string
- type unix_dirname = string
- type unix_filename = string
- type host_dirname = string
- type host_filename = string
- type prog = string
- type arg = string
- type args = string list
- type command_line = (prog * arg list)
-
- type findlib_name = string
- type findlib_full = string
-
- type compiled_object =
- | Byte
- | Native
- | Best
-
-
- type dependency =
- | FindlibPackage of findlib_full * OASISVersion.comparator option
- | InternalLibrary of name
-
-
- type tool =
- | ExternalTool of name
- | InternalExecutable of name
-
-
- type vcs =
- | Darcs
- | Git
- | Svn
- | Cvs
- | Hg
- | Bzr
- | Arch
- | Monotone
- | OtherVCS of url
-
-
- type plugin_kind =
- [ `Configure
- | `Build
- | `Doc
- | `Test
- | `Install
- | `Extra
- ]
-
- type plugin_data_purpose =
- [ `Configure
- | `Build
- | `Install
- | `Clean
- | `Distclean
- | `Install
- | `Uninstall
- | `Test
- | `Doc
- | `Extra
- | `Other of string
- ]
-
- type 'a plugin = 'a * name * OASISVersion.t option
-
- type all_plugin = plugin_kind plugin
-
- type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list
-
-(* # 102 "src/oasis/OASISTypes.ml" *)
-
- type 'a conditional = 'a OASISExpr.choices
-
- type custom =
- {
- pre_command: (command_line option) conditional;
- post_command: (command_line option) conditional;
- }
-
-
- type common_section =
- {
- cs_name: name;
- cs_data: PropList.Data.t;
- cs_plugin_data: plugin_data;
- }
-
-
- type build_section =
- {
- bs_build: bool conditional;
- bs_install: bool conditional;
- bs_path: unix_dirname;
- bs_compiled_object: compiled_object;
- bs_build_depends: dependency list;
- bs_build_tools: tool list;
- bs_c_sources: unix_filename list;
- bs_data_files: (unix_filename * unix_filename option) list;
- bs_ccopt: args conditional;
- bs_cclib: args conditional;
- bs_dlllib: args conditional;
- bs_dllpath: args conditional;
- bs_byteopt: args conditional;
- bs_nativeopt: args conditional;
- }
-
-
- type library =
- {
- lib_modules: string list;
- lib_pack: bool;
- lib_internal_modules: string list;
- lib_findlib_parent: findlib_name option;
- lib_findlib_name: findlib_name option;
- lib_findlib_containers: findlib_name list;
- }
-
- type executable =
- {
- exec_custom: bool;
- exec_main_is: unix_filename;
- }
-
- type flag =
- {
- flag_description: string option;
- flag_default: bool conditional;
- }
-
- type source_repository =
- {
- src_repo_type: vcs;
- src_repo_location: url;
- src_repo_browser: url option;
- src_repo_module: string option;
- src_repo_branch: string option;
- src_repo_tag: string option;
- src_repo_subdir: unix_filename option;
- }
-
- type test =
- {
- test_type: [`Test] plugin;
- test_command: command_line conditional;
- test_custom: custom;
- test_working_directory: unix_filename option;
- test_run: bool conditional;
- test_tools: tool list;
- }
-
- type doc_format =
- | HTML of unix_filename
- | DocText
- | PDF
- | PostScript
- | Info of unix_filename
- | DVI
- | OtherDoc
-
-
- type doc =
- {
- doc_type: [`Doc] plugin;
- doc_custom: custom;
- doc_build: bool conditional;
- doc_install: bool conditional;
- doc_install_dir: unix_filename;
- doc_title: string;
- doc_authors: string list;
- doc_abstract: string option;
- doc_format: doc_format;
- doc_data_files: (unix_filename * unix_filename option) list;
- doc_build_tools: tool list;
- }
-
- type section =
- | Library of common_section * build_section * library
- | Executable of common_section * build_section * executable
- | Flag of common_section * flag
- | SrcRepo of common_section * source_repository
- | Test of common_section * test
- | Doc of common_section * doc
-
-
- type section_kind =
- [ `Library | `Executable | `Flag | `SrcRepo | `Test | `Doc ]
-
- type package =
- {
- oasis_version: OASISVersion.t;
- ocaml_version: OASISVersion.comparator option;
- findlib_version: OASISVersion.comparator option;
- name: package_name;
- version: OASISVersion.t;
- license: OASISLicense.t;
- license_file: unix_filename option;
- copyrights: string list;
- maintainers: string list;
- authors: string list;
- homepage: url option;
- synopsis: string;
- description: string option;
- categories: url list;
-
- conf_type: [`Configure] plugin;
- conf_custom: custom;
-
- build_type: [`Build] plugin;
- build_custom: custom;
-
- install_type: [`Install] plugin;
- install_custom: custom;
- uninstall_custom: custom;
-
- clean_custom: custom;
- distclean_custom: custom;
-
- files_ab: unix_filename list;
- sections: section list;
- plugins: [`Extra] plugin list;
- schema_data: PropList.Data.t;
- plugin_data: plugin_data;
- }
-
-end
-
-module OASISUnixPath = struct
-(* # 21 "src/oasis/OASISUnixPath.ml" *)
-
- type unix_filename = string
- type unix_dirname = string
-
- type host_filename = string
- type host_dirname = string
-
- let current_dir_name = "."
-
- let parent_dir_name = ".."
-
- let is_current_dir fn =
- fn = current_dir_name || fn = ""
-
- let concat f1 f2 =
- if is_current_dir f1 then
- f2
- else
- let f1' =
- try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1
- in
- f1'^"/"^f2
-
- let make =
- function
- | hd :: tl ->
- List.fold_left
- (fun f p -> concat f p)
- hd
- tl
- | [] ->
- invalid_arg "OASISUnixPath.make"
-
- let dirname f =
- try
- String.sub f 0 (String.rindex f '/')
- with Not_found ->
- current_dir_name
-
- let basename f =
- try
- let pos_start =
- (String.rindex f '/') + 1
- in
- String.sub f pos_start ((String.length f) - pos_start)
- with Not_found ->
- f
-
- let chop_extension f =
- try
- let last_dot =
- String.rindex f '.'
- in
- let sub =
- String.sub f 0 last_dot
- in
- try
- let last_slash =
- String.rindex f '/'
- in
- if last_slash < last_dot then
- sub
- else
- f
- with Not_found ->
- sub
-
- with Not_found ->
- f
-
- let capitalize_file f =
- let dir = dirname f in
- let base = basename f in
- concat dir (String.capitalize base)
-
- let uncapitalize_file f =
- let dir = dirname f in
- let base = basename f in
- concat dir (String.uncapitalize base)
-
-end
-
-module OASISHostPath = struct
-(* # 21 "src/oasis/OASISHostPath.ml" *)
-
-
- open Filename
-
- module Unix = OASISUnixPath
-
- let make =
- function
- | [] ->
- invalid_arg "OASISHostPath.make"
- | hd :: tl ->
- List.fold_left Filename.concat hd tl
-
- let of_unix ufn =
- if Sys.os_type = "Unix" then
- ufn
- else
- make
- (List.map
- (fun p ->
- if p = Unix.current_dir_name then
- current_dir_name
- else if p = Unix.parent_dir_name then
- parent_dir_name
- else
- p)
- (OASISString.nsplit ufn '/'))
-
-
-end
-
-module OASISSection = struct
-(* # 21 "src/oasis/OASISSection.ml" *)
-
- open OASISTypes
-
- let section_kind_common =
- function
- | Library (cs, _, _) ->
- `Library, cs
- | Executable (cs, _, _) ->
- `Executable, cs
- | Flag (cs, _) ->
- `Flag, cs
- | SrcRepo (cs, _) ->
- `SrcRepo, cs
- | Test (cs, _) ->
- `Test, cs
- | Doc (cs, _) ->
- `Doc, cs
-
- let section_common sct =
- snd (section_kind_common sct)
-
- let section_common_set cs =
- function
- | Library (_, bs, lib) -> Library (cs, bs, lib)
- | Executable (_, bs, exec) -> Executable (cs, bs, exec)
- | Flag (_, flg) -> Flag (cs, flg)
- | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo)
- | Test (_, tst) -> Test (cs, tst)
- | Doc (_, doc) -> Doc (cs, doc)
-
- (** Key used to identify section
- *)
- let section_id sct =
- let k, cs =
- section_kind_common sct
- in
- k, cs.cs_name
-
- let string_of_section sct =
- let k, nm =
- section_id sct
- in
- (match k with
- | `Library -> "library"
- | `Executable -> "executable"
- | `Flag -> "flag"
- | `SrcRepo -> "src repository"
- | `Test -> "test"
- | `Doc -> "doc")
- ^" "^nm
-
- let section_find id scts =
- List.find
- (fun sct -> id = section_id sct)
- scts
-
- module CSection =
- struct
- type t = section
-
- let id = section_id
-
- let compare t1 t2 =
- compare (id t1) (id t2)
-
- let equal t1 t2 =
- (id t1) = (id t2)
-
- let hash t =
- Hashtbl.hash (id t)
- end
-
- module MapSection = Map.Make(CSection)
- module SetSection = Set.Make(CSection)
-
-end
-
-module OASISBuildSection = struct
-(* # 21 "src/oasis/OASISBuildSection.ml" *)
-
-end
-
-module OASISExecutable = struct
-(* # 21 "src/oasis/OASISExecutable.ml" *)
-
- open OASISTypes
-
- let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program =
- let dir =
- OASISUnixPath.concat
- bs.bs_path
- (OASISUnixPath.dirname exec.exec_main_is)
- in
- let is_native_exec =
- match bs.bs_compiled_object with
- | Native -> true
- | Best -> is_native ()
- | Byte -> false
- in
-
- OASISUnixPath.concat
- dir
- (cs.cs_name^(suffix_program ())),
-
- if not is_native_exec &&
- not exec.exec_custom &&
- bs.bs_c_sources <> [] then
- Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ()))
- else
- None
-
-end
-
-module OASISLibrary = struct
-(* # 21 "src/oasis/OASISLibrary.ml" *)
-
- open OASISTypes
- open OASISUtils
- open OASISGettext
- open OASISSection
-
- type library_name = name
- type findlib_part_name = name
- type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t
-
- exception InternalLibraryNotFound of library_name
- exception FindlibPackageNotFound of findlib_name
-
- type group_t =
- | Container of findlib_name * group_t list
- | Package of (findlib_name *
- common_section *
- build_section *
- library *
- group_t list)
-
- (* Look for a module file, considering capitalization or not. *)
- let find_module source_file_exists (cs, bs, lib) modul =
- let possible_base_fn =
- List.map
- (OASISUnixPath.concat bs.bs_path)
- [modul;
- OASISUnixPath.uncapitalize_file modul;
- OASISUnixPath.capitalize_file modul]
- in
- (* TODO: we should be able to be able to determine the source for every
- * files. Hence we should introduce a Module(source: fn) for the fields
- * Modules and InternalModules
- *)
- List.fold_left
- (fun acc base_fn ->
- match acc with
- | `No_sources _ ->
- begin
- let file_found =
- List.fold_left
- (fun acc ext ->
- if source_file_exists (base_fn^ext) then
- (base_fn^ext) :: acc
- else
- acc)
- []
- [".ml"; ".mli"; ".mll"; ".mly"]
- in
- match file_found with
- | [] ->
- acc
- | lst ->
- `Sources (base_fn, lst)
- end
- | `Sources _ ->
- acc)
- (`No_sources possible_base_fn)
- possible_base_fn
-
- let source_unix_files ~ctxt (cs, bs, lib) source_file_exists =
- List.fold_left
- (fun acc modul ->
- match find_module source_file_exists (cs, bs, lib) modul with
- | `Sources (base_fn, lst) ->
- (base_fn, lst) :: acc
- | `No_sources _ ->
- OASISMessage.warning
- ~ctxt
- (f_ "Cannot find source file matching \
- module '%s' in library %s")
- modul cs.cs_name;
- acc)
- []
- (lib.lib_modules @ lib.lib_internal_modules)
-
- let generated_unix_files
- ~ctxt
- ~is_native
- ~has_native_dynlink
- ~ext_lib
- ~ext_dll
- ~source_file_exists
- (cs, bs, lib) =
-
- let find_modules lst ext =
- let find_module modul =
- match find_module source_file_exists (cs, bs, lib) modul with
- | `Sources (base_fn, _) ->
- [base_fn]
- | `No_sources lst ->
- OASISMessage.warning
- ~ctxt
- (f_ "Cannot find source file matching \
- module '%s' in library %s")
- modul cs.cs_name;
- lst
- in
- List.map
- (fun nm ->
- List.map
- (fun base_fn -> base_fn ^"."^ext)
- (find_module nm))
- lst
- in
-
- (* The headers that should be compiled along *)
- let headers =
- if lib.lib_pack then
- []
- else
- find_modules
- lib.lib_modules
- "cmi"
- in
-
- (* The .cmx that be compiled along *)
- let cmxs =
- let should_be_built =
- (not lib.lib_pack) && (* Do not install .cmx packed submodules *)
- match bs.bs_compiled_object with
- | Native -> true
- | Best -> is_native
- | Byte -> false
- in
- if should_be_built then
- find_modules
- (lib.lib_modules @ lib.lib_internal_modules)
- "cmx"
- else
- []
- in
-
- let acc_nopath =
- []
- in
-
- (* Compute what libraries should be built *)
- let acc_nopath =
- (* Add the packed header file if required *)
- let add_pack_header acc =
- if lib.lib_pack then
- [cs.cs_name^".cmi"] :: acc
- else
- acc
- in
- let byte acc =
- add_pack_header ([cs.cs_name^".cma"] :: acc)
- in
- let native acc =
- let acc =
- add_pack_header
- (if has_native_dynlink then
- [cs.cs_name^".cmxs"] :: acc
- else acc)
- in
- [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc
- in
- match bs.bs_compiled_object with
- | Native ->
- byte (native acc_nopath)
- | Best when is_native ->
- byte (native acc_nopath)
- | Byte | Best ->
- byte acc_nopath
- in
-
- (* Add C library to be built *)
- let acc_nopath =
- if bs.bs_c_sources <> [] then
- begin
- ["lib"^cs.cs_name^"_stubs"^ext_lib]
- ::
- ["dll"^cs.cs_name^"_stubs"^ext_dll]
- ::
- acc_nopath
- end
- else
- acc_nopath
- in
-
- (* All the files generated *)
- List.rev_append
- (List.rev_map
- (List.rev_map
- (OASISUnixPath.concat bs.bs_path))
- acc_nopath)
- (headers @ cmxs)
-
- type data = common_section * build_section * library
- type tree =
- | Node of (data option) * (tree MapString.t)
- | Leaf of data
-
- let findlib_mapping pkg =
- (* Map from library name to either full findlib name or parts + parent. *)
- let fndlb_parts_of_lib_name =
- let fndlb_parts cs lib =
- let name =
- match lib.lib_findlib_name with
- | Some nm -> nm
- | None -> cs.cs_name
- in
- let name =
- String.concat "." (lib.lib_findlib_containers @ [name])
- in
- name
- in
- List.fold_left
- (fun mp ->
- function
- | Library (cs, _, lib) ->
- begin
- let lib_name = cs.cs_name in
- let fndlb_parts = fndlb_parts cs lib in
- if MapString.mem lib_name mp then
- failwithf
- (f_ "The library name '%s' is used more than once.")
- lib_name;
- match lib.lib_findlib_parent with
- | Some lib_name_parent ->
- MapString.add
- lib_name
- (`Unsolved (lib_name_parent, fndlb_parts))
- mp
- | None ->
- MapString.add
- lib_name
- (`Solved fndlb_parts)
- mp
- end
-
- | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ ->
- mp)
- MapString.empty
- pkg.sections
- in
-
- (* Solve the above graph to be only library name to full findlib name. *)
- let fndlb_name_of_lib_name =
- let rec solve visited mp lib_name lib_name_child =
- if SetString.mem lib_name visited then
- failwithf
- (f_ "Library '%s' is involved in a cycle \
- with regard to findlib naming.")
- lib_name;
- let visited = SetString.add lib_name visited in
- try
- match MapString.find lib_name mp with
- | `Solved fndlb_nm ->
- fndlb_nm, mp
- | `Unsolved (lib_nm_parent, post_fndlb_nm) ->
- let pre_fndlb_nm, mp =
- solve visited mp lib_nm_parent lib_name
- in
- let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in
- fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp
- with Not_found ->
- failwithf
- (f_ "Library '%s', which is defined as the findlib parent of \
- library '%s', doesn't exist.")
- lib_name lib_name_child
- in
- let mp =
- MapString.fold
- (fun lib_name status mp ->
- match status with
- | `Solved _ ->
- (* Solved initialy, no need to go further *)
- mp
- | `Unsolved _ ->
- let _, mp = solve SetString.empty mp lib_name "<none>" in
- mp)
- fndlb_parts_of_lib_name
- fndlb_parts_of_lib_name
- in
- MapString.map
- (function
- | `Solved fndlb_nm -> fndlb_nm
- | `Unsolved _ -> assert false)
- mp
- in
-
- (* Convert an internal library name to a findlib name. *)
- let findlib_name_of_library_name lib_nm =
- try
- MapString.find lib_nm fndlb_name_of_lib_name
- with Not_found ->
- raise (InternalLibraryNotFound lib_nm)
- in
-
- (* Add a library to the tree.
- *)
- let add sct mp =
- let fndlb_fullname =
- let cs, _, _ = sct in
- let lib_name = cs.cs_name in
- findlib_name_of_library_name lib_name
- in
- let rec add_children nm_lst (children : tree MapString.t) =
- match nm_lst with
- | (hd :: tl) ->
- begin
- let node =
- try
- add_node tl (MapString.find hd children)
- with Not_found ->
- (* New node *)
- new_node tl
- in
- MapString.add hd node children
- end
- | [] ->
- (* Should not have a nameless library. *)
- assert false
- and add_node tl node =
- if tl = [] then
- begin
- match node with
- | Node (None, children) ->
- Node (Some sct, children)
- | Leaf (cs', _, _) | Node (Some (cs', _, _), _) ->
- (* TODO: allow to merge Package, i.e.
- * archive(byte) = "foo.cma foo_init.cmo"
- *)
- let cs, _, _ = sct in
- failwithf
- (f_ "Library '%s' and '%s' have the same findlib name '%s'")
- cs.cs_name cs'.cs_name fndlb_fullname
- end
- else
- begin
- match node with
- | Leaf data ->
- Node (Some data, add_children tl MapString.empty)
- | Node (data_opt, children) ->
- Node (data_opt, add_children tl children)
- end
- and new_node =
- function
- | [] ->
- Leaf sct
- | hd :: tl ->
- Node (None, MapString.add hd (new_node tl) MapString.empty)
- in
- add_children (OASISString.nsplit fndlb_fullname '.') mp
- in
-
- let rec group_of_tree mp =
- MapString.fold
- (fun nm node acc ->
- let cur =
- match node with
- | Node (Some (cs, bs, lib), children) ->
- Package (nm, cs, bs, lib, group_of_tree children)
- | Node (None, children) ->
- Container (nm, group_of_tree children)
- | Leaf (cs, bs, lib) ->
- Package (nm, cs, bs, lib, [])
- in
- cur :: acc)
- mp []
- in
-
- let group_mp =
- List.fold_left
- (fun mp ->
- function
- | Library (cs, bs, lib) ->
- add (cs, bs, lib) mp
- | _ ->
- mp)
- MapString.empty
- pkg.sections
- in
-
- let groups =
- group_of_tree group_mp
- in
-
- let library_name_of_findlib_name =
- Lazy.lazy_from_fun
- (fun () ->
- (* Revert findlib_name_of_library_name. *)
- MapString.fold
- (fun k v mp -> MapString.add v k mp)
- fndlb_name_of_lib_name
- MapString.empty)
- in
- let library_name_of_findlib_name fndlb_nm =
- try
- MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name)
- with Not_found ->
- raise (FindlibPackageNotFound fndlb_nm)
- in
-
- groups,
- findlib_name_of_library_name,
- library_name_of_findlib_name
-
- let findlib_of_group =
- function
- | Container (fndlb_nm, _)
- | Package (fndlb_nm, _, _, _, _) -> fndlb_nm
-
- let root_of_group grp =
- let rec root_lib_aux =
- (* We do a DFS in the group. *)
- function
- | Container (_, children) ->
- List.fold_left
- (fun res grp ->
- if res = None then
- root_lib_aux grp
- else
- res)
- None
- children
- | Package (_, cs, bs, lib, _) ->
- Some (cs, bs, lib)
- in
- match root_lib_aux grp with
- | Some res ->
- res
- | None ->
- failwithf
- (f_ "Unable to determine root library of findlib library '%s'")
- (findlib_of_group grp)
-
-end
-
-module OASISFlag = struct
-(* # 21 "src/oasis/OASISFlag.ml" *)
-
-end
-
-module OASISPackage = struct
-(* # 21 "src/oasis/OASISPackage.ml" *)
-
-end
-
-module OASISSourceRepository = struct
-(* # 21 "src/oasis/OASISSourceRepository.ml" *)
-
-end
-
-module OASISTest = struct
-(* # 21 "src/oasis/OASISTest.ml" *)
-
-end
-
-module OASISDocument = struct
-(* # 21 "src/oasis/OASISDocument.ml" *)
-
-end
-
-module OASISExec = struct
-(* # 21 "src/oasis/OASISExec.ml" *)
-
- open OASISGettext
- open OASISUtils
- open OASISMessage
-
- (* TODO: I don't like this quote, it is there because $(rm) foo expands to
- * 'rm -f' foo...
- *)
- let run ~ctxt ?f_exit_code ?(quote=true) cmd args =
- let cmd =
- if quote then
- if Sys.os_type = "Win32" then
- if String.contains cmd ' ' then
- (* Double the 1st double quote... win32... sigh *)
- "\""^(Filename.quote cmd)
- else
- cmd
- else
- Filename.quote cmd
- else
- cmd
- in
- let cmdline =
- String.concat " " (cmd :: args)
- in
- info ~ctxt (f_ "Running command '%s'") cmdline;
- match f_exit_code, Sys.command cmdline with
- | None, 0 -> ()
- | None, i ->
- failwithf
- (f_ "Command '%s' terminated with error code %d")
- cmdline i
- | Some f, i ->
- f i
-
- let run_read_output ~ctxt ?f_exit_code cmd args =
- let fn =
- Filename.temp_file "oasis-" ".txt"
- in
- try
- begin
- let () =
- run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn])
- in
- let chn =
- open_in fn
- in
- let routput =
- ref []
- in
- begin
- try
- while true do
- routput := (input_line chn) :: !routput
- done
- with End_of_file ->
- ()
- end;
- close_in chn;
- Sys.remove fn;
- List.rev !routput
- end
- with e ->
- (try Sys.remove fn with _ -> ());
- raise e
-
- let run_read_one_line ~ctxt ?f_exit_code cmd args =
- match run_read_output ~ctxt ?f_exit_code cmd args with
- | [fst] ->
- fst
- | lst ->
- failwithf
- (f_ "Command return unexpected output %S")
- (String.concat "\n" lst)
-end
-
-module OASISFileUtil = struct
-(* # 21 "src/oasis/OASISFileUtil.ml" *)
-
- open OASISGettext
-
- let file_exists_case fn =
- let dirname = Filename.dirname fn in
- let basename = Filename.basename fn in
- if Sys.file_exists dirname then
- if basename = Filename.current_dir_name then
- true
- else
- List.mem
- basename
- (Array.to_list (Sys.readdir dirname))
- else
- false
-
- let find_file ?(case_sensitive=true) paths exts =
-
- (* Cardinal product of two list *)
- let ( * ) lst1 lst2 =
- List.flatten
- (List.map
- (fun a ->
- List.map
- (fun b -> a,b)
- lst2)
- lst1)
- in
-
- let rec combined_paths lst =
- match lst with
- | p1 :: p2 :: tl ->
- let acc =
- (List.map
- (fun (a,b) -> Filename.concat a b)
- (p1 * p2))
- in
- combined_paths (acc :: tl)
- | [e] ->
- e
- | [] ->
- []
- in
-
- let alternatives =
- List.map
- (fun (p,e) ->
- if String.length e > 0 && e.[0] <> '.' then
- p ^ "." ^ e
- else
- p ^ e)
- ((combined_paths paths) * exts)
- in
- List.find
- (if case_sensitive then
- file_exists_case
- else
- Sys.file_exists)
- alternatives
-
- let which ~ctxt prg =
- let path_sep =
- match Sys.os_type with
- | "Win32" ->
- ';'
- | _ ->
- ':'
- in
- let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in
- let exec_ext =
- match Sys.os_type with
- | "Win32" ->
- "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep)
- | _ ->
- [""]
- in
- find_file ~case_sensitive:false [path_lst; [prg]] exec_ext
-
- (**/**)
- let rec fix_dir dn =
- (* Windows hack because Sys.file_exists "src\\" = false when
- * Sys.file_exists "src" = true
- *)
- let ln =
- String.length dn
- in
- if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then
- fix_dir (String.sub dn 0 (ln - 1))
- else
- dn
-
- let q = Filename.quote
- (**/**)
-
- let cp ~ctxt ?(recurse=false) src tgt =
- if recurse then
- match Sys.os_type with
- | "Win32" ->
- OASISExec.run ~ctxt
- "xcopy" [q src; q tgt; "/E"]
- | _ ->
- OASISExec.run ~ctxt
- "cp" ["-r"; q src; q tgt]
- else
- OASISExec.run ~ctxt
- (match Sys.os_type with
- | "Win32" -> "copy"
- | _ -> "cp")
- [q src; q tgt]
-
- let mkdir ~ctxt tgt =
- OASISExec.run ~ctxt
- (match Sys.os_type with
- | "Win32" -> "md"
- | _ -> "mkdir")
- [q tgt]
-
- let rec mkdir_parent ~ctxt f tgt =
- let tgt =
- fix_dir tgt
- in
- if Sys.file_exists tgt then
- begin
- if not (Sys.is_directory tgt) then
- OASISUtils.failwithf
- (f_ "Cannot create directory '%s', a file of the same name already \
- exists")
- tgt
- end
- else
- begin
- mkdir_parent ~ctxt f (Filename.dirname tgt);
- if not (Sys.file_exists tgt) then
- begin
- f tgt;
- mkdir ~ctxt tgt
- end
- end
-
- let rmdir ~ctxt tgt =
- if Sys.readdir tgt = [||] then
- begin
- match Sys.os_type with
- | "Win32" ->
- OASISExec.run ~ctxt "rd" [q tgt]
- | _ ->
- OASISExec.run ~ctxt "rm" ["-r"; q tgt]
- end
-
- let glob ~ctxt fn =
- let basename =
- Filename.basename fn
- in
- if String.length basename >= 2 &&
- basename.[0] = '*' &&
- basename.[1] = '.' then
- begin
- let ext_len =
- (String.length basename) - 2
- in
- let ext =
- String.sub basename 2 ext_len
- in
- let dirname =
- Filename.dirname fn
- in
- Array.fold_left
- (fun acc fn ->
- try
- let fn_ext =
- String.sub
- fn
- ((String.length fn) - ext_len)
- ext_len
- in
- if fn_ext = ext then
- (Filename.concat dirname fn) :: acc
- else
- acc
- with Invalid_argument _ ->
- acc)
- []
- (Sys.readdir dirname)
- end
- else
- begin
- if file_exists_case fn then
- [fn]
- else
- []
- end
-end
-
-
-# 2142 "setup.ml"
-module BaseEnvLight = struct
-(* # 21 "src/base/BaseEnvLight.ml" *)
-
- module MapString = Map.Make(String)
-
- type t = string MapString.t
-
- let default_filename =
- Filename.concat
- (Sys.getcwd ())
- "setup.data"
-
- let load ?(allow_empty=false) ?(filename=default_filename) () =
- if Sys.file_exists filename then
- begin
- let chn =
- open_in_bin filename
- in
- let st =
- Stream.of_channel chn
- in
- let line =
- ref 1
- in
- let st_line =
- Stream.from
- (fun _ ->
- try
- match Stream.next st with
- | '\n' -> incr line; Some '\n'
- | c -> Some c
- with Stream.Failure -> None)
- in
- let lexer =
- Genlex.make_lexer ["="] st_line
- in
- let rec read_file mp =
- match Stream.npeek 3 lexer with
- | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] ->
- Stream.junk lexer;
- Stream.junk lexer;
- Stream.junk lexer;
- read_file (MapString.add nm value mp)
- | [] ->
- mp
- | _ ->
- failwith
- (Printf.sprintf
- "Malformed data file '%s' line %d"
- filename !line)
- in
- let mp =
- read_file MapString.empty
- in
- close_in chn;
- mp
- end
- else if allow_empty then
- begin
- MapString.empty
- end
- else
- begin
- failwith
- (Printf.sprintf
- "Unable to load environment, the file '%s' doesn't exist."
- filename)
- end
-
- let var_get name env =
- let rec var_expand str =
- let buff =
- Buffer.create ((String.length str) * 2)
- in
- Buffer.add_substitute
- buff
- (fun var ->
- try
- var_expand (MapString.find var env)
- with Not_found ->
- failwith
- (Printf.sprintf
- "No variable %s defined when trying to expand %S."
- var
- str))
- str;
- Buffer.contents buff
- in
- var_expand (MapString.find name env)
-
- let var_choose lst env =
- OASISExpr.choose
- (fun nm -> var_get nm env)
- lst
-end
-
-
-# 2240 "setup.ml"
-module BaseContext = struct
-(* # 21 "src/base/BaseContext.ml" *)
-
- open OASISContext
-
- let args = args
-
- let default = default
-
-end
-
-module BaseMessage = struct
-(* # 21 "src/base/BaseMessage.ml" *)
-
- (** Message to user, overrid for Base
- @author Sylvain Le Gall
- *)
- open OASISMessage
- open BaseContext
-
- let debug fmt = debug ~ctxt:!default fmt
-
- let info fmt = info ~ctxt:!default fmt
-
- let warning fmt = warning ~ctxt:!default fmt
-
- let error fmt = error ~ctxt:!default fmt
-
-end
-
-module BaseEnv = struct
-(* # 21 "src/base/BaseEnv.ml" *)
-
- open OASISGettext
- open OASISUtils
- open PropList
-
- module MapString = BaseEnvLight.MapString
-
- type origin_t =
- | ODefault
- | OGetEnv
- | OFileLoad
- | OCommandLine
-
- type cli_handle_t =
- | CLINone
- | CLIAuto
- | CLIWith
- | CLIEnable
- | CLIUser of (Arg.key * Arg.spec * Arg.doc) list
-
- type definition_t =
- {
- hide: bool;
- dump: bool;
- cli: cli_handle_t;
- arg_help: string option;
- group: string option;
- }
-
- let schema =
- Schema.create "environment"
-
- (* Environment data *)
- let env =
- Data.create ()
-
- (* Environment data from file *)
- let env_from_file =
- ref MapString.empty
-
- (* Lexer for var *)
- let var_lxr =
- Genlex.make_lexer []
-
- let rec var_expand str =
- let buff =
- Buffer.create ((String.length str) * 2)
- in
- Buffer.add_substitute
- buff
- (fun var ->
- try
- (* TODO: this is a quick hack to allow calling Test.Command
- * without defining executable name really. I.e. if there is
- * an exec Executable toto, then $(toto) should be replace
- * by its real name. It is however useful to have this function
- * for other variable that depend on the host and should be
- * written better than that.
- *)
- let st =
- var_lxr (Stream.of_string var)
- in
- match Stream.npeek 3 st with
- | [Genlex.Ident "utoh"; Genlex.Ident nm] ->
- OASISHostPath.of_unix (var_get nm)
- | [Genlex.Ident "utoh"; Genlex.String s] ->
- OASISHostPath.of_unix s
- | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] ->
- String.escaped (var_get nm)
- | [Genlex.Ident "ocaml_escaped"; Genlex.String s] ->
- String.escaped s
- | [Genlex.Ident nm] ->
- var_get nm
- | _ ->
- failwithf
- (f_ "Unknown expression '%s' in variable expansion of %s.")
- var
- str
- with
- | Unknown_field (_, _) ->
- failwithf
- (f_ "No variable %s defined when trying to expand %S.")
- var
- str
- | Stream.Error e ->
- failwithf
- (f_ "Syntax error when parsing '%s' when trying to \
- expand %S: %s")
- var
- str
- e)
- str;
- Buffer.contents buff
-
- and var_get name =
- let vl =
- try
- Schema.get schema env name
- with Unknown_field _ as e ->
- begin
- try
- MapString.find name !env_from_file
- with Not_found ->
- raise e
- end
- in
- var_expand vl
-
- let var_choose ?printer ?name lst =
- OASISExpr.choose
- ?printer
- ?name
- var_get
- lst
-
- let var_protect vl =
- let buff =
- Buffer.create (String.length vl)
- in
- String.iter
- (function
- | '$' -> Buffer.add_string buff "\\$"
- | c -> Buffer.add_char buff c)
- vl;
- Buffer.contents buff
-
- let var_define
- ?(hide=false)
- ?(dump=true)
- ?short_desc
- ?(cli=CLINone)
- ?arg_help
- ?group
- name (* TODO: type constraint on the fact that name must be a valid OCaml
- id *)
- dflt =
-
- let default =
- [
- OFileLoad, (fun () -> MapString.find name !env_from_file);
- ODefault, dflt;
- OGetEnv, (fun () -> Sys.getenv name);
- ]
- in
-
- let extra =
- {
- hide = hide;
- dump = dump;
- cli = cli;
- arg_help = arg_help;
- group = group;
- }
- in
-
- (* Try to find a value that can be defined
- *)
- let var_get_low lst =
- let errors, res =
- List.fold_left
- (fun (errors, res) (o, v) ->
- if res = None then
- begin
- try
- errors, Some (v ())
- with
- | Not_found ->
- errors, res
- | Failure rsn ->
- (rsn :: errors), res
- | e ->
- (Printexc.to_string e) :: errors, res
- end
- else
- errors, res)
- ([], None)
- (List.sort
- (fun (o1, _) (o2, _) ->
- Pervasives.compare o2 o1)
- lst)
- in
- match res, errors with
- | Some v, _ ->
- v
- | None, [] ->
- raise (Not_set (name, None))
- | None, lst ->
- raise (Not_set (name, Some (String.concat (s_ ", ") lst)))
- in
-
- let help =
- match short_desc with
- | Some fs -> Some fs
- | None -> None
- in
-
- let var_get_lst =
- FieldRO.create
- ~schema
- ~name
- ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s])
- ~print:var_get_low
- ~default
- ~update:(fun ?context x old_x -> x @ old_x)
- ?help
- extra
- in
-
- fun () ->
- var_expand (var_get_low (var_get_lst env))
-
- let var_redefine
- ?hide
- ?dump
- ?short_desc
- ?cli
- ?arg_help
- ?group
- name
- dflt =
- if Schema.mem schema name then
- begin
- (* TODO: look suspsicious, we want to memorize dflt not dflt () *)
- Schema.set schema env ~context:ODefault name (dflt ());
- fun () -> var_get name
- end
- else
- begin
- var_define
- ?hide
- ?dump
- ?short_desc
- ?cli
- ?arg_help
- ?group
- name
- dflt
- end
-
- let var_ignore (e : unit -> string) =
- ()
-
- let print_hidden =
- var_define
- ~hide:true
- ~dump:false
- ~cli:CLIAuto
- ~arg_help:"Print even non-printable variable. (debug)"
- "print_hidden"
- (fun () -> "false")
-
- let var_all () =
- List.rev
- (Schema.fold
- (fun acc nm def _ ->
- if not def.hide || bool_of_string (print_hidden ()) then
- nm :: acc
- else
- acc)
- []
- schema)
-
- let default_filename =
- BaseEnvLight.default_filename
-
- let load ?allow_empty ?filename () =
- env_from_file := BaseEnvLight.load ?allow_empty ?filename ()
-
- let unload () =
- env_from_file := MapString.empty;
- Data.clear env
-
- let dump ?(filename=default_filename) () =
- let chn =
- open_out_bin filename
- in
- let output nm value =
- Printf.fprintf chn "%s=%S\n" nm value
- in
- let mp_todo =
- (* Dump data from schema *)
- Schema.fold
- (fun mp_todo nm def _ ->
- if def.dump then
- begin
- try
- let value =
- Schema.get
- schema
- env
- nm
- in
- output nm value
- with Not_set _ ->
- ()
- end;
- MapString.remove nm mp_todo)
- !env_from_file
- schema
- in
- (* Dump data defined outside of schema *)
- MapString.iter output mp_todo;
-
- (* End of the dump *)
- close_out chn
-
- let print () =
- let printable_vars =
- Schema.fold
- (fun acc nm def short_descr_opt ->
- if not def.hide || bool_of_string (print_hidden ()) then
- begin
- try
- let value =
- Schema.get
- schema
- env
- nm
- in
- let txt =
- match short_descr_opt with
- | Some s -> s ()
- | None -> nm
- in
- (txt, value) :: acc
- with Not_set _ ->
- acc
- end
- else
- acc)
- []
- schema
- in
- let max_length =
- List.fold_left max 0
- (List.rev_map String.length
- (List.rev_map fst printable_vars))
- in
- let dot_pad str =
- String.make ((max_length - (String.length str)) + 3) '.'
- in
-
- Printf.printf "\nConfiguration: \n";
- List.iter
- (fun (name,value) ->
- Printf.printf "%s: %s %s\n" name (dot_pad name) value)
- (List.rev printable_vars);
- Printf.printf "\n%!"
-
- let args () =
- let arg_concat =
- OASISUtils.varname_concat ~hyphen:'-'
- in
- [
- "--override",
- Arg.Tuple
- (
- let rvr = ref ""
- in
- let rvl = ref ""
- in
- [
- Arg.Set_string rvr;
- Arg.Set_string rvl;
- Arg.Unit
- (fun () ->
- Schema.set
- schema
- env
- ~context:OCommandLine
- !rvr
- !rvl)
- ]
- ),
- "var+val Override any configuration variable.";
-
- ]
- @
- List.flatten
- (Schema.fold
- (fun acc name def short_descr_opt ->
- let var_set s =
- Schema.set
- schema
- env
- ~context:OCommandLine
- name
- s
- in
-
- let arg_name =
- OASISUtils.varname_of_string ~hyphen:'-' name
- in
-
- let hlp =
- match short_descr_opt with
- | Some txt -> txt ()
- | None -> ""
- in
-
- let arg_hlp =
- match def.arg_help with
- | Some s -> s
- | None -> "str"
- in
-
- let default_value =
- try
- Printf.sprintf
- (f_ " [%s]")
- (Schema.get
- schema
- env
- name)
- with Not_set _ ->
- ""
- in
-
- let args =
- match def.cli with
- | CLINone ->
- []
- | CLIAuto ->
- [
- arg_concat "--" arg_name,
- Arg.String var_set,
- Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value
- ]
- | CLIWith ->
- [
- arg_concat "--with-" arg_name,
- Arg.String var_set,
- Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value
- ]
- | CLIEnable ->
- let dflt =
- if default_value = " [true]" then
- s_ " [default: enabled]"
- else
- s_ " [default: disabled]"
- in
- [
- arg_concat "--enable-" arg_name,
- Arg.Unit (fun () -> var_set "true"),
- Printf.sprintf (f_ " %s%s") hlp dflt;
-
- arg_concat "--disable-" arg_name,
- Arg.Unit (fun () -> var_set "false"),
- Printf.sprintf (f_ " %s%s") hlp dflt
- ]
- | CLIUser lst ->
- lst
- in
- args :: acc)
- []
- schema)
-end
-
-module BaseArgExt = struct
-(* # 21 "src/base/BaseArgExt.ml" *)
-
- open OASISUtils
- open OASISGettext
-
- let parse argv args =
- (* Simulate command line for Arg *)
- let current =
- ref 0
- in
-
- try
- Arg.parse_argv
- ~current:current
- (Array.concat [[|"none"|]; argv])
- (Arg.align args)
- (failwithf (f_ "Don't know what to do with arguments: '%s'"))
- (s_ "configure options:")
- with
- | Arg.Help txt ->
- print_endline txt;
- exit 0
- | Arg.Bad txt ->
- prerr_endline txt;
- exit 1
-end
-
-module BaseCheck = struct
-(* # 21 "src/base/BaseCheck.ml" *)
-
- open BaseEnv
- open BaseMessage
- open OASISUtils
- open OASISGettext
-
- let prog_best prg prg_lst =
- var_redefine
- prg
- (fun () ->
- let alternate =
- List.fold_left
- (fun res e ->
- match res with
- | Some _ ->
- res
- | None ->
- try
- Some (OASISFileUtil.which ~ctxt:!BaseContext.default e)
- with Not_found ->
- None)
- None
- prg_lst
- in
- match alternate with
- | Some prg -> prg
- | None -> raise Not_found)
-
- let prog prg =
- prog_best prg [prg]
-
- let prog_opt prg =
- prog_best prg [prg^".opt"; prg]
-
- let ocamlfind =
- prog "ocamlfind"
-
- let version
- var_prefix
- cmp
- fversion
- () =
- (* Really compare version provided *)
- let var =
- var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp)
- in
- var_redefine
- ~hide:true
- var
- (fun () ->
- let version_str =
- match fversion () with
- | "[Distributed with OCaml]" ->
- begin
- try
- (var_get "ocaml_version")
- with Not_found ->
- warning
- (f_ "Variable ocaml_version not defined, fallback \
- to default");
- Sys.ocaml_version
- end
- | res ->
- res
- in
- let version =
- OASISVersion.version_of_string version_str
- in
- if OASISVersion.comparator_apply version cmp then
- version_str
- else
- failwithf
- (f_ "Cannot satisfy version constraint on %s: %s (version: %s)")
- var_prefix
- (OASISVersion.string_of_comparator cmp)
- version_str)
- ()
-
- let package_version pkg =
- OASISExec.run_read_one_line ~ctxt:!BaseContext.default
- (ocamlfind ())
- ["query"; "-format"; "%v"; pkg]
-
- let package ?version_comparator pkg () =
- let var =
- OASISUtils.varname_concat
- "pkg_"
- (OASISUtils.varname_of_string pkg)
- in
- let findlib_dir pkg =
- let dir =
- OASISExec.run_read_one_line ~ctxt:!BaseContext.default
- (ocamlfind ())
- ["query"; "-format"; "%d"; pkg]
- in
- if Sys.file_exists dir && Sys.is_directory dir then
- dir
- else
- failwithf
- (f_ "When looking for findlib package %s, \
- directory %s return doesn't exist")
- pkg dir
- in
- let vl =
- var_redefine
- var
- (fun () -> findlib_dir pkg)
- ()
- in
- (
- match version_comparator with
- | Some ver_cmp ->
- ignore
- (version
- var
- ver_cmp
- (fun _ -> package_version pkg)
- ())
- | None ->
- ()
- );
- vl
-end
-
-module BaseOCamlcConfig = struct
-(* # 21 "src/base/BaseOCamlcConfig.ml" *)
-
-
- open BaseEnv
- open OASISUtils
- open OASISGettext
-
- module SMap = Map.Make(String)
-
- let ocamlc =
- BaseCheck.prog_opt "ocamlc"
-
- let ocamlc_config_map =
- (* Map name to value for ocamlc -config output
- (name ^": "^value)
- *)
- let rec split_field mp lst =
- match lst with
- | line :: tl ->
- let mp =
- try
- let pos_semicolon =
- String.index line ':'
- in
- if pos_semicolon > 1 then
- (
- let name =
- String.sub line 0 pos_semicolon
- in
- let linelen =
- String.length line
- in
- let value =
- if linelen > pos_semicolon + 2 then
- String.sub
- line
- (pos_semicolon + 2)
- (linelen - pos_semicolon - 2)
- else
- ""
- in
- SMap.add name value mp
- )
- else
- (
- mp
- )
- with Not_found ->
- (
- mp
- )
- in
- split_field mp tl
- | [] ->
- mp
- in
-
- let cache =
- lazy
- (var_protect
- (Marshal.to_string
- (split_field
- SMap.empty
- (OASISExec.run_read_output
- ~ctxt:!BaseContext.default
- (ocamlc ()) ["-config"]))
- []))
- in
- var_redefine
- "ocamlc_config_map"
- ~hide:true
- ~dump:false
- (fun () ->
- (* TODO: update if ocamlc change !!! *)
- Lazy.force cache)
-
- let var_define nm =
- (* Extract data from ocamlc -config *)
- let avlbl_config_get () =
- Marshal.from_string
- (ocamlc_config_map ())
- 0
- in
- let chop_version_suffix s =
- try
- String.sub s 0 (String.index s '+')
- with _ ->
- s
- in
-
- let nm_config, value_config =
- match nm with
- | "ocaml_version" ->
- "version", chop_version_suffix
- | _ -> nm, (fun x -> x)
- in
- var_redefine
- nm
- (fun () ->
- try
- let map =
- avlbl_config_get ()
- in
- let value =
- SMap.find nm_config map
- in
- value_config value
- with Not_found ->
- failwithf
- (f_ "Cannot find field '%s' in '%s -config' output")
- nm
- (ocamlc ()))
-
-end
-
-module BaseStandardVar = struct
-(* # 21 "src/base/BaseStandardVar.ml" *)
-
-
- open OASISGettext
- open OASISTypes
- open OASISExpr
- open BaseCheck
- open BaseEnv
-
- let ocamlfind = BaseCheck.ocamlfind
- let ocamlc = BaseOCamlcConfig.ocamlc
- let ocamlopt = prog_opt "ocamlopt"
- let ocamlbuild = prog "ocamlbuild"
-
-
- (**/**)
- let rpkg =
- ref None
-
- let pkg_get () =
- match !rpkg with
- | Some pkg -> pkg
- | None -> failwith (s_ "OASIS Package is not set")
-
- let var_cond = ref []
-
- let var_define_cond ~since_version f dflt =
- let holder = ref (fun () -> dflt) in
- let since_version =
- OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version)
- in
- var_cond :=
- (fun ver ->
- if OASISVersion.comparator_apply ver since_version then
- holder := f ()) :: !var_cond;
- fun () -> !holder ()
-
- (**/**)
-
- let pkg_name =
- var_define
- ~short_desc:(fun () -> s_ "Package name")
- "pkg_name"
- (fun () -> (pkg_get ()).name)
-
- let pkg_version =
- var_define
- ~short_desc:(fun () -> s_ "Package version")
- "pkg_version"
- (fun () ->
- (OASISVersion.string_of_version (pkg_get ()).version))
-
- let c = BaseOCamlcConfig.var_define
-
- let os_type = c "os_type"
- let system = c "system"
- let architecture = c "architecture"
- let ccomp_type = c "ccomp_type"
- let ocaml_version = c "ocaml_version"
-
- (* TODO: Check standard variable presence at runtime *)
-
- let standard_library_default = c "standard_library_default"
- let standard_library = c "standard_library"
- let standard_runtime = c "standard_runtime"
- let bytecomp_c_compiler = c "bytecomp_c_compiler"
- let native_c_compiler = c "native_c_compiler"
- let model = c "model"
- let ext_obj = c "ext_obj"
- let ext_asm = c "ext_asm"
- let ext_lib = c "ext_lib"
- let ext_dll = c "ext_dll"
- let default_executable_name = c "default_executable_name"
- let systhread_supported = c "systhread_supported"
-
- let flexlink =
- BaseCheck.prog "flexlink"
-
- let flexdll_version =
- var_define
- ~short_desc:(fun () -> "FlexDLL version (Win32)")
- "flexdll_version"
- (fun () ->
- let lst =
- OASISExec.run_read_output ~ctxt:!BaseContext.default
- (flexlink ()) ["-help"]
- in
- match lst with
- | line :: _ ->
- Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver)
- | [] ->
- raise Not_found)
-
- (**/**)
- let p name hlp dflt =
- var_define
- ~short_desc:hlp
- ~cli:CLIAuto
- ~arg_help:"dir"
- name
- dflt
-
- let (/) a b =
- if os_type () = Sys.os_type then
- Filename.concat a b
- else if os_type () = "Unix" then
- OASISUnixPath.concat a b
- else
- OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat")
- (os_type ())
- (**/**)
-
- let prefix =
- p "prefix"
- (fun () -> s_ "Install architecture-independent files dir")
- (fun () ->
- match os_type () with
- | "Win32" ->
- let program_files =
- Sys.getenv "PROGRAMFILES"
- in
- program_files/(pkg_name ())
- | _ ->
- "/usr/local")
-
- let exec_prefix =
- p "exec_prefix"
- (fun () -> s_ "Install architecture-dependent files in dir")
- (fun () -> "$prefix")
-
- let bindir =
- p "bindir"
- (fun () -> s_ "User executables")
- (fun () -> "$exec_prefix"/"bin")
-
- let sbindir =
- p "sbindir"
- (fun () -> s_ "System admin executables")
- (fun () -> "$exec_prefix"/"sbin")
-
- let libexecdir =
- p "libexecdir"
- (fun () -> s_ "Program executables")
- (fun () -> "$exec_prefix"/"libexec")
-
- let sysconfdir =
- p "sysconfdir"
- (fun () -> s_ "Read-only single-machine data")
- (fun () -> "$prefix"/"etc")
-
- let sharedstatedir =
- p "sharedstatedir"
- (fun () -> s_ "Modifiable architecture-independent data")
- (fun () -> "$prefix"/"com")
-
- let localstatedir =
- p "localstatedir"
- (fun () -> s_ "Modifiable single-machine data")
- (fun () -> "$prefix"/"var")
-
- let libdir =
- p "libdir"
- (fun () -> s_ "Object code libraries")
- (fun () -> "$exec_prefix"/"lib")
-
- let datarootdir =
- p "datarootdir"
- (fun () -> s_ "Read-only arch-independent data root")
- (fun () -> "$prefix"/"share")
-
- let datadir =
- p "datadir"
- (fun () -> s_ "Read-only architecture-independent data")
- (fun () -> "$datarootdir")
-
- let infodir =
- p "infodir"
- (fun () -> s_ "Info documentation")
- (fun () -> "$datarootdir"/"info")
-
- let localedir =
- p "localedir"
- (fun () -> s_ "Locale-dependent data")
- (fun () -> "$datarootdir"/"locale")
-
- let mandir =
- p "mandir"
- (fun () -> s_ "Man documentation")
- (fun () -> "$datarootdir"/"man")
-
- let docdir =
- p "docdir"
- (fun () -> s_ "Documentation root")
- (fun () -> "$datarootdir"/"doc"/"$pkg_name")
-
- let htmldir =
- p "htmldir"
- (fun () -> s_ "HTML documentation")
- (fun () -> "$docdir")
-
- let dvidir =
- p "dvidir"
- (fun () -> s_ "DVI documentation")
- (fun () -> "$docdir")
-
- let pdfdir =
- p "pdfdir"
- (fun () -> s_ "PDF documentation")
- (fun () -> "$docdir")
-
- let psdir =
- p "psdir"
- (fun () -> s_ "PS documentation")
- (fun () -> "$docdir")
-
- let destdir =
- p "destdir"
- (fun () -> s_ "Prepend a path when installing package")
- (fun () ->
- raise
- (PropList.Not_set
- ("destdir",
- Some (s_ "undefined by construct"))))
-
- let findlib_version =
- var_define
- "findlib_version"
- (fun () ->
- BaseCheck.package_version "findlib")
-
- let is_native =
- var_define
- "is_native"
- (fun () ->
- try
- let _s : string =
- ocamlopt ()
- in
- "true"
- with PropList.Not_set _ ->
- let _s : string =
- ocamlc ()
- in
- "false")
-
- let ext_program =
- var_define
- "suffix_program"
- (fun () ->
- match os_type () with
- | "Win32" -> ".exe"
- | _ -> "")
-
- let rm =
- var_define
- ~short_desc:(fun () -> s_ "Remove a file.")
- "rm"
- (fun () ->
- match os_type () with
- | "Win32" -> "del"
- | _ -> "rm -f")
-
- let rmdir =
- var_define
- ~short_desc:(fun () -> s_ "Remove a directory.")
- "rmdir"
- (fun () ->
- match os_type () with
- | "Win32" -> "rd"
- | _ -> "rm -rf")
-
- let debug =
- var_define
- ~short_desc:(fun () -> s_ "Turn ocaml debug flag on")
- ~cli:CLIEnable
- "debug"
- (fun () -> "true")
-
- let profile =
- var_define
- ~short_desc:(fun () -> s_ "Turn ocaml profile flag on")
- ~cli:CLIEnable
- "profile"
- (fun () -> "false")
-
- let tests =
- var_define_cond ~since_version:"0.3"
- (fun () ->
- var_define
- ~short_desc:(fun () ->
- s_ "Compile tests executable and library and run them")
- ~cli:CLIEnable
- "tests"
- (fun () -> "false"))
- "true"
-
- let docs =
- var_define_cond ~since_version:"0.3"
- (fun () ->
- var_define
- ~short_desc:(fun () -> s_ "Create documentations")
- ~cli:CLIEnable
- "docs"
- (fun () -> "true"))
- "true"
-
- let native_dynlink =
- var_define
- ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.")
- ~cli:CLINone
- "native_dynlink"
- (fun () ->
- let res =
- let ocaml_lt_312 () =
- OASISVersion.comparator_apply
- (OASISVersion.version_of_string (ocaml_version ()))
- (OASISVersion.VLesser
- (OASISVersion.version_of_string "3.12.0"))
- in
- let flexdll_lt_030 () =
- OASISVersion.comparator_apply
- (OASISVersion.version_of_string (flexdll_version ()))
- (OASISVersion.VLesser
- (OASISVersion.version_of_string "0.30"))
- in
- let has_native_dynlink =
- let ocamlfind = ocamlfind () in
- try
- let fn =
- OASISExec.run_read_one_line
- ~ctxt:!BaseContext.default
- ocamlfind
- ["query"; "-predicates"; "native"; "dynlink";
- "-format"; "%d/%a"]
- in
- Sys.file_exists fn
- with _ ->
- false
- in
- if not has_native_dynlink then
- false
- else if ocaml_lt_312 () then
- false
- else if (os_type () = "Win32" || os_type () = "Cygwin")
- && flexdll_lt_030 () then
- begin
- BaseMessage.warning
- (f_ ".cmxs generation disabled because FlexDLL needs to be \
- at least 0.30. Please upgrade FlexDLL from %s to 0.30.")
- (flexdll_version ());
- false
- end
- else
- true
- in
- string_of_bool res)
-
- let init pkg =
- rpkg := Some pkg;
- List.iter (fun f -> f pkg.oasis_version) !var_cond
-
-end
-
-module BaseFileAB = struct
-(* # 21 "src/base/BaseFileAB.ml" *)
-
- open BaseEnv
- open OASISGettext
- open BaseMessage
-
- let to_filename fn =
- let fn =
- OASISHostPath.of_unix fn
- in
- if not (Filename.check_suffix fn ".ab") then
- warning
- (f_ "File '%s' doesn't have '.ab' extension")
- fn;
- Filename.chop_extension fn
-
- let replace fn_lst =
- let buff =
- Buffer.create 13
- in
- List.iter
- (fun fn ->
- let fn =
- OASISHostPath.of_unix fn
- in
- let chn_in =
- open_in fn
- in
- let chn_out =
- open_out (to_filename fn)
- in
- (
- try
- while true do
- Buffer.add_string buff (var_expand (input_line chn_in));
- Buffer.add_char buff '\n'
- done
- with End_of_file ->
- ()
- );
- Buffer.output_buffer chn_out buff;
- Buffer.clear buff;
- close_in chn_in;
- close_out chn_out)
- fn_lst
-end
-
-module BaseLog = struct
-(* # 21 "src/base/BaseLog.ml" *)
-
- open OASISUtils
-
- let default_filename =
- Filename.concat
- (Filename.dirname BaseEnv.default_filename)
- "setup.log"
-
- module SetTupleString =
- Set.Make
- (struct
- type t = string * string
- let compare (s11, s12) (s21, s22) =
- match String.compare s11 s21 with
- | 0 -> String.compare s12 s22
- | n -> n
- end)
-
- let load () =
- if Sys.file_exists default_filename then
- begin
- let chn =
- open_in default_filename
- in
- let scbuf =
- Scanf.Scanning.from_file default_filename
- in
- let rec read_aux (st, lst) =
- if not (Scanf.Scanning.end_of_input scbuf) then
- begin
- let acc =
- try
- Scanf.bscanf scbuf "%S %S\n"
- (fun e d ->
- let t =
- e, d
- in
- if SetTupleString.mem t st then
- st, lst
- else
- SetTupleString.add t st,
- t :: lst)
- with Scanf.Scan_failure _ ->
- failwith
- (Scanf.bscanf scbuf
- "%l"
- (fun line ->
- Printf.sprintf
- "Malformed log file '%s' at line %d"
- default_filename
- line))
- in
- read_aux acc
- end
- else
- begin
- close_in chn;
- List.rev lst
- end
- in
- read_aux (SetTupleString.empty, [])
- end
- else
- begin
- []
- end
-
- let register event data =
- let chn_out =
- open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename
- in
- Printf.fprintf chn_out "%S %S\n" event data;
- close_out chn_out
-
- let unregister event data =
- if Sys.file_exists default_filename then
- begin
- let lst =
- load ()
- in
- let chn_out =
- open_out default_filename
- in
- let write_something =
- ref false
- in
- List.iter
- (fun (e, d) ->
- if e <> event || d <> data then
- begin
- write_something := true;
- Printf.fprintf chn_out "%S %S\n" e d
- end)
- lst;
- close_out chn_out;
- if not !write_something then
- Sys.remove default_filename
- end
-
- let filter events =
- let st_events =
- List.fold_left
- (fun st e ->
- SetString.add e st)
- SetString.empty
- events
- in
- List.filter
- (fun (e, _) -> SetString.mem e st_events)
- (load ())
-
- let exists event data =
- List.exists
- (fun v -> (event, data) = v)
- (load ())
-end
-
-module BaseBuilt = struct
-(* # 21 "src/base/BaseBuilt.ml" *)
-
- open OASISTypes
- open OASISGettext
- open BaseStandardVar
- open BaseMessage
-
- type t =
- | BExec (* Executable *)
- | BExecLib (* Library coming with executable *)
- | BLib (* Library *)
- | BDoc (* Document *)
-
- let to_log_event_file t nm =
- "built_"^
- (match t with
- | BExec -> "exec"
- | BExecLib -> "exec_lib"
- | BLib -> "lib"
- | BDoc -> "doc")^
- "_"^nm
-
- let to_log_event_done t nm =
- "is_"^(to_log_event_file t nm)
-
- let register t nm lst =
- BaseLog.register
- (to_log_event_done t nm)
- "true";
- List.iter
- (fun alt ->
- let registered =
- List.fold_left
- (fun registered fn ->
- if OASISFileUtil.file_exists_case fn then
- begin
- BaseLog.register
- (to_log_event_file t nm)
- (if Filename.is_relative fn then
- Filename.concat (Sys.getcwd ()) fn
- else
- fn);
- true
- end
- else
- registered)
- false
- alt
- in
- if not registered then
- warning
- (f_ "Cannot find an existing alternative files among: %s")
- (String.concat (s_ ", ") alt))
- lst
-
- let unregister t nm =
- List.iter
- (fun (e, d) ->
- BaseLog.unregister e d)
- (BaseLog.filter
- [to_log_event_file t nm;
- to_log_event_done t nm])
-
- let fold t nm f acc =
- List.fold_left
- (fun acc (_, fn) ->
- if OASISFileUtil.file_exists_case fn then
- begin
- f acc fn
- end
- else
- begin
- warning
- (f_ "File '%s' has been marked as built \
- for %s but doesn't exist")
- fn
- (Printf.sprintf
- (match t with
- | BExec | BExecLib ->
- (f_ "executable %s")
- | BLib ->
- (f_ "library %s")
- | BDoc ->
- (f_ "documentation %s"))
- nm);
- acc
- end)
- acc
- (BaseLog.filter
- [to_log_event_file t nm])
-
- let is_built t nm =
- List.fold_left
- (fun is_built (_, d) ->
- (try
- bool_of_string d
- with _ ->
- false))
- false
- (BaseLog.filter
- [to_log_event_done t nm])
-
- let of_executable ffn (cs, bs, exec) =
- let unix_exec_is, unix_dll_opt =
- OASISExecutable.unix_exec_is
- (cs, bs, exec)
- (fun () ->
- bool_of_string
- (is_native ()))
- ext_dll
- ext_program
- in
- let evs =
- (BExec, cs.cs_name, [[ffn unix_exec_is]])
- ::
- (match unix_dll_opt with
- | Some fn ->
- [BExecLib, cs.cs_name, [[ffn fn]]]
- | None ->
- [])
- in
- evs,
- unix_exec_is,
- unix_dll_opt
-
- let of_library ffn (cs, bs, lib) =
- let unix_lst =
- OASISLibrary.generated_unix_files
- ~ctxt:!BaseContext.default
- ~source_file_exists:(fun fn ->
- OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn))
- ~is_native:(bool_of_string (is_native ()))
- ~has_native_dynlink:(bool_of_string (native_dynlink ()))
- ~ext_lib:(ext_lib ())
- ~ext_dll:(ext_dll ())
- (cs, bs, lib)
- in
- let evs =
- [BLib,
- cs.cs_name,
- List.map (List.map ffn) unix_lst]
- in
- evs, unix_lst
-
-end
-
-module BaseCustom = struct
-(* # 21 "src/base/BaseCustom.ml" *)
-
- open BaseEnv
- open BaseMessage
- open OASISTypes
- open OASISGettext
-
- let run cmd args extra_args =
- OASISExec.run ~ctxt:!BaseContext.default ~quote:false
- (var_expand cmd)
- (List.map
- var_expand
- (args @ (Array.to_list extra_args)))
-
- let hook ?(failsafe=false) cstm f e =
- let optional_command lst =
- let printer =
- function
- | Some (cmd, args) -> String.concat " " (cmd :: args)
- | None -> s_ "No command"
- in
- match
- var_choose
- ~name:(s_ "Pre/Post Command")
- ~printer
- lst with
- | Some (cmd, args) ->
- begin
- try
- run cmd args [||]
- with e when failsafe ->
- warning
- (f_ "Command '%s' fail with error: %s")
- (String.concat " " (cmd :: args))
- (match e with
- | Failure msg -> msg
- | e -> Printexc.to_string e)
- end
- | None ->
- ()
- in
- let res =
- optional_command cstm.pre_command;
- f e
- in
- optional_command cstm.post_command;
- res
-end
-
-module BaseDynVar = struct
-(* # 21 "src/base/BaseDynVar.ml" *)
-
-
- open OASISTypes
- open OASISGettext
- open BaseEnv
- open BaseBuilt
-
- let init pkg =
- (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *)
- (* TODO: provide compile option for library libary_byte_args_VARNAME... *)
- List.iter
- (function
- | Executable (cs, bs, exec) ->
- if var_choose bs.bs_build then
- var_ignore
- (var_redefine
- (* We don't save this variable *)
- ~dump:false
- ~short_desc:(fun () ->
- Printf.sprintf
- (f_ "Filename of executable '%s'")
- cs.cs_name)
- (OASISUtils.varname_of_string cs.cs_name)
- (fun () ->
- let fn_opt =
- fold
- BExec cs.cs_name
- (fun _ fn -> Some fn)
- None
- in
- match fn_opt with
- | Some fn -> fn
- | None ->
- raise
- (PropList.Not_set
- (cs.cs_name,
- Some (Printf.sprintf
- (f_ "Executable '%s' not yet built.")
- cs.cs_name)))))
-
- | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ ->
- ())
- pkg.sections
-end
-
-module BaseTest = struct
-(* # 21 "src/base/BaseTest.ml" *)
-
- open BaseEnv
- open BaseMessage
- open OASISTypes
- open OASISExpr
- open OASISGettext
-
- let test lst pkg extra_args =
-
- let one_test (failure, n) (test_plugin, cs, test) =
- if var_choose
- ~name:(Printf.sprintf
- (f_ "test %s run")
- cs.cs_name)
- ~printer:string_of_bool
- test.test_run then
- begin
- let () =
- info (f_ "Running test '%s'") cs.cs_name
- in
- let back_cwd =
- match test.test_working_directory with
- | Some dir ->
- let cwd =
- Sys.getcwd ()
- in
- let chdir d =
- info (f_ "Changing directory to '%s'") d;
- Sys.chdir d
- in
- chdir dir;
- fun () -> chdir cwd
-
- | None ->
- fun () -> ()
- in
- try
- let failure_percent =
- BaseCustom.hook
- test.test_custom
- (test_plugin pkg (cs, test))
- extra_args
- in
- back_cwd ();
- (failure_percent +. failure, n + 1)
- with e ->
- begin
- back_cwd ();
- raise e
- end
- end
- else
- begin
- info (f_ "Skipping test '%s'") cs.cs_name;
- (failure, n)
- end
- in
- let (failed, n) =
- List.fold_left
- one_test
- (0.0, 0)
- lst
- in
- let failure_percent =
- if n = 0 then
- 0.0
- else
- failed /. (float_of_int n)
- in
- let msg =
- Printf.sprintf
- (f_ "Tests had a %.2f%% failure rate")
- (100. *. failure_percent)
- in
- if failure_percent > 0.0 then
- failwith msg
- else
- info "%s" msg;
-
- (* Possible explanation why the tests where not run. *)
- if OASISVersion.version_0_3_or_after pkg.oasis_version &&
- not (bool_of_string (BaseStandardVar.tests ())) &&
- lst <> [] then
- BaseMessage.warning
- "Tests are turned off, consider enabling with \
- 'ocaml setup.ml -configure --enable-tests'"
-end
-
-module BaseDoc = struct
-(* # 21 "src/base/BaseDoc.ml" *)
-
- open BaseEnv
- open BaseMessage
- open OASISTypes
- open OASISGettext
-
- let doc lst pkg extra_args =
-
- let one_doc (doc_plugin, cs, doc) =
- if var_choose
- ~name:(Printf.sprintf
- (f_ "documentation %s build")
- cs.cs_name)
- ~printer:string_of_bool
- doc.doc_build then
- begin
- info (f_ "Building documentation '%s'") cs.cs_name;
- BaseCustom.hook
- doc.doc_custom
- (doc_plugin pkg (cs, doc))
- extra_args
- end
- in
- List.iter one_doc lst;
-
- if OASISVersion.version_0_3_or_after pkg.oasis_version &&
- not (bool_of_string (BaseStandardVar.docs ())) &&
- lst <> [] then
- BaseMessage.warning
- "Docs are turned off, consider enabling with \
- 'ocaml setup.ml -configure --enable-docs'"
-end
-
-module BaseSetup = struct
-(* # 21 "src/base/BaseSetup.ml" *)
-
- open BaseEnv
- open BaseMessage
- open OASISTypes
- open OASISSection
- open OASISGettext
- open OASISUtils
-
- type std_args_fun =
- package -> string array -> unit
-
- type ('a, 'b) section_args_fun =
- name * (package -> (common_section * 'a) -> string array -> 'b)
-
- type t =
- {
- configure: std_args_fun;
- build: std_args_fun;
- doc: ((doc, unit) section_args_fun) list;
- test: ((test, float) section_args_fun) list;
- install: std_args_fun;
- uninstall: std_args_fun;
- clean: std_args_fun list;
- clean_doc: (doc, unit) section_args_fun list;
- clean_test: (test, unit) section_args_fun list;
- distclean: std_args_fun list;
- distclean_doc: (doc, unit) section_args_fun list;
- distclean_test: (test, unit) section_args_fun list;
- package: package;
- oasis_fn: string option;
- oasis_version: string;
- oasis_digest: Digest.t option;
- oasis_exec: string option;
- oasis_setup_args: string list;
- setup_update: bool;
- }
-
- (* Associate a plugin function with data from package *)
- let join_plugin_sections filter_map lst =
- List.rev
- (List.fold_left
- (fun acc sct ->
- match filter_map sct with
- | Some e ->
- e :: acc
- | None ->
- acc)
- []
- lst)
-
- (* Search for plugin data associated with a section name *)
- let lookup_plugin_section plugin action nm lst =
- try
- List.assoc nm lst
- with Not_found ->
- failwithf
- (f_ "Cannot find plugin %s matching section %s for %s action")
- plugin
- nm
- action
-
- let configure t args =
- (* Run configure *)
- BaseCustom.hook
- t.package.conf_custom
- (fun () ->
- (* Reload if preconf has changed it *)
- begin
- try
- unload ();
- load ();
- with _ ->
- ()
- end;
-
- (* Run plugin's configure *)
- t.configure t.package args;
-
- (* Dump to allow postconf to change it *)
- dump ())
- ();
-
- (* Reload environment *)
- unload ();
- load ();
-
- (* Save environment *)
- print ();
-
- (* Replace data in file *)
- BaseFileAB.replace t.package.files_ab
-
- let build t args =
- BaseCustom.hook
- t.package.build_custom
- (t.build t.package)
- args
-
- let doc t args =
- BaseDoc.doc
- (join_plugin_sections
- (function
- | Doc (cs, e) ->
- Some
- (lookup_plugin_section
- "documentation"
- (s_ "build")
- cs.cs_name
- t.doc,
- cs,
- e)
- | _ ->
- None)
- t.package.sections)
- t.package
- args
-
- let test t args =
- BaseTest.test
- (join_plugin_sections
- (function
- | Test (cs, e) ->
- Some
- (lookup_plugin_section
- "test"
- (s_ "run")
- cs.cs_name
- t.test,
- cs,
- e)
- | _ ->
- None)
- t.package.sections)
- t.package
- args
-
- let all t args =
- let rno_doc =
- ref false
- in
- let rno_test =
- ref false
- in
- Arg.parse_argv
- ~current:(ref 0)
- (Array.of_list
- ((Sys.executable_name^" all") ::
- (Array.to_list args)))
- [
- "-no-doc",
- Arg.Set rno_doc,
- s_ "Don't run doc target";
-
- "-no-test",
- Arg.Set rno_test,
- s_ "Don't run test target";
- ]
- (failwithf (f_ "Don't know what to do with '%s'"))
- "";
-
- info "Running configure step";
- configure t [||];
-
- info "Running build step";
- build t [||];
-
- (* Load setup.log dynamic variables *)
- BaseDynVar.init t.package;
-
- if not !rno_doc then
- begin
- info "Running doc step";
- doc t [||];
- end
- else
- begin
- info "Skipping doc step"
- end;
-
- if not !rno_test then
- begin
- info "Running test step";
- test t [||]
- end
- else
- begin
- info "Skipping test step"
- end
-
- let install t args =
- BaseCustom.hook
- t.package.install_custom
- (t.install t.package)
- args
-
- let uninstall t args =
- BaseCustom.hook
- t.package.uninstall_custom
- (t.uninstall t.package)
- args
-
- let reinstall t args =
- uninstall t args;
- install t args
-
- let clean, distclean =
- let failsafe f a =
- try
- f a
- with e ->
- warning
- (f_ "Action fail with error: %s")
- (match e with
- | Failure msg -> msg
- | e -> Printexc.to_string e)
- in
-
- let generic_clean t cstm mains docs tests args =
- BaseCustom.hook
- ~failsafe:true
- cstm
- (fun () ->
- (* Clean section *)
- List.iter
- (function
- | Test (cs, test) ->
- let f =
- try
- List.assoc cs.cs_name tests
- with Not_found ->
- fun _ _ _ -> ()
- in
- failsafe
- (f t.package (cs, test))
- args
- | Doc (cs, doc) ->
- let f =
- try
- List.assoc cs.cs_name docs
- with Not_found ->
- fun _ _ _ -> ()
- in
- failsafe
- (f t.package (cs, doc))
- args
- | Library _
- | Executable _
- | Flag _
- | SrcRepo _ ->
- ())
- t.package.sections;
- (* Clean whole package *)
- List.iter
- (fun f ->
- failsafe
- (f t.package)
- args)
- mains)
- ()
- in
-
- let clean t args =
- generic_clean
- t
- t.package.clean_custom
- t.clean
- t.clean_doc
- t.clean_test
- args
- in
-
- let distclean t args =
- (* Call clean *)
- clean t args;
-
- (* Call distclean code *)
- generic_clean
- t
- t.package.distclean_custom
- t.distclean
- t.distclean_doc
- t.distclean_test
- args;
-
- (* Remove generated file *)
- List.iter
- (fun fn ->
- if Sys.file_exists fn then
- begin
- info (f_ "Remove '%s'") fn;
- Sys.remove fn
- end)
- (BaseEnv.default_filename
- ::
- BaseLog.default_filename
- ::
- (List.rev_map BaseFileAB.to_filename t.package.files_ab))
- in
-
- clean, distclean
-
- let version t _ =
- print_endline t.oasis_version
-
- let update_setup_ml, no_update_setup_ml_cli =
- let b = ref true in
- b,
- ("-no-update-setup-ml",
- Arg.Clear b,
- s_ " Don't try to update setup.ml, even if _oasis has changed.")
-
- let update_setup_ml t =
- let oasis_fn =
- match t.oasis_fn with
- | Some fn -> fn
- | None -> "_oasis"
- in
- let oasis_exec =
- match t.oasis_exec with
- | Some fn -> fn
- | None -> "oasis"
- in
- let ocaml =
- Sys.executable_name
- in
- let setup_ml, args =
- match Array.to_list Sys.argv with
- | setup_ml :: args ->
- setup_ml, args
- | [] ->
- failwith
- (s_ "Expecting non-empty command line arguments.")
- in
- let ocaml, setup_ml =
- if Sys.executable_name = Sys.argv.(0) then
- (* We are not running in standard mode, probably the script
- * is precompiled.
- *)
- "ocaml", "setup.ml"
- else
- ocaml, setup_ml
- in
- let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in
- let do_update () =
- let oasis_exec_version =
- OASISExec.run_read_one_line
- ~ctxt:!BaseContext.default
- ~f_exit_code:
- (function
- | 0 ->
- ()
- | 1 ->
- failwithf
- (f_ "Executable '%s' is probably an old version \
- of oasis (< 0.3.0), please update to version \
- v%s.")
- oasis_exec t.oasis_version
- | 127 ->
- failwithf
- (f_ "Cannot find executable '%s', please install \
- oasis v%s.")
- oasis_exec t.oasis_version
- | n ->
- failwithf
- (f_ "Command '%s version' exited with code %d.")
- oasis_exec n)
- oasis_exec ["version"]
- in
- if OASISVersion.comparator_apply
- (OASISVersion.version_of_string oasis_exec_version)
- (OASISVersion.VGreaterEqual
- (OASISVersion.version_of_string t.oasis_version)) then
- begin
- (* We have a version >= for the executable oasis, proceed with
- * update.
- *)
- (* TODO: delegate this check to 'oasis setup'. *)
- if Sys.os_type = "Win32" then
- failwithf
- (f_ "It is not possible to update the running script \
- setup.ml on Windows. Please update setup.ml by \
- running '%s'.")
- (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args))
- else
- begin
- OASISExec.run
- ~ctxt:!BaseContext.default
- ~f_exit_code:
- (function
- | 0 ->
- ()
- | n ->
- failwithf
- (f_ "Unable to update setup.ml using '%s', \
- please fix the problem and retry.")
- oasis_exec)
- oasis_exec ("setup" :: t.oasis_setup_args);
- OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args)
- end
- end
- else
- failwithf
- (f_ "The version of '%s' (v%s) doesn't match the version of \
- oasis used to generate the %s file. Please install at \
- least oasis v%s.")
- oasis_exec oasis_exec_version setup_ml t.oasis_version
- in
-
- if !update_setup_ml then
- begin
- try
- match t.oasis_digest with
- | Some dgst ->
- if Sys.file_exists oasis_fn && dgst <> Digest.file "_oasis" then
- begin
- do_update ();
- true
- end
- else
- false
- | None ->
- false
- with e ->
- error
- (f_ "Error when updating setup.ml. If you want to avoid this error, \
- you can bypass the update of %s by running '%s %s %s %s'")
- setup_ml ocaml setup_ml no_update_setup_ml_cli
- (String.concat " " args);
- raise e
- end
- else
- false
-
- let setup t =
- let catch_exn =
- ref true
- in
- try
- let act_ref =
- ref (fun _ ->
- failwithf
- (f_ "No action defined, run '%s %s -help'")
- Sys.executable_name
- Sys.argv.(0))
-
- in
- let extra_args_ref =
- ref []
- in
- let allow_empty_env_ref =
- ref false
- in
- let arg_handle ?(allow_empty_env=false) act =
- Arg.Tuple
- [
- Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref);
-
- Arg.Unit
- (fun () ->
- allow_empty_env_ref := allow_empty_env;
- act_ref := act);
- ]
- in
-
- Arg.parse
- (Arg.align
- ([
- "-configure",
- arg_handle ~allow_empty_env:true configure,
- s_ "[options*] Configure the whole build process.";
-
- "-build",
- arg_handle build,
- s_ "[options*] Build executables and libraries.";
-
- "-doc",
- arg_handle doc,
- s_ "[options*] Build documents.";
-
- "-test",
- arg_handle test,
- s_ "[options*] Run tests.";
-
- "-all",
- arg_handle ~allow_empty_env:true all,
- s_ "[options*] Run configure, build, doc and test targets.";
-
- "-install",
- arg_handle install,
- s_ "[options*] Install libraries, data, executables \
- and documents.";
-
- "-uninstall",
- arg_handle uninstall,
- s_ "[options*] Uninstall libraries, data, executables \
- and documents.";
-
- "-reinstall",
- arg_handle reinstall,
- s_ "[options*] Uninstall and install libraries, data, \
- executables and documents.";
-
- "-clean",
- arg_handle ~allow_empty_env:true clean,
- s_ "[options*] Clean files generated by a build.";
-
- "-distclean",
- arg_handle ~allow_empty_env:true distclean,
- s_ "[options*] Clean files generated by a build and configure.";
-
- "-version",
- arg_handle ~allow_empty_env:true version,
- s_ " Display version of OASIS used to generate this setup.ml.";
-
- "-no-catch-exn",
- Arg.Clear catch_exn,
- s_ " Don't catch exception, useful for debugging.";
- ]
- @
- (if t.setup_update then
- [no_update_setup_ml_cli]
- else
- [])
- @ (BaseContext.args ())))
- (failwithf (f_ "Don't know what to do with '%s'"))
- (s_ "Setup and run build process current package\n");
-
- (* Build initial environment *)
- load ~allow_empty:!allow_empty_env_ref ();
-
- (** Initialize flags *)
- List.iter
- (function
- | Flag (cs, {flag_description = hlp;
- flag_default = choices}) ->
- begin
- let apply ?short_desc () =
- var_ignore
- (var_define
- ~cli:CLIEnable
- ?short_desc
- (OASISUtils.varname_of_string cs.cs_name)
- (fun () ->
- string_of_bool
- (var_choose
- ~name:(Printf.sprintf
- (f_ "default value of flag %s")
- cs.cs_name)
- ~printer:string_of_bool
- choices)))
- in
- match hlp with
- | Some hlp ->
- apply ~short_desc:(fun () -> hlp) ()
- | None ->
- apply ()
- end
- | _ ->
- ())
- t.package.sections;
-
- BaseStandardVar.init t.package;
-
- BaseDynVar.init t.package;
-
- if t.setup_update && update_setup_ml t then
- ()
- else
- !act_ref t (Array.of_list (List.rev !extra_args_ref))
-
- with e when !catch_exn ->
- error "%s" (Printexc.to_string e);
- exit 1
-
-end
-
-
-# 4480 "setup.ml"
-module InternalConfigurePlugin = struct
-(* # 21 "src/plugins/internal/InternalConfigurePlugin.ml" *)
-
- (** Configure using internal scheme
- @author Sylvain Le Gall
- *)
-
- open BaseEnv
- open OASISTypes
- open OASISUtils
- open OASISGettext
- open BaseMessage
-
- (** Configure build using provided series of check to be done
- * and then output corresponding file.
- *)
- let configure pkg argv =
- let var_ignore_eval var =
- let _s : string =
- var ()
- in
- ()
- in
-
- let errors =
- ref SetString.empty
- in
-
- let buff =
- Buffer.create 13
- in
-
- let add_errors fmt =
- Printf.kbprintf
- (fun b ->
- errors := SetString.add (Buffer.contents b) !errors;
- Buffer.clear b)
- buff
- fmt
- in
-
- let warn_exception e =
- warning "%s" (Printexc.to_string e)
- in
-
- (* Check tools *)
- let check_tools lst =
- List.iter
- (function
- | ExternalTool tool ->
- begin
- try
- var_ignore_eval (BaseCheck.prog tool)
- with e ->
- warn_exception e;
- add_errors (f_ "Cannot find external tool '%s'") tool
- end
- | InternalExecutable nm1 ->
- (* Check that matching tool is built *)
- List.iter
- (function
- | Executable ({cs_name = nm2},
- {bs_build = build},
- _) when nm1 = nm2 ->
- if not (var_choose build) then
- add_errors
- (f_ "Cannot find buildable internal executable \
- '%s' when checking build depends")
- nm1
- | _ ->
- ())
- pkg.sections)
- lst
- in
-
- let build_checks sct bs =
- if var_choose bs.bs_build then
- begin
- if bs.bs_compiled_object = Native then
- begin
- try
- var_ignore_eval BaseStandardVar.ocamlopt
- with e ->
- warn_exception e;
- add_errors
- (f_ "Section %s requires native compilation")
- (OASISSection.string_of_section sct)
- end;
-
- (* Check tools *)
- check_tools bs.bs_build_tools;
-
- (* Check depends *)
- List.iter
- (function
- | FindlibPackage (findlib_pkg, version_comparator) ->
- begin
- try
- var_ignore_eval
- (BaseCheck.package ?version_comparator findlib_pkg)
- with e ->
- warn_exception e;
- match version_comparator with
- | None ->
- add_errors
- (f_ "Cannot find findlib package %s")
- findlib_pkg
- | Some ver_cmp ->
- add_errors
- (f_ "Cannot find findlib package %s (%s)")
- findlib_pkg
- (OASISVersion.string_of_comparator ver_cmp)
- end
- | InternalLibrary nm1 ->
- (* Check that matching library is built *)
- List.iter
- (function
- | Library ({cs_name = nm2},
- {bs_build = build},
- _) when nm1 = nm2 ->
- if not (var_choose build) then
- add_errors
- (f_ "Cannot find buildable internal library \
- '%s' when checking build depends")
- nm1
- | _ ->
- ())
- pkg.sections)
- bs.bs_build_depends
- end
- in
-
- (* Parse command line *)
- BaseArgExt.parse argv (BaseEnv.args ());
-
- (* OCaml version *)
- begin
- match pkg.ocaml_version with
- | Some ver_cmp ->
- begin
- try
- var_ignore_eval
- (BaseCheck.version
- "ocaml"
- ver_cmp
- BaseStandardVar.ocaml_version)
- with e ->
- warn_exception e;
- add_errors
- (f_ "OCaml version %s doesn't match version constraint %s")
- (BaseStandardVar.ocaml_version ())
- (OASISVersion.string_of_comparator ver_cmp)
- end
- | None ->
- ()
- end;
-
- (* Findlib version *)
- begin
- match pkg.findlib_version with
- | Some ver_cmp ->
- begin
- try
- var_ignore_eval
- (BaseCheck.version
- "findlib"
- ver_cmp
- BaseStandardVar.findlib_version)
- with e ->
- warn_exception e;
- add_errors
- (f_ "Findlib version %s doesn't match version constraint %s")
- (BaseStandardVar.findlib_version ())
- (OASISVersion.string_of_comparator ver_cmp)
- end
- | None ->
- ()
- end;
-
- (* FlexDLL *)
- if BaseStandardVar.os_type () = "Win32" ||
- BaseStandardVar.os_type () = "Cygwin" then
- begin
- try
- var_ignore_eval BaseStandardVar.flexlink
- with e ->
- warn_exception e;
- add_errors (f_ "Cannot find 'flexlink'")
- end;
-
- (* Check build depends *)
- List.iter
- (function
- | Executable (_, bs, _)
- | Library (_, bs, _) as sct ->
- build_checks sct bs
- | Doc (_, doc) ->
- if var_choose doc.doc_build then
- check_tools doc.doc_build_tools
- | Test (_, test) ->
- if var_choose test.test_run then
- check_tools test.test_tools
- | _ ->
- ())
- pkg.sections;
-
- (* Check if we need native dynlink (presence of libraries that compile to
- * native)
- *)
- begin
- let has_cmxa =
- List.exists
- (function
- | Library (_, bs, _) ->
- var_choose bs.bs_build &&
- (bs.bs_compiled_object = Native ||
- (bs.bs_compiled_object = Best &&
- bool_of_string (BaseStandardVar.is_native ())))
- | _ ->
- false)
- pkg.sections
- in
- if has_cmxa then
- var_ignore_eval BaseStandardVar.native_dynlink
- end;
-
- (* Check errors *)
- if SetString.empty != !errors then
- begin
- List.iter
- (fun e -> error "%s" e)
- (SetString.elements !errors);
- failwithf
- (fn_
- "%d configuration error"
- "%d configuration errors"
- (SetString.cardinal !errors))
- (SetString.cardinal !errors)
- end
-
-end
-
-module InternalInstallPlugin = struct
-(* # 21 "src/plugins/internal/InternalInstallPlugin.ml" *)
-
- (** Install using internal scheme
- @author Sylvain Le Gall
- *)
-
- open BaseEnv
- open BaseStandardVar
- open BaseMessage
- open OASISTypes
- open OASISLibrary
- open OASISGettext
- open OASISUtils
-
- let exec_hook =
- ref (fun (cs, bs, exec) -> cs, bs, exec)
-
- let lib_hook =
- ref (fun (cs, bs, lib) -> cs, bs, lib, [])
-
- let doc_hook =
- ref (fun (cs, doc) -> cs, doc)
-
- let install_file_ev =
- "install-file"
-
- let install_dir_ev =
- "install-dir"
-
- let install_findlib_ev =
- "install-findlib"
-
- let win32_max_command_line_length = 8000
-
- let split_install_command ocamlfind findlib_name meta files =
- if Sys.os_type = "Win32" then
- (* Arguments for the first command: *)
- let first_args = ["install"; findlib_name; meta] in
- (* Arguments for remaining commands: *)
- let other_args = ["install"; findlib_name; "-add"] in
- (* Extract as much files as possible from [files], [len] is
- the current command line length: *)
- let rec get_files len acc files =
- match files with
- | [] ->
- (List.rev acc, [])
- | file :: rest ->
- let len = len + 1 + String.length file in
- if len > win32_max_command_line_length then
- (List.rev acc, files)
- else
- get_files len (file :: acc) rest
- in
- (* Split the command into several commands. *)
- let rec split args files =
- match files with
- | [] ->
- []
- | _ ->
- (* Length of "ocamlfind install <lib> [META|-add]" *)
- let len =
- List.fold_left
- (fun len arg ->
- len + 1 (* for the space *) + String.length arg)
- (String.length ocamlfind)
- args
- in
- match get_files len [] files with
- | ([], _) ->
- failwith (s_ "Command line too long.")
- | (firsts, others) ->
- let cmd = args @ firsts in
- (* Use -add for remaining commands: *)
- let () =
- let findlib_ge_132 =
- OASISVersion.comparator_apply
- (OASISVersion.version_of_string
- (BaseStandardVar.findlib_version ()))
- (OASISVersion.VGreaterEqual
- (OASISVersion.version_of_string "1.3.2"))
- in
- if not findlib_ge_132 then
- failwithf
- (f_ "Installing the library %s require to use the flag \
- '-add' of ocamlfind because the command line is too \
- long. This flag is only available for findlib 1.3.2. \
- Please upgrade findlib from %s to 1.3.2")
- findlib_name (BaseStandardVar.findlib_version ())
- in
- let cmds = split other_args others in
- cmd :: cmds
- in
- (* The first command does not use -add: *)
- split first_args files
- else
- ["install" :: findlib_name :: meta :: files]
-
- let install pkg argv =
-
- let in_destdir =
- try
- let destdir =
- destdir ()
- in
- (* Practically speaking destdir is prepended
- * at the beginning of the target filename
- *)
- fun fn -> destdir^fn
- with PropList.Not_set _ ->
- fun fn -> fn
- in
-
- let install_file ?tgt_fn src_file envdir =
- let tgt_dir =
- in_destdir (envdir ())
- in
- let tgt_file =
- Filename.concat
- tgt_dir
- (match tgt_fn with
- | Some fn ->
- fn
- | None ->
- Filename.basename src_file)
- in
- (* Create target directory if needed *)
- OASISFileUtil.mkdir_parent
- ~ctxt:!BaseContext.default
- (fun dn ->
- info (f_ "Creating directory '%s'") dn;
- BaseLog.register install_dir_ev dn)
- tgt_dir;
-
- (* Really install files *)
- info (f_ "Copying file '%s' to '%s'") src_file tgt_file;
- OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file;
- BaseLog.register install_file_ev tgt_file
- in
-
- (* Install data into defined directory *)
- let install_data srcdir lst tgtdir =
- let tgtdir =
- OASISHostPath.of_unix (var_expand tgtdir)
- in
- List.iter
- (fun (src, tgt_opt) ->
- let real_srcs =
- OASISFileUtil.glob
- ~ctxt:!BaseContext.default
- (Filename.concat srcdir src)
- in
- if real_srcs = [] then
- failwithf
- (f_ "Wildcard '%s' doesn't match any files")
- src;
- List.iter
- (fun fn ->
- install_file
- fn
- (fun () ->
- match tgt_opt with
- | Some s ->
- OASISHostPath.of_unix (var_expand s)
- | None ->
- tgtdir))
- real_srcs)
- lst
- in
-
- (** Install all libraries *)
- let install_libs pkg =
-
- let files_of_library (f_data, acc) data_lib =
- let cs, bs, lib, lib_extra =
- !lib_hook data_lib
- in
- if var_choose bs.bs_install &&
- BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then
- begin
- let acc =
- (* Start with acc + lib_extra *)
- List.rev_append lib_extra acc
- in
- let acc =
- (* Add uncompiled header from the source tree *)
- let path =
- OASISHostPath.of_unix bs.bs_path
- in
- List.fold_left
- (fun acc modul ->
- try
- List.find
- OASISFileUtil.file_exists_case
- (List.map
- (Filename.concat path)
- [modul^".mli";
- modul^".ml";
- String.uncapitalize modul^".mli";
- String.capitalize modul^".mli";
- String.uncapitalize modul^".ml";
- String.capitalize modul^".ml"])
- :: acc
- with Not_found ->
- begin
- warning
- (f_ "Cannot find source header for module %s \
- in library %s")
- modul cs.cs_name;
- acc
- end)
- acc
- lib.lib_modules
- in
-
- let acc =
- (* Get generated files *)
- BaseBuilt.fold
- BaseBuilt.BLib
- cs.cs_name
- (fun acc fn -> fn :: acc)
- acc
- in
-
- let f_data () =
- (* Install data associated with the library *)
- install_data
- bs.bs_path
- bs.bs_data_files
- (Filename.concat
- (datarootdir ())
- pkg.name);
- f_data ()
- in
-
- (f_data, acc)
- end
- else
- begin
- (f_data, acc)
- end
- in
-
- (* Install one group of library *)
- let install_group_lib grp =
- (* Iterate through all group nodes *)
- let rec install_group_lib_aux data_and_files grp =
- let data_and_files, children =
- match grp with
- | Container (_, children) ->
- data_and_files, children
- | Package (_, cs, bs, lib, children) ->
- files_of_library data_and_files (cs, bs, lib), children
- in
- List.fold_left
- install_group_lib_aux
- data_and_files
- children
- in
-
- (* Findlib name of the root library *)
- let findlib_name =
- findlib_of_group grp
- in
-
- (* Determine root library *)
- let root_lib =
- root_of_group grp
- in
-
- (* All files to install for this library *)
- let f_data, files =
- install_group_lib_aux (ignore, []) grp
- in
-
- (* Really install, if there is something to install *)
- if files = [] then
- begin
- warning
- (f_ "Nothing to install for findlib library '%s'")
- findlib_name
- end
- else
- begin
- let meta =
- (* Search META file *)
- let (_, bs, _) =
- root_lib
- in
- let res =
- Filename.concat bs.bs_path "META"
- in
- if not (OASISFileUtil.file_exists_case res) then
- failwithf
- (f_ "Cannot find file '%s' for findlib library %s")
- res
- findlib_name;
- res
- in
- let files =
- (* Make filename shorter to avoid hitting command max line length
- * too early, esp. on Windows.
- *)
- let remove_prefix p n =
- let plen = String.length p in
- let nlen = String.length n in
- if plen <= nlen && String.sub n 0 plen = p then
- begin
- let fn_sep =
- if Sys.os_type = "Win32" then
- '\\'
- else
- '/'
- in
- let cutpoint = plen +
- (if plen < nlen && n.[plen] = fn_sep then
- 1
- else
- 0)
- in
- String.sub n cutpoint (nlen - cutpoint)
- end
- else
- n
- in
- List.map (remove_prefix (Sys.getcwd ())) files
- in
- info
- (f_ "Installing findlib library '%s'")
- findlib_name;
- let ocamlfind = ocamlfind () in
- let commands =
- split_install_command
- ocamlfind
- findlib_name
- meta
- files
- in
- List.iter
- (OASISExec.run ~ctxt:!BaseContext.default ocamlfind)
- commands;
- BaseLog.register install_findlib_ev findlib_name
- end;
-
- (* Install data files *)
- f_data ();
-
- in
-
- let group_libs, _, _ =
- findlib_mapping pkg
- in
-
- (* We install libraries in groups *)
- List.iter install_group_lib group_libs
- in
-
- let install_execs pkg =
- let install_exec data_exec =
- let (cs, bs, exec) =
- !exec_hook data_exec
- in
- if var_choose bs.bs_install &&
- BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then
- begin
- let exec_libdir () =
- Filename.concat
- (libdir ())
- pkg.name
- in
- BaseBuilt.fold
- BaseBuilt.BExec
- cs.cs_name
- (fun () fn ->
- install_file
- ~tgt_fn:(cs.cs_name ^ ext_program ())
- fn
- bindir)
- ();
- BaseBuilt.fold
- BaseBuilt.BExecLib
- cs.cs_name
- (fun () fn ->
- install_file
- fn
- exec_libdir)
- ();
- install_data
- bs.bs_path
- bs.bs_data_files
- (Filename.concat
- (datarootdir ())
- pkg.name)
- end
- in
- List.iter
- (function
- | Executable (cs, bs, exec)->
- install_exec (cs, bs, exec)
- | _ ->
- ())
- pkg.sections
- in
-
- let install_docs pkg =
- let install_doc data =
- let (cs, doc) =
- !doc_hook data
- in
- if var_choose doc.doc_install &&
- BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then
- begin
- let tgt_dir =
- OASISHostPath.of_unix (var_expand doc.doc_install_dir)
- in
- BaseBuilt.fold
- BaseBuilt.BDoc
- cs.cs_name
- (fun () fn ->
- install_file
- fn
- (fun () -> tgt_dir))
- ();
- install_data
- Filename.current_dir_name
- doc.doc_data_files
- doc.doc_install_dir
- end
- in
- List.iter
- (function
- | Doc (cs, doc) ->
- install_doc (cs, doc)
- | _ ->
- ())
- pkg.sections
- in
-
- install_libs pkg;
- install_execs pkg;
- install_docs pkg
-
- (* Uninstall already installed data *)
- let uninstall _ argv =
- List.iter
- (fun (ev, data) ->
- if ev = install_file_ev then
- begin
- if OASISFileUtil.file_exists_case data then
- begin
- info
- (f_ "Removing file '%s'")
- data;
- Sys.remove data
- end
- else
- begin
- warning
- (f_ "File '%s' doesn't exist anymore")
- data
- end
- end
- else if ev = install_dir_ev then
- begin
- if Sys.file_exists data && Sys.is_directory data then
- begin
- if Sys.readdir data = [||] then
- begin
- info
- (f_ "Removing directory '%s'")
- data;
- OASISFileUtil.rmdir ~ctxt:!BaseContext.default data
- end
- else
- begin
- warning
- (f_ "Directory '%s' is not empty (%s)")
- data
- (String.concat
- ", "
- (Array.to_list
- (Sys.readdir data)))
- end
- end
- else
- begin
- warning
- (f_ "Directory '%s' doesn't exist anymore")
- data
- end
- end
- else if ev = install_findlib_ev then
- begin
- info (f_ "Removing findlib library '%s'") data;
- OASISExec.run ~ctxt:!BaseContext.default
- (ocamlfind ()) ["remove"; data]
- end
- else
- failwithf (f_ "Unknown log event '%s'") ev;
- BaseLog.unregister ev data)
- (* We process event in reverse order *)
- (List.rev
- (BaseLog.filter
- [install_file_ev;
- install_dir_ev;
- install_findlib_ev;]))
-
-end
-
-
-# 5233 "setup.ml"
-module OCamlbuildCommon = struct
-(* # 21 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *)
-
- (** Functions common to OCamlbuild build and doc plugin
- *)
-
- open OASISGettext
- open BaseEnv
- open BaseStandardVar
-
- let ocamlbuild_clean_ev =
- "ocamlbuild-clean"
-
- let ocamlbuildflags =
- var_define
- ~short_desc:(fun () -> "OCamlbuild additional flags")
- "ocamlbuildflags"
- (fun () -> "")
-
- (** Fix special arguments depending on environment *)
- let fix_args args extra_argv =
- List.flatten
- [
- if (os_type ()) = "Win32" then
- [
- "-classic-display";
- "-no-log";
- "-no-links";
- "-install-lib-dir";
- (Filename.concat (standard_library ()) "ocamlbuild")
- ]
- else
- [];
-
- if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then
- [
- "-byte-plugin"
- ]
- else
- [];
- args;
-
- if bool_of_string (debug ()) then
- ["-tag"; "debug"]
- else
- [];
-
- if bool_of_string (profile ()) then
- ["-tag"; "profile"]
- else
- [];
-
- OASISString.nsplit (ocamlbuildflags ()) ' ';
-
- Array.to_list extra_argv;
- ]
-
- (** Run 'ocamlbuild -clean' if not already done *)
- let run_clean extra_argv =
- let extra_cli =
- String.concat " " (Array.to_list extra_argv)
- in
- (* Run if never called with these args *)
- if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then
- begin
- OASISExec.run ~ctxt:!BaseContext.default
- (ocamlbuild ()) (fix_args ["-clean"] extra_argv);
- BaseLog.register ocamlbuild_clean_ev extra_cli;
- at_exit
- (fun () ->
- try
- BaseLog.unregister ocamlbuild_clean_ev extra_cli
- with _ ->
- ())
- end
-
- (** Run ocamlbuild, unregister all clean events *)
- let run_ocamlbuild args extra_argv =
- (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html
- *)
- OASISExec.run ~ctxt:!BaseContext.default
- (ocamlbuild ()) (fix_args args extra_argv);
- (* Remove any clean event, we must run it again *)
- List.iter
- (fun (e, d) -> BaseLog.unregister e d)
- (BaseLog.filter [ocamlbuild_clean_ev])
-
- (** Determine real build directory *)
- let build_dir extra_argv =
- let rec search_args dir =
- function
- | "-build-dir" :: dir :: tl ->
- search_args dir tl
- | _ :: tl ->
- search_args dir tl
- | [] ->
- dir
- in
- search_args "_build" (fix_args [] extra_argv)
-
-end
-
-module OCamlbuildPlugin = struct
-(* # 21 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *)
-
- (** Build using ocamlbuild
- @author Sylvain Le Gall
- *)
-
- open OASISTypes
- open OASISGettext
- open OASISUtils
- open BaseEnv
- open OCamlbuildCommon
- open BaseStandardVar
- open BaseMessage
-
- let cond_targets_hook =
- ref (fun lst -> lst)
-
- let build pkg argv =
-
- (* Return the filename in build directory *)
- let in_build_dir fn =
- Filename.concat
- (build_dir argv)
- fn
- in
-
- (* Return the unix filename in host build directory *)
- let in_build_dir_of_unix fn =
- in_build_dir (OASISHostPath.of_unix fn)
- in
-
- let cond_targets =
- List.fold_left
- (fun acc ->
- function
- | Library (cs, bs, lib) when var_choose bs.bs_build ->
- begin
- let evs, unix_files =
- BaseBuilt.of_library
- in_build_dir_of_unix
- (cs, bs, lib)
- in
-
- let ends_with nd fn =
- let nd_len =
- String.length nd
- in
- (String.length fn >= nd_len)
- &&
- (String.sub
- fn
- (String.length fn - nd_len)
- nd_len) = nd
- in
-
- let tgts =
- List.flatten
- (List.filter
- (fun l -> l <> [])
- (List.map
- (List.filter
- (fun fn ->
- ends_with ".cma" fn
- || ends_with ".cmxs" fn
- || ends_with ".cmxa" fn
- || ends_with (ext_lib ()) fn
- || ends_with (ext_dll ()) fn))
- unix_files))
- in
-
- match tgts with
- | _ :: _ ->
- (evs, tgts) :: acc
- | [] ->
- failwithf
- (f_ "No possible ocamlbuild targets for library %s")
- cs.cs_name
- end
-
- | Executable (cs, bs, exec) when var_choose bs.bs_build ->
- begin
- let evs, unix_exec_is, unix_dll_opt =
- BaseBuilt.of_executable
- in_build_dir_of_unix
- (cs, bs, exec)
- in
-
- let target ext =
- let unix_tgt =
- (OASISUnixPath.concat
- bs.bs_path
- (OASISUnixPath.chop_extension
- exec.exec_main_is))^ext
- in
- let evs =
- (* Fix evs, we want to use the unix_tgt, without copying *)
- List.map
- (function
- | BaseBuilt.BExec, nm, lst when nm = cs.cs_name ->
- BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]]
- | ev ->
- ev)
- evs
- in
- evs, [unix_tgt]
- in
-
- (* Add executable *)
- let acc =
- match bs.bs_compiled_object with
- | Native ->
- (target ".native") :: acc
- | Best when bool_of_string (is_native ()) ->
- (target ".native") :: acc
- | Byte
- | Best ->
- (target ".byte") :: acc
- in
- acc
- end
-
- | Library _ | Executable _ | Test _
- | SrcRepo _ | Flag _ | Doc _ ->
- acc)
- []
- (* Keep the pkg.sections ordered *)
- (List.rev pkg.sections);
- in
-
- (* Check and register built files *)
- let check_and_register (bt, bnm, lst) =
- List.iter
- (fun fns ->
- if not (List.exists OASISFileUtil.file_exists_case fns) then
- failwithf
- (f_ "No one of expected built files %s exists")
- (String.concat (s_ ", ") (List.map (Printf.sprintf "'%s'") fns)))
- lst;
- (BaseBuilt.register bt bnm lst)
- in
-
- let cond_targets =
- (* Run the hook *)
- !cond_targets_hook cond_targets
- in
-
- (* Run a list of target... *)
- run_ocamlbuild
- (List.flatten
- (List.map snd cond_targets))
- argv;
- (* ... and register events *)
- List.iter
- check_and_register
- (List.flatten (List.map fst cond_targets))
-
-
- let clean pkg extra_args =
- run_clean extra_args;
- List.iter
- (function
- | Library (cs, _, _) ->
- BaseBuilt.unregister BaseBuilt.BLib cs.cs_name
- | Executable (cs, _, _) ->
- BaseBuilt.unregister BaseBuilt.BExec cs.cs_name;
- BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name
- | _ ->
- ())
- pkg.sections
-
-end
-
-module OCamlbuildDocPlugin = struct
-(* # 21 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *)
-
- (* Create documentation using ocamlbuild .odocl files
- @author Sylvain Le Gall
- *)
-
- open OASISTypes
- open OASISGettext
- open OASISMessage
- open OCamlbuildCommon
- open BaseStandardVar
-
-
-
- let doc_build path pkg (cs, doc) argv =
- let index_html =
- OASISUnixPath.make
- [
- path;
- cs.cs_name^".docdir";
- "index.html";
- ]
- in
- let tgt_dir =
- OASISHostPath.make
- [
- build_dir argv;
- OASISHostPath.of_unix path;
- cs.cs_name^".docdir";
- ]
- in
- run_ocamlbuild [index_html] argv;
- List.iter
- (fun glb ->
- BaseBuilt.register
- BaseBuilt.BDoc
- cs.cs_name
- [OASISFileUtil.glob ~ctxt:!BaseContext.default
- (Filename.concat tgt_dir glb)])
- ["*.html"; "*.css"]
-
- let doc_clean t pkg (cs, doc) argv =
- run_clean argv;
- BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name
-
-end
-
-
-# 5558 "setup.ml"
-module CustomPlugin = struct
-(* # 21 "src/plugins/custom/CustomPlugin.ml" *)
-
- (** Generate custom configure/build/doc/test/install system
- @author
- *)
-
- open BaseEnv
- open OASISGettext
- open OASISTypes
-
-
-
- type t =
- {
- cmd_main: command_line conditional;
- cmd_clean: (command_line option) conditional;
- cmd_distclean: (command_line option) conditional;
- }
-
- let run = BaseCustom.run
-
- let main t _ extra_args =
- let cmd, args =
- var_choose
- ~name:(s_ "main command")
- t.cmd_main
- in
- run cmd args extra_args
-
- let clean t pkg extra_args =
- match var_choose t.cmd_clean with
- | Some (cmd, args) ->
- run cmd args extra_args
- | _ ->
- ()
-
- let distclean t pkg extra_args =
- match var_choose t.cmd_distclean with
- | Some (cmd, args) ->
- run cmd args extra_args
- | _ ->
- ()
-
- module Build =
- struct
- let main t pkg extra_args =
- main t pkg extra_args;
- List.iter
- (fun sct ->
- let evs =
- match sct with
- | Library (cs, bs, lib) when var_choose bs.bs_build ->
- begin
- let evs, _ =
- BaseBuilt.of_library
- OASISHostPath.of_unix
- (cs, bs, lib)
- in
- evs
- end
- | Executable (cs, bs, exec) when var_choose bs.bs_build ->
- begin
- let evs, _, _ =
- BaseBuilt.of_executable
- OASISHostPath.of_unix
- (cs, bs, exec)
- in
- evs
- end
- | _ ->
- []
- in
- List.iter
- (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst)
- evs)
- pkg.sections
-
- let clean t pkg extra_args =
- clean t pkg extra_args;
- (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild
- * considering moving this to BaseSetup?
- *)
- List.iter
- (function
- | Library (cs, _, _) ->
- BaseBuilt.unregister BaseBuilt.BLib cs.cs_name
- | Executable (cs, _, _) ->
- BaseBuilt.unregister BaseBuilt.BExec cs.cs_name;
- BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name
- | _ ->
- ())
- pkg.sections
-
- let distclean t pkg extra_args =
- distclean t pkg extra_args
- end
-
- module Test =
- struct
- let main t pkg (cs, test) extra_args =
- try
- main t pkg extra_args;
- 0.0
- with Failure s ->
- BaseMessage.warning
- (f_ "Test '%s' fails: %s")
- cs.cs_name
- s;
- 1.0
-
- let clean t pkg (cs, test) extra_args =
- clean t pkg extra_args
-
- let distclean t pkg (cs, test) extra_args =
- distclean t pkg extra_args
- end
-
- module Doc =
- struct
- let main t pkg (cs, _) extra_args =
- main t pkg extra_args;
- BaseBuilt.register BaseBuilt.BDoc cs.cs_name []
-
- let clean t pkg (cs, _) extra_args =
- clean t pkg extra_args;
- BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name
-
- let distclean t pkg (cs, _) extra_args =
- distclean t pkg extra_args
- end
-
-end
-
-
-# 5694 "setup.ml"
-open OASISTypes;;
-
-let setup_t =
- {
- BaseSetup.configure = InternalConfigurePlugin.configure;
- build = OCamlbuildPlugin.build;
- test =
- [
- ("nonregression",
- CustomPlugin.Test.main
- {
- CustomPlugin.cmd_main =
- [(OASISExpr.EBool true, ("make", ["test-compile"]))];
- cmd_clean = [(OASISExpr.EBool true, None)];
- cmd_distclean = [(OASISExpr.EBool true, None)]
- })
- ];
- doc = [];
- install = InternalInstallPlugin.install;
- uninstall = InternalInstallPlugin.uninstall;
- clean = [OCamlbuildPlugin.clean];
- clean_test =
- [
- ("nonregression",
- CustomPlugin.Test.clean
- {
- CustomPlugin.cmd_main =
- [(OASISExpr.EBool true, ("make", ["test-compile"]))];
- cmd_clean = [(OASISExpr.EBool true, None)];
- cmd_distclean = [(OASISExpr.EBool true, None)]
- })
- ];
- clean_doc = [];
- distclean = [];
- distclean_test =
- [
- ("nonregression",
- CustomPlugin.Test.distclean
- {
- CustomPlugin.cmd_main =
- [(OASISExpr.EBool true, ("make", ["test-compile"]))];
- cmd_clean = [(OASISExpr.EBool true, None)];
- cmd_distclean = [(OASISExpr.EBool true, None)]
- })
- ];
- distclean_doc = [];
- package =
- {
- oasis_version = "0.2";
- ocaml_version = None;
- findlib_version = None;
- name = "Lustre Compiler";
- version = "1.2";
- license =
- OASISLicense.DEP5License
- (OASISLicense.DEP5Unit
- {
- OASISLicense.license = "LGPL";
- excption = None;
- version = OASISLicense.Version "2.1"
- });
- license_file = None;
- copyrights = [];
- maintainers = [];
- authors = [];
- homepage = None;
- synopsis = "Lustre compiler C and Java backends";
- description = None;
- categories = [];
- conf_type = (`Configure, "internal", Some "0.3");
- conf_custom =
- {
- pre_command = [(OASISExpr.EBool true, None)];
- post_command = [(OASISExpr.EBool true, None)]
- };
- build_type = (`Build, "ocamlbuild", Some "0.3");
- build_custom =
- {
- pre_command =
- [
- (OASISExpr.EBool true,
- Some (("./svn_version.sh", ["$(prefix)"])))
- ];
- post_command = [(OASISExpr.EBool true, None)]
- };
- install_type = (`Install, "internal", Some "0.3");
- install_custom =
- {
- pre_command = [(OASISExpr.EBool true, None)];
- post_command =
- [
- (OASISExpr.EBool true,
- Some
- (("mkdir",
- [
- "-p";
- "$(prefix)/include/lustrec;";
- "cp";
- "-rf";
- "include/*";
- "$(prefix)/include/lustrec"
- ])))
- ]
- };
- uninstall_custom =
- {
- pre_command = [(OASISExpr.EBool true, None)];
- post_command = [(OASISExpr.EBool true, None)]
- };
- clean_custom =
- {
- pre_command = [(OASISExpr.EBool true, None)];
- post_command = [(OASISExpr.EBool true, None)]
- };
- distclean_custom =
- {
- pre_command = [(OASISExpr.EBool true, None)];
- post_command = [(OASISExpr.EBool true, None)]
- };
- files_ab = [];
- sections =
- [
- Executable
- ({
- cs_name = "lustrec";
- cs_data = PropList.Data.create ();
- cs_plugin_data = []
- },
- {
- bs_build = [(OASISExpr.EBool true, true)];
- bs_install = [(OASISExpr.EBool true, true)];
- bs_path = "src";
- bs_compiled_object = Native;
- bs_build_depends =
- [
- FindlibPackage ("ocamlgraph", None);
- FindlibPackage ("str", None);
- FindlibPackage ("unix", None)
- ];
- bs_build_tools = [ExternalTool "ocamlbuild"];
- bs_c_sources = [];
- bs_data_files = [];
- bs_ccopt = [(OASISExpr.EBool true, [])];
- bs_cclib = [(OASISExpr.EBool true, [])];
- bs_dlllib = [(OASISExpr.EBool true, [])];
- bs_dllpath = [(OASISExpr.EBool true, [])];
- bs_byteopt = [(OASISExpr.EBool true, [])];
- bs_nativeopt = [(OASISExpr.EBool true, [])]
- },
- {
- exec_custom = false;
- exec_main_is = "main_lustre_compiler.ml"
- });
- Test
- ({
- cs_name = "nonregression";
- cs_data = PropList.Data.create ();
- cs_plugin_data = []
- },
- {
- test_type = (`Test, "custom", None);
- test_command =
- [(OASISExpr.EBool true, ("make", ["test-compile"]))];
- test_custom =
- {
- pre_command = [(OASISExpr.EBool true, None)];
- post_command = [(OASISExpr.EBool true, None)]
- };
- test_working_directory = Some "test";
- test_run = [(OASISExpr.EBool true, true)];
- test_tools = []
- })
- ];
- plugins = [(`Extra, "DevFiles", Some "0.2")];
- schema_data = PropList.Data.create ();
- plugin_data = []
- };
- oasis_fn = Some "_oasis";
- oasis_version = "0.3.0";
- oasis_digest = Some "wX\249B\007\151\134\1970p\217\138\017\214\244\241";
- oasis_exec = None;
- oasis_setup_args = [];
- setup_update = false
- };;
-
-let setup () = BaseSetup.setup setup_t;;
-
-# 5883 "setup.ml"
-(* OASIS_STOP *)
-let () = setup ();;
diff --git a/src/Makefile b/src/Makefile
deleted file mode 100644
index c49e53d8ce09253e8bfbe0a48eb24601b4dac135..0000000000000000000000000000000000000000
--- a/src/Makefile
+++ /dev/null
@@ -1,41 +0,0 @@
-OCAMLBUILD=/home/ploc/.opam/4.03.0+trunk/bin/ocamlbuild -classic-display -use-ocamlfind -no-links
-
-prefix=/home/ploc/Local
-exec_prefix=${prefix}
-bindir=${exec_prefix}/bin
-datarootdir = ${prefix}/share
-includedir = ${prefix}/include
-
-LUSI_LIBS=include/math.lusi include/conv.lusi
-LOCAL_BINDIR=../bin
-LOCAL_DOCDIR=../doc/manual
-
-lustrec:
- @echo Compiling binary lustrec
- @$(OCAMLBUILD) main_lustre_compiler.native
- @mkdir -p $(LOCAL_BINDIR)
- @mv _build/main_lustre_compiler.native $(LOCAL_BINDIR)/lustrec
-
-doc:
- @echo Generating doc
- @$(OCAMLBUILD) lustrec.docdir/index.html
- @rm -rf $(LOCAL_DOCDIR)
- @cp -rf _build/lustrec.docdir $(LOCAL_DOCDIR)
-
-dot: doc
- $(OCAMLBUILD) lustrec.docdir/lustrec.dot
- dot -T ps -o lustrec.dot _build/lustrec.docdir/lustrec.dot
- mv _build/lustrec.docdir/lustrec.dot $(LOCAL_DOCDIR)
-
-clean:
- $(OCAMLBUILD) -clean
-
-dist-clean: clean
- rm -f Makefile myocamlbuild.ml config.log config.status configure
- rm -f include/*.lusic include/math.h include/conv.h
-
-install:
- make -C .. install
-
-.PHONY: compile-lusi doc dot lustrec lustrec.odocl clean install dist-clean
-
diff --git a/src/Makefile.in b/src/Makefile.in
index 126a31f7253c95cb62dd436db79d0ecb71822650..a5d6b72f03b69981c6b62934bca6bc88d9495fba 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -1,4 +1,4 @@
-OCAMLBUILD=@OCAMLBUILD@ -classic-display -use-ocamlfind -no-links
+OCAMLBUILD=@OCAMLBUILD@ -use-ocamlfind -no-links
prefix=@prefix@
exec_prefix=@exec_prefix@
@@ -10,12 +10,20 @@ LUSI_LIBS=include/math.lusi include/conv.lusi
LOCAL_BINDIR=../bin
LOCAL_DOCDIR=../doc/manual
+all: lustrec lustret
+
lustrec:
@echo Compiling binary lustrec
@$(OCAMLBUILD) main_lustre_compiler.native
@mkdir -p $(LOCAL_BINDIR)
@mv _build/main_lustre_compiler.native $(LOCAL_BINDIR)/lustrec
+lustret:
+ @echo Compiling binary lustret
+ @$(OCAMLBUILD) main_lustre_testgen.native
+ @mkdir -p $(LOCAL_BINDIR)
+ @mv _build/main_lustre_testgen.native $(LOCAL_BINDIR)/lustret
+
doc:
@echo Generating doc
@$(OCAMLBUILD) lustrec.docdir/index.html
@@ -37,5 +45,5 @@ dist-clean: clean
install:
make -C .. install
-.PHONY: compile-lusi doc dot lustrec lustrec.odocl clean install dist-clean
+.PHONY: compile-lusi doc dot lustrec lustret lustrec.odocl clean install dist-clean
diff --git a/src/_tags b/src/_tags
deleted file mode 100644
index 6c8a93fd6c102a5f71464baf81a7b9e32fac23f1..0000000000000000000000000000000000000000
--- a/src/_tags
+++ /dev/null
@@ -1,13 +0,0 @@
-"backends/C": include
-"backends/Horn": include
-"backends/EMF": include
-"plugins/scopes": include
-<**/.svn>: -traverse
-<**/.svn>: not_hygienic
-"main_lustre_compiler.native": package(ocamlgraph)
-"main_lustre_compiler.native": use_str
-"main_lustre_compiler.native": use_unix
-"main_lustre_compiler.native": use_nums
-<*.ml{,i}>: package(ocamlgraph)
-<*.ml{,i}>: use_str
-<*.ml{,i}>: use_unix
diff --git a/src/_tags.in b/src/_tags.in
new file mode 100644
index 0000000000000000000000000000000000000000..d188c2a01d9139645707e48a064896b7d026ebc0
--- /dev/null
+++ b/src/_tags.in
@@ -0,0 +1,22 @@
+"backends": include
+"backends/C": include
+"backends/Horn": include
+"backends/EMF": include
+"plugins/salsa": include
+"plugins/scopes": include
+"plugins/mpfr": include
+<**/.svn>: -traverse
+<**/.svn>: not_hygienic
+
+<**/*.native>: package(ocamlgraph)
+<**/*.native>: use_str
+<**/*.native>: use_unix
+<**/*.native>: package(num)
+
+
+# Required for ocamldoc. Otherwise failed to build
+<*.ml{,i}>: package(ocamlgraph)
+
+# Plugin dependencies
+@SALSA_TAG@
+
diff --git a/src/backends/C/c_backend.ml b/src/backends/C/c_backend.ml
index 0fa4971b627338908b57d515ad828e6acb83216f..3a9f1e9179881aee69c6737275555a5e587dbf84 100644
--- a/src/backends/C/c_backend.ml
+++ b/src/backends/C/c_backend.ml
@@ -10,6 +10,7 @@
(********************************************************************)
open Format
+open C_backend_mauve
(********************************************************************************************)
(* Translation function *)
(********************************************************************************************)
@@ -38,7 +39,7 @@ let gen_files funs basename prog machines dependencies =
close_out header_out;
(* Generating Lib C file *)
- let source_lib_file = destname ^ ".c" in (* Could be changed *)
+ let source_lib_file = (if !Options.cpp then destname ^ ".cpp" else destname ^ ".c") in (* Could be changed *)
let source_lib_out = open_out source_lib_file in
let source_lib_fmt = formatter_of_out_channel source_lib_out in
print_lib_c source_lib_fmt basename prog machines dependencies;
@@ -54,7 +55,7 @@ let gen_files funs basename prog machines dependencies =
raise (Corelang.Error (Location.dummy_loc, LustreSpec.Main_not_found))
end
| Some m -> begin
- let source_main_file = destname ^ "_main.c" in (* Could be changed *)
+ let source_main_file = (if !Options.cpp then destname ^ "_main.cpp" else destname ^ "_main.c") in (* Could be changed *)
let source_main_out = open_out source_main_file in
let source_main_fmt = formatter_of_out_channel source_main_out in
@@ -65,6 +66,33 @@ let gen_files funs basename prog machines dependencies =
end
));
+ (match !Options.mauve with
+ | "" -> ()
+ | mauve -> (
+ (* looking for the main node *)
+ match Machine_code.get_machine_opt mauve machines with
+ | None -> begin
+ Global.main_node := mauve;
+ Format.eprintf "Code generation error: %a@." Corelang.pp_error LustreSpec.Main_not_found;
+ raise (Corelang.Error (Location.dummy_loc, LustreSpec.Main_not_found))
+ end
+ | Some m -> begin
+ let source_mauve_file = destname ^ "_mauve.hpp" in
+ let source_mauve_out = open_out source_mauve_file in
+ let source_mauve_fmt = formatter_of_out_channel source_mauve_out in
+ (* Header *)
+ print_mauve_header source_mauve_fmt m basename prog machines dependencies;
+ (* Shell *)
+ print_mauve_shell source_mauve_fmt m basename prog machines dependencies;
+ (* Core *)
+ print_mauve_core source_mauve_fmt m basename prog machines dependencies;
+ (* FSM *)
+ print_mauve_fsm source_mauve_fmt m basename prog machines dependencies;
+
+ close_out source_mauve_out;
+ end
+ ));
+
(* Makefiles:
- for the moment two cases
diff --git a/src/backends/C/c_backend_cmake.ml b/src/backends/C/c_backend_cmake.ml
new file mode 100644
index 0000000000000000000000000000000000000000..205c3311c9ff57ea87e04d4446b798b859f05f9a
--- /dev/null
+++ b/src/backends/C/c_backend_cmake.ml
@@ -0,0 +1,107 @@
+(********************************************************************)
+(* *)
+(* The LustreC compiler toolset / The LustreC Development Team *)
+(* Copyright 2012 - -- ONERA - CNRS - INPT *)
+(* *)
+(* LustreC is free software, distributed WITHOUT ANY WARRANTY *)
+(* under the terms of the GNU Lesser General Public License *)
+(* version 2.1. *)
+(* *)
+(********************************************************************)
+
+open Format
+open LustreSpec
+open Corelang
+
+let header_has_code header =
+ List.exists
+ (fun top ->
+ match top.top_decl_desc with
+ | Const _ -> true
+ | ImportedNode nd -> nd.nodei_in_lib = []
+ | _ -> false
+ )
+ header
+
+let header_libs header =
+ List.fold_left (fun accu top ->
+ match top.top_decl_desc with
+ | ImportedNode nd -> Utils.list_union nd.nodei_in_lib accu
+ | _ -> accu
+ ) [] header
+
+
+let compiled_dependencies dep =
+ List.filter (fun (Dep (_, _, header, _)) -> header_has_code header) dep
+
+let lib_dependencies dep =
+ List.fold_left
+ (fun accu (Dep (_, _, header, _)) -> Utils.list_union (header_libs header) accu) [] dep
+
+let fprintf_dependencies fmt (dep: dep_t list) =
+ let compiled_dep = compiled_dependencies dep in
+ List.iter (fun s -> (* Format.eprintf "Adding dependency: %s@." s; *)
+ fprintf fmt "\t${GCC} -I${INC} -c %s@." s)
+ (("${INC}/io_frontend.c"):: (* IO functions when a main function is computed *)
+ (List.map
+ (fun (Dep (local, s, _, _)) ->
+ (if local then s else Version.include_path ^ "/" ^ s) ^ ".c")
+ compiled_dep))
+
+module type MODIFIERS_MKF =
+sig (* dep was (bool * ident * top_decl list) *)
+ val other_targets: Format.formatter -> string -> string -> dep_t list -> unit
+end
+
+module EmptyMod =
+(struct
+ let other_targets _ _ _ _ = ()
+end: MODIFIERS_MKF)
+
+module Main = functor (Mod: MODIFIERS_MKF) ->
+struct
+
+
+ let print_cmake basename nodename (dependencies: dep_t list) fmt =
+
+ (* Printing the basic file CMakeLists.txt *)
+ let fmt_CMakeLists_txt = formatter_of_out_channel (open_out (!Options.dest_dir ^ "/CMakeLists.txt")) in
+ fprintf fmt_CMakeLists_txt "cmake_minimum_required(VERSION 3.0)@.";
+ fprintf fmt_CMakeLists_txt "project(%s C)@." basename;
+ fprintf mt_CMakeLists_txt "@.";
+ fprintf mt_CMakeLists_txt "set(LUSTREC_DEFINE_TARGETS ON)@.";
+ fprintf mt_CMakeLists_txt "include(lustrec-%s.cmake)" basename;
+
+
+ fprintf fmt "GCC=gcc@.";
+ fprintf fmt "LUSTREC=%s@." Sys.executable_name;
+ fprintf fmt "LUSTREC_BASE=%s@." (Filename.dirname (Filename.dirname Sys.executable_name));
+ fprintf fmt "INC=${LUSTREC_BASE}/include/lustrec@.";
+ fprintf fmt "@.";
+
+ (* Main binary *)
+ fprintf fmt "%s_%s: %s.c %s_main.c@." basename nodename basename basename;
+ fprintf fmt "\t${GCC} -O0 -I${INC} -I. -c %s.c@." basename;
+ fprintf fmt "\t${GCC} -O0 -I${INC} -I. -c %s_main.c@." basename;
+ fprintf_dependencies fmt dependencies;
+ fprintf fmt "\t${GCC} -O0 -o %s_%s io_frontend.o %a %s.o %s_main.o %a@." basename nodename
+ (Utils.fprintf_list ~sep:" " (fun fmt (Dep (_, s, _, _)) -> Format.fprintf fmt "%s.o" s))
+ (compiled_dependencies dependencies)
+ basename (* library .o *)
+ basename (* main function . o *)
+ (Utils.fprintf_list ~sep:" " (fun fmt lib -> fprintf fmt "-l%s" lib)) (lib_dependencies dependencies)
+ ;
+ fprintf fmt "@.";
+ fprintf fmt "clean:@.";
+ fprintf fmt "\t\\rm -f *.o %s_%s@." basename nodename;
+ fprintf fmt "@.";
+ fprintf fmt ".PHONY: %s_%s@." basename nodename;
+ fprintf fmt "@.";
+ Mod.other_targets fmt basename nodename dependencies;
+ fprintf fmt "@.";
+
+end
+
+(* Local Variables: *)
+(* compile-command:"make -C ../../.." *)
+(* End: *)
diff --git a/src/backends/C/c_backend_common.ml b/src/backends/C/c_backend_common.ml
index 78aa10088364499f844da5c110b063a8ec2340a2..02f1f0ada558ed732841768c01d8f3a2f780fc66 100644
--- a/src/backends/C/c_backend_common.ml
+++ b/src/backends/C/c_backend_common.ml
@@ -24,7 +24,7 @@ let print_version fmt =
(if !Options.mpfr then "MPFR multi-precision" else "(double) floating-point")
let file_to_module_name basename =
- let baseNAME = String.uppercase basename in
+ let baseNAME = String.uppercase_ascii basename in
let baseNAME = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" baseNAME in
baseNAME
@@ -94,6 +94,7 @@ let pp_global_clear_name fmt id = fprintf fmt "%s_CLEAR" id
let pp_machine_memtype_name fmt id = fprintf fmt "struct %s_mem" id
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id
+let pp_machine_dealloc_name fmt id = fprintf fmt "%s_dealloc" id
let pp_machine_static_declare_name fmt id = fprintf fmt "%s_DECLARE" id
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id
@@ -124,14 +125,17 @@ let is_basic_c_type t =
| Types.Tbool | Types.Treal | Types.Tint -> true
| _ -> false
-let pp_basic_c_type fmt t =
- match (Types.repr t).Types.tdesc with
- | Types.Tbool -> fprintf fmt "_Bool"
- | Types.Treal when !Options.mpfr -> fprintf fmt "%s" Mpfr.mpfr_t
- | Types.Treal -> fprintf fmt "double"
- | Types.Tint -> fprintf fmt "int"
+let pp_c_basic_type_desc t_dsec =
+ match t_dsec with
+ | Types.Tbool when !Options.cpp -> "bool"
+ | Types.Tbool -> "_Bool"
+ | Types.Tint -> !Options.int_type
+ | Types.Treal when !Options.mpfr -> Mpfr.mpfr_t
+ | Types.Treal -> !Options.real_type
| _ -> assert false (* Not a basic C type. Do not handle arrays or pointers *)
+let pp_basic_c_type fmt t = fprintf fmt "%s" (pp_c_basic_type_desc (Types.repr t).Types.tdesc)
+
let pp_c_type var fmt t =
let rec aux t pp_suffix =
match (Types.repr t).Types.tdesc with
@@ -162,6 +166,7 @@ let rec pp_c_initialize fmt t =
let pp_c_tag fmt t =
pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t)
+
(* Prints a constant value *)
let rec pp_c_const fmt c =
match c with
@@ -348,6 +353,11 @@ let print_alloc_prototype fmt (name, static) =
pp_machine_alloc_name name
(Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
+let print_dealloc_prototype fmt name =
+ fprintf fmt "void %a (%a * _alloc)"
+ pp_machine_dealloc_name name
+ pp_machine_memtype_name name
+
let print_reset_prototype self fmt (name, static) =
fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
pp_machine_reset_name name
@@ -422,8 +432,11 @@ let print_import_alloc_prototype fmt (Dep (_, s, _, stateful)) =
let print_extern_alloc_prototypes fmt (Dep (_,_, header,_)) =
List.iter (fun decl -> match decl.top_decl_desc with
| ImportedNode ind when not ind.nodei_stateless ->
- let static = List.filter (fun v -> v.var_dec_const) ind.nodei_inputs
- in fprintf fmt "extern %a;@." print_alloc_prototype (ind.nodei_id, static)
+ let static = List.filter (fun v -> v.var_dec_const) ind.nodei_inputs in
+ begin
+ fprintf fmt "extern %a;@.@." print_alloc_prototype (ind.nodei_id, static);
+ fprintf fmt "extern %a;@.@." print_dealloc_prototype ind.nodei_id;
+ end
| _ -> ()
) header
@@ -461,6 +474,7 @@ let pp_c_var m self pp_var fmt var =
pp_c_val self pp_var fmt (mk_val (StateVar var) var.var_type)
else
pp_c_val self pp_var fmt (mk_val (LocalVar var) var.var_type)
+
let pp_array_suffix fmt loop_vars =
Utils.fprintf_list ~sep:"" (fun fmt v -> fprintf fmt "[%s]" v) fmt loop_vars
diff --git a/src/backends/C/c_backend_header.ml b/src/backends/C/c_backend_header.ml
index 09d4f683c738399bd691932db1af066d14866964..e9f8fcdae9785c406480262b9d793e357d4c38b5 100644
--- a/src/backends/C/c_backend_header.ml
+++ b/src/backends/C/c_backend_header.ml
@@ -39,7 +39,10 @@ let print_import_standard fmt =
begin
fprintf fmt "#include <mpfr.h>@."
end;
- fprintf fmt "#include \"%s/arrow.h\"@.@." !Options.include_dir
+ if !Options.cpp then
+ fprintf fmt "#include \"%s/arrow.hpp\"@.@." arrow_top_decl.top_decl_owner
+ else
+ fprintf fmt "#include \"%s/arrow.h\"@.@." arrow_top_decl.top_decl_owner
end
@@ -177,7 +180,10 @@ let print_machine_decl fmt m =
begin
(* Dynamic allocation *)
fprintf fmt "extern %a;@.@."
- print_alloc_prototype (m.mname.node_id, m.mstatic)
+ print_alloc_prototype (m.mname.node_id, m.mstatic);
+
+ fprintf fmt "extern %a;@.@."
+ print_dealloc_prototype m.mname.node_id;
end;
let self = mk_self m in
fprintf fmt "extern %a;@.@."
@@ -219,8 +225,11 @@ let print_machine_alloc_decl fmt m =
else
begin
(* Dynamic allocation *)
- fprintf fmt "extern %a;@."
- print_alloc_prototype (m.mname.node_id, m.mstatic)
+ fprintf fmt "extern %a;@.@."
+ print_alloc_prototype (m.mname.node_id, m.mstatic);
+
+ fprintf fmt "extern %a;@.@."
+ print_dealloc_prototype m.mname.node_id
end
end
diff --git a/src/backends/C/c_backend_lusic.ml b/src/backends/C/c_backend_lusic.ml
new file mode 100644
index 0000000000000000000000000000000000000000..7b75129372dceec53cafa7a88a9804c5f189d7e7
--- /dev/null
+++ b/src/backends/C/c_backend_lusic.ml
@@ -0,0 +1,18 @@
+open Lusic
+
+let print_lusic_to_h basename extension =
+let module HeaderMod = C_backend_header.EmptyMod in
+let module Header = C_backend_header.Main (HeaderMod) in
+ let lusic = read_lusic basename extension in
+ let header_name = basename ^ ".h" in
+ let h_out = open_out header_name in
+ let h_fmt = Format.formatter_of_out_channel h_out in
+ begin
+ assert (not lusic.obsolete);
+ (*Format.eprintf "lusic to h: %i items.@." (List.length lusic.contents);*)
+ Typing.uneval_prog_generics lusic.contents;
+ Clock_calculus.uneval_prog_generics lusic.contents;
+ Header.print_header_from_header h_fmt (Filename.basename basename) lusic.contents;
+ close_out h_out
+ end
+
diff --git a/src/backends/C/c_backend_main.ml b/src/backends/C/c_backend_main.ml
index 9283feaafebd56b05c40d3afd0b96df3d87117c6..7fd49d414614f67357718a380cf9323d21e922cc 100644
--- a/src/backends/C/c_backend_main.ml
+++ b/src/backends/C/c_backend_main.ml
@@ -165,10 +165,8 @@ let print_main_code fmt basename m =
print_main_initialize mname main_mem fmt m;
end;
print_main_loop mname main_mem fmt m;
- if Scopes.Plugin.is_active () then
- begin
- fprintf fmt "@ %t" Scopes.Plugin.pp
- end;
+
+ Plugins.c_backend_main_loop_body_suffix fmt ();
fprintf fmt "@]@ }@ @ ";
if !Options.mpfr then
begin
@@ -179,8 +177,8 @@ let print_main_code fmt basename m =
fprintf fmt "@]@ }@."
let print_main_header fmt =
- fprintf fmt "#include <stdio.h>@.#include <unistd.h>@.#include \"%s/io_frontend.h\"@."
- !Options.include_dir
+ fprintf fmt (if !Options.cpp then "#include <stdio.h>@.#include <unistd.h>@.#include \"%s/io_frontend.hpp\"@." else "#include <stdio.h>@.#include <unistd.h>@.#include \"%s/io_frontend.h\"@.")
+ (Options.core_dependency "io_frontend")
let print_main_c main_fmt main_machine basename prog machines _ (*dependencies*) =
print_main_header main_fmt;
diff --git a/src/backends/C/c_backend_makefile.ml b/src/backends/C/c_backend_makefile.ml
index a006cd7b8ff40c0e0ef24b59be08b52e4e63315d..56913bbe7dd627ddd759c0dd6f89079cbf0d3d14 100644
--- a/src/backends/C/c_backend_makefile.ml
+++ b/src/backends/C/c_backend_makefile.ml
@@ -63,7 +63,7 @@ struct
let print_makefile basename nodename (dependencies: dep_t list) fmt =
- fprintf fmt "GCC=gcc@.";
+ fprintf fmt "GCC=gcc -O0@.";
fprintf fmt "LUSTREC=%s@." Sys.executable_name;
fprintf fmt "LUSTREC_BASE=%s@." (Filename.dirname (Filename.dirname Sys.executable_name));
fprintf fmt "INC=${LUSTREC_BASE}/include/lustrec@.";
@@ -71,10 +71,10 @@ let print_makefile basename nodename (dependencies: dep_t list) fmt =
(* Main binary *)
fprintf fmt "%s_%s: %s.c %s_main.c@." basename nodename basename basename;
- fprintf fmt "\t${GCC} -O0 -I${INC} -I. -c %s.c@." basename;
- fprintf fmt "\t${GCC} -O0 -I${INC} -I. -c %s_main.c@." basename;
+ fprintf fmt "\t${GCC} -I${INC} -I. -c %s.c@." basename;
+ fprintf fmt "\t${GCC} -I${INC} -I. -c %s_main.c@." basename;
fprintf_dependencies fmt dependencies;
- fprintf fmt "\t${GCC} -O0 -o %s_%s io_frontend.o %a %s.o %s_main.o %a@." basename nodename
+ fprintf fmt "\t${GCC} -o %s_%s io_frontend.o %a %s.o %s_main.o %a@." basename nodename
(Utils.fprintf_list ~sep:" " (fun fmt (Dep (_, s, _, _)) -> Format.fprintf fmt "%s.o" s))
(compiled_dependencies dependencies)
basename (* library .o *)
diff --git a/src/backends/C/c_backend_mauve.ml b/src/backends/C/c_backend_mauve.ml
new file mode 100644
index 0000000000000000000000000000000000000000..0cb928cea519481799a6c379cf4ff348213ffcdf
--- /dev/null
+++ b/src/backends/C/c_backend_mauve.ml
@@ -0,0 +1,231 @@
+open LustreSpec
+open Corelang
+open Machine_code
+open Format
+open C_backend_common
+open Utils
+open Printers
+
+(* module type MODIFIERS_MAINSRC =
+sig
+end
+
+module EmptyMod =
+struct
+end
+
+module Mauve = functor (Mod: MODIFIERS_MAINSRC) ->
+struct
+end
+ *)
+(********************************************************************************************)
+(* Main related functions *)
+(********************************************************************************************)
+
+let shell_name node = node ^ "Shell"
+let core_name node = node ^ "Core"
+let fsm_name node = node ^ "FSM"
+
+(* -------------------------------------------------- *)
+(* Hearder *)
+(* -------------------------------------------------- *)
+
+let print_mauve_header fmt mauve_machine basename prog machines _ (*dependencies*) =
+ fprintf fmt "#include \"mauve/runtime.hpp\"@.";
+ print_import_alloc_prototype fmt (Dep (true, basename, [], true (* assuming it is stateful*) ));
+ pp_print_newline fmt ();
+ pp_print_newline fmt ()
+
+(* -------------------------------------------------- *)
+(* Shell *)
+(* -------------------------------------------------- *)
+
+let mauve_default_value v =
+ (* let v_name = v.var_id in *)
+
+ let v_type = (Types.repr v.var_type).Types.tdesc in
+ match v_type with
+ | Types.Tbool -> "false"
+ | Types.Tint -> "0"
+ | Types.Treal -> "0.0"
+ | _ -> assert false
+
+let print_mauve_default fmt mauve_machine v =
+ let v_name: string = v.var_id in
+ let found = ref false in
+ let annotations: expr_annot list = mauve_machine.mname.node_annot in
+ List.iter
+ (fun (al: expr_annot) ->
+ List.iter
+ (fun ((sl, e): string list * eexpr) -> if not !found then match sl with
+ | ["mauve"; "default"; name] ->
+ if v_name = name then begin (pp_expr fmt e.eexpr_qfexpr); found := true; end
+ | _ -> ();
+ ) al.annots;
+ ) annotations;
+ if not !found then fprintf fmt "%s" (mauve_default_value v)
+
+
+let print_mauve_shell fmt mauve_machine basename prog machines _ (*dependencies*) =
+ let node_name = mauve_machine.mname.node_id in
+
+ fprintf fmt "/*@.";
+ fprintf fmt " * SHELL@.";
+ fprintf fmt " */@.";
+
+ fprintf fmt "struct %s: public Shell {@." (shell_name node_name);
+
+ (* in ports *)
+ fprintf fmt "\t// InputPorts@.";
+ List.iter
+ (fun v ->
+ let v_name = v.var_id in
+ let v_type = pp_c_basic_type_desc (Types.repr v.var_type).Types.tdesc in
+ fprintf fmt "\tReadPort<%s> & port_%s = mk_readPort<%s>(\"%s\", " v_type v_name v_type v_name;
+ print_mauve_default fmt mauve_machine v;
+ fprintf fmt ");@.";
+ ) mauve_machine.mstep.step_inputs;
+ (* out ports *)
+ fprintf fmt "\t// OutputPorts@.";
+ List.iter
+ (fun v ->
+ let v_name = v.var_id in
+ let v_type = pp_c_basic_type_desc (Types.repr v.var_type).Types.tdesc in
+ fprintf fmt "\tWritePort<%s> & port_%s = mk_writePort<%s>(\"%s\");@." v_type v_name v_type v_name;
+ ) mauve_machine.mstep.step_outputs;
+
+ fprintf fmt "};@.";
+
+ pp_print_newline fmt ()
+
+let print_mauve_step fmt node_name mauve_machine =
+ fprintf fmt "\t\t%s_step(" node_name;
+ List.iter
+ (fun v ->
+ let v_name = v.var_id in
+ fprintf fmt "%s, " v_name;
+ ) mauve_machine.mstep.step_inputs;
+ List.iter
+ (fun v ->
+ let v_name = v.var_id in
+ fprintf fmt "&%s, " v_name;
+ ) mauve_machine.mstep.step_outputs;
+ fprintf fmt "node";
+ fprintf fmt ");@."
+
+(* -------------------------------------------------- *)
+(* Core *)
+(* -------------------------------------------------- *)
+
+let print_mauve_core fmt mauve_machine basename prog machines _ (*dependencies*) =
+ let node_name = mauve_machine.mname.node_id in
+
+ fprintf fmt "/*@.";
+ fprintf fmt " * CORE@.";
+ fprintf fmt " */@.";
+
+ fprintf fmt "struct %s: public Core<%s> {@." (core_name node_name) (shell_name node_name);
+
+ (* Attribute *)
+ fprintf fmt "\tstruct %s_mem * node;@." node_name;
+ pp_print_newline fmt ();
+ (* Update *)
+ fprintf fmt "\tvoid update() {@.";
+ List.iter
+ (fun v ->
+ let v_name = v.var_id in
+ let v_type = pp_c_basic_type_desc (Types.repr v.var_type).Types.tdesc in
+ fprintf fmt "\t\t%s %s = port_%s.read();@." v_type v_name v_name;
+ ) mauve_machine.mstep.step_inputs;
+ List.iter
+ (fun v ->
+ let v_name = v.var_id in
+ let v_type = pp_c_basic_type_desc (Types.repr v.var_type).Types.tdesc in
+ fprintf fmt "\t\t%s %s;@." v_type v_name;
+ ) mauve_machine.mstep.step_outputs;
+ print_mauve_step fmt node_name mauve_machine;
+ List.iter
+ (fun v ->
+ let v_name = v.var_id in
+ fprintf fmt "\t\tport_%s.write(%s);@." v_name v_name;
+ ) mauve_machine.mstep.step_outputs;
+ fprintf fmt "\t}@.";
+ pp_print_newline fmt ();
+ (* Configure *)
+ fprintf fmt "\tbool configure_hook() override {@.";
+ fprintf fmt "\t\tnode = %s_alloc();@." node_name;
+ fprintf fmt "\t\t%s_reset(node);@." node_name;
+ fprintf fmt "\t\treturn true;@.";
+ fprintf fmt "\t}@.";
+ pp_print_newline fmt ();
+ (* Cleanup *)
+ fprintf fmt "\tvoid cleanup_hook() override {@.";
+ fprintf fmt "\t\t%s_reset(node);@." node_name;
+ fprintf fmt "\t\t%s_dealloc(node);@." node_name;
+ fprintf fmt "\t}@.";
+ fprintf fmt "};@.";
+ pp_print_newline fmt ()
+
+(* -------------------------------------------------- *)
+(* FSM *)
+(* -------------------------------------------------- *)
+
+let print_period_conversion fmt expr = (
+ match expr.expr_desc with
+ | Expr_tuple [p; u] -> (
+ match u.expr_desc with
+ | Expr_ident "s" -> fprintf fmt "sec_to_ns("; (pp_expr fmt p); fprintf fmt ")"
+ | Expr_ident "ssec"-> fprintf fmt "sec_to_ns("; (pp_expr fmt p); fprintf fmt ")"
+ | Expr_ident "ms" -> fprintf fmt "ms_to_ns(" ; (pp_expr fmt p); fprintf fmt ")"
+ | Expr_ident "ns" -> pp_expr fmt p
+ | _ -> assert false
+ )
+ | _ -> assert false
+ )
+
+let print_mauve_period fmt mauve_machine =
+ let found = ref false in
+ let annotations: expr_annot list = mauve_machine.mname.node_annot in
+ List.iter
+ (fun (al: expr_annot) ->
+ List.iter
+ (fun ((sl, e): string list * eexpr) -> if not !found then match sl with
+ | ["mauve"; "period" ] -> (print_period_conversion fmt e.eexpr_qfexpr); found := true;
+ | _ -> ();
+ ) al.annots;
+ ) annotations;
+ if not !found then fprintf fmt "0"
+
+
+let print_mauve_fsm fmt mauve_machine basename prog machines _ (*dependencies*) =
+ let node_name = mauve_machine.mname.node_id in
+
+ fprintf fmt "/*@.";
+ fprintf fmt " * FSM@.";
+ fprintf fmt " */@.";
+
+ fprintf fmt "struct %s: public FiniteStateMachine<%s, %s> {@." (fsm_name node_name) (shell_name node_name) (core_name node_name);
+
+ (* Attribute *)
+ fprintf fmt "\tExecState<%s> & update = mk_execution (\"Update\" , &%s::update);@." (core_name node_name) (core_name node_name);
+ fprintf fmt "\tSynchroState<%s> & synchro = mk_synchronization(\"Synchro\", " (core_name node_name);
+ print_mauve_period fmt mauve_machine;
+ fprintf fmt ");@.";
+ pp_print_newline fmt ();
+ (* Configure *)
+ fprintf fmt "\tbool configure_hook() override {@.";
+ fprintf fmt "\t\tset_initial(update);@.";
+ fprintf fmt "\t\tset_next(update, synchro);@.";
+ fprintf fmt "\t\tset_next(synchro, update);@.";
+ fprintf fmt "\t\treturn true;@.";
+ fprintf fmt "\t}@.";
+ pp_print_newline fmt ();
+ (* Cleanup *)
+ fprintf fmt "\tvoid cleanup_hook() override {@.";
+ fprintf fmt "\t}@.";
+ fprintf fmt "};@.";
+ pp_print_newline fmt ()
+
+(* Local Variables: *)
+(* compile-command:"make -C ../../.." *)
+(* End: *)
diff --git a/src/backends/C/c_backend_src.ml b/src/backends/C/c_backend_src.ml
index f4a3b532584d6505f3bb243fcae401b72235a30c..37c663a81785a09db6893c576dace3b203d80050 100644
--- a/src/backends/C/c_backend_src.ml
+++ b/src/backends/C/c_backend_src.ml
@@ -30,6 +30,7 @@ struct
(* Instruction Printing functions *)
(********************************************************************************************)
+
(* Computes the depth to which multi-dimension array assignments should be expanded.
It equals the maximum number of nested static array constructions accessible from root [v].
*)
@@ -140,40 +141,42 @@ let rec pp_c_const_suffix var_type fmt c =
(* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *)
let rec pp_value_suffix self var_type loop_vars pp_value fmt value =
- (*Format.eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars;*)
- match loop_vars, value.value_desc with
- | (x, LAcc i) :: q, _ when is_const_index i ->
- let r = ref (Dimension.size_const_dimension (Machine_code.dimension_of_value i)) in
- pp_value_suffix self var_type ((x, LInt r)::q) pp_value fmt value
- | (_, LInt r) :: q, Cst (Const_array cl) ->
- let var_type = Types.array_element_type var_type in
- pp_value_suffix self var_type q pp_value fmt (mk_val (Cst (List.nth cl !r)) Type_predef.type_int)
- | (_, LInt r) :: q, Array vl ->
- let var_type = Types.array_element_type var_type in
- pp_value_suffix self var_type q pp_value fmt (List.nth vl !r)
- | loop_var :: q, Array vl ->
- let var_type = Types.array_element_type var_type in
- Format.fprintf fmt "(%a[]){%a }%a" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_value_suffix self var_type q pp_value)) vl pp_suffix [loop_var]
- | [] , Array vl ->
- let var_type = Types.array_element_type var_type in
- Format.fprintf fmt "(%a[]){%a }" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_value_suffix self var_type [] pp_value)) vl
- | _ :: q, Power (v, n) ->
- pp_value_suffix self var_type q pp_value fmt v
- | _ , Fun (n, vl) ->
- Basic_library.pp_c n (pp_value_suffix self var_type loop_vars pp_value) fmt vl
- | _ , Access (v, i) ->
- let var_type = Type_predef.type_array (Dimension.mkdim_var ()) var_type in
- pp_value_suffix self var_type ((Dimension.mkdim_var (), LAcc i) :: loop_vars) pp_value fmt v
- | _ , LocalVar v -> Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars
- | _ , StateVar v ->
- (* array memory vars are represented by an indirection to a local var with the right type,
- in order to avoid casting everywhere. *)
- if Types.is_array_type v.var_type
- then Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars
- else Format.fprintf fmt "%s->_reg.%a%a" self pp_value v pp_suffix loop_vars
- | _ , Cst cst -> pp_c_const_suffix var_type fmt cst
- | _ , _ -> (Format.eprintf "internal error: C_backend_src.pp_value_suffix %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars; assert false)
-
+ (*Format.eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars;*)
+ (
+ match loop_vars, value.value_desc with
+ | (x, LAcc i) :: q, _ when is_const_index i ->
+ let r = ref (Dimension.size_const_dimension (Machine_code.dimension_of_value i)) in
+ pp_value_suffix self var_type ((x, LInt r)::q) pp_value fmt value
+ | (_, LInt r) :: q, Cst (Const_array cl) ->
+ let var_type = Types.array_element_type var_type in
+ pp_value_suffix self var_type q pp_value fmt (mk_val (Cst (List.nth cl !r)) Type_predef.type_int)
+ | (_, LInt r) :: q, Array vl ->
+ let var_type = Types.array_element_type var_type in
+ pp_value_suffix self var_type q pp_value fmt (List.nth vl !r)
+ | loop_var :: q, Array vl ->
+ let var_type = Types.array_element_type var_type in
+ Format.fprintf fmt "(%a[]){%a }%a" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_value_suffix self var_type q pp_value)) vl pp_suffix [loop_var]
+ | [] , Array vl ->
+ let var_type = Types.array_element_type var_type in
+ Format.fprintf fmt "(%a[]){%a }" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_value_suffix self var_type [] pp_value)) vl
+ | _ :: q, Power (v, n) ->
+ pp_value_suffix self var_type q pp_value fmt v
+ | _ , Fun (n, vl) ->
+ Basic_library.pp_c n (pp_value_suffix self var_type loop_vars pp_value) fmt vl
+ | _ , Access (v, i) ->
+ let var_type = Type_predef.type_array (Dimension.mkdim_var ()) var_type in
+ pp_value_suffix self var_type ((Dimension.mkdim_var (), LAcc i) :: loop_vars) pp_value fmt v
+ | _ , LocalVar v -> Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars
+ | _ , StateVar v ->
+ (* array memory vars are represented by an indirection to a local var with the right type,
+ in order to avoid casting everywhere. *)
+ if Types.is_array_type v.var_type
+ then Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars
+ else Format.fprintf fmt "%s->_reg.%a%a" self pp_value v pp_suffix loop_vars
+ | _ , Cst cst -> pp_c_const_suffix var_type fmt cst
+ | _ , _ -> (Format.eprintf "internal error: C_backend_src.pp_value_suffix %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars; assert false)
+ )
+
(* Subsumes C_backend_common.pp_c_val to cope with aggressive substitution
which may yield constant arrays in expressions.
Type is needed to correctly print constant arrays.
@@ -392,6 +395,11 @@ let print_alloc_instance fmt (i, (m, static)) =
pp_machine_alloc_name (node_name m)
(Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
+let print_dealloc_instance fmt (i, (m, _)) =
+ fprintf fmt "%a (_alloc->%s);@,"
+ pp_machine_dealloc_name (node_name m)
+ i
+
let print_alloc_const fmt m =
let const_locals = List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals in
fprintf fmt "%a%t"
@@ -409,6 +417,10 @@ let print_alloc_array fmt vdecl =
(pp_c_type "") base_type
vdecl.var_id
+let print_dealloc_array fmt vdecl =
+ fprintf fmt "free (_alloc->_reg.%s);@,"
+ vdecl.var_id
+
let print_alloc_code fmt m =
let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
fprintf fmt "%a *_alloc;@,_alloc = (%a *) malloc(sizeof(%a));@,assert(_alloc);@,%a%areturn _alloc;"
@@ -418,6 +430,12 @@ let print_alloc_code fmt m =
(Utils.fprintf_list ~sep:"" print_alloc_array) array_mem
(Utils.fprintf_list ~sep:"" print_alloc_instance) m.minstances
+let print_dealloc_code fmt m =
+ let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
+ fprintf fmt "%a%afree (_alloc);@,return;"
+ (Utils.fprintf_list ~sep:"" print_dealloc_array) array_mem
+ (Utils.fprintf_list ~sep:"" print_dealloc_instance) m.minstances
+
let print_stateless_init_code dependencies fmt m self =
let minit = List.map (function MReset i -> i | _ -> assert false) m.minit in
let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
@@ -588,8 +606,9 @@ let print_step_code dependencies fmt m self =
let print_global_init_code fmt basename prog dependencies =
let baseNAME = file_to_module_name basename in
let constants = List.map const_of_top (get_consts prog) in
- fprintf fmt "@[<v 2>%a {@,static _Bool init = 0;@,@[<v 2>if (!init) { @,init = 1;@,%a%t%a@]@,}@,return;@]@,}@.@."
+ fprintf fmt "@[<v 2>%a {@,static %s init = 0;@,@[<v 2>if (!init) { @,init = 1;@,%a%t%a@]@,}@,return;@]@,}@.@."
print_global_init_prototype baseNAME
+ (pp_c_basic_type_desc Types.Tbool)
(* constants *)
(Utils.fprintf_list ~sep:"@," (pp_const_initialize (pp_c_var_read Machine_code.empty_machine))) constants
(Utils.pp_final_char_if_non_empty "@," dependencies)
@@ -599,8 +618,9 @@ let print_global_init_code fmt basename prog dependencies =
let print_global_clear_code fmt basename prog dependencies =
let baseNAME = file_to_module_name basename in
let constants = List.map const_of_top (get_consts prog) in
- fprintf fmt "@[<v 2>%a {@,static _Bool clear = 0;@,@[<v 2>if (!clear) { @,clear = 1;@,%a%t%a@]@,}@,return;@]@,}@.@."
+ fprintf fmt "@[<v 2>%a {@,static %s clear = 0;@,@[<v 2>if (!clear) { @,clear = 1;@,%a%t%a@]@,}@,return;@]@,}@.@."
print_global_clear_prototype baseNAME
+ (pp_c_basic_type_desc Types.Tbool)
(* constants *)
(Utils.fprintf_list ~sep:"@," (pp_const_clear (pp_c_var_read Machine_code.empty_machine))) constants
(Utils.pp_final_char_if_non_empty "@," dependencies)
@@ -615,13 +635,18 @@ let print_machine dependencies fmt m =
end
else
begin
- (* Alloc function, only if non static mode *)
+ (* Alloc functions, only if non static mode *)
if (not !Options.static_mem) then
begin
fprintf fmt "@[<v 2>%a {@,%a%a@]@,}@.@."
print_alloc_prototype (m.mname.node_id, m.mstatic)
print_alloc_const m
print_alloc_code m;
+
+ fprintf fmt "@[<v 2>%a {@,%a%a@]@,}@.@."
+ print_dealloc_prototype m.mname.node_id
+ print_alloc_const m
+ print_dealloc_code m;
end;
let self = mk_self m in
(* Reset function *)
@@ -682,7 +707,12 @@ let print_lib_c source_fmt basename prog machines dependencies =
fprintf source_fmt "@]@.";
fprintf source_fmt "/* Node allocation function prototypes */@.";
fprintf source_fmt "@[<v>";
- List.iter (fun m -> fprintf source_fmt "%a;@." print_alloc_prototype (m.mname.node_id, m.mstatic)) machines;
+ List.iter
+ (fun m -> fprintf source_fmt "%a;@.@.%a;@.@."
+ print_alloc_prototype (m.mname.node_id, m.mstatic)
+ print_dealloc_prototype m.mname.node_id
+ )
+ machines;
fprintf source_fmt "@]@.";
end;
diff --git a/src/backends/Horn/horn_backend.ml b/src/backends/Horn/horn_backend.ml
index 4b53f2c0083c94630dbf07376a0efa004e32bf3f..76351c408084d9b2e0fd33be20c777d17a4c321d 100644
--- a/src/backends/Horn/horn_backend.ml
+++ b/src/backends/Horn/horn_backend.ml
@@ -27,7 +27,6 @@ open Horn_backend_collecting_sem
(*
TODO:
- gerer les traces. Ca merde pour l'instant dans le calcul des memoires sur les arrows
-
- gerer le reset --- DONE
- reconstruire les rechable states DONE
- reintroduire le cex/traces ... DONE
@@ -52,7 +51,7 @@ end
let load_file f =
let ic = open_in f in
let n = in_channel_length ic in
- let s = String.create n in
+ let s = Bytes.create n in
really_input ic s 0 n;
close_in ic;
(s)
@@ -81,12 +80,12 @@ let print_type_definitions fmt =
let print_dep fmt prog =
Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>.. extracting Horn libraries@,");
- fprintf fmt "; Statically linked libraries@";
+ fprintf fmt "; Statically linked libraries@,";
let dependencies = Corelang.get_dependencies prog in
List.iter
(fun dep ->
let (local, s) = Corelang.dependency_of_top dep in
- let basename = ((if local then !Options.dest_dir else !Options.include_dir)) ^ s ^ ".smt2" in
+ let basename = (Options.name_dependency (local, s)) ^ ".smt2" in
Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@[<v 0> Horn Library %s@," basename);
let horn = load_file basename in
fprintf fmt "@.%s@." horn;
@@ -112,7 +111,16 @@ let check_sfunction mannot =
end
| _::_ -> false
+let preprocess machines =
+ List.fold_right (fun m res ->
+ if List.mem m.mname.node_id registered_keywords then
+ { m with mname = { m.mname with node_id = protect_kwd m.mname.node_id }}::res
+ else
+ m :: res
+ ) machines []
+
let translate fmt basename prog machines=
+ let machines = preprocess machines in
(* We print typedef *)
print_dep fmt prog; (*print static library e.g. math*)
print_type_definitions fmt;
diff --git a/src/backends/Horn/horn_backend_collecting_sem.ml b/src/backends/Horn/horn_backend_collecting_sem.ml
index b8eb14aaf3d00f6c5a99d8e3e4c2c2f6f38f6f82..f6393bcb9ab19956f9b472bfbf5424e4daf5189c 100644
--- a/src/backends/Horn/horn_backend_collecting_sem.ml
+++ b/src/backends/Horn/horn_backend_collecting_sem.ml
@@ -146,8 +146,7 @@ let cex_computation machines fmt node machine =
(Utils.fprintf_list ~sep:" " (pp_horn_var machine)) cex_memory_next ;
fprintf fmt "; Inductive def@.";
- (* Declare dummy inputs. Outputs should have been declared previously with collecting sem *)
- (Utils.fprintf_list ~sep:" " (fun fmt v -> fprintf fmt "%a@." pp_decl_var v)) fmt cex_output_dummy;
+ (* Declare dummy inputs. Outputs should have been declared previously with collecting sem *)
(Utils.fprintf_list ~sep:" " (fun fmt v -> fprintf fmt "%a@." pp_decl_var v)) fmt cex_input_dummy;
fprintf fmt "(declare-var cexcpt Int)@.";
fprintf fmt
diff --git a/src/backends/Horn/horn_backend_common.ml b/src/backends/Horn/horn_backend_common.ml
index 8372781a4b992212b4051fa24a7f5545f82ee3bc..3e3e0263711a66274ecef593e98317f8c9ead61c 100644
--- a/src/backends/Horn/horn_backend_common.ml
+++ b/src/backends/Horn/horn_backend_common.ml
@@ -47,6 +47,22 @@ let pp_conj pp fmt l =
+(********************************************************************************************)
+(* Workaround to prevent the use of declared keywords as node name *)
+(********************************************************************************************)
+let registered_keywords = ["implies"]
+
+let protect_kwd s =
+ if List.mem s registered_keywords then
+ "__" ^ s
+ else
+ s
+
+let node_name n =
+ let name = node_name n in
+ protect_kwd name
+
+
let concat prefix x = if prefix = "" then x else prefix ^ "." ^ x
let rename f = (fun v -> {v with var_id = f v.var_id } )
let rename_machine p = rename (fun n -> concat p n)
@@ -60,17 +76,17 @@ let rename_next = rename (fun n -> n ^ "_x")
let rename_next_list = List.map rename_next
let get_machine machines node_name =
- try
+(* try *)
List.find (fun m -> m.mname.node_id = node_name) machines
-with Not_found -> Format.eprintf "Unable to find machine %s in machines %a@.@?"
- node_name
- (Utils.fprintf_list ~sep:", " (fun fmt m -> pp_print_string fmt m.mname.node_id)) machines
- ; assert false
+(* with Not_found -> Format.eprintf "Unable to find machine %s in machines %a@.@?" *)
+(* node_name *)
+(* (Utils.fprintf_list ~sep:", " (fun fmt m -> pp_print_string fmt m.mname.node_id)) machines *)
+(* ; assert false *)
let local_memory_vars machines machine =
rename_machine_list machine.mname.node_id machine.mmemory
-
-let instances_memory_vars ?(without_arrow=false) machines machine : LustreSpec.var_decl list =
+
+let instances_memory_vars ?(without_arrow=false) machines machine =
let rec aux fst prefix m =
(
if not fst then (
@@ -81,10 +97,10 @@ let instances_memory_vars ?(without_arrow=false) machines machine : LustreSpec.v
List.fold_left (fun accu (id, (n, _)) ->
let name = node_name n in
if without_arrow && name = "_arrow" then
- accu
+ accu
else
let machine_n = get_machine machines name in
- ( aux false (concat prefix
+ ( aux false (concat prefix
(if fst then id else concat m.mname.node_id id))
machine_n ) @ accu
) [] (m.minstances)
@@ -121,16 +137,16 @@ let inout_vars machines m =
let step_vars machines m =
(inout_vars machines m)
- @ (rename_current_list (full_memory_vars machines m))
+ @ (rename_current_list (full_memory_vars machines m))
@ (rename_next_list (full_memory_vars machines m))
let step_vars_m_x machines m =
(inout_vars machines m)
- @ (rename_mid_list (full_memory_vars machines m))
+ @ (rename_mid_list (full_memory_vars machines m))
@ (rename_next_list (full_memory_vars machines m))
let reset_vars machines m =
- (rename_current_list (full_memory_vars machines m))
+ (rename_current_list (full_memory_vars machines m))
@ (rename_mid_list (full_memory_vars machines m))
diff --git a/src/backends/Horn/horn_backend_printers.ml b/src/backends/Horn/horn_backend_printers.ml
index 9bf8d0c5c90839137c1cc2c1d1ca05c5da6d03eb..4068c1c83b19a2703099391fd8d3518902d9ff05 100644
--- a/src/backends/Horn/horn_backend_printers.ml
+++ b/src/backends/Horn/horn_backend_printers.ml
@@ -21,8 +21,7 @@ open Corelang
open Machine_code
open Horn_backend_common
-
-
+
(********************************************************************************************)
(* Instruction Printing functions *)
(********************************************************************************************)
@@ -336,7 +335,7 @@ let rec pp_machine_instr machines reset_instances (m: machine_t) fmt instr : ide
fix here as (not a) or b *)
(pp_horn_val self (pp_horn_var m)) g
tag;
- let rs = pp_machine_instrs machines reset_instances m fmt instrs in
+ let _ (* rs *) = pp_machine_instrs machines reset_instances m fmt instrs in
fprintf fmt "@])";
() (* rs *)
in
diff --git a/src/backends/Horn/horn_backend_traces.ml b/src/backends/Horn/horn_backend_traces.ml
index 433df28892786f3234a44c84c66299d0250bcb54..1ec1e1efbd4cebbaf3b765a2430a5056d5c7f286 100644
--- a/src/backends/Horn/horn_backend_traces.ml
+++ b/src/backends/Horn/horn_backend_traces.ml
@@ -159,12 +159,13 @@ let traces_file fmt basename prog machines =
Printers.pp_expr ee)) (memories_old);
let arrow_vars = arrow_vars machines m in
- let arrow_vars_mid = rename_mid_list arrow_vars and
+ let arrow_vars_curr = rename_current_list arrow_vars and
+ arrow_vars_mid = rename_mid_list arrow_vars and
arrow_vars_next = rename_next_list arrow_vars
in
Utils.fprintf_list ~sep:"@ "
(fun fmt v -> fprintf fmt "<reset name=\"%a\"/>" pp_var v)
- fmt (arrow_vars_mid@arrow_vars_next);
+ fmt (arrow_vars_curr@arrow_vars_mid@arrow_vars_next);
fprintf fmt "@]@ </Node>";
)) (List.rev machines);
fprintf fmt "</Traces>@."
diff --git a/src/basic_library.ml b/src/basic_library.ml
index e353ed28b43bbe179a2198974a0924c6da9ca0d5..51dbc472b6756cd42b8d838d334e591a40f7c499 100644
--- a/src/basic_library.ml
+++ b/src/basic_library.ml
@@ -135,6 +135,9 @@ let is_value_internal_fun v =
| Fun (f, vl) -> is_internal_fun f (List.map (fun v -> v.value_type) vl)
| _ -> assert false
+let is_numeric_operator x =
+ List.mem x arith_funs
+
let is_homomorphic_fun x =
List.mem x internal_funs
diff --git a/src/compiler_common.ml b/src/compiler_common.ml
index 44dd47a7c831618f51f8e59b26733ebebc45d5a3..688b2724b902cd7b79e94e2f427cd1a637d28f45 100644
--- a/src/compiler_common.ml
+++ b/src/compiler_common.ml
@@ -25,7 +25,7 @@ let create_dest_dir () =
begin
if not (Sys.file_exists !Options.dest_dir) then
begin
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. creating destination directory@,");
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. creating destination directory@ ");
Unix.mkdir !Options.dest_dir (Unix.stat ".").Unix.st_perm
end;
if (Unix.stat !Options.dest_dir).Unix.st_kind <> Unix.S_DIR then
@@ -69,7 +69,7 @@ let parse_source source_name =
(* Parsing *)
Log.report ~level:1
- (fun fmt -> fprintf fmt ".. parsing source file %s@," source_name);
+ (fun fmt -> fprintf fmt ".. parsing source file %s@ " source_name);
try
let prog = Parse.prog Parser_lustre.prog Lexer_lustre.token lexbuf in
(*ignore (Modules.load_program ISet.empty prog);*)
@@ -226,16 +226,16 @@ let is_stateful topdecl =
let import_dependencies prog =
- Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>.. extracting dependencies@,");
+ Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 0>.. extracting dependencies@ ");
let dependencies = Corelang.get_dependencies prog in
let deps =
List.fold_left
(fun (compilation_dep, type_env, clock_env) dep ->
let (local, s) = Corelang.dependency_of_top dep in
- let basename = Modules.name_dependency (local, s) in
- Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@[<v 0>Library %s@," basename);
+ let basename = Options.name_dependency (local, s) in
+ Log.report ~level:1 (fun fmt -> Format.fprintf fmt " Library %s@ " basename);
let lusic = Modules.import_dependency dep.top_decl_loc (local, s) in
- Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@]@ ");
+ (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "");*)
let (lusi_type_env, lusi_clock_env) = get_envs_from_top_decls lusic.Lusic.contents in
let is_stateful = List.exists is_stateful lusic.Lusic.contents in
let new_dep = Dep (local, s, lusic.Lusic.contents, is_stateful ) in
@@ -249,3 +249,10 @@ let import_dependencies prog =
deps
end
+let track_exception () =
+ if !Options.track_exceptions
+ then (Printexc.print_backtrace stdout; flush stdout)
+ else ()
+
+
+
diff --git a/src/corelang.ml b/src/corelang.ml
index dd52634c54438cecd951b451d190be8a58bbebfb..68550689da02dd65e63dacda0c6d1675e624c85e 100755
--- a/src/corelang.ml
+++ b/src/corelang.ml
@@ -241,7 +241,7 @@ let is_imported_node td =
(* alias and type definition table *)
-let mktop = mktop_decl Location.dummy_loc !Options.include_dir false
+let mktop = mktop_decl Location.dummy_loc !Options.dest_dir false
let top_int_type = mktop (TypeDef {tydef_id = "int"; tydef_desc = Tydec_int})
let top_bool_type = mktop (TypeDef {tydef_id = "bool"; tydef_desc = Tydec_bool})
@@ -473,8 +473,21 @@ let rec dimension_of_expr expr =
let sort_handlers hl =
List.sort (fun (t, _) (t', _) -> compare t t') hl
+let num_10 = Num.num_of_int 10
+
+let rec is_eq_const c1 c2 =
+ match c1, c2 with
+ | Const_real (n1, i1, _), Const_real (n2, i2, _)
+ -> Num.(let n1 = n1 // (num_10 **/ (num_of_int i1)) in
+ let n2 = n2 // (num_10 **/ (num_of_int i2)) in
+ eq_num n1 n2)
+ | Const_struct lcl1, Const_struct lcl2
+ -> List.length lcl1 = List.length lcl2
+ && List.for_all2 (fun (l1, c1) (l2, c2) -> l1 = l2 && is_eq_const c1 c2) lcl1 lcl2
+ | _ -> c1 = c2
+
let rec is_eq_expr e1 e2 = match e1.expr_desc, e2.expr_desc with
- | Expr_const c1, Expr_const c2 -> c1 = c2
+ | Expr_const c1, Expr_const c2 -> is_eq_const c1 c2
| Expr_ident i1, Expr_ident i2 -> i1 = i2
| Expr_array el1, Expr_array el2
| Expr_tuple el1, Expr_tuple el2 ->
@@ -504,8 +517,13 @@ let get_var id var_list =
List.find (fun v -> v.var_id = id) var_list
let get_node_var id node =
- get_var id (get_node_vars node)
-
+ try
+ get_var id (get_node_vars node)
+ with Not_found -> begin
+ (* Format.eprintf "Unable to find variable %s in node %s@.@?" id node.node_id; *)
+ raise Not_found
+ end
+
let get_node_eqs =
let get_eqs stmts =
List.fold_right
@@ -1033,6 +1051,11 @@ let copy_top top =
let copy_prog top_list =
List.map copy_top top_list
+let functional_backend () =
+ match !Options.output with
+ | "horn" | "lustre" | "acsl" -> true
+ | _ -> false
+
(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
diff --git a/src/corelang.mli b/src/corelang.mli
index f8754778f7ff3091f9b26904e3bd7a32274f31a7..44eec4c548373f99770164e01d4eea86402f0e1e 100755
--- a/src/corelang.mli
+++ b/src/corelang.mli
@@ -124,6 +124,7 @@ val eq_replace_rhs_var: (ident -> bool) -> (ident -> ident) -> eq -> eq
(** rename_prog f_node f_var f_const prog *)
val rename_prog: (ident -> ident) -> (ident -> ident) -> (ident -> ident) -> program -> program
+
val substitute_expr: var_decl list -> eq list -> expr -> expr
val copy_var_decl: var_decl -> var_decl
@@ -139,6 +140,7 @@ val extend_eexpr: (quantifier_type * var_decl list) list -> eexpr -> eexpr
val update_expr_annot: ident -> expr -> expr_annot -> expr
(* val mkpredef_call: Location.t -> ident -> eexpr list -> eexpr*)
+val functional_backend: unit -> bool
(* Local Variables: *)
(* compile-command:"make -C .." *)
(* End: *)
diff --git a/src/dimension.ml b/src/dimension.ml
index 79d6f1f03ee904c1f07a1267f79b4053de34e3ab..ec0b2f26618e50d765841e634ab557c88f5c3364 100644
--- a/src/dimension.ml
+++ b/src/dimension.ml
@@ -243,14 +243,7 @@ let rec eval eval_op eval_const dim =
end
| Dvar -> ()
| Dunivar -> assert false
-(*
-in
-begin
- Format.eprintf "Dimension.eval %a = " pp_dimension dim;
- eval eval_op eval_const dim;
- Format.eprintf "%a@." pp_dimension dim
-end
-*)
+
let uneval const univar =
let univar = repr univar in
match univar.dim_desc with
diff --git a/src/inliner.ml b/src/inliner.ml
index de1f975dc4fff63266d42cabd7e5675502c1be66..167131cafb9a7f2c96f9dbc5dcf3e4cdbd193e3d 100644
--- a/src/inliner.ml
+++ b/src/inliner.ml
@@ -94,8 +94,6 @@ let get_carrier_inputs input_arg_list =
else res)
input_arg_list []
*)
-
-
(*
expr, locals', eqs = inline_call id args' reset locals node nodes
@@ -150,14 +148,14 @@ let inline_call node loc uid args reset locals caller =
*)
vdecl
end
- (*Format.eprintf "Inliner.rename_var %a@." Printers.pp_var v;*)
+ (*Format.eprintf "Inliner.rename_var %a@." Printers.pp_var v;*)
in
let inputs' = List.map (fun (vdecl, _) -> rename_var vdecl) dynamic_inputs in
let outputs' = List.map rename_var node.node_outputs in
let locals' =
- (List.map (fun (vdecl, arg) -> let vdecl' = rename_var vdecl in { vdecl' with var_dec_value = Some (Corelang.expr_of_dimension arg) }) static_inputs)
+ (List.map (fun (vdecl, arg) -> let vdecl' = rename_var vdecl in { vdecl' with var_dec_value = Some (Corelang.expr_of_dimension arg) }) static_inputs)
@ (List.map rename_var node.node_locals)
- in
+in
(* checking we are at the appropriate (early) step: node_checks and
node_gencalls should be empty (not yet assigned) *)
assert (node.node_checks = []);
@@ -444,10 +442,20 @@ let global_inline basename prog type_env clock_env =
| _ -> main_opt, nodes, top::others)
prog (None, [], [])
in
+
(* Recursively each call of a node in the top node is replaced *)
let main_node = Utils.desome main_node in
let main_node' = inline_all_calls main_node other_nodes in
let res = List.map (fun top -> if check_node_name !Options.main_node top then main_node' else top) prog in
+ (* Code snippet from unstable branch. May be used when reactivating witnesses.
+ let res = main_node'::other_tops in
+ if !Options.witnesses then (
+ witness
+ basename
+ (match main_node.top_decl_desc with Node nd -> nd.node_id | _ -> assert false)
+ prog res type_env clock_env
+ );
+*)
res
let local_inline basename prog type_env clock_env =
diff --git a/src/lexerLustreSpec.mll b/src/lexerLustreSpec.mll
index c265bbe88e1d4642b4f699b793988ec2350d9c14..8027d3e836854be88fd77d40a99f67310923af0b 100644
--- a/src/lexerLustreSpec.mll
+++ b/src/lexerLustreSpec.mll
@@ -15,10 +15,10 @@
open Parser_lustre
open Utils
- exception Error of Location.t
-
let str_buf = Buffer.create 1024
+ exception Error of Location.t
+
(* As advised by Caml documentation. This way a single lexer rule is
used to handle all the possible keywords. *)
let keyword_table =
diff --git a/src/liveness.ml b/src/liveness.ml
index 23bd59449713ec8472605153f35c2cafb4b547e1..f754b4ccbf143eb5f2547ad5544bb137bd2e7234 100755
--- a/src/liveness.ml
+++ b/src/liveness.ml
@@ -127,11 +127,7 @@ let is_aliasable_input node var =
| None -> []
| Some (_, args) -> List.fold_right (fun e r -> match e.expr_desc with Expr_ident id -> id::r | _ -> r) args [] in
fun v -> is_aliasable v && List.mem v.var_id inputs_var
-(*
- let res =
-is_aliasable v && List.mem v.var_id inputs_var
- in (Format.eprintf "aliasable %s by %s = %B@." var v.var_id res; res)
-*)
+
(* replace variable [v] by [v'] in graph [g].
[v'] is a dead variable
*)
@@ -207,10 +203,8 @@ let compute_reuse node ctx heads var =
let disjoint_live = Disjunction.CISet.inter disjoint live in
Log.report ~level:7 (fun fmt -> Format.fprintf fmt "disjoint live:%a@." Disjunction.pp_ciset disjoint_live);
let reuse = Disjunction.CISet.max_elt disjoint_live in
- (*let reuse' = Hashtbl.find ctx.policy reuse.var_id in*)
begin
IdentDepGraph.add_edge ctx.dep_graph var.var_id reuse.var_id;
- (*if reuse != reuse' then IdentDepGraph.add_edge ctx.dep_graph reuse.var_id reuse'.var_id;*)
Hashtbl.add ctx.policy var.var_id reuse;
ctx.evaluated <- Disjunction.CISet.add var ctx.evaluated;
(*Format.eprintf "%s reused by live@." var.var_id;*)
@@ -220,13 +214,11 @@ let compute_reuse node ctx heads var =
let dead = Disjunction.CISet.filter (fun v -> is_graph_root v.var_id ctx.dep_graph) quasi_dead in
Log.report ~level:7 (fun fmt -> Format.fprintf fmt "dead:%a@." Disjunction.pp_ciset dead);
let reuse = Disjunction.CISet.choose dead in
- (*let reuse' = Hashtbl.find ctx.policy reuse.var_id in*)
begin
IdentDepGraph.add_edge ctx.dep_graph var.var_id reuse.var_id;
- (*if reuse != reuse' then IdentDepGraph.add_edge ctx.dep_graph reuse.var_id reuse'.var_id;*)
Hashtbl.add ctx.policy var.var_id reuse;
ctx.evaluated <- Disjunction.CISet.add var ctx.evaluated;
- (*Format.eprintf "%s reused by dead %a@." var.var_id Disjunction.pp_ciset dead;*)
+ (*Format.eprintf "%s reused by dead %s@." var.var_id reuse.var_id;*)
end
with Not_found ->
begin
diff --git a/src/log.ml b/src/log.ml
index 24a2846f4f2c2b91887709c8cadf89d69b419fe5..ca13920f96610ed9e6da56d695afae5f5515eda5 100644
--- a/src/log.ml
+++ b/src/log.ml
@@ -13,7 +13,8 @@ let report ~level:level p =
if !Options.verbose_level >= level then
begin
Format.eprintf "%t" p;
- Format.pp_print_flush Format.err_formatter ()
+ (* Removed the flush since it was breaking most open/close boxes *)
+ (* Format.pp_print_flush Format.err_formatter () *)
end
(* Local Variables: *)
diff --git a/src/lusic.ml b/src/lusic.ml
index 76ed1611815d7ecba6ed48cdf5878e67cdf4dedd..72506aecbf233d3b00a7accb8ce9eb1b1e08ab66 100644
--- a/src/lusic.ml
+++ b/src/lusic.ml
@@ -31,17 +31,17 @@ module Header = C_backend_header.Main (HeaderMod)
(* extracts a header from a program representing module owner = dirname/basename *)
let extract_header dirname basename prog =
let owner = dirname ^ "/" ^ basename in
- List.fold_right
- (fun decl header ->
- (*Format.eprintf "Lusic.extract_header: header = %B, owner = %s, decl_owner = %s@." decl.top_decl_itf owner decl.top_decl_owner;*)
- if decl.top_decl_itf || decl.top_decl_owner <> owner then header else
- match decl.top_decl_desc with
- | Node nd -> { decl with top_decl_desc = ImportedNode (Corelang.get_node_interface nd) } :: header
- | ImportedNode _ -> header
- | Const _
- | TypeDef _
- | Open _ -> decl :: header)
- prog []
+ List.fold_right
+ (fun decl header ->
+ (*Format.eprintf "Lusic.extract_header: header = %B, owner = %s, decl_owner = %s@." decl.top_decl_itf owner decl.top_decl_owner;*)
+ if decl.top_decl_itf || decl.top_decl_owner <> owner then header else
+ match decl.top_decl_desc with
+ | Node nd -> { decl with top_decl_desc = ImportedNode (Corelang.get_node_interface nd) } :: header
+ | ImportedNode _ -> header
+ | Const _
+ | TypeDef _
+ | Open _ -> decl :: header)
+ prog []
let check_obsolete lusic basename =
if lusic.obsolete then raise (Error (Location.dummy_loc, Wrong_number basename))
diff --git a/src/lustreSpec.ml b/src/lustreSpec.ml
index dc05e1a1ee3438543ccc2ab82d225df5d82f1cfe..ecc039a857e4d5b4c8dcbed0b579c10f48f241d8 100644
--- a/src/lustreSpec.ml
+++ b/src/lustreSpec.ml
@@ -9,8 +9,6 @@
(* *)
(********************************************************************)
-open Format
-
type ident = Utils.ident
type rat = Utils.rat
type tag = Utils.tag
diff --git a/lustrec.odocl b/src/lustrec.odocl
similarity index 94%
rename from lustrec.odocl
rename to src/lustrec.odocl
index 6e8696909198d6e43399fb5bc51899ecc6cde785..f6d36e4a65853d71b1a83decfc1f6c5cab4f2d64 100644
--- a/lustrec.odocl
+++ b/src/lustrec.odocl
@@ -33,13 +33,17 @@ Log
Lusic
LustreSpec
Machine_code
+Mmap
+Mutation
Main_lustre_compiler
+Main_lustre_testgen
Modules
Mpfr
Normalization
Optimize_machine
Optimize_prog
Options
+PathConditions
Parse
Parser_lustre
Plugins
diff --git a/src/machine_code.ml b/src/machine_code.ml
index 6e0842688681e5c2863313609db249258161cd56..93aabec8235a334787893a17a55dd1d797869ddf 100644
--- a/src/machine_code.ml
+++ b/src/machine_code.ml
@@ -14,6 +14,8 @@ open Corelang
open Clocks
open Causality
+let print_statelocaltag = true
+
exception NormalizationError
module OrdVarDecl:Map.OrderedType with type t=var_decl =
@@ -24,8 +26,17 @@ module ISet = Set.Make(OrdVarDecl)
let rec pp_val fmt v =
match v.value_desc with
| Cst c -> Printers.pp_const fmt c
- | LocalVar v -> Format.pp_print_string fmt v.var_id
- | StateVar v -> Format.pp_print_string fmt v.var_id
+ | LocalVar v ->
+ if print_statelocaltag then
+ Format.fprintf fmt "%s(L)" v.var_id
+ else
+ Format.pp_print_string fmt v.var_id
+
+ | StateVar v ->
+ if print_statelocaltag then
+ Format.fprintf fmt "%s(S)" v.var_id
+ else
+ Format.pp_print_string fmt v.var_id
| Array vl -> Format.fprintf fmt "[%a]" (Utils.fprintf_list ~sep:", " pp_val) vl
| Access (t, i) -> Format.fprintf fmt "%a[%a]" pp_val t pp_val i
| Power (v, n) -> Format.fprintf fmt "(%a^%a)" pp_val v pp_val n
@@ -78,6 +89,8 @@ type machine_t = {
mannot: expr_annot list;
}
+let machine_vars m = m.mstep.step_inputs @ m.mstep.step_locals @ m.mstep.step_outputs @ m.mmemory
+
let pp_step fmt s =
Format.fprintf fmt "@[<v>inputs : %a@ outputs: %a@ locals : %a@ checks : %a@ instrs : @[%a@]@ asserts : @[%a@]@]@ "
(Utils.fprintf_list ~sep:", " Printers.pp_var) s.step_inputs
@@ -105,6 +118,10 @@ let pp_machine fmt m =
(fun fmt -> match m.mspec with | None -> () | Some spec -> Printers.pp_spec fmt spec)
(Utils.fprintf_list ~sep:"@ " Printers.pp_expr_annot) m.mannot
+let pp_machines fmt ml =
+ Format.fprintf fmt "@[<v 0>%a@]" (Utils.fprintf_list ~sep:"@," pp_machine) ml
+
+
let rec is_const_value v =
match v.value_desc with
| Cst _ -> true
@@ -164,7 +181,7 @@ let arrow_desc =
let arrow_top_decl =
{
top_decl_desc = Node arrow_desc;
- top_decl_owner = !Options.include_dir;
+ top_decl_owner = (Options.core_dependency "arrow");
top_decl_itf = false;
top_decl_loc = Location.dummy_loc
}
@@ -353,15 +370,19 @@ let rec translate_expr node ((m, si, j, d, s) as args) expr =
| Expr_appl (id, e, _) when Basic_library.is_expr_internal_fun expr ->
let nd = node_from_name id in
Fun (node_name nd, List.map (translate_expr node args) (expr_list_of_expr e))
- (*| Expr_ite (g,t,e) -> (
+ | Expr_ite (g,t,e) -> (
(* special treatment depending on the active backend. For horn backend, ite
are preserved in expression. While they are removed for C or Java
backends. *)
- match !Options.output with | "horn" ->
- Fun ("ite", [translate_expr node args g; translate_expr node args t; translate_expr node args e])
+ match !Options.output with
+ | "horn" ->
+ Fun ("ite", [translate_expr node args g; translate_expr node args t; translate_expr node args e])
| "C" | "java" | _ ->
- (Printers.pp_expr Format.err_formatter expr; Format.pp_print_flush Format.err_formatter (); raise NormalizationError)
- )*)
+ (Format.eprintf "Normalization error for backend %s: %a@."
+ !Options.output
+ Printers.pp_expr expr;
+ raise NormalizationError)
+ )
| _ -> raise NormalizationError
in
mk_val value_desc expr.expr_type
@@ -388,72 +409,72 @@ let reset_instance node args i r c =
[control_on_clock node args c (conditional g [MReset i] [MNoReset i])]
let translate_eq node ((m, si, j, d, s) as args) eq =
- (* Format.eprintf "translate_eq %a with clock %a@." Printers.pp_node_eq eq Clocks.print_ck eq.eq_rhs.expr_clock; *)
+ (* Format.eprintf "translate_eq %a with clock %a@." Printers.pp_node_eq eq Clocks.print_ck eq.eq_rhs.expr_clock; *)
match eq.eq_lhs, eq.eq_rhs.expr_desc with
| [x], Expr_arrow (e1, e2) ->
- let var_x = get_node_var x node in
- let o = new_instance node arrow_top_decl eq.eq_rhs.expr_tag in
- let c1 = translate_expr node args e1 in
- let c2 = translate_expr node args e2 in
- (m,
- MReset o :: si,
- Utils.IMap.add o (arrow_top_decl, []) j,
- d,
- (control_on_clock node args eq.eq_rhs.expr_clock (MStep ([var_x], o, [c1;c2]))) :: s)
+ let var_x = get_node_var x node in
+ let o = new_instance node arrow_top_decl eq.eq_rhs.expr_tag in
+ let c1 = translate_expr node args e1 in
+ let c2 = translate_expr node args e2 in
+ (m,
+ MReset o :: si,
+ Utils.IMap.add o (arrow_top_decl, []) j,
+ d,
+ (control_on_clock node args eq.eq_rhs.expr_clock (MStep ([var_x], o, [c1;c2]))) :: s)
| [x], Expr_pre e1 when ISet.mem (get_node_var x node) d ->
- let var_x = get_node_var x node in
- (ISet.add var_x m,
- si,
- j,
- d,
- control_on_clock node args eq.eq_rhs.expr_clock (MStateAssign (var_x, translate_expr node args e1)) :: s)
+ let var_x = get_node_var x node in
+ (ISet.add var_x m,
+ si,
+ j,
+ d,
+ control_on_clock node args eq.eq_rhs.expr_clock (MStateAssign (var_x, translate_expr node args e1)) :: s)
| [x], Expr_fby (e1, e2) when ISet.mem (get_node_var x node) d ->
- let var_x = get_node_var x node in
- (ISet.add var_x m,
- MStateAssign (var_x, translate_expr node args e1) :: si,
- j,
- d,
- control_on_clock node args eq.eq_rhs.expr_clock (MStateAssign (var_x, translate_expr node args e2)) :: s)
+ let var_x = get_node_var x node in
+ (ISet.add var_x m,
+ MStateAssign (var_x, translate_expr node args e1) :: si,
+ j,
+ d,
+ control_on_clock node args eq.eq_rhs.expr_clock (MStateAssign (var_x, translate_expr node args e2)) :: s)
| p , Expr_appl (f, arg, r) when not (Basic_library.is_expr_internal_fun eq.eq_rhs) ->
- let var_p = List.map (fun v -> get_node_var v node) p in
- let el = expr_list_of_expr arg in
- let vl = List.map (translate_expr node args) el in
- let node_f = node_from_name f in
- let call_f =
- node_f,
- NodeDep.filter_static_inputs (node_inputs node_f) el in
- let o = new_instance node node_f eq.eq_rhs.expr_tag in
- let env_cks = List.fold_right (fun arg cks -> arg.expr_clock :: cks) el [eq.eq_rhs.expr_clock] in
- let call_ck = Clock_calculus.compute_root_clock (Clock_predef.ck_tuple env_cks) in
- (*Clocks.new_var true in
- Clock_calculus.unify_imported_clock (Some call_ck) eq.eq_rhs.expr_clock eq.eq_rhs.expr_loc;
- Format.eprintf "call %a: %a: %a@," Printers.pp_expr eq.eq_rhs Clocks.print_ck (Clock_predef.ck_tuple env_cks) Clocks.print_ck call_ck;*)
- (m,
- (if Stateless.check_node node_f then si else MReset o :: si),
- Utils.IMap.add o call_f j,
- d,
- (if Stateless.check_node node_f
- then []
- else reset_instance node args o r call_ck) @
- (control_on_clock node args call_ck (MStep (var_p, o, vl))) :: s)
-(*
- (* special treatment depending on the active backend. For horn backend, x = ite (g,t,e)
- are preserved. While they are replaced as if g then x = t else x = e in C or Java
- backends. *)
- | [x], Expr_ite (c, t, e)
+ let var_p = List.map (fun v -> get_node_var v node) p in
+ let el = expr_list_of_expr arg in
+ let vl = List.map (translate_expr node args) el in
+ let node_f = node_from_name f in
+ let call_f =
+ node_f,
+ NodeDep.filter_static_inputs (node_inputs node_f) el in
+ let o = new_instance node node_f eq.eq_rhs.expr_tag in
+ let env_cks = List.fold_right (fun arg cks -> arg.expr_clock :: cks) el [eq.eq_rhs.expr_clock] in
+ let call_ck = Clock_calculus.compute_root_clock (Clock_predef.ck_tuple env_cks) in
+ (*Clocks.new_var true in
+ Clock_calculus.unify_imported_clock (Some call_ck) eq.eq_rhs.expr_clock eq.eq_rhs.expr_loc;
+ Format.eprintf "call %a: %a: %a@," Printers.pp_expr eq.eq_rhs Clocks.print_ck (Clock_predef.ck_tuple env_cks) Clocks.print_ck call_ck;*)
+ (m,
+ (if Stateless.check_node node_f then si else MReset o :: si),
+ Utils.IMap.add o call_f j,
+ d,
+ (if Stateless.check_node node_f
+ then []
+ else reset_instance node args o r call_ck) @
+ (control_on_clock node args call_ck (MStep (var_p, o, vl))) :: s)
+ (*
+ (* special treatment depending on the active backend. For horn backend, x = ite (g,t,e)
+ are preserved. While they are replaced as if g then x = t else x = e in C or Java
+ backends. *)
+ | [x], Expr_ite (c, t, e)
when (match !Options.output with | "horn" -> true | "C" | "java" | _ -> false)
- ->
+ ->
let var_x = get_node_var x node in
(m,
- si,
- j,
- d,
- (control_on_clock node args eq.eq_rhs.expr_clock
- (MLocalAssign (var_x, translate_expr node args eq.eq_rhs))::s)
+ si,
+ j,
+ d,
+ (control_on_clock node args eq.eq_rhs.expr_clock
+ (MLocalAssign (var_x, translate_expr node args eq.eq_rhs))::s)
)
-*)
+ *)
| [x], _ -> (
let var_x = get_node_var x node in
(m, si, j, d,
@@ -465,10 +486,10 @@ let translate_eq node ((m, si, j, d, s) as args) eq =
)
)
| _ ->
- begin
- Format.eprintf "internal error: Machine_code.translate_eq %a@?" Printers.pp_node_eq eq;
- assert false
- end
+ begin
+ Format.eprintf "internal error: Machine_code.translate_eq %a@?" Printers.pp_node_eq eq;
+ assert false
+ end
let find_eq xl eqs =
let rec aux accu eqs =
@@ -534,14 +555,47 @@ let translate_decl nd sch =
let sorted_eqs = sort_equations_from_schedule nd sch in
let constant_eqs = constant_equations nd in
-
- let init_args = ISet.empty, [], Utils.IMap.empty, List.fold_right (fun l -> ISet.add l) nd.node_locals ISet.empty, [] in
+
+ (* In case of non functional backend (eg. C), additional local variables have
+ to be declared for each assert *)
+ let new_locals, assert_instrs, nd_node_asserts =
+ let exprl = List.map (fun assert_ -> assert_.assert_expr ) nd.node_asserts in
+ if Corelang.functional_backend () then
+ [], [], exprl
+ else (* Each assert(e) is associated to a fresh variable v and declared as
+ v=e; assert (v); *)
+ let _, vars, eql, assertl =
+ List.fold_left (fun (i, vars, eqlist, assertlist) expr ->
+ let loc = expr.expr_loc in
+ let var_id = nd.node_id ^ "_assert_" ^ string_of_int i in
+ let assert_var =
+ mkvar_decl
+ loc
+ ~orig:false (* fresh var *)
+ (var_id,
+ mktyp loc Tydec_bool,
+ mkclock loc Ckdec_any,
+ false, (* not a constant *)
+ None (* no default value *)
+ )
+ in
+ assert_var.var_type <- Types.new_ty (Types.Tbool);
+ let eq = mkeq loc ([var_id], expr) in
+ (i+1, assert_var::vars, eq::eqlist, {expr with expr_desc = Expr_ident var_id}::assertlist)
+ ) (1, [], [], []) exprl
+ in
+ vars, eql, assertl
+ in
+ let locals_list = nd.node_locals @ new_locals in
+
+ let nd = { nd with node_locals = locals_list } in
+ let init_args = ISet.empty, [], Utils.IMap.empty, List.fold_right (fun l -> ISet.add l) locals_list ISet.empty, [] in
(* memories, init instructions, node calls, local variables (including memories), step instrs *)
let m0, init0, j0, locals0, s0 = translate_eqs nd init_args constant_eqs in
assert (ISet.is_empty m0);
assert (init0 = []);
assert (Utils.IMap.is_empty j0);
- let m, init, j, locals, s = translate_eqs nd (m0, init0, j0, locals0, []) sorted_eqs in
+ let m, init, j, locals, s = translate_eqs nd (m0, init0, j0, locals0, []) (assert_instrs@sorted_eqs) in
let mmap = Utils.IMap.fold (fun i n res -> (i, n)::res) j [] in
{
mname = nd;
@@ -564,10 +618,7 @@ let translate_decl nd sch =
| "horn" -> s
| "C" | "java" | _ ->*) join_guards_list s
);
- step_asserts =
- let exprl = List.map (fun assert_ -> assert_.assert_expr ) nd.node_asserts in
- List.map (translate_expr nd init_args) exprl
- ;
+ step_asserts = List.map (translate_expr nd init_args) nd_node_asserts;
};
mspec = nd.node_spec;
mannot = nd.node_annot;
diff --git a/src/main_lustre_compiler.ml b/src/main_lustre_compiler.ml
index 8aa4dde7ea341af6d31fe363505aa59e7ab4bf95..0b6abe6c9f509d666bc2ebe71ea6b990e14ba008 100644
--- a/src/main_lustre_compiler.ml
+++ b/src/main_lustre_compiler.ml
@@ -50,7 +50,7 @@ let compile_header dirname basename extension =
(fun fmt -> fprintf fmt ".. generating compiled header file %sc@," (destname ^ extension));
Lusic.write_lusic true header destname lusic_ext;
Lusic.print_lusic_to_h destname lusic_ext;
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@.")
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@ ")
end
(* check whether a source file has a compiled header,
@@ -88,17 +88,12 @@ let compile_source_to_header prog computed_types_env computed_clocks_env dirname
end
-let functional_backend () =
- match !Options.output with
- | "horn" | "lustre" | "emf" | "acsl" -> true
- | _ -> false
(* From prog to prog *)
let stage1 prog dirname basename =
- (* Removing automata *)
+ (* Removing automata *)
let prog = expand_automata prog in
-
- Log.report ~level:4 (fun fmt -> fprintf fmt ".. after automata expansion:@.@[<v 2>@ %a@]@," Printers.pp_prog prog);
+ Log.report ~level:4 (fun fmt -> fprintf fmt ".. after automata expansion:@, @[<v 2>@,%a@]@ " Printers.pp_prog prog);
(* Importing source *)
let _ = Modules.load_program ISet.empty prog in
@@ -120,7 +115,7 @@ let stage1 prog dirname basename =
in
(* Checking stateless/stateful status *)
- if Scopes.Plugin.is_active () then
+ if Plugins.check_force_stateful () then
force_stateful_decls prog
else
check_stateless_decls prog;
@@ -251,36 +246,42 @@ let stage2 prog =
- introduce fresh local variables for each real pure subexpression
*)
(* DFS with modular code generation *)
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines generation@ ");
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines generation@,");
let machine_code = Machine_code.translate_prog prog node_schs in
- Log.report ~level:4 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,"
- (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
- machine_code);
+ Log.report ~level:3 (fun fmt -> fprintf fmt ".. generated machines (unoptimized):@ %a@ "Machine_code.pp_machines machine_code);
(* Optimize machine code *)
let machine_code =
- if !Options.optimization >= 4 && !Options.output <> "horn" then
+ if !Options.optimization >= 4 (* && !Options.output <> "horn" *) then
begin
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines optimization: common sub-expression elimination@,");
- Optimize_machine.machines_cse machine_code
+ Log.report ~level:1
+ (fun fmt -> fprintf fmt ".. machines optimization: sub-expression elimination@,");
+ let machine_code = Optimize_machine.machines_cse machine_code in
+ Log.report ~level:3 (fun fmt -> fprintf fmt ".. generated machines (sub-expr elim):@ %a@ "Machine_code.pp_machines machine_code);
+ machine_code
end
else
machine_code
in
(* Optimize machine code *)
let machine_code, removed_table =
- if !Options.optimization >= 2 && !Options.output <> "horn" then
+ if !Options.optimization >= 2 (*&& !Options.output <> "horn"*) then
begin
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines optimization: constants inlining@,");
- Optimize_machine.machines_unfold (Corelang.get_consts prog) node_schs machine_code
+ Log.report ~level:1 (fun fmt -> fprintf fmt
+ ".. machines optimization: const. inlining (partial eval. with const)@,");
+ let machine_code, removed_table = Optimize_machine.machines_unfold (Corelang.get_consts prog) node_schs machine_code in
+ Log.report ~level:3 (fun fmt -> fprintf fmt "\t@[Eliminated constants: @[%a@]@]@ "
+ (pp_imap Optimize_machine.pp_elim) removed_table);
+ Log.report ~level:3 (fun fmt -> fprintf fmt ".. generated machines (const inlining):@ %a@ "Machine_code.pp_machines machine_code);
+ machine_code, removed_table
end
else
machine_code, IMap.empty
in
(* Optimize machine code *)
- let machine_code =
- if !Options.optimization >= 3 && !Options.output <> "horn" then
+ let machine_code =
+ if !Options.optimization >= 3 && not (Corelang.functional_backend ()) then
begin
Log.report ~level:1 (fun fmt -> fprintf fmt ".. machines optimization: minimize stack usage by reusing variables@,");
let node_schs = Scheduling.remove_prog_inlined_locals removed_table node_schs in
@@ -385,7 +386,7 @@ let stage3 prog machine_code dependencies basename =
let rec compile_source dirname basename extension =
let source_name = dirname ^ "/" ^ basename ^ extension in
- Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v>");
+ Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 0>");
(* Parsing source *)
let prog = parse_source source_name in
@@ -397,13 +398,14 @@ let rec compile_source dirname basename extension =
prog
in
let prog, dependencies =
+ Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>.. Phase 1 : Normalisation@,");
try
stage1 prog dirname basename
with StopPhase1 prog -> (
if !Options.lusi then
begin
let lusi_ext = extension ^ "i" in
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. generating interface file %s@," (basename ^ lusi_ext));
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. generating interface file %s@ " (basename ^ lusi_ext));
print_lusi prog dirname basename lusi_ext;
Log.report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@.");
exit 0
@@ -412,32 +414,37 @@ let rec compile_source dirname basename extension =
assert false
)
in
+ Log.report ~level:1 (fun fmt -> fprintf fmt "@]@,");
+ Log.report ~level:3 (fun fmt -> fprintf fmt ".. Normalized program:@ %a@ "Printers.pp_prog prog);
+
+ Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>.. Phase 2 : Machines generation@,");
let machine_code =
stage2 prog
in
+
+ Log.report ~level:1 (fun fmt -> fprintf fmt "@]@ ");
+ Log.report ~level:3 (fun fmt -> fprintf fmt ".. Generated machines:@ %a@ "Machine_code.pp_machines machine_code);
+
if Scopes.Plugin.show_scopes () then
begin
let all_scopes = Scopes.compute_scopes prog !Options.main_node in
(* Printing scopes *)
if !Options.verbose_level >= 1 then
Format.printf "Possible scopes are:@ ";
- Format.printf "@[<v>%a@ @]@.@?" Scopes.print_scopes all_scopes;
+ Format.printf "@[<v>%a@ @]@ @?" Scopes.print_scopes all_scopes;
exit 0
end;
- let machine_code =
- if Scopes.Plugin.is_active () then
- Scopes.Plugin.process_scopes !Options.main_node prog machine_code
- else
- machine_code
- in
+ let machine_code = Plugins.refine_machine_code prog machine_code in
stage3 prog machine_code dependencies basename;
- Log.report ~level:1 (fun fmt -> fprintf fmt ".. done @ @]@.");
+ begin
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@.");
(* We stop the process here *)
- exit 0
+ exit 0
+ end
let compile dirname basename extension =
match extension with
@@ -466,13 +473,7 @@ let _ =
try
Printexc.record_backtrace true;
- let options = Options.options @
- List.flatten (
- List.map Options.plugin_opt [
- Scopes.Plugin.name, Scopes.Plugin.activate, Scopes.Plugin.options
- ]
- )
- in
+ let options = Options.lustrec_options @ (Plugins.options ()) in
Arg.parse options anonymous usage
with
@@ -481,7 +482,7 @@ let _ =
| Corelang.Error _ (*| Task_set.Error _*)
| Causality.Error _ -> exit 1
| Sys_error msg -> (eprintf "Failure: %s@." msg)
- | exc -> (Utils.track_exception (); raise exc)
+ | exc -> (track_exception (); raise exc)
(* Local Variables: *)
(* compile-command:"make -C .." *)
diff --git a/src/main_lustre_testgen.ml b/src/main_lustre_testgen.ml
new file mode 100644
index 0000000000000000000000000000000000000000..6979999a54cdf9cb08d185d10830c7377c5da3ae
--- /dev/null
+++ b/src/main_lustre_testgen.ml
@@ -0,0 +1,179 @@
+(********************************************************************)
+(* *)
+(* The LustreC compiler toolset / The LustreC Development Team *)
+(* Copyright 2012 - -- ONERA - CNRS - INPT *)
+(* *)
+(* LustreC is free software, distributed WITHOUT ANY WARRANTY *)
+(* under the terms of the GNU Lesser General Public License *)
+(* version 2.1. *)
+(* *)
+(********************************************************************)
+
+(* This module is used for the lustre test generator *)
+
+open Format
+open Log
+
+open Utils
+open LustreSpec
+open Compiler_common
+
+let usage = "Usage: lustret [options] \x1b[4msource file\x1b[0m"
+
+let extensions = [".lus"]
+
+(* From prog to prog *)
+let stage1 prog dirname basename =
+ (* Removing automata *)
+ let prog = expand_automata prog in
+
+ Log.report ~level:4 (fun fmt -> fprintf fmt ".. after automata expansion:@.@[<v 2>@ %a@]@," Printers.pp_prog prog);
+
+ (* Importing source *)
+ let _ = Modules.load_program ISet.empty prog in
+
+ (* Extracting dependencies *)
+ let dependencies, type_env, clock_env = import_dependencies prog in
+
+ (* Sorting nodes *)
+ let prog = SortProg.sort prog in
+
+ (* Perform inlining before any analysis *)
+ let orig, prog =
+ if !Options.global_inline && !Options.main_node <> "" then
+ (if !Options.witnesses then prog else []),
+ Inliner.global_inline basename prog type_env clock_env
+ else (* if !Option.has_local_inline *)
+ [],
+ Inliner.local_inline basename prog type_env clock_env
+ in
+
+ check_stateless_decls prog;
+
+ (* Typing *)
+ let _ (*computed_types_env*) = type_decls type_env prog in
+
+ (* Clock calculus *)
+ let _ (*computed_clocks_env*) = clock_decls clock_env prog in
+
+ (* Creating destination directory if needed *)
+ create_dest_dir ();
+
+ Typing.uneval_prog_generics prog;
+ Clock_calculus.uneval_prog_generics prog;
+
+ if !Options.global_inline && !Options.main_node <> "" && !Options.witnesses then
+ begin
+ let orig = Corelang.copy_prog orig in
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. generating witness file@,");
+ check_stateless_decls orig;
+ let _ = Typing.type_prog type_env orig in
+ let _ = Clock_calculus.clock_prog clock_env orig in
+ Typing.uneval_prog_generics orig;
+ Clock_calculus.uneval_prog_generics orig;
+ Inliner.witness
+ basename
+ !Options.main_node
+ orig prog type_env clock_env
+ end;
+
+ (* Normalization phase *)
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. normalization@,");
+ (* Special treatment of arrows in lustre backend. We want to keep them *)
+ if !Options.output = "lustre" then
+ Normalization.unfold_arrow_active := false;
+ let prog = Normalization.normalize_prog prog in
+ Log.report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Printers.pp_prog prog);
+
+ prog, dependencies
+
+let testgen_source dirname basename extension =
+ let source_name = dirname ^ "/" ^ basename ^ extension in
+
+ Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v>");
+
+ (* Parsing source *)
+ let prog = parse_source source_name in
+
+ let prog, dependencies = stage1 prog dirname basename in
+
+ if !Options.gen_mcdc then (
+ PathConditions.mcdc prog;
+ exit 0
+ ) ;
+ (* generate mutants *)
+ let mutants, mutation_printer = Mutation.mutate !Options.nb_mutants prog in
+
+ (* Print generated mutants in target directory. *)
+ let cpt = ref 0 in
+ List.iter (fun (mutation, mutant) ->
+ (* Debugging code *)
+ (* if List.mem !cpt [238;371;601;799;875;998] then *)
+ (* Format.eprintf "Mutant %i: %a -> %a" !cpt Printers.pp_expr orig_e Printers.pp_expr new_e *)
+ (* ; *)
+ incr cpt;
+ let mutant_filename =
+ match !Options.dest_dir with
+ | "" -> (* Mutants are generated in source directory *)
+ basename^ ".mutant.n" ^ (string_of_int !cpt) ^ extension
+ | dir -> (* Mutants are generated in target directory *)
+ dir ^ "/" ^ (Filename.basename basename)^ ".mutant.n" ^ (string_of_int !cpt) ^ extension
+ in
+ let mutant_out = (
+ try
+ open_out mutant_filename
+ with
+ Sys_error _ -> Format.eprintf "Unable to open file %s for writing.@." mutant_filename; exit 1
+ )
+ in
+ let mutant_fmt = formatter_of_out_channel mutant_out in
+ report ~level:1 (fun fmt -> fprintf fmt ".. generating mutant %s: %a@,@?" mutant_filename mutation_printer mutation);
+ Format.fprintf mutant_fmt "%a@." Printers.pp_prog mutant
+ )
+ mutants;
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. done @ @]@.");
+ (* We stop the process here *)
+ exit 0
+
+let testgen dirname basename extension =
+ match extension with
+ | ".lus" -> testgen_source dirname basename extension
+ | _ -> assert false
+
+let anonymous filename =
+ let ok_ext, ext = List.fold_left
+ (fun (ok, ext) ext' ->
+ if not ok && Filename.check_suffix filename ext' then
+ true, ext'
+ else
+ ok, ext)
+ (false, "") extensions in
+ if ok_ext then
+ let dirname = Filename.dirname filename in
+ let basename = Filename.chop_suffix (Filename.basename filename) ext in
+ testgen dirname basename ext
+ else
+ raise (Arg.Bad ("Can only compile *.lus files"))
+
+let _ =
+ Global.initialize ();
+ Corelang.add_internal_funs ();
+ try
+ Printexc.record_backtrace true;
+
+ let options = Options.lustret_options
+
+ in
+
+ Arg.parse options anonymous usage
+ with
+ | Parse.Error _
+ | Types.Error (_,_) | Clocks.Error (_,_)
+ | Corelang.Error _ (*| Task_set.Error _*)
+ | Causality.Error _ -> exit 1
+ | Sys_error msg -> (eprintf "Failure: %s@." msg)
+ | exc -> (track_exception (); raise exc)
+
+(* Local Variables: *)
+(* compile-command:"make -C .." *)
+(* End: *)
diff --git a/src/mmap.ml b/src/mmap.ml
new file mode 100644
index 0000000000000000000000000000000000000000..7d65bc6bc93299c5b7bba60f2804667765aae61a
--- /dev/null
+++ b/src/mmap.ml
@@ -0,0 +1,337 @@
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU Library General Public License, with *)
+(* the special exception on linking described in file ../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+module type OrderedType =
+ sig
+ type t
+ val compare: t -> t -> int
+ end
+
+module type S =
+ sig
+ type key
+ type +'a t
+ val empty: 'a t
+ val is_empty: 'a t -> bool
+ val mem: key -> 'a t -> bool
+ val add: key -> 'a -> 'a t -> 'a t
+ val singleton: key -> 'a -> 'a t
+ val remove: key -> 'a t -> 'a t
+ val merge:
+ (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+ val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
+ val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+ val iter: (key -> 'a -> unit) -> 'a t -> unit
+ val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val for_all: (key -> 'a -> bool) -> 'a t -> bool
+ val exists: (key -> 'a -> bool) -> 'a t -> bool
+ val filter: (key -> 'a -> bool) -> 'a t -> 'a t
+ val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+ val cardinal: 'a t -> int
+ val bindings: 'a t -> (key * 'a) list
+ val min_binding: 'a t -> (key * 'a)
+ val max_binding: 'a t -> (key * 'a)
+ val choose: 'a t -> (key * 'a)
+ val split: key -> 'a t -> 'a t * 'a option * 'a t
+ val find: key -> 'a t -> 'a
+ val map: ('a -> 'b) -> 'a t -> 'b t
+ val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t
+ end
+
+module Make(Ord: OrderedType) = struct
+
+ type key = Ord.t
+
+ type 'a t =
+ Empty
+ | Node of 'a t * key * 'a * 'a t * int
+
+ let height = function
+ Empty -> 0
+ | Node(_,_,_,_,h) -> h
+
+ let create l x d r =
+ let hl = height l and hr = height r in
+ Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+ let singleton x d = Node(Empty, x, d, Empty, 1)
+
+ let bal l x d r =
+ let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
+ let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
+ if hl > hr + 2 then begin
+ match l with
+ Empty -> invalid_arg "Map.bal"
+ | Node(ll, lv, ld, lr, _) ->
+ if height ll >= height lr then
+ create ll lv ld (create lr x d r)
+ else begin
+ match lr with
+ Empty -> invalid_arg "Map.bal"
+ | Node(lrl, lrv, lrd, lrr, _)->
+ create (create ll lv ld lrl) lrv lrd (create lrr x d r)
+ end
+ end else if hr > hl + 2 then begin
+ match r with
+ Empty -> invalid_arg "Map.bal"
+ | Node(rl, rv, rd, rr, _) ->
+ if height rr >= height rl then
+ create (create l x d rl) rv rd rr
+ else begin
+ match rl with
+ Empty -> invalid_arg "Map.bal"
+ | Node(rll, rlv, rld, rlr, _) ->
+ create (create l x d rll) rlv rld (create rlr rv rd rr)
+ end
+ end else
+ Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+ let empty = Empty
+
+ let is_empty = function Empty -> true | _ -> false
+
+ let rec add x data = function
+ Empty ->
+ Node(Empty, x, data, Empty, 1)
+ | Node(l, v, d, r, h) ->
+ let c = Ord.compare x v in
+ if c = 0 then
+ Node(l, x, data, r, h)
+ else if c < 0 then
+ bal (add x data l) v d r
+ else
+ bal l v d (add x data r)
+
+ let rec find x = function
+ Empty ->
+ raise Not_found
+ | Node(l, v, d, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then d
+ else find x (if c < 0 then l else r)
+
+ let rec mem x = function
+ Empty ->
+ false
+ | Node(l, v, d, r, _) ->
+ let c = Ord.compare x v in
+ c = 0 || mem x (if c < 0 then l else r)
+
+ let rec min_binding = function
+ Empty -> raise Not_found
+ | Node(Empty, x, d, r, _) -> (x, d)
+ | Node(l, x, d, r, _) -> min_binding l
+
+ let rec max_binding = function
+ Empty -> raise Not_found
+ | Node(l, x, d, Empty, _) -> (x, d)
+ | Node(l, x, d, r, _) -> max_binding r
+
+ let rec remove_min_binding = function
+ Empty -> invalid_arg "Map.remove_min_elt"
+ | Node(Empty, x, d, r, _) -> r
+ | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
+
+ let merge t1 t2 =
+ match (t1, t2) with
+ (Empty, t) -> t
+ | (t, Empty) -> t
+ | (_, _) ->
+ let (x, d) = min_binding t2 in
+ bal t1 x d (remove_min_binding t2)
+
+ let rec remove x = function
+ Empty ->
+ Empty
+ | Node(l, v, d, r, h) ->
+ let c = Ord.compare x v in
+ if c = 0 then
+ merge l r
+ else if c < 0 then
+ bal (remove x l) v d r
+ else
+ bal l v d (remove x r)
+
+ let rec iter f = function
+ Empty -> ()
+ | Node(l, v, d, r, _) ->
+ iter f l; f v d; iter f r
+
+ let rec map f = function
+ Empty ->
+ Empty
+ | Node(l, v, d, r, h) ->
+ let l' = map f l in
+ let d' = f d in
+ let r' = map f r in
+ Node(l', v, d', r', h)
+
+ let rec mapi f = function
+ Empty ->
+ Empty
+ | Node(l, v, d, r, h) ->
+ let l' = mapi f l in
+ let d' = f v d in
+ let r' = mapi f r in
+ Node(l', v, d', r', h)
+
+ let rec fold f m accu =
+ match m with
+ Empty -> accu
+ | Node(l, v, d, r, _) ->
+ fold f r (f v d (fold f l accu))
+
+ let rec for_all p = function
+ Empty -> true
+ | Node(l, v, d, r, _) -> p v d && for_all p l && for_all p r
+
+ let rec exists p = function
+ Empty -> false
+ | Node(l, v, d, r, _) -> p v d || exists p l || exists p r
+
+ (* Beware: those two functions assume that the added k is *strictly*
+ smaller (or bigger) than all the present keys in the tree; it
+ does not test for equality with the current min (or max) key.
+
+ Indeed, they are only used during the "join" operation which
+ respects this precondition.
+ *)
+
+ let rec add_min_binding k v = function
+ | Empty -> singleton k v
+ | Node (l, x, d, r, h) ->
+ bal (add_min_binding k v l) x d r
+
+ let rec add_max_binding k v = function
+ | Empty -> singleton k v
+ | Node (l, x, d, r, h) ->
+ bal l x d (add_max_binding k v r)
+
+ (* Same as create and bal, but no assumptions are made on the
+ relative heights of l and r. *)
+
+ let rec join l v d r =
+ match (l, r) with
+ (Empty, _) -> add_min_binding v d r
+ | (_, Empty) -> add_max_binding v d l
+ | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) ->
+ if lh > rh + 2 then bal ll lv ld (join lr v d r) else
+ if rh > lh + 2 then bal (join l v d rl) rv rd rr else
+ create l v d r
+
+ (* Merge two trees l and r into one.
+ All elements of l must precede the elements of r.
+ No assumption on the heights of l and r. *)
+
+ let concat t1 t2 =
+ match (t1, t2) with
+ (Empty, t) -> t
+ | (t, Empty) -> t
+ | (_, _) ->
+ let (x, d) = min_binding t2 in
+ join t1 x d (remove_min_binding t2)
+
+ let concat_or_join t1 v d t2 =
+ match d with
+ | Some d -> join t1 v d t2
+ | None -> concat t1 t2
+
+ let rec split x = function
+ Empty ->
+ (Empty, None, Empty)
+ | Node(l, v, d, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then (l, Some d, r)
+ else if c < 0 then
+ let (ll, pres, rl) = split x l in (ll, pres, join rl v d r)
+ else
+ let (lr, pres, rr) = split x r in (join l v d lr, pres, rr)
+
+ let rec merge f s1 s2 =
+ match (s1, s2) with
+ (Empty, Empty) -> Empty
+ | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 ->
+ let (l2, d2, r2) = split v1 s2 in
+ concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2)
+ | (_, Node (l2, v2, d2, r2, h2)) ->
+ let (l1, d1, r1) = split v2 s1 in
+ concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2)
+ | _ ->
+ assert false
+
+ let rec filter p = function
+ Empty -> Empty
+ | Node(l, v, d, r, _) ->
+ (* call [p] in the expected left-to-right order *)
+ let l' = filter p l in
+ let pvd = p v d in
+ let r' = filter p r in
+ if pvd then join l' v d r' else concat l' r'
+
+ let rec partition p = function
+ Empty -> (Empty, Empty)
+ | Node(l, v, d, r, _) ->
+ (* call [p] in the expected left-to-right order *)
+ let (lt, lf) = partition p l in
+ let pvd = p v d in
+ let (rt, rf) = partition p r in
+ if pvd
+ then (join lt v d rt, concat lf rf)
+ else (concat lt rt, join lf v d rf)
+
+ type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration
+
+ let rec cons_enum m e =
+ match m with
+ Empty -> e
+ | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e))
+
+ let compare cmp m1 m2 =
+ let rec compare_aux e1 e2 =
+ match (e1, e2) with
+ (End, End) -> 0
+ | (End, _) -> -1
+ | (_, End) -> 1
+ | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
+ let c = Ord.compare v1 v2 in
+ if c <> 0 then c else
+ let c = cmp d1 d2 in
+ if c <> 0 then c else
+ compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
+ in compare_aux (cons_enum m1 End) (cons_enum m2 End)
+
+ let equal cmp m1 m2 =
+ let rec equal_aux e1 e2 =
+ match (e1, e2) with
+ (End, End) -> true
+ | (End, _) -> false
+ | (_, End) -> false
+ | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
+ Ord.compare v1 v2 = 0 && cmp d1 d2 &&
+ equal_aux (cons_enum r1 e1) (cons_enum r2 e2)
+ in equal_aux (cons_enum m1 End) (cons_enum m2 End)
+
+ let rec cardinal = function
+ Empty -> 0
+ | Node(l, _, _, r, _) -> cardinal l + 1 + cardinal r
+
+ let rec bindings_aux accu = function
+ Empty -> accu
+ | Node(l, v, d, r, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l
+
+ let bindings s =
+ bindings_aux [] s
+
+ let choose = min_binding
+
+end
diff --git a/src/modules.ml b/src/modules.ml
index 98a0b83910a89d2c68b8a7cc688f6b7ea9d1a194..4928fd388a7fd6fea1c009b4b8a453b5a296e022 100644
--- a/src/modules.ml
+++ b/src/modules.ml
@@ -113,11 +113,8 @@ let add_const itf name value =
| _ -> assert false
with Not_found -> Hashtbl.add consts_table name value
-let name_dependency (local, dep) =
- ((if local then !Options.dest_dir else !Options.include_dir) ^ "/") ^ dep
-
let import_dependency_aux loc (local, dep) =
- let basename = name_dependency (local, dep) in
+ let basename = Options.name_dependency (local, dep) in
let extension = ".lusic" in
try
let lusic = Lusic.read_lusic basename extension in
@@ -154,15 +151,15 @@ let check_dependency lusic basename =
)
let rec load_header_rec imported header =
- List.fold_left (fun imp decl ->
+ List.fold_left (fun imported decl ->
match decl.top_decl_desc with
| Node nd -> assert false
- | ImportedNode ind -> (add_imported_node ind.nodei_id decl; imp)
- | Const c -> (add_const true c.const_id decl; imp)
- | TypeDef tdef -> (add_type true tdef.tydef_id decl; imp)
+ | ImportedNode ind -> (add_imported_node ind.nodei_id decl; imported)
+ | Const c -> (add_const true c.const_id decl; imported)
+ | TypeDef tdef -> (add_type true tdef.tydef_id decl; imported)
| Open (local, dep) ->
- let basename = name_dependency (local, dep) in
- if ISet.mem basename imported then imp else
+ let basename = Options.name_dependency (local, dep) in
+ if ISet.mem basename imported then imported else
let lusic = import_dependency_aux decl.top_decl_loc (local, dep)
in load_header_rec (ISet.add basename imported) lusic.Lusic.contents
) imported header
@@ -179,15 +176,15 @@ let load_header imported header =
);;
let rec load_program_rec imported program =
- List.fold_left (fun imp decl ->
+ List.fold_left (fun imported decl ->
match decl.top_decl_desc with
- | Node nd -> (add_node nd.node_id decl; imp)
+ | Node nd -> (add_node nd.node_id decl; imported)
| ImportedNode ind -> assert false
- | Const c -> (add_const false c.const_id decl; imp)
- | TypeDef tdef -> (add_type false tdef.tydef_id decl; imp)
+ | Const c -> (add_const false c.const_id decl; imported)
+ | TypeDef tdef -> (add_type false tdef.tydef_id decl; imported)
| Open (local, dep) ->
- let basename = name_dependency (local, dep) in
- if ISet.mem basename imported then imp else
+ let basename = Options.name_dependency (local, dep) in
+ if ISet.mem basename imported then imported else
let lusic = import_dependency_aux decl.top_decl_loc (local, dep)
in load_header_rec (ISet.add basename imported) lusic.Lusic.contents
) imported program
diff --git a/src/mutation.ml b/src/mutation.ml
new file mode 100644
index 0000000000000000000000000000000000000000..be895a4a0f14f3c2af6f46cf584d0ea5cdf9d471
--- /dev/null
+++ b/src/mutation.ml
@@ -0,0 +1,667 @@
+open LustreSpec
+open Corelang
+open Log
+open Format
+
+let random_seed = ref 0
+let threshold_delay = 95
+let threshold_inc_int = 97
+let threshold_dec_int = 97
+let threshold_random_int = 96
+let threshold_switch_int = 100 (* not implemented yet *)
+let threshold_random_float = 100 (* not used yet *)
+let threshold_negate_bool_var = 95
+let threshold_arith_op = 95
+let threshold_rel_op = 95
+let threshold_bool_op = 95
+
+let int_consts = ref []
+
+let rename_app id =
+ if !Options.no_mutation_suffix then
+ id
+ else
+ id ^ "_mutant"
+
+(************************************************************************************)
+(* Gathering constants in the code *)
+(************************************************************************************)
+
+module IntSet = Set.Make (struct type t = int let compare = compare end)
+module OpCount = Mmap.Make (struct type t = string let compare = compare end)
+
+type records = {
+ consts: IntSet.t;
+ nb_boolexpr: int;
+ nb_pre: int;
+ nb_op: int OpCount.t;
+}
+
+let arith_op = ["+" ; "-" ; "*" ; "/"]
+let bool_op = ["&&"; "||"; "xor"; "impl"]
+let rel_op = ["<" ; "<=" ; ">" ; ">=" ; "!=" ; "=" ]
+let ops = arith_op @ bool_op @ rel_op
+let all_ops = "not" :: ops
+
+let empty_records =
+ {consts=IntSet.empty; nb_boolexpr=0; nb_pre=0; nb_op=OpCount.empty}
+
+let records = ref empty_records
+
+let merge_records records_list =
+ let merge_record r1 r2 =
+ {
+ consts = IntSet.union r1.consts r2.consts;
+
+ nb_boolexpr = r1.nb_boolexpr + r2.nb_boolexpr;
+ nb_pre = r1.nb_pre + r2.nb_pre;
+
+ nb_op = OpCount.merge (fun op r1opt r2opt ->
+ match r1opt, r2opt with
+ | None, _ -> r2opt
+ | _, None -> r1opt
+ | Some x, Some y -> Some (x+y)
+ ) r1.nb_op r2.nb_op
+ }
+ in
+ List.fold_left merge_record empty_records records_list
+
+let compute_records_const_value c =
+ match c with
+ | Const_int i -> {empty_records with consts = IntSet.singleton i}
+ | _ -> empty_records
+
+let rec compute_records_expr expr =
+ let boolexpr =
+ if (Types.repr expr.expr_type).Types.tdesc = Types.Tbool then
+ {empty_records with nb_boolexpr = 1}
+ else
+ empty_records
+ in
+ let subrec =
+ match expr.expr_desc with
+ | Expr_const c -> compute_records_const_value c
+ | Expr_tuple l -> merge_records (List.map compute_records_expr l)
+ | Expr_ite (i,t,e) ->
+ merge_records (List.map compute_records_expr [i;t;e])
+ | Expr_arrow (e1, e2) ->
+ merge_records (List.map compute_records_expr [e1;e2])
+ | Expr_pre e ->
+ merge_records (
+ ({empty_records with nb_pre = 1})
+ ::[compute_records_expr e])
+ | Expr_appl (op_id, args, r) ->
+ if List.mem op_id ops then
+ merge_records (
+ ({empty_records with nb_op = OpCount.singleton op_id 1})
+ ::[compute_records_expr args])
+ else
+ compute_records_expr args
+ | _ -> empty_records
+ in
+ merge_records [boolexpr;subrec]
+
+let compute_records_eq eq = compute_records_expr eq.eq_rhs
+
+let compute_records_node nd =
+ merge_records (List.map compute_records_eq (get_node_eqs nd))
+
+let compute_records_top_decl td =
+ match td.top_decl_desc with
+ | Node nd -> compute_records_node nd
+ | Const cst -> compute_records_const_value cst.const_value
+ | _ -> empty_records
+
+let compute_records prog =
+ merge_records (List.map compute_records_top_decl prog)
+
+(*****************************************************************)
+(* Random mutation *)
+(*****************************************************************)
+
+let check_mut e1 e2 =
+ let rec eq e1 e2 =
+ match e1.expr_desc, e2.expr_desc with
+ | Expr_const c1, Expr_const c2 -> c1 = c2
+ | Expr_ident id1, Expr_ident id2 -> id1 = id2
+ | Expr_tuple el1, Expr_tuple el2 -> List.length el1 = List.length el2 && List.for_all2 eq el1 el2
+ | Expr_ite (i1, t1, e1), Expr_ite (i2, t2, e2) -> eq i1 i2 && eq t1 t2 && eq e1 e2
+ | Expr_arrow (x1, y1), Expr_arrow (x2, y2) -> eq x1 x2 && eq y1 y2
+ | Expr_pre e1, Expr_pre e2 -> eq e1 e2
+ | Expr_appl (id1, e1, _), Expr_appl (id2, e2, _) -> id1 = id2 && eq e1 e2
+ | _ -> false
+ in
+ if not (eq e1 e2) then
+ Some (e1, e2)
+ else
+ None
+
+let mk_cst_expr c = mkexpr Location.dummy_loc (Expr_const c)
+
+let rdm_mutate_int i =
+ if Random.int 100 > threshold_inc_int then
+ i+1
+ else if Random.int 100 > threshold_dec_int then
+ i-1
+ else if Random.int 100 > threshold_random_int then
+ Random.int 10
+ else if Random.int 100 > threshold_switch_int then
+ let idx = Random.int (List.length !int_consts) in
+ List.nth !int_consts idx
+ else
+ i
+
+let rdm_mutate_real r =
+ if Random.int 100 > threshold_random_float then
+ (* interval [0, bound] for random values *)
+ let bound = 10 in
+ (* max number of digits after comma *)
+ let digits = 5 in
+ (* number of digits after comma *)
+ let shift = Random.int (digits + 1) in
+ let eshift = 10. ** (float_of_int shift) in
+ let i = Random.int (1 + bound * (int_of_float eshift)) in
+ let f = float_of_int i /. eshift in
+ (Num.num_of_int i, shift, string_of_float f)
+ else
+ r
+
+let rdm_mutate_op op =
+match op with
+| "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op ->
+ let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in
+ List.nth filtered (Random.int 3)
+| "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op ->
+ let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in
+ List.nth filtered (Random.int 3)
+| "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op ->
+ let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in
+ List.nth filtered (Random.int 5)
+| _ -> op
+
+
+let rdm_mutate_var expr =
+ match (Types.repr expr.expr_type).Types.tdesc with
+ | Types.Tbool ->
+ (* if Random.int 100 > threshold_negate_bool_var then *)
+ let new_e = mkpredef_call expr.expr_loc "not" [expr] in
+ Some (expr, new_e), new_e
+ (* else *)
+ (* expr *)
+ | _ -> None, expr
+
+let rdm_mutate_pre orig_expr =
+ let new_e = Expr_pre orig_expr in
+ Some (orig_expr, {orig_expr with expr_desc = new_e}), new_e
+
+
+let rdm_mutate_const_value c =
+ match c with
+ | Const_int i -> Const_int (rdm_mutate_int i)
+ | Const_real (n, i, s) -> let (n', i', s') = rdm_mutate_real (n, i, s) in Const_real (n', i', s')
+ | Const_array _
+ | Const_string _
+ | Const_struct _
+ | Const_tag _ -> c
+
+let rdm_mutate_const c =
+ let new_const = rdm_mutate_const_value c.const_value in
+ let mut = check_mut (mk_cst_expr c.const_value) (mk_cst_expr new_const) in
+ mut, { c with const_value = new_const }
+
+
+let select_in_list list rdm_mutate_elem =
+ let selected = Random.int (List.length list) in
+ let mutation_opt, new_list, _ =
+ List.fold_right
+ (fun elem (mutation_opt, res, cpt) -> if cpt = selected then
+ let mutation, new_elem = rdm_mutate_elem elem in
+ Some mutation, new_elem::res, cpt+1 else mutation_opt, elem::res, cpt+1)
+ list
+ (None, [], 0)
+ in
+ match mutation_opt with
+ | Some mut -> mut, new_list
+ | _ -> assert false
+
+
+let rec rdm_mutate_expr expr =
+ let mk_e d = { expr with expr_desc = d } in
+ match expr.expr_desc with
+ | Expr_ident id -> rdm_mutate_var expr
+ | Expr_const c ->
+ let new_const = rdm_mutate_const_value c in
+ let mut = check_mut (mk_cst_expr c) (mk_cst_expr new_const) in
+ mut, mk_e (Expr_const new_const)
+ | Expr_tuple l ->
+ let mut, l' = select_in_list l rdm_mutate_expr in
+ mut, mk_e (Expr_tuple l')
+ | Expr_ite (i,t,e) -> (
+ let mut, l = select_in_list [i; t; e] rdm_mutate_expr in
+ match l with
+ | [i'; t'; e'] -> mut, mk_e (Expr_ite (i', t', e'))
+ | _ -> assert false
+ )
+ | Expr_arrow (e1, e2) -> (
+ let mut, l = select_in_list [e1; e2] rdm_mutate_expr in
+ match l with
+ | [e1'; e2'] -> mut, mk_e (Expr_arrow (e1', e2'))
+ | _ -> assert false
+ )
+ | Expr_pre e ->
+ let select_pre = Random.bool () in
+ if select_pre then
+ let mut, new_expr = rdm_mutate_pre expr in
+ mut, mk_e new_expr
+ else
+ let mut, e' = rdm_mutate_expr e in
+ mut, mk_e (Expr_pre e')
+ | Expr_appl (op_id, args, r) ->
+ let select_op = Random.bool () in
+ if select_op then
+ let new_op_id = rdm_mutate_op op_id in
+ let new_e = mk_e (Expr_appl (new_op_id, args, r)) in
+ let mut = check_mut expr new_e in
+ mut, new_e
+ else
+ let mut, new_args = rdm_mutate_expr args in
+ mut, mk_e (Expr_appl (op_id, new_args, r))
+ (* Other constructs are kept.
+ | Expr_fby of expr * expr
+ | Expr_array of expr list
+ | Expr_access of expr * Dimension.dim_expr
+ | Expr_power of expr * Dimension.dim_expr
+ | Expr_when of expr * ident * label
+ | Expr_merge of ident * (label * expr) list
+ | Expr_uclock of expr * int
+ | Expr_dclock of expr * int
+ | Expr_phclock of expr * rat *)
+ | _ -> None, expr
+
+
+let rdm_mutate_eq eq =
+ let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in
+ mutation, { eq with eq_rhs = new_rhs }
+
+let rnd_mutate_stmt stmt =
+ match stmt with
+ | Eq eq -> let mut, new_eq = rdm_mutate_eq eq in
+ report ~level:1
+ (fun fmt -> fprintf fmt "mutation: %a becomes %a@."
+ Printers.pp_node_eq eq
+ Printers.pp_node_eq new_eq);
+ mut, Eq new_eq
+ | Aut aut -> assert false
+
+let rdm_mutate_node nd =
+ let mutation, new_node_stmts =
+ select_in_list
+ nd.node_stmts rnd_mutate_stmt
+ in
+ mutation, { nd with node_stmts = new_node_stmts }
+
+let rdm_mutate_top_decl td =
+ match td.top_decl_desc with
+ | Node nd ->
+ let mutation, new_node = rdm_mutate_node nd in
+ mutation, { td with top_decl_desc = Node new_node}
+ | Const cst ->
+ let mut, new_cst = rdm_mutate_const cst in
+ mut, { td with top_decl_desc = Const new_cst }
+ | _ -> None, td
+
+(* Create a single mutant with the provided random seed *)
+let rdm_mutate_prog prog =
+ select_in_list prog rdm_mutate_top_decl
+
+let rdm_mutate nb prog =
+ let rec iterate nb res =
+ incr random_seed;
+ if nb <= 0 then
+ res
+ else (
+ Random.init !random_seed;
+ let mutation, new_mutant = rdm_mutate_prog prog in
+ match mutation with
+ None -> iterate nb res
+ | Some mutation -> (
+ if List.mem_assoc mutation res then (
+ iterate nb res
+ )
+ else (
+ report ~level:1 (fun fmt -> fprintf fmt "%i mutants remaining@." nb);
+ iterate (nb-1) ((mutation, new_mutant)::res)
+ )
+ )
+ )
+ in
+ iterate nb []
+
+
+(*****************************************************************)
+(* Random mutation *)
+(*****************************************************************)
+
+type mutant_t = Boolexpr of int | Pre of int | Op of string * int * string | IncrIntCst of int | DecrIntCst of int | SwitchIntCst of int * int
+
+let target : mutant_t option ref = ref None
+
+let print_directive fmt d =
+ match d with
+ | Pre n -> Format.fprintf fmt "pre %i" n
+ | Boolexpr n -> Format.fprintf fmt "boolexpr %i" n
+ | Op (o, i, d) -> Format.fprintf fmt "%s %i -> %s" o i d
+ | IncrIntCst n -> Format.fprintf fmt "incr int cst %i" n
+ | DecrIntCst n -> Format.fprintf fmt "decr int cst %i" n
+ | SwitchIntCst (n, m) -> Format.fprintf fmt "switch int cst %i -> %i" n m
+
+let fold_mutate_int i =
+ if Random.int 100 > threshold_inc_int then
+ i+1
+ else if Random.int 100 > threshold_dec_int then
+ i-1
+ else if Random.int 100 > threshold_random_int then
+ Random.int 10
+ else if Random.int 100 > threshold_switch_int then
+ try
+ let idx = Random.int (List.length !int_consts) in
+ List.nth !int_consts idx
+ with _ -> i
+ else
+ i
+
+let fold_mutate_float f =
+ if Random.int 100 > threshold_random_float then
+ Random.float 10.
+ else
+ f
+
+let fold_mutate_op op =
+(* match op with *)
+(* | "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op -> *)
+(* let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in *)
+(* List.nth filtered (Random.int 3) *)
+(* | "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op -> *)
+(* let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in *)
+(* List.nth filtered (Random.int 3) *)
+(* | "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op -> *)
+(* let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in *)
+(* List.nth filtered (Random.int 5) *)
+(* | _ -> op *)
+ match !target with
+ | Some (Op(op_orig, 0, op_new)) when op_orig = op -> (
+ target := None;
+ op_new
+ )
+ | Some (Op(op_orig, n, op_new)) when op_orig = op -> (
+ target := Some (Op(op_orig, n-1, op_new));
+ op
+ )
+ | _ -> if List.mem op Basic_library.internal_funs then op else rename_app op
+
+
+let fold_mutate_var expr =
+ (* match (Types.repr expr.expr_type).Types.tdesc with *)
+ (* | Types.Tbool -> *)
+ (* (\* if Random.int 100 > threshold_negate_bool_var then *\) *)
+ (* mkpredef_unary_call Location.dummy_loc "not" expr *)
+ (* (\* else *\) *)
+ (* (\* expr *\) *)
+ (* | _ ->
+ *)expr
+
+let fold_mutate_boolexpr expr =
+ match !target with
+ | Some (Boolexpr 0) -> (
+ target := None;
+ mkpredef_call expr.expr_loc "not" [expr]
+ )
+ | Some (Boolexpr n) ->
+ (target := Some (Boolexpr (n-1)); expr)
+ | _ -> expr
+
+let fold_mutate_pre orig_expr e =
+ match !target with
+ Some (Pre 0) -> (
+ target := None;
+ Expr_pre ({orig_expr with expr_desc = Expr_pre e})
+ )
+ | Some (Pre n) -> (
+ target := Some (Pre (n-1));
+ Expr_pre e
+ )
+ | _ -> Expr_pre e
+
+let fold_mutate_const_value c =
+match c with
+| Const_int i -> (
+ match !target with
+ | Some (IncrIntCst 0) -> (target := None; Const_int (i+1))
+ | Some (DecrIntCst 0) -> (target := None; Const_int (i-1))
+ | Some (SwitchIntCst (0, id)) -> (target := None; Const_int (List.nth (IntSet.elements (IntSet.remove i !records.consts)) id))
+ | Some (IncrIntCst n) -> (target := Some (IncrIntCst (n-1)); c)
+ | Some (DecrIntCst n) -> (target := Some (DecrIntCst (n-1)); c)
+ | Some (SwitchIntCst (n, id)) -> (target := Some (SwitchIntCst (n-1, id)); c)
+ | _ -> c)
+| _ -> c
+
+(*
+ match c with
+ | Const_int i -> Const_int (fold_mutate_int i)
+ | Const_real s -> Const_real s (* those are string, let's leave them *)
+ | Const_float f -> Const_float (fold_mutate_float f)
+ | Const_array _
+ | Const_tag _ -> c
+TODO
+
+ *)
+let fold_mutate_const c =
+ { c with const_value = fold_mutate_const_value c.const_value }
+
+let rec fold_mutate_expr expr =
+ let new_expr =
+ match expr.expr_desc with
+ | Expr_ident id -> fold_mutate_var expr
+ | _ -> (
+ let new_desc = match expr.expr_desc with
+ | Expr_const c -> Expr_const (fold_mutate_const_value c)
+ | Expr_tuple l -> Expr_tuple (List.fold_right (fun e res -> (fold_mutate_expr e)::res) l [])
+ | Expr_ite (i,t,e) -> Expr_ite (fold_mutate_expr i, fold_mutate_expr t, fold_mutate_expr e)
+ | Expr_arrow (e1, e2) -> Expr_arrow (fold_mutate_expr e1, fold_mutate_expr e2)
+ | Expr_pre e -> fold_mutate_pre expr (fold_mutate_expr e)
+ | Expr_appl (op_id, args, r) -> Expr_appl (fold_mutate_op op_id, fold_mutate_expr args, r)
+ (* Other constructs are kept.
+ | Expr_fby of expr * expr
+ | Expr_array of expr list
+ | Expr_access of expr * Dimension.dim_expr
+ | Expr_power of expr * Dimension.dim_expr
+ | Expr_when of expr * ident * label
+ | Expr_merge of ident * (label * expr) list
+ | Expr_uclock of expr * int
+ | Expr_dclock of expr * int
+ | Expr_phclock of expr * rat *)
+ | _ -> expr.expr_desc
+
+ in
+ { expr with expr_desc = new_desc }
+ )
+ in
+ if (Types.repr expr.expr_type).Types.tdesc = Types.Tbool then
+ fold_mutate_boolexpr new_expr
+ else
+ new_expr
+
+let fold_mutate_eq eq =
+ { eq with eq_rhs = fold_mutate_expr eq.eq_rhs }
+
+let fold_mutate_stmt stmt =
+ match stmt with
+ | Eq eq -> Eq (fold_mutate_eq eq)
+ | Aut aut -> assert false
+
+let fold_mutate_node nd =
+ { nd with
+ node_stmts =
+ List.fold_right (fun stmt res -> (fold_mutate_stmt stmt)::res) nd.node_stmts [];
+ node_id = rename_app nd.node_id
+ }
+
+let fold_mutate_top_decl td =
+ match td.top_decl_desc with
+ | Node nd -> { td with top_decl_desc = Node (fold_mutate_node nd)}
+ | Const cst -> { td with top_decl_desc = Const (fold_mutate_const cst)}
+ | _ -> td
+
+(* Create a single mutant with the provided random seed *)
+let fold_mutate_prog prog =
+ List.fold_right (fun e res -> (fold_mutate_top_decl e)::res) prog []
+
+let create_mutant prog directive =
+ target := Some directive;
+ let prog' = fold_mutate_prog prog in
+ target := None;
+ prog'
+
+
+let op_mutation op =
+ let res =
+ let rem_op l = List.filter (fun e -> e <> op) l in
+ if List.mem op arith_op then rem_op arith_op else
+ if List.mem op bool_op then rem_op bool_op else
+ if List.mem op rel_op then rem_op rel_op else
+ (Format.eprintf "Failing with op %s@." op;
+ assert false
+ )
+ in
+ (* Format.eprintf "Mutation op %s to [%a]@." op (Utils.fprintf_list ~sep:"," Format.pp_print_string) res; *)
+ res
+
+let rec remains select list =
+ match list with
+ [] -> []
+ | hd::tl -> if select hd then tl else remains select tl
+
+let next_change m =
+ let res =
+ let rec first_op () =
+ try
+ let min_binding = OpCount.min_binding !records.nb_op in
+ Op (fst min_binding, 0, List.hd (op_mutation (fst min_binding)))
+ with Not_found -> first_boolexpr ()
+ and first_boolexpr () =
+ if !records.nb_boolexpr > 0 then
+ Boolexpr 0
+ else first_pre ()
+ and first_pre () =
+ if !records.nb_pre > 0 then
+ Pre 0
+ else
+ first_op ()
+ and first_intcst () =
+ if IntSet.cardinal !records.consts > 0 then
+ IncrIntCst 0
+ else
+ first_boolexpr ()
+ in
+ match m with
+ | Boolexpr n ->
+ if n+1 >= !records.nb_boolexpr then
+ first_pre ()
+ else
+ Boolexpr (n+1)
+ | Pre n ->
+ if n+1 >= !records.nb_pre then
+ first_op ()
+ else Pre (n+1)
+ | Op (orig, id, mut_op) -> (
+ match remains (fun x -> x = mut_op) (op_mutation orig) with
+ | next_op::_ -> Op (orig, id, next_op)
+ | [] -> if id+1 >= OpCount.find orig !records.nb_op then (
+ match remains (fun (k1, _) -> k1 = orig) (OpCount.bindings !records.nb_op) with
+ | [] -> first_intcst ()
+ | hd::_ -> Op (fst hd, 0, List.hd (op_mutation (fst hd)))
+ ) else
+ Op(orig, id+1, List.hd (op_mutation orig))
+ )
+ | IncrIntCst n ->
+ if n+1 >= IntSet.cardinal !records.consts then
+ DecrIntCst 0
+ else IncrIntCst (n+1)
+ | DecrIntCst n ->
+ if n+1 >= IntSet.cardinal !records.consts then
+ SwitchIntCst (0, 0)
+ else DecrIntCst (n+1)
+ | SwitchIntCst (n, m) ->
+ if m+1 > -1 + IntSet.cardinal !records.consts then
+ SwitchIntCst (n, m+1)
+ else if n+1 >= IntSet.cardinal !records.consts then
+ SwitchIntCst (n+1, 0)
+ else first_boolexpr ()
+
+ in
+ (* Format.eprintf "from: %a to: %a@." print_directive m print_directive res; *)
+ res
+
+let fold_mutate nb prog =
+ incr random_seed;
+ Random.init !random_seed;
+ let find_next_new mutants mutant =
+ let rec find_next_new init current =
+ if init = current then raise Not_found else
+ if List.mem current mutants then
+ find_next_new init (next_change current)
+ else
+ current
+ in
+ find_next_new mutant (next_change mutant)
+ in
+ (* Creating list of nb elements of mutants *)
+ let rec create_mutants_directives rnb mutants =
+ if rnb <= 0 then mutants
+ else
+ let random_mutation =
+ match Random.int 6 with
+ | 5 -> IncrIntCst (try Random.int (IntSet.cardinal !records.consts) with _ -> 0)
+ | 4 -> DecrIntCst (try Random.int (IntSet.cardinal !records.consts) with _ -> 0)
+ | 3 -> SwitchIntCst ((try Random.int (IntSet.cardinal !records.consts) with _ -> 0), (try Random.int (-1 + IntSet.cardinal !records.consts) with _ -> 0))
+ | 2 -> Pre (try Random.int !records.nb_pre with _ -> 0)
+ | 1 -> Boolexpr (try Random.int !records.nb_boolexpr with _ -> 0)
+ | 0 -> let bindings = OpCount.bindings !records.nb_op in
+ let op, nb_op = List.nth bindings (try Random.int (List.length bindings) with _ -> 0) in
+ let new_op = List.nth (op_mutation op) (try Random.int (List.length (op_mutation op)) with _ -> 0) in
+ Op (op, (try Random.int nb_op with _ -> 0), new_op)
+ | _ -> assert false
+ in
+ if List.mem random_mutation mutants then
+ try
+ let new_mutant = (find_next_new mutants random_mutation) in
+ report ~level:2 (fun fmt -> fprintf fmt " %i mutants generated out of %i expected@." (nb-rnb) nb);
+ create_mutants_directives (rnb-1) (new_mutant::mutants)
+ with Not_found -> (
+ report ~level:1 (fun fmt -> fprintf fmt "Only %i mutants generated out of %i expected@." (nb-rnb) nb);
+ mutants
+ )
+ else
+ create_mutants_directives (rnb-1) (random_mutation::mutants)
+ in
+ let mutants_directives = create_mutants_directives nb [] in
+ List.map (fun d -> d, create_mutant prog d) mutants_directives
+
+
+let mutate nb prog =
+ records := compute_records prog;
+ (* Format.printf "Records: %i pre, %i boolexpr" (\* , %a ops *\) *)
+ (* !records.nb_pre *)
+(* !records.nb_boolexpr *)
+(* (\* !records.op *\) *)
+(* ; *)
+ fold_mutate nb prog, print_directive
+
+
+
+
+(* Local Variables: *)
+(* compile-command:"make -C .." *)
+(* End: *)
+
+
diff --git a/src/myocamlbuild.ml.in b/src/myocamlbuild.ml.in
deleted file mode 100644
index 6c041039ee2c665e66ba93abc766bb64cd080847..0000000000000000000000000000000000000000
--- a/src/myocamlbuild.ml.in
+++ /dev/null
@@ -1,14 +0,0 @@
-open Ocamlbuild_plugin
-open Command
-;;
-
-dispatch begin function
-| After_rules ->
- (* We declare external libraries *)
- ocaml_lib ~extern:true ~dir:"@OCAMLGRAPH_PATH@" "graph";
- if @CC_NOASNEEDED@ then
- flag ["ocaml"; "link"]
- (S [A"-cclib";A"-Wl,--no-as-needed"]);
-| _ -> ()
-end
-
diff --git a/src/normalization.ml b/src/normalization.ml
index 040606c3c96c90bd6d6e882022b82bb3335b61c2..c8de574ec886f7f59d1193de4917a5e4239f084e 100644
--- a/src/normalization.ml
+++ b/src/normalization.ml
@@ -80,8 +80,8 @@ let mk_fresh_var node loc ty ck =
let get_expr_alias defs expr =
try Some (List.find (fun eq -> is_eq_expr eq.eq_rhs expr) defs)
with
- Not_found -> None
-
+ | Not_found -> None
+
(* Replace [expr] with (tuple of) [locals] *)
let replace_expr locals expr =
match locals with
@@ -156,13 +156,13 @@ let mk_expr_alias_opt opt node (defs, vars) expr =
taking propagated [offsets] into account
in order to change expression type *)
let mk_norm_expr offsets ref_e norm_d =
-(*Format.eprintf "mk_norm_expr %a %a @." Printers.pp_expr ref_e Printers.pp_expr { ref_e with expr_desc = norm_d};*)
+ (*Format.eprintf "mk_norm_expr %a %a @." Printers.pp_expr ref_e Printers.pp_expr { ref_e with expr_desc = norm_d};*)
let drop_array_type ty =
Types.map_tuple_type Types.array_element_type ty in
{ ref_e with
expr_desc = norm_d;
expr_type = Utils.repeat (List.length offsets) drop_array_type ref_e.expr_type }
-
+
(* normalize_<foo> : defs * used vars -> <foo> -> (updated defs * updated vars) * normalized <foo> *)
let rec normalize_list alias node offsets norm_element defvars elist =
List.fold_right
@@ -172,7 +172,7 @@ let rec normalize_list alias node offsets norm_element defvars elist =
) elist (defvars, [])
let rec normalize_expr ?(alias=true) node offsets defvars expr =
-(*Format.eprintf "normalize %B %a:%a [%a]@." alias Printers.pp_expr expr Types.print_ty expr.expr_type (Utils.fprintf_list ~sep:"," Dimension.pp_dimension) offsets;*)
+ (*Format.eprintf "normalize %B %a:%a [%a]@." alias Printers.pp_expr expr Types.print_ty expr.expr_type (Utils.fprintf_list ~sep:"," Dimension.pp_dimension) offsets;*)
match expr.expr_desc with
| Expr_const _
| Expr_ident _ -> defvars, unfold_offsets expr offsets
diff --git a/src/optimize_machine.ml b/src/optimize_machine.ml
index 9adc3d08c96ca47a2083e32dd8761f8289bbae1d..b0ab49ab41b2181ebeff5498dfd41addb2f8e8eb 100644
--- a/src/optimize_machine.ml
+++ b/src/optimize_machine.ml
@@ -19,9 +19,9 @@ open Dimension
let pp_elim fmt elim =
begin
- Format.fprintf fmt "{ /* elim table: */@.";
- IMap.iter (fun v expr -> Format.fprintf fmt "%s |-> %a@." v pp_val expr) elim;
- Format.fprintf fmt "}@.";
+ Format.fprintf fmt "@[{ /* elim table: */@ ";
+ IMap.iter (fun v expr -> Format.fprintf fmt "%s |-> %a@ " v pp_val expr) elim;
+ Format.fprintf fmt "}@ @]";
end
let rec eliminate elim instr =
@@ -58,6 +58,11 @@ let eliminate_dim elim dim =
with Not_found -> mkdim_ident dim.dim_loc v)
dim
+
+(* 8th Jan 2016: issues when merging salsa with horn_encoding: The following
+ functions seem unsused. They have to be adapted to the new type for expr
+*)
+
let unfold_expr_offset m offset expr =
List.fold_left
(fun res -> (function | Index i -> mk_val (Access (res, value_of_dimension m i))
@@ -321,7 +326,31 @@ let subst_instr subst instrs instr =
let instr = eliminate subst instr in
let v = get_assign_lhs instr in
let e = get_assign_rhs instr in
- try
+ (* Difficulties to merge with unstable. Here is the other code:
+
+try
+ let instr' = List.find (fun instr' -> is_assign instr' && get_assign_rhs instr' = e) instrs in
+ match v.value_desc with
+ | LocalVar v ->
+ IMap.add v.var_id (get_assign_lhs instr') subst, instrs
+ | StateVar v ->
+ let lhs' = get_assign_lhs instr' in
+ let typ' = lhs'.value_type in
+ (match lhs'.value_desc with
+ | LocalVar v' ->
+ let instr = eliminate subst (mk_assign (mk_val (StateVar v) typ') (mk_val (LocalVar v') typ')) in
+ subst, instr :: instrs
+ | StateVar v' ->
+ let subst_v' = IMap.add v'.var_id (mk_val (StateVar v) typ') IMap.empty in
+let instrs' = snd (List.fold_right (fun instr (ok, instrs) -> (ok || instr = instr', if ok then instr :: instrs else if instr = instr' then instrs else eliminate subst_v' instr :: instrs)) instrs (false, [])) in
+ IMap.add v'.var_id (mk_val (StateVar v) typ') subst, instr :: instrs'
+ | _ -> assert false)
+ | _ -> assert false
+ with Not_found -> subst, instr :: instrs
+
+*)
+
+try
let instr' = List.find (fun instr' -> is_assign instr' && get_assign_rhs instr' = e) instrs in
match v.value_desc with
| LocalVar v ->
diff --git a/src/options.ml b/src/options.ml
index 9faabdc079772b0a5e1d82b45f06010d585e1995..e9a39c0000afc2da448ac3b84d32be47711064b1 100755
--- a/src/options.ml
+++ b/src/options.ml
@@ -11,18 +11,19 @@
let version = Version.number
let codename = Version.codename
-let include_dir = ref "."
-let include_path =
-if (!include_dir != ".") then Version.prefix ^ !include_dir
-else Version.include_path
+let include_dirs = ref ["."]
+(* let include_path = *)
+(* if (!include_dir <> ".") then Version.prefix ^ !include_dir *)
+(* else Version.include_path *)
let print_version () =
Format.printf "Lustrec compiler, version %s (%s)@." version codename;
- Format.printf "Include directory: %s@." include_path;
- Format.printf "User selected Include directory: %s@." !include_dir
+ Format.printf "Standard lib: %s@." Version.include_path;
+ Format.printf "User provided include directory: @[<h>%a@]@."
+ (Utils.fprintf_list ~sep:"@ " Format.pp_print_string) !include_dirs
let main_node = ref ""
let static_mem = ref true
@@ -49,24 +50,85 @@ let traces = ref false
let horn_cex = ref false
let horn_query = ref true
-let salsa_enabled = ref true
+let cpp = ref false
+let int_type = ref "int"
+let real_type = ref "double"
let sfunction = ref ""
+let mauve = ref ""
+(* test generation options *)
+let nb_mutants = ref 1000
+let gen_mcdc = ref false
+let no_mutation_suffix = ref false
+
+let add_include_dir dir =
+ let removed_slash_suffix =
+ let len = String.length dir in
+ if dir.[len-1] = '/' then
+ String.sub dir 0 (len - 1)
+ else
+ dir
+ in
+ include_dirs := removed_slash_suffix :: !include_dirs
+
+
+(** Solving the path of required library:
+ If local: look in the folders described in !Options.include_dirs
+ If non local: look first as a local, then in Version.include_path:
+ ie. in Version.include_path::!Options.include_dirs
+ Note that in options.ml, include folder are added as heads. One need to
+ perform a fold_right to respect the order
+*)
+let search_lib_path (local, full_file_name) =
+ let paths = (if local then !include_dirs else Version.include_path::!include_dirs) in
+ let name =
+ List.fold_right (fun dir res ->
+ match res with Some _ -> res
+ | None ->
+ let path_to_lib = dir ^ "/" ^ full_file_name in
+ if Sys.file_exists path_to_lib then
+ Some dir
+ else
+ None
+ )
+ paths
+ None
+ in
+ match name with
+ | None -> Format.eprintf "Unable to find library %s in paths %a@.@?" full_file_name (Utils.fprintf_list ~sep:", " Format.pp_print_string) paths;raise Not_found
+ | Some s -> s
+
+(* Search for path of core libs (without lusic: arrow and io_frontend *)
+let core_dependency lib_name =
+ search_lib_path (false, lib_name ^ ".h")
+
+let name_dependency (local, dep) =
+ let dir = search_lib_path (false, dep ^ ".lusic") in
+ dir ^ "/" ^ dep
+
let set_mpfr prec =
if prec > 0 then (
mpfr := true;
mpfr_prec := prec;
- salsa_enabled := false; (* We deactivate salsa *)
+ (* salsa_enabled := false; (* We deactivate salsa *) TODO *)
)
else
failwith "mpfr requires a positive integer"
-
-let options =
-[ "-d", Arg.Set_string dest_dir,
-"uses the specified directory \x1b[4mdir\x1b[0m as root for generated/imported object and C files <default: .>";
-"-I", Arg.Set_string include_dir, "Include directory";
+
+let common_options =
+ [ "-d", Arg.Set_string dest_dir, "uses the specified \x1b[4mdirectory\x1b[0m as root for generated/imported object and C files <default: .>";
+ "-I", Arg.String add_include_dir, "sets include \x1b[4mdirectory\x1b[0m";
"-node", Arg.Set_string main_node, "specifies the \x1b[4mmain\x1b[0m node";
+ "-print-types", Arg.Set print_types, "prints node types";
+ "-print-clocks", Arg.Set print_clocks, "prints node clocks";
+ "-verbose", Arg.Set_int verbose_level, "changes verbose \x1b[4mlevel\x1b[0m <default: 1>";
+ "-version", Arg.Unit print_version, " displays the version";
+ ]
+
+let lustrec_options =
+ common_options @
+ [
"-init", Arg.Set delay_calculus, "performs an initialisation analysis for Lustre nodes <default: no analysis>";
"-dynamic", Arg.Clear static_mem, "specifies a dynamic allocation scheme for main Lustre node <default: static>";
"-check-access", Arg.Set check, "checks at runtime that array accesses always lie within bounds <default: no check>";
@@ -77,21 +139,31 @@ let options =
"-c-spec", Arg.Unit (fun () -> spec := "c"), "generates a C encoding of the specification instead of ACSL contracts and annotations. Only meaningful for the C backend";
(* "-java", Arg.Unit (fun () -> output := "java"), "generates Java output instead of C"; *)
"-horn", Arg.Unit (fun () -> output := "horn"), "generates Horn clauses encoding output instead of C";
- "-horn-traces", Arg.Unit (fun () -> output := "horn"; traces:=true), "produce traceability file for Horn backend. Enable the horn backend.";
- "-horn-cex", Arg.Unit (fun () -> output := "horn"; horn_cex:=true), "generate cex enumeration. Enable the horn backend (work in progress)";
- "-horn-query", Arg.Unit (fun () -> output := "horn"; horn_query:=true), "generate queries in generated Horn file. Enable the horn backend (work in progress)";
- "-horn-sfunction", Arg.Set_string sfunction, "Get the endpoint predicate of the sfunction";
- "-print_reuse", Arg.Set print_reuse, "prints variable reuse policy";
+ "-horn-traces", Arg.Unit (fun () -> output := "horn"; traces:=true), "produces traceability file for Horn backend. Enable the horn backend.";
+ "-horn-cex", Arg.Unit (fun () -> output := "horn"; horn_cex:=true), "generates cex enumeration. Enable the horn backend (work in progress)";
+ "-horn-query", Arg.Unit (fun () -> output := "horn"; horn_query:=true), "generates queries in generated Horn file. Enable the horn backend (work in progress)";
+ "-horn-sfunction", Arg.Set_string sfunction, "gets the endpoint predicate of the \x1b[4msfunction\x1b[0m";
+ "-print-reuse", Arg.Set print_reuse, "prints variable reuse policy";
"-lustre", Arg.Unit (fun () -> output := "lustre"), "generates Lustre output, performing all active optimizations";
- "-emf", Arg.Unit (fun () -> output := "emf"), "generates EMF output, to be used by CocoSim";
- "-inline", Arg.Unit (fun () -> global_inline := true; const_unfold := true), "inline all node calls (require a main node). Implies constant unfolding";
- "-witnesses", Arg.Set witnesses, "enable production of witnesses during compilation";
- "-print_types", Arg.Set print_types, "prints node types";
- "-print_clocks", Arg.Set print_clocks, "prints node clocks";
+ "-emf", Arg.Unit (fun () -> output := "emf"), "generates EMF output, to be used by CocoSim";
+ "-inline", Arg.Unit (fun () -> global_inline := true; const_unfold := true), "inlines all node calls (require a main node). Implies constant unfolding";
+ "-witnesses", Arg.Set witnesses, "enables production of witnesses during compilation";
"-O", Arg.Set_int optimization, "changes optimization \x1b[4mlevel\x1b[0m <default: 2>";
"-verbose", Arg.Set_int verbose_level, "changes verbose \x1b[4mlevel\x1b[0m <default: 1>";
- "-version", Arg.Unit print_version, " displays the version";]
+
+ "-c++" , Arg.Set cpp , "c++ backend";
+ "-int" , Arg.Set_string int_type , "specifies the integer type (default=\"int\")";
+ "-real", Arg.Set_string real_type, "specifies the real type (default=\"double\" without mpfr option)";
+
+ "-mauve", Arg.String (fun node -> mauve := node; cpp := true; static_mem := false), "generates the mauve code";
+]
+let lustret_options =
+ common_options @
+ [ "-nb-mutants", Arg.Set_int nb_mutants, "\x1b[4mnumber\x1b[0m of mutants to produce <default: 1000>";
+ "-mcdc-cond", Arg.Set gen_mcdc, "generates MC/DC coverage";
+ "-no-mutation-suffix", Arg.Set no_mutation_suffix, "does not rename node with the _mutant suffix"
+ ]
let plugin_opt (name, activate, options) =
( "-" ^ name , Arg.Unit activate, "activate plugin " ^ name ) ::
diff --git a/src/parser_lustre.mly b/src/parser_lustre.mly
index 0fdbe921a49f3250d172c8c4abb3aa5562eadf10..4764d162f4010ac4d6a1d738a986e95dd5116a9f 100755
--- a/src/parser_lustre.mly
+++ b/src/parser_lustre.mly
@@ -1,654 +1,654 @@
-/********************************************************************/
-/* */
-/* The LustreC compiler toolset / The LustreC Development Team */
-/* Copyright 2012 - -- ONERA - CNRS - INPT */
-/* */
-/* LustreC is free software, distributed WITHOUT ANY WARRANTY */
-/* under the terms of the GNU Lesser General Public License */
-/* version 2.1. */
-/* */
-/********************************************************************/
-
-%{
-open Utils
-open LustreSpec
-open Corelang
-open Dimension
-open Parse
-
-let get_loc () = Location.symbol_rloc ()
-
-let mkident x = x, get_loc ()
-let mktyp x = mktyp (get_loc ()) x
-let mkclock x = mkclock (get_loc ()) x
-let mkvar_decl x loc = mkvar_decl loc ~orig:true x
-let mkexpr x = mkexpr (get_loc ()) x
-let mkeexpr x = mkeexpr (get_loc ()) x
-let mkeq x = mkeq (get_loc ()) x
-let mkassert x = mkassert (get_loc ()) x
-let mktop_decl itf x = mktop_decl (get_loc ()) (Location.get_module ()) itf x
-let mkpredef_call x = mkpredef_call (get_loc ()) x
-(*let mkpredef_unary_call x = mkpredef_unary_call (get_loc ()) x*)
-
-let mkdim_int i = mkdim_int (get_loc ()) i
-let mkdim_bool b = mkdim_bool (get_loc ()) b
-let mkdim_ident id = mkdim_ident (get_loc ()) id
-let mkdim_appl f args = mkdim_appl (get_loc ()) f args
-let mkdim_ite i t e = mkdim_ite (get_loc ()) i t e
-
-let mkannots annots = { annots = annots; annot_loc = get_loc () }
-
-let node_stack : ident list ref = ref []
-let debug_calls () = Format.eprintf "call stack: %a@.@?" (Utils.fprintf_list ~sep:", " Format.pp_print_string) !node_stack
-let push_node nd = node_stack:= nd :: !node_stack
-let pop_node () = try node_stack := List.tl !node_stack with _ -> assert false
-let get_current_node () = try List.hd !node_stack with _ -> assert false
-
-let rec fby expr n init =
- if n<=1 then
- mkexpr (Expr_arrow (init, mkexpr (Expr_pre expr)))
- else
- mkexpr (Expr_arrow (init, mkexpr (Expr_pre (fby expr (n-1) init))))
-
-%}
-
-%token <int> INT
-%token <Num.num * int * string> REAL
-
-%token <string> STRING
-%token AUTOMATON STATE UNTIL UNLESS RESTART RESUME LAST
-%token STATELESS ASSERT OPEN QUOTE FUNCTION
-%token <string> IDENT
-%token <string> UIDENT
-%token TRUE FALSE
-%token <LustreSpec.expr_annot> ANNOT
-%token <LustreSpec.node_annot> NODESPEC
-%token LBRACKET RBRACKET LCUR RCUR LPAR RPAR SCOL COL COMMA COLCOL
-%token AMPERAMPER BARBAR NOT POWER
-%token IF THEN ELSE
-%token UCLOCK DCLOCK PHCLOCK TAIL
-%token MERGE FBY WHEN WHENNOT EVERY
-%token NODE LET TEL RETURNS VAR IMPORTED SENSOR ACTUATOR WCET TYPE CONST
-%token STRUCT ENUM
-%token TINT TREAL TBOOL TCLOCK
-%token RATE DUE
-%token EQ LT GT LTE GTE NEQ
-%token AND OR XOR IMPL
-%token MULT DIV MOD
-%token MINUS PLUS UMINUS
-%token PRE ARROW
-%token REQUIRES ENSURES OBSERVER
-%token INVARIANT BEHAVIOR ASSUMES CCODE MATLAB
-%token EXISTS FORALL
-%token PROTOTYPE LIB
-%token EOF
-
-%nonassoc prec_exists prec_forall
-%nonassoc COMMA
-%nonassoc EVERY
-%left MERGE IF
-%nonassoc ELSE
-%right ARROW FBY
-%left WHEN WHENNOT UCLOCK DCLOCK PHCLOCK
-%right COLCOL
-%right IMPL
-%left OR XOR BARBAR
-%left AND AMPERAMPER
-%left NOT
-%nonassoc INT
-%nonassoc EQ LT GT LTE GTE NEQ
-%left MINUS PLUS
-%left MULT DIV MOD
-%left UMINUS
-%left POWER
-%left PRE LAST
-%nonassoc RBRACKET
-%nonassoc LBRACKET
-
-%start prog
-%type <LustreSpec.top_decl list> prog
-
-%start header
-%type <LustreSpec.top_decl list> header
-
-%start lustre_annot
-%type <LustreSpec.expr_annot> lustre_annot
-
-%start lustre_spec
-%type <LustreSpec.node_annot> lustre_spec
-
-%start signed_const
-%type <LustreSpec.constant> signed_const
-
-%%
-
-module_ident:
- UIDENT { $1 }
-| IDENT { $1 }
-
-tag_ident:
- UIDENT { $1 }
-| TRUE { tag_true }
-| FALSE { tag_false }
-
-node_ident:
- UIDENT { $1 }
-| IDENT { $1 }
-
-node_ident_decl:
- node_ident { push_node $1; $1 }
-
-vdecl_ident:
- UIDENT { mkident $1 }
-| IDENT { mkident $1 }
-
-const_ident:
- UIDENT { $1 }
-| IDENT { $1 }
-
-type_ident:
- IDENT { $1 }
-
-prog:
- open_list typ_def_prog top_decl_list EOF { $1 @ $2 @ (List.rev $3) }
-
-typ_def_prog:
- typ_def_list { $1 false }
-
-header:
- open_list typ_def_header top_decl_header_list EOF { $1 @ $2 @ (List.rev $3) }
-
-typ_def_header:
- typ_def_list { $1 true }
-
-open_list:
- { [] }
-| open_lusi open_list { $1 :: $2 }
-
-open_lusi:
-| OPEN QUOTE module_ident QUOTE { mktop_decl false (Open (true, $3))}
-| OPEN LT module_ident GT { mktop_decl false (Open (false, $3)) }
-
-top_decl_list:
- {[]}
-| top_decl_list top_decl {$2@$1}
-
-
-top_decl_header_list:
- { [] }
-| top_decl_header_list top_decl_header { $2@$1 }
-
-state_annot:
- FUNCTION { true }
-| NODE { false }
-
-top_decl_header:
-| CONST cdecl_list { List.rev ($2 true) }
-| nodespec_list state_annot node_ident LPAR vdecl_list SCOL_opt RPAR RETURNS LPAR vdecl_list SCOL_opt RPAR prototype_opt in_lib_list SCOL
- {let nd = mktop_decl true (ImportedNode
- {nodei_id = $3;
- nodei_type = Types.new_var ();
- nodei_clock = Clocks.new_var true;
- nodei_inputs = List.rev $5;
- nodei_outputs = List.rev $10;
- nodei_stateless = $2;
- nodei_spec = $1;
- nodei_prototype = $13;
- nodei_in_lib = $14;})
- in
- (*add_imported_node $3 nd;*) [nd] }
-
-prototype_opt:
- { None }
-| PROTOTYPE node_ident { Some $2}
-
-in_lib_list:
-{ [] }
-| LIB module_ident in_lib_list { $2::$3 }
-
-top_decl:
-| CONST cdecl_list { List.rev ($2 false) }
-| nodespec_list state_annot node_ident_decl LPAR vdecl_list SCOL_opt RPAR RETURNS LPAR vdecl_list SCOL_opt RPAR SCOL_opt locals LET stmt_list TEL
- {
- let stmts, asserts, annots = $16 in
- (* Declaring eqs annots *)
- List.iter (fun ann ->
- List.iter (fun (key, _) ->
- Annotations.add_node_ann $3 key
- ) ann.annots
- ) annots;
- (* Building the node *)
- let nd = mktop_decl false (Node
- {node_id = $3;
- node_type = Types.new_var ();
- node_clock = Clocks.new_var true;
- node_inputs = List.rev $5;
- node_outputs = List.rev $10;
- node_locals = List.rev $14;
- node_gencalls = [];
- node_checks = [];
- node_asserts = asserts;
- node_stmts = stmts;
- node_dec_stateless = $2;
- node_stateless = None;
- node_spec = $1;
- node_annot = annots})
- in
- pop_node ();
- (*add_node $3 nd;*) [nd] }
-
-nodespec_list:
- { None }
-| NODESPEC nodespec_list {
- (function
- | None -> (fun s1 -> Some s1)
- | Some s2 -> (fun s1 -> Some (merge_node_annot s1 s2))) $2 $1 }
-
-typ_def_list:
- /* empty */ { (fun itf -> []) }
-| typ_def SCOL typ_def_list { (fun itf -> let ty1 = ($1 itf) in ty1 :: ($3 itf)) }
-
-typ_def:
- TYPE type_ident EQ typ_def_rhs { (fun itf ->
- let typ = mktop_decl itf (TypeDef { tydef_id = $2;
- tydef_desc = $4
- })
- in (*add_type itf $2 typ;*) typ) }
-
-typ_def_rhs:
- typeconst { $1 }
-| ENUM LCUR tag_list RCUR { Tydec_enum (List.rev $3) }
-| STRUCT LCUR field_list RCUR { Tydec_struct (List.rev $3) }
-
-array_typ_decl:
- %prec POWER { fun typ -> typ }
- | POWER dim array_typ_decl { fun typ -> $3 (Tydec_array ($2, typ)) }
-
-typeconst:
- TINT array_typ_decl { $2 Tydec_int }
-| TBOOL array_typ_decl { $2 Tydec_bool }
-| TREAL array_typ_decl { $2 Tydec_real }
-/* | TFLOAT array_typ_decl { $2 Tydec_float } */
-| type_ident array_typ_decl { $2 (Tydec_const $1) }
-| TBOOL TCLOCK { Tydec_clock Tydec_bool }
-| IDENT TCLOCK { Tydec_clock (Tydec_const $1) }
-
-tag_list:
- UIDENT { $1 :: [] }
-| tag_list COMMA UIDENT { $3 :: $1 }
-
-field_list: { [] }
-| field_list IDENT COL typeconst SCOL { ($2, $4) :: $1 }
-
-stmt_list:
- { [], [], [] }
-| eq stmt_list {let eql, assertl, annotl = $2 in ((Eq $1)::eql), assertl, annotl}
-| assert_ stmt_list {let eql, assertl, annotl = $2 in eql, ($1::assertl), annotl}
-| ANNOT stmt_list {let eql, assertl, annotl = $2 in eql, assertl, $1::annotl}
-| automaton stmt_list {let eql, assertl, annotl = $2 in ((Aut $1)::eql), assertl, annotl}
-
-automaton:
- AUTOMATON type_ident handler_list { Automata.mkautomata (get_loc ()) $2 $3 }
-
-handler_list:
- { [] }
-| handler handler_list { $1::$2 }
-
-handler:
- STATE UIDENT COL unless_list locals LET stmt_list TEL until_list { Automata.mkhandler (get_loc ()) $2 $4 $9 $5 $7 }
-
-unless_list:
- { [] }
-| unless unless_list { $1::$2 }
-
-until_list:
- { [] }
-| until until_list { $1::$2 }
-
-unless:
- UNLESS expr RESTART UIDENT { (get_loc (), $2, true, $4) }
-| UNLESS expr RESUME UIDENT { (get_loc (), $2, false, $4) }
-
-until:
- UNTIL expr RESTART UIDENT { (get_loc (), $2, true, $4) }
-| UNTIL expr RESUME UIDENT { (get_loc (), $2, false, $4) }
-
-assert_:
-| ASSERT expr SCOL {mkassert ($2)}
-
-eq:
- ident_list EQ expr SCOL {mkeq (List.rev (List.map fst $1), $3)}
-| LPAR ident_list RPAR EQ expr SCOL {mkeq (List.rev (List.map fst $2), $5)}
-
-lustre_spec:
-| contract EOF { $1 }
-
-contract:
-requires ensures behaviors { { requires = $1; ensures = $2; behaviors = $3; spec_loc = get_loc () } }
-
-requires:
-{ [] }
-| REQUIRES qexpr SCOL requires { $2::$4 }
-
-ensures:
-{ [] }
-| ENSURES qexpr SCOL ensures { $2 :: $4 }
-| OBSERVER node_ident LPAR tuple_expr RPAR SCOL ensures {
- mkeexpr (mkexpr ((Expr_appl ($2, mkexpr (Expr_tuple $4), None)))) :: $7
-}
-
-behaviors:
-{ [] }
-| BEHAVIOR IDENT COL assumes ensures behaviors { ($2,$4,$5,get_loc ())::$6 }
-
-assumes:
-{ [] }
-| ASSUMES qexpr SCOL assumes { $2::$4 }
-
-/* WARNING: UNUSED RULES */
-tuple_qexpr:
-| qexpr COMMA qexpr {[$3;$1]}
-| tuple_qexpr COMMA qexpr {$3::$1}
-
-qexpr:
-| expr { mkeexpr $1 }
- /* Quantifiers */
-| EXISTS vdecl SCOL qexpr %prec prec_exists { extend_eexpr [Exists, $2] $4 }
-| FORALL vdecl SCOL qexpr %prec prec_forall { extend_eexpr [Forall, $2] $4 }
-
-
-tuple_expr:
- expr COMMA expr {[$3;$1]}
-| tuple_expr COMMA expr {$3::$1}
-
-// Same as tuple expr but accepting lists with single element
-array_expr:
- expr {[$1]}
-| expr COMMA array_expr {$1::$3}
-
-dim_list:
- dim RBRACKET { fun base -> mkexpr (Expr_access (base, $1)) }
-| dim RBRACKET LBRACKET dim_list { fun base -> $4 (mkexpr (Expr_access (base, $1))) }
-
-expr:
-/* constants */
- INT {mkexpr (Expr_const (Const_int $1))}
-| REAL {let c,e,s = $1 in mkexpr (Expr_const (Const_real (c,e,s)))}
-/* | FLOAT {mkexpr (Expr_const (Const_float $1))}*/
-/* Idents or type enum tags */
-| IDENT { mkexpr (Expr_ident $1) }
-| tag_ident { mkexpr (Expr_ident $1) (*(Expr_const (Const_tag $1))*) }
-| LPAR ANNOT expr RPAR
- {update_expr_annot (get_current_node ()) $3 $2}
-| LPAR expr RPAR
- {$2}
-| LPAR tuple_expr RPAR
- {mkexpr (Expr_tuple (List.rev $2))}
-
-/* Array expressions */
-| LBRACKET array_expr RBRACKET { mkexpr (Expr_array $2) }
-| expr POWER dim { mkexpr (Expr_power ($1, $3)) }
-| expr LBRACKET dim_list { $3 $1 }
-
-/* Temporal operators */
-| PRE expr
- {mkexpr (Expr_pre $2)}
-| expr ARROW expr
- {mkexpr (Expr_arrow ($1,$3))}
-| expr FBY expr
- {(*mkexpr (Expr_fby ($1,$3))*)
- mkexpr (Expr_arrow ($1, mkexpr (Expr_pre $3)))}
-| expr WHEN vdecl_ident
- {mkexpr (Expr_when ($1,fst $3,tag_true))}
-| expr WHENNOT vdecl_ident
- {mkexpr (Expr_when ($1,fst $3,tag_false))}
-| expr WHEN tag_ident LPAR vdecl_ident RPAR
- {mkexpr (Expr_when ($1, fst $5, $3))}
-| MERGE vdecl_ident handler_expr_list
- {mkexpr (Expr_merge (fst $2,$3))}
-
-/* Applications */
-| node_ident LPAR expr RPAR
- {mkexpr (Expr_appl ($1, $3, None))}
-| node_ident LPAR expr RPAR EVERY expr
- {mkexpr (Expr_appl ($1, $3, Some $6))}
-| node_ident LPAR tuple_expr RPAR
- {
- let id=$1 in
- let args=List.rev $3 in
- match id, args with
- | "fbyn", [expr;n;init] ->
- let n = match n.expr_desc with
- | Expr_const (Const_int n) -> n
- | _ -> assert false
- in
- fby expr n init
- | _ -> mkexpr (Expr_appl ($1, mkexpr (Expr_tuple args), None))
- }
-| node_ident LPAR tuple_expr RPAR EVERY expr
- {
- let id=$1 in
- let args=List.rev $3 in
- let clock=$6 in
- if id="fby" then
- assert false (* TODO Ca veut dire quoi fby (e,n,init) every c *)
- else
- mkexpr (Expr_appl (id, mkexpr (Expr_tuple args), Some clock))
- }
-
-/* Boolean expr */
-| expr AND expr
- {mkpredef_call "&&" [$1;$3]}
-| expr AMPERAMPER expr
- {mkpredef_call "&&" [$1;$3]}
-| expr OR expr
- {mkpredef_call "||" [$1;$3]}
-| expr BARBAR expr
- {mkpredef_call "||" [$1;$3]}
-| expr XOR expr
- {mkpredef_call "xor" [$1;$3]}
-| NOT expr
- {mkpredef_call "not" [$2]}
-| expr IMPL expr
- {mkpredef_call "impl" [$1;$3]}
-
-/* Comparison expr */
-| expr EQ expr
- {mkpredef_call "=" [$1;$3]}
-| expr LT expr
- {mkpredef_call "<" [$1;$3]}
-| expr LTE expr
- {mkpredef_call "<=" [$1;$3]}
-| expr GT expr
- {mkpredef_call ">" [$1;$3]}
-| expr GTE expr
- {mkpredef_call ">=" [$1;$3]}
-| expr NEQ expr
- {mkpredef_call "!=" [$1;$3]}
-
-/* Arithmetic expr */
-| expr PLUS expr
- {mkpredef_call "+" [$1;$3]}
-| expr MINUS expr
- {mkpredef_call "-" [$1;$3]}
-| expr MULT expr
- {mkpredef_call "*" [$1;$3]}
-| expr DIV expr
- {mkpredef_call "/" [$1;$3]}
-| MINUS expr %prec UMINUS
- {mkpredef_call "uminus" [$2]}
-| expr MOD expr
- {mkpredef_call "mod" [$1;$3]}
-
-/* If */
-| IF expr THEN expr ELSE expr
- {mkexpr (Expr_ite ($2, $4, $6))}
-
-handler_expr_list:
- { [] }
-| handler_expr handler_expr_list { $1 :: $2 }
-
-handler_expr:
- LPAR tag_ident ARROW expr RPAR { ($2, $4) }
-
-signed_const_array:
-| signed_const { [$1] }
-| signed_const COMMA signed_const_array { $1 :: $3 }
-
-signed_const_struct:
-| IDENT EQ signed_const { [ ($1, $3) ] }
-| IDENT EQ signed_const COMMA signed_const_struct { ($1, $3) :: $5 }
-
-signed_const:
- INT {Const_int $1}
-| REAL {let c,e,s =$1 in Const_real (c,e,s)}
-/* | FLOAT {Const_float $1} */
-| tag_ident {Const_tag $1}
-| MINUS INT {Const_int (-1 * $2)}
-| MINUS REAL {let c,e,s = $2 in Const_real (Num.minus_num c, e, "-" ^ s)}
-/* | MINUS FLOAT {Const_float (-1. *. $2)} */
-| LCUR signed_const_struct RCUR { Const_struct $2 }
-| LBRACKET signed_const_array RBRACKET { Const_array $2 }
-
-dim:
- INT { mkdim_int $1 }
-| LPAR dim RPAR { $2 }
-| UIDENT { mkdim_ident $1 }
-| IDENT { mkdim_ident $1 }
-| dim AND dim
- {mkdim_appl "&&" [$1;$3]}
-| dim AMPERAMPER dim
- {mkdim_appl "&&" [$1;$3]}
-| dim OR dim
- {mkdim_appl "||" [$1;$3]}
-| dim BARBAR dim
- {mkdim_appl "||" [$1;$3]}
-| dim XOR dim
- {mkdim_appl "xor" [$1;$3]}
-| NOT dim
- {mkdim_appl "not" [$2]}
-| dim IMPL dim
- {mkdim_appl "impl" [$1;$3]}
-
-/* Comparison dim */
-| dim EQ dim
- {mkdim_appl "=" [$1;$3]}
-| dim LT dim
- {mkdim_appl "<" [$1;$3]}
-| dim LTE dim
- {mkdim_appl "<=" [$1;$3]}
-| dim GT dim
- {mkdim_appl ">" [$1;$3]}
-| dim GTE dim
- {mkdim_appl ">=" [$1;$3]}
-| dim NEQ dim
- {mkdim_appl "!=" [$1;$3]}
-
-/* Arithmetic dim */
-| dim PLUS dim
- {mkdim_appl "+" [$1;$3]}
-| dim MINUS dim
- {mkdim_appl "-" [$1;$3]}
-| dim MULT dim
- {mkdim_appl "*" [$1;$3]}
-| dim DIV dim
- {mkdim_appl "/" [$1;$3]}
-| MINUS dim %prec UMINUS
- {mkdim_appl "uminus" [$2]}
-| dim MOD dim
- {mkdim_appl "mod" [$1;$3]}
-/* If */
-| IF dim THEN dim ELSE dim
- {mkdim_ite $2 $4 $6}
-
-locals:
- {[]}
-| VAR local_vdecl_list SCOL {$2}
-
-vdecl_list:
- vdecl {$1}
-| vdecl_list SCOL vdecl {$3 @ $1}
-
-vdecl:
- ident_list COL typeconst clock
- { List.map (fun (id, loc) -> mkvar_decl (id, mktyp $3, $4, false, None) loc) $1 }
-| CONST ident_list /* static parameters don't have clocks */
- { List.map (fun (id, loc) -> mkvar_decl (id, mktyp Tydec_any, mkclock Ckdec_any, true, None) loc) $2 }
-| CONST ident_list COL typeconst /* static parameters don't have clocks */
- { List.map (fun (id, loc) -> mkvar_decl (id, mktyp $4, mkclock Ckdec_any, true, None) loc) $2 }
-
-local_vdecl_list:
- local_vdecl {$1}
-| local_vdecl_list SCOL local_vdecl {$3 @ $1}
-
-local_vdecl:
-/* Useless no ?*/ ident_list
- { List.map (fun (id, loc) -> mkvar_decl (id, mktyp Tydec_any, mkclock Ckdec_any, false, None) loc) $1 }
-| ident_list COL typeconst clock
- { List.map (fun (id, loc) -> mkvar_decl (id, mktyp $3, $4, false, None) loc) $1 }
-| CONST vdecl_ident EQ expr /* static parameters don't have clocks */
- { let (id, loc) = $2 in [ mkvar_decl (id, mktyp Tydec_any, mkclock Ckdec_any, true, Some $4) loc] }
-| CONST vdecl_ident COL typeconst EQ expr /* static parameters don't have clocks */
- { let (id, loc) = $2 in [ mkvar_decl (id, mktyp $4, mkclock Ckdec_any, true, Some $6) loc] }
-
-cdecl_list:
- cdecl SCOL { (fun itf -> [$1 itf]) }
-| cdecl cdecl_list SCOL { (fun itf -> let c1 = ($1 itf) in c1::($2 itf)) }
-
-cdecl:
- const_ident EQ signed_const {
- (fun itf ->
- let c = mktop_decl itf (Const {
- const_id = $1;
- const_loc = Location.symbol_rloc ();
- const_type = Types.new_var ();
- const_value = $3})
- in
- (*add_const itf $1 c;*) c)
- }
-
-clock:
- {mkclock Ckdec_any}
-| when_list
- {mkclock (Ckdec_bool (List.rev $1))}
-
-when_cond:
- WHEN IDENT {($2, tag_true)}
-| WHENNOT IDENT {($2, tag_false)}
-| WHEN tag_ident LPAR IDENT RPAR {($4, $2)}
-
-when_list:
- when_cond {[$1]}
-| when_list when_cond {$2::$1}
-
-ident_list:
- vdecl_ident {[$1]}
-| ident_list COMMA vdecl_ident {$3::$1}
-
-SCOL_opt:
- SCOL {} | {}
-
-
-lustre_annot:
-lustre_annot_list EOF { { annots = $1; annot_loc = get_loc () } }
-
-lustre_annot_list:
- { [] }
-| kwd COL qexpr SCOL lustre_annot_list { ($1,$3)::$5 }
-| IDENT COL qexpr SCOL lustre_annot_list { ([$1],$3)::$5 }
-| INVARIANT COL qexpr SCOL lustre_annot_list{ (["invariant"],$3)::$5 }
-| OBSERVER COL qexpr SCOL lustre_annot_list { (["observer"],$3)::$5 }
-| CCODE COL qexpr SCOL lustre_annot_list{ (["c_code"],$3)::$5 }
-| MATLAB COL qexpr SCOL lustre_annot_list{ (["matlab"],$3)::$5 }
-
-
-kwd:
-DIV { [] }
-| DIV IDENT kwd { $2::$3}
-
-%%
-(* Local Variables: *)
-(* compile-command:"make -C .." *)
-(* End: *)
-
-
+/********************************************************************/
+/* */
+/* The LustreC compiler toolset / The LustreC Development Team */
+/* Copyright 2012 - -- ONERA - CNRS - INPT */
+/* */
+/* LustreC is free software, distributed WITHOUT ANY WARRANTY */
+/* under the terms of the GNU Lesser General Public License */
+/* version 2.1. */
+/* */
+/********************************************************************/
+
+%{
+open Utils
+open LustreSpec
+open Corelang
+open Dimension
+open Parse
+
+let get_loc () = Location.symbol_rloc ()
+
+let mkident x = x, get_loc ()
+let mktyp x = mktyp (get_loc ()) x
+let mkclock x = mkclock (get_loc ()) x
+let mkvar_decl x loc = mkvar_decl loc ~orig:true x
+let mkexpr x = mkexpr (get_loc ()) x
+let mkeexpr x = mkeexpr (get_loc ()) x
+let mkeq x = mkeq (get_loc ()) x
+let mkassert x = mkassert (get_loc ()) x
+let mktop_decl itf x = mktop_decl (get_loc ()) (Location.get_module ()) itf x
+let mkpredef_call x = mkpredef_call (get_loc ()) x
+(*let mkpredef_unary_call x = mkpredef_unary_call (get_loc ()) x*)
+
+let mkdim_int i = mkdim_int (get_loc ()) i
+let mkdim_bool b = mkdim_bool (get_loc ()) b
+let mkdim_ident id = mkdim_ident (get_loc ()) id
+let mkdim_appl f args = mkdim_appl (get_loc ()) f args
+let mkdim_ite i t e = mkdim_ite (get_loc ()) i t e
+
+let mkannots annots = { annots = annots; annot_loc = get_loc () }
+
+let node_stack : ident list ref = ref []
+let debug_calls () = Format.eprintf "call stack: %a@.@?" (Utils.fprintf_list ~sep:", " Format.pp_print_string) !node_stack
+let push_node nd = node_stack:= nd :: !node_stack
+let pop_node () = try node_stack := List.tl !node_stack with _ -> assert false
+let get_current_node () = try List.hd !node_stack with _ -> assert false
+
+let rec fby expr n init =
+ if n<=1 then
+ mkexpr (Expr_arrow (init, mkexpr (Expr_pre expr)))
+ else
+ mkexpr (Expr_arrow (init, mkexpr (Expr_pre (fby expr (n-1) init))))
+
+%}
+
+%token <int> INT
+%token <Num.num * int * string> REAL
+
+%token <string> STRING
+%token AUTOMATON STATE UNTIL UNLESS RESTART RESUME LAST
+%token STATELESS ASSERT OPEN QUOTE FUNCTION
+%token <string> IDENT
+%token <string> UIDENT
+%token TRUE FALSE
+%token <LustreSpec.expr_annot> ANNOT
+%token <LustreSpec.node_annot> NODESPEC
+%token LBRACKET RBRACKET LCUR RCUR LPAR RPAR SCOL COL COMMA COLCOL
+%token AMPERAMPER BARBAR NOT POWER
+%token IF THEN ELSE
+%token UCLOCK DCLOCK PHCLOCK TAIL
+%token MERGE FBY WHEN WHENNOT EVERY
+%token NODE LET TEL RETURNS VAR IMPORTED SENSOR ACTUATOR WCET TYPE CONST
+%token STRUCT ENUM
+%token TINT TREAL TBOOL TCLOCK
+%token RATE DUE
+%token EQ LT GT LTE GTE NEQ
+%token AND OR XOR IMPL
+%token MULT DIV MOD
+%token MINUS PLUS UMINUS
+%token PRE ARROW
+%token REQUIRES ENSURES OBSERVER
+%token INVARIANT BEHAVIOR ASSUMES CCODE MATLAB
+%token EXISTS FORALL
+%token PROTOTYPE LIB
+%token EOF
+
+%nonassoc prec_exists prec_forall
+%nonassoc COMMA
+%nonassoc EVERY
+%left MERGE IF
+%nonassoc ELSE
+%right ARROW FBY
+%left WHEN WHENNOT UCLOCK DCLOCK PHCLOCK
+%right COLCOL
+%right IMPL
+%left OR XOR BARBAR
+%left AND AMPERAMPER
+%left NOT
+%nonassoc INT
+%nonassoc EQ LT GT LTE GTE NEQ
+%left MINUS PLUS
+%left MULT DIV MOD
+%left UMINUS
+%left POWER
+%left PRE LAST
+%nonassoc RBRACKET
+%nonassoc LBRACKET
+
+%start prog
+%type <LustreSpec.top_decl list> prog
+
+%start header
+%type <LustreSpec.top_decl list> header
+
+%start lustre_annot
+%type <LustreSpec.expr_annot> lustre_annot
+
+%start lustre_spec
+%type <LustreSpec.node_annot> lustre_spec
+
+%start signed_const
+%type <LustreSpec.constant> signed_const
+
+%%
+
+module_ident:
+ UIDENT { $1 }
+| IDENT { $1 }
+
+tag_ident:
+ UIDENT { $1 }
+| TRUE { tag_true }
+| FALSE { tag_false }
+
+node_ident:
+ UIDENT { $1 }
+| IDENT { $1 }
+
+node_ident_decl:
+ node_ident { push_node $1; $1 }
+
+vdecl_ident:
+ UIDENT { mkident $1 }
+| IDENT { mkident $1 }
+
+const_ident:
+ UIDENT { $1 }
+| IDENT { $1 }
+
+type_ident:
+ IDENT { $1 }
+
+prog:
+ open_list typ_def_prog top_decl_list EOF { $1 @ $2 @ (List.rev $3) }
+
+typ_def_prog:
+ typ_def_list { $1 false }
+
+header:
+ open_list typ_def_header top_decl_header_list EOF { $1 @ $2 @ (List.rev $3) }
+
+typ_def_header:
+ typ_def_list { $1 true }
+
+open_list:
+ { [] }
+| open_lusi open_list { $1 :: $2 }
+
+open_lusi:
+| OPEN QUOTE module_ident QUOTE { mktop_decl false (Open (true, $3))}
+| OPEN LT module_ident GT { mktop_decl false (Open (false, $3)) }
+
+top_decl_list:
+ {[]}
+| top_decl_list top_decl {$2@$1}
+
+
+top_decl_header_list:
+ { [] }
+| top_decl_header_list top_decl_header { $2@$1 }
+
+state_annot:
+ FUNCTION { true }
+| NODE { false }
+
+top_decl_header:
+| CONST cdecl_list { List.rev ($2 true) }
+| nodespec_list state_annot node_ident LPAR vdecl_list SCOL_opt RPAR RETURNS LPAR vdecl_list SCOL_opt RPAR prototype_opt in_lib_list SCOL
+ {let nd = mktop_decl true (ImportedNode
+ {nodei_id = $3;
+ nodei_type = Types.new_var ();
+ nodei_clock = Clocks.new_var true;
+ nodei_inputs = List.rev $5;
+ nodei_outputs = List.rev $10;
+ nodei_stateless = $2;
+ nodei_spec = $1;
+ nodei_prototype = $13;
+ nodei_in_lib = $14;})
+ in
+ (*add_imported_node $3 nd;*) [nd] }
+
+prototype_opt:
+ { None }
+| PROTOTYPE node_ident { Some $2}
+
+in_lib_list:
+{ [] }
+| LIB module_ident in_lib_list { $2::$3 }
+
+top_decl:
+| CONST cdecl_list { List.rev ($2 false) }
+| nodespec_list state_annot node_ident_decl LPAR vdecl_list SCOL_opt RPAR RETURNS LPAR vdecl_list SCOL_opt RPAR SCOL_opt locals LET stmt_list TEL
+ {
+ let stmts, asserts, annots = $16 in
+ (* Declaring eqs annots *)
+ List.iter (fun ann ->
+ List.iter (fun (key, _) ->
+ Annotations.add_node_ann $3 key
+ ) ann.annots
+ ) annots;
+ (* Building the node *)
+ let nd = mktop_decl false (Node
+ {node_id = $3;
+ node_type = Types.new_var ();
+ node_clock = Clocks.new_var true;
+ node_inputs = List.rev $5;
+ node_outputs = List.rev $10;
+ node_locals = List.rev $14;
+ node_gencalls = [];
+ node_checks = [];
+ node_asserts = asserts;
+ node_stmts = stmts;
+ node_dec_stateless = $2;
+ node_stateless = None;
+ node_spec = $1;
+ node_annot = annots})
+ in
+ pop_node ();
+ (*add_node $3 nd;*) [nd] }
+
+nodespec_list:
+ { None }
+| NODESPEC nodespec_list {
+ (function
+ | None -> (fun s1 -> Some s1)
+ | Some s2 -> (fun s1 -> Some (merge_node_annot s1 s2))) $2 $1 }
+
+typ_def_list:
+ /* empty */ { (fun itf -> []) }
+| typ_def SCOL typ_def_list { (fun itf -> let ty1 = ($1 itf) in ty1 :: ($3 itf)) }
+
+typ_def:
+ TYPE type_ident EQ typ_def_rhs { (fun itf ->
+ let typ = mktop_decl itf (TypeDef { tydef_id = $2;
+ tydef_desc = $4
+ })
+ in (*add_type itf $2 typ;*) typ) }
+
+typ_def_rhs:
+ typeconst { $1 }
+| ENUM LCUR tag_list RCUR { Tydec_enum (List.rev $3) }
+| STRUCT LCUR field_list RCUR { Tydec_struct (List.rev $3) }
+
+array_typ_decl:
+ %prec POWER { fun typ -> typ }
+ | POWER dim array_typ_decl { fun typ -> $3 (Tydec_array ($2, typ)) }
+
+typeconst:
+ TINT array_typ_decl { $2 Tydec_int }
+| TBOOL array_typ_decl { $2 Tydec_bool }
+| TREAL array_typ_decl { $2 Tydec_real }
+/* | TFLOAT array_typ_decl { $2 Tydec_float } */
+| type_ident array_typ_decl { $2 (Tydec_const $1) }
+| TBOOL TCLOCK { Tydec_clock Tydec_bool }
+| IDENT TCLOCK { Tydec_clock (Tydec_const $1) }
+
+tag_list:
+ UIDENT { $1 :: [] }
+| tag_list COMMA UIDENT { $3 :: $1 }
+
+field_list: { [] }
+| field_list IDENT COL typeconst SCOL { ($2, $4) :: $1 }
+
+stmt_list:
+ { [], [], [] }
+| eq stmt_list {let eql, assertl, annotl = $2 in ((Eq $1)::eql), assertl, annotl}
+| assert_ stmt_list {let eql, assertl, annotl = $2 in eql, ($1::assertl), annotl}
+| ANNOT stmt_list {let eql, assertl, annotl = $2 in eql, assertl, $1::annotl}
+| automaton stmt_list {let eql, assertl, annotl = $2 in ((Aut $1)::eql), assertl, annotl}
+
+automaton:
+ AUTOMATON type_ident handler_list { Automata.mkautomata (get_loc ()) $2 $3 }
+
+handler_list:
+ { [] }
+| handler handler_list { $1::$2 }
+
+handler:
+ STATE UIDENT COL unless_list locals LET stmt_list TEL until_list { Automata.mkhandler (get_loc ()) $2 $4 $9 $5 $7 }
+
+unless_list:
+ { [] }
+| unless unless_list { $1::$2 }
+
+until_list:
+ { [] }
+| until until_list { $1::$2 }
+
+unless:
+ UNLESS expr RESTART UIDENT { (get_loc (), $2, true, $4) }
+| UNLESS expr RESUME UIDENT { (get_loc (), $2, false, $4) }
+
+until:
+ UNTIL expr RESTART UIDENT { (get_loc (), $2, true, $4) }
+| UNTIL expr RESUME UIDENT { (get_loc (), $2, false, $4) }
+
+assert_:
+| ASSERT expr SCOL {mkassert ($2)}
+
+eq:
+ ident_list EQ expr SCOL {mkeq (List.rev (List.map fst $1), $3)}
+| LPAR ident_list RPAR EQ expr SCOL {mkeq (List.rev (List.map fst $2), $5)}
+
+lustre_spec:
+| contract EOF { $1 }
+
+contract:
+requires ensures behaviors { { requires = $1; ensures = $2; behaviors = $3; spec_loc = get_loc () } }
+
+requires:
+{ [] }
+| REQUIRES qexpr SCOL requires { $2::$4 }
+
+ensures:
+{ [] }
+| ENSURES qexpr SCOL ensures { $2 :: $4 }
+| OBSERVER node_ident LPAR tuple_expr RPAR SCOL ensures {
+ mkeexpr (mkexpr ((Expr_appl ($2, mkexpr (Expr_tuple $4), None)))) :: $7
+}
+
+behaviors:
+{ [] }
+| BEHAVIOR IDENT COL assumes ensures behaviors { ($2,$4,$5,get_loc ())::$6 }
+
+assumes:
+{ [] }
+| ASSUMES qexpr SCOL assumes { $2::$4 }
+
+/* WARNING: UNUSED RULES */
+tuple_qexpr:
+| qexpr COMMA qexpr {[$3;$1]}
+| tuple_qexpr COMMA qexpr {$3::$1}
+
+qexpr:
+| expr { mkeexpr $1 }
+ /* Quantifiers */
+| EXISTS vdecl SCOL qexpr %prec prec_exists { extend_eexpr [Exists, $2] $4 }
+| FORALL vdecl SCOL qexpr %prec prec_forall { extend_eexpr [Forall, $2] $4 }
+
+
+tuple_expr:
+ expr COMMA expr {[$3;$1]}
+| tuple_expr COMMA expr {$3::$1}
+
+// Same as tuple expr but accepting lists with single element
+array_expr:
+ expr {[$1]}
+| expr COMMA array_expr {$1::$3}
+
+dim_list:
+ dim RBRACKET { fun base -> mkexpr (Expr_access (base, $1)) }
+| dim RBRACKET LBRACKET dim_list { fun base -> $4 (mkexpr (Expr_access (base, $1))) }
+
+expr:
+/* constants */
+ INT {mkexpr (Expr_const (Const_int $1))}
+| REAL {let c,e,s = $1 in mkexpr (Expr_const (Const_real (c,e,s)))}
+/* | FLOAT {mkexpr (Expr_const (Const_float $1))}*/
+/* Idents or type enum tags */
+| IDENT { mkexpr (Expr_ident $1) }
+| tag_ident { mkexpr (Expr_ident $1) (*(Expr_const (Const_tag $1))*) }
+| LPAR ANNOT expr RPAR
+ {update_expr_annot (get_current_node ()) $3 $2}
+| LPAR expr RPAR
+ {$2}
+| LPAR tuple_expr RPAR
+ {mkexpr (Expr_tuple (List.rev $2))}
+
+/* Array expressions */
+| LBRACKET array_expr RBRACKET { mkexpr (Expr_array $2) }
+| expr POWER dim { mkexpr (Expr_power ($1, $3)) }
+| expr LBRACKET dim_list { $3 $1 }
+
+/* Temporal operators */
+| PRE expr
+ {mkexpr (Expr_pre $2)}
+| expr ARROW expr
+ {mkexpr (Expr_arrow ($1,$3))}
+| expr FBY expr
+ {(*mkexpr (Expr_fby ($1,$3))*)
+ mkexpr (Expr_arrow ($1, mkexpr (Expr_pre $3)))}
+| expr WHEN vdecl_ident
+ {mkexpr (Expr_when ($1,fst $3,tag_true))}
+| expr WHENNOT vdecl_ident
+ {mkexpr (Expr_when ($1,fst $3,tag_false))}
+| expr WHEN tag_ident LPAR vdecl_ident RPAR
+ {mkexpr (Expr_when ($1, fst $5, $3))}
+| MERGE vdecl_ident handler_expr_list
+ {mkexpr (Expr_merge (fst $2,$3))}
+
+/* Applications */
+| node_ident LPAR expr RPAR
+ {mkexpr (Expr_appl ($1, $3, None))}
+| node_ident LPAR expr RPAR EVERY expr
+ {mkexpr (Expr_appl ($1, $3, Some $6))}
+| node_ident LPAR tuple_expr RPAR
+ {
+ let id=$1 in
+ let args=List.rev $3 in
+ match id, args with
+ | "fbyn", [expr;n;init] ->
+ let n = match n.expr_desc with
+ | Expr_const (Const_int n) -> n
+ | _ -> assert false
+ in
+ fby expr n init
+ | _ -> mkexpr (Expr_appl ($1, mkexpr (Expr_tuple args), None))
+ }
+| node_ident LPAR tuple_expr RPAR EVERY expr
+ {
+ let id=$1 in
+ let args=List.rev $3 in
+ let clock=$6 in
+ if id="fby" then
+ assert false (* TODO Ca veut dire quoi fby (e,n,init) every c *)
+ else
+ mkexpr (Expr_appl (id, mkexpr (Expr_tuple args), Some clock))
+ }
+
+/* Boolean expr */
+| expr AND expr
+ {mkpredef_call "&&" [$1;$3]}
+| expr AMPERAMPER expr
+ {mkpredef_call "&&" [$1;$3]}
+| expr OR expr
+ {mkpredef_call "||" [$1;$3]}
+| expr BARBAR expr
+ {mkpredef_call "||" [$1;$3]}
+| expr XOR expr
+ {mkpredef_call "xor" [$1;$3]}
+| NOT expr
+ {mkpredef_call "not" [$2]}
+| expr IMPL expr
+ {mkpredef_call "impl" [$1;$3]}
+
+/* Comparison expr */
+| expr EQ expr
+ {mkpredef_call "=" [$1;$3]}
+| expr LT expr
+ {mkpredef_call "<" [$1;$3]}
+| expr LTE expr
+ {mkpredef_call "<=" [$1;$3]}
+| expr GT expr
+ {mkpredef_call ">" [$1;$3]}
+| expr GTE expr
+ {mkpredef_call ">=" [$1;$3]}
+| expr NEQ expr
+ {mkpredef_call "!=" [$1;$3]}
+
+/* Arithmetic expr */
+| expr PLUS expr
+ {mkpredef_call "+" [$1;$3]}
+| expr MINUS expr
+ {mkpredef_call "-" [$1;$3]}
+| expr MULT expr
+ {mkpredef_call "*" [$1;$3]}
+| expr DIV expr
+ {mkpredef_call "/" [$1;$3]}
+| MINUS expr %prec UMINUS
+ {mkpredef_call "uminus" [$2]}
+| expr MOD expr
+ {mkpredef_call "mod" [$1;$3]}
+
+/* If */
+| IF expr THEN expr ELSE expr
+ {mkexpr (Expr_ite ($2, $4, $6))}
+
+handler_expr_list:
+ { [] }
+| handler_expr handler_expr_list { $1 :: $2 }
+
+handler_expr:
+ LPAR tag_ident ARROW expr RPAR { ($2, $4) }
+
+signed_const_array:
+| signed_const { [$1] }
+| signed_const COMMA signed_const_array { $1 :: $3 }
+
+signed_const_struct:
+| IDENT EQ signed_const { [ ($1, $3) ] }
+| IDENT EQ signed_const COMMA signed_const_struct { ($1, $3) :: $5 }
+
+signed_const:
+ INT {Const_int $1}
+| REAL {let c,e,s =$1 in Const_real (c,e,s)}
+/* | FLOAT {Const_float $1} */
+| tag_ident {Const_tag $1}
+| MINUS INT {Const_int (-1 * $2)}
+| MINUS REAL {let c,e,s = $2 in Const_real (Num.minus_num c, e, "-" ^ s)}
+/* | MINUS FLOAT {Const_float (-1. *. $2)} */
+| LCUR signed_const_struct RCUR { Const_struct $2 }
+| LBRACKET signed_const_array RBRACKET { Const_array $2 }
+
+dim:
+ INT { mkdim_int $1 }
+| LPAR dim RPAR { $2 }
+| UIDENT { mkdim_ident $1 }
+| IDENT { mkdim_ident $1 }
+| dim AND dim
+ {mkdim_appl "&&" [$1;$3]}
+| dim AMPERAMPER dim
+ {mkdim_appl "&&" [$1;$3]}
+| dim OR dim
+ {mkdim_appl "||" [$1;$3]}
+| dim BARBAR dim
+ {mkdim_appl "||" [$1;$3]}
+| dim XOR dim
+ {mkdim_appl "xor" [$1;$3]}
+| NOT dim
+ {mkdim_appl "not" [$2]}
+| dim IMPL dim
+ {mkdim_appl "impl" [$1;$3]}
+
+/* Comparison dim */
+| dim EQ dim
+ {mkdim_appl "=" [$1;$3]}
+| dim LT dim
+ {mkdim_appl "<" [$1;$3]}
+| dim LTE dim
+ {mkdim_appl "<=" [$1;$3]}
+| dim GT dim
+ {mkdim_appl ">" [$1;$3]}
+| dim GTE dim
+ {mkdim_appl ">=" [$1;$3]}
+| dim NEQ dim
+ {mkdim_appl "!=" [$1;$3]}
+
+/* Arithmetic dim */
+| dim PLUS dim
+ {mkdim_appl "+" [$1;$3]}
+| dim MINUS dim
+ {mkdim_appl "-" [$1;$3]}
+| dim MULT dim
+ {mkdim_appl "*" [$1;$3]}
+| dim DIV dim
+ {mkdim_appl "/" [$1;$3]}
+| MINUS dim %prec UMINUS
+ {mkdim_appl "uminus" [$2]}
+| dim MOD dim
+ {mkdim_appl "mod" [$1;$3]}
+/* If */
+| IF dim THEN dim ELSE dim
+ {mkdim_ite $2 $4 $6}
+
+locals:
+ {[]}
+| VAR local_vdecl_list SCOL {$2}
+
+vdecl_list:
+ vdecl {$1}
+| vdecl_list SCOL vdecl {$3 @ $1}
+
+vdecl:
+ ident_list COL typeconst clock
+ { List.map (fun (id, loc) -> mkvar_decl (id, mktyp $3, $4, false, None) loc) $1 }
+| CONST ident_list /* static parameters don't have clocks */
+ { List.map (fun (id, loc) -> mkvar_decl (id, mktyp Tydec_any, mkclock Ckdec_any, true, None) loc) $2 }
+| CONST ident_list COL typeconst /* static parameters don't have clocks */
+ { List.map (fun (id, loc) -> mkvar_decl (id, mktyp $4, mkclock Ckdec_any, true, None) loc) $2 }
+
+local_vdecl_list:
+ local_vdecl {$1}
+| local_vdecl_list SCOL local_vdecl {$3 @ $1}
+
+local_vdecl:
+/* Useless no ?*/ ident_list
+ { List.map (fun (id, loc) -> mkvar_decl (id, mktyp Tydec_any, mkclock Ckdec_any, false, None) loc) $1 }
+| ident_list COL typeconst clock
+ { List.map (fun (id, loc) -> mkvar_decl (id, mktyp $3, $4, false, None) loc) $1 }
+| CONST vdecl_ident EQ expr /* static parameters don't have clocks */
+ { let (id, loc) = $2 in [ mkvar_decl (id, mktyp Tydec_any, mkclock Ckdec_any, true, Some $4) loc] }
+| CONST vdecl_ident COL typeconst EQ expr /* static parameters don't have clocks */
+ { let (id, loc) = $2 in [ mkvar_decl (id, mktyp $4, mkclock Ckdec_any, true, Some $6) loc] }
+
+cdecl_list:
+ cdecl SCOL { (fun itf -> [$1 itf]) }
+| cdecl cdecl_list SCOL { (fun itf -> let c1 = ($1 itf) in c1::($2 itf)) }
+
+cdecl:
+ const_ident EQ signed_const {
+ (fun itf ->
+ let c = mktop_decl itf (Const {
+ const_id = $1;
+ const_loc = Location.symbol_rloc ();
+ const_type = Types.new_var ();
+ const_value = $3})
+ in
+ (*add_const itf $1 c;*) c)
+ }
+
+clock:
+ {mkclock Ckdec_any}
+| when_list
+ {mkclock (Ckdec_bool (List.rev $1))}
+
+when_cond:
+ WHEN IDENT {($2, tag_true)}
+| WHENNOT IDENT {($2, tag_false)}
+| WHEN tag_ident LPAR IDENT RPAR {($4, $2)}
+
+when_list:
+ when_cond {[$1]}
+| when_list when_cond {$2::$1}
+
+ident_list:
+ vdecl_ident {[$1]}
+| ident_list COMMA vdecl_ident {$3::$1}
+
+SCOL_opt:
+ SCOL {} | {}
+
+
+lustre_annot:
+lustre_annot_list EOF { { annots = $1; annot_loc = get_loc () } }
+
+lustre_annot_list:
+ { [] }
+| kwd COL qexpr SCOL lustre_annot_list { ($1,$3)::$5 }
+| IDENT COL qexpr SCOL lustre_annot_list { ([$1],$3)::$5 }
+| INVARIANT COL qexpr SCOL lustre_annot_list{ (["invariant"],$3)::$5 }
+| OBSERVER COL qexpr SCOL lustre_annot_list { (["observer"],$3)::$5 }
+| CCODE COL qexpr SCOL lustre_annot_list{ (["c_code"],$3)::$5 }
+| MATLAB COL qexpr SCOL lustre_annot_list{ (["matlab"],$3)::$5 }
+
+
+kwd:
+DIV { [] }
+| DIV IDENT kwd { $2::$3}
+
+%%
+(* Local Variables: *)
+(* compile-command:"make -C .." *)
+(* End: *)
+
+
diff --git a/src/pathConditions.ml b/src/pathConditions.ml
new file mode 100644
index 0000000000000000000000000000000000000000..b97a06085a83da1b8843bfba96b7a9bbaea42a4a
--- /dev/null
+++ b/src/pathConditions.ml
@@ -0,0 +1,179 @@
+open LustreSpec
+open Corelang
+open Log
+open Format
+
+module IdSet = Set.Make (struct type t = expr * int let compare = compare end)
+
+let inout_vars = ref []
+
+let print_tautology_var fmt v =
+ match (Types.repr v.var_type).Types.tdesc with
+ | Types.Tbool -> Format.fprintf fmt "(%s or not %s)" v.var_id v.var_id
+ | Types.Tint -> Format.fprintf fmt "(%s > 0 or %s <= 0)" v.var_id v.var_id
+ | Types.Treal -> Format.fprintf fmt "(%s > 0 or %s <= 0)" v.var_id v.var_id
+ | _ -> Format.fprintf fmt "(true)"
+
+let print_path arg = match !inout_vars with
+ | [] -> Format.printf "%t@." arg
+ | l -> Format.printf "%t and %a@." arg (Utils.fprintf_list ~sep:" and " (fun fmt elem -> print_tautology_var fmt elem)) l
+
+let rel_op = ["="; "!="; "<"; "<="; ">" ; ">=" ]
+
+let rec print_pre fmt nb_pre =
+ if nb_pre <= 0 then ()
+ else (
+ Format.fprintf fmt "pre ";
+ print_pre fmt (nb_pre-1)
+ )
+(*
+let combine2 f sub1 sub2 =
+ let elem_e1 = List.fold_right IdSet.add (List.map fst sub1) IdSet.empty in
+ let elem_e2 = List.fold_right IdSet.add (List.map fst sub2) IdSet.empty in
+ let common = IdSet.inter elem_e1 elem_e2 in
+ let sub1_filtered = List.filter (fun (v, _) -> not (IdSet.mem v common)) sub1 in
+ let sub2_filtered = List.filter (fun (v, _) -> not (IdSet.mem v common)) sub2 in
+ (List.map (fun (v, negv) -> (v, f negv e2)) sub1_filtered) @
+ (List.map (fun (v, negv) -> (v, f e1 negv)) sub2_filtered) @
+ (List.map (fun v -> (v, {expr with expr_desc = Expr_arrow(List.assoc v sub1, List.assoc v sub2)}) (IdSet.elements common)) )
+*)
+
+let rec select (v: expr * int) (active: bool list) (modified: ((expr * int) * expr) list list) (orig: expr list) =
+match active, modified, orig with
+| true::active_tl, e::modified_tl, _::orig_tl -> (List.assoc v e)::(select v active_tl modified_tl orig_tl)
+| false::active_tl, _::modified_tl, e::orig_tl -> e::(select v active_tl modified_tl orig_tl)
+| [], [], [] -> []
+| _ -> assert false
+
+let combine (f: expr list -> expr ) subs orig : ((expr * int) * expr) list =
+ let elems = List.map (fun sub_i -> List.fold_right IdSet.add (List.map fst sub_i) IdSet.empty) subs in
+ let all = List.fold_right IdSet.union elems IdSet.empty in
+ List.map (fun v ->
+ let active_subs = List.map (IdSet.mem v) elems in
+ v, f (select v active_subs subs orig)
+ ) (IdSet.elements all)
+
+let rec compute_neg_expr cpt_pre expr =
+ match expr.expr_desc with
+ | Expr_tuple l ->
+ let neg = List.map (compute_neg_expr cpt_pre) l in
+ combine (fun l' -> {expr with expr_desc = Expr_tuple l'}) neg l
+
+ | Expr_ite (i,t,e) when (Types.repr t.expr_type).Types.tdesc = Types.Tbool -> (
+ let list = [i; t; e] in
+ let neg = List.map (compute_neg_expr cpt_pre) list in
+ combine (fun l ->
+ match l with
+ | [i'; t'; e'] -> {expr with expr_desc = Expr_ite(i', t', e')}
+ | _ -> assert false
+ ) neg list
+ )
+ | Expr_ite (i,t,e) -> ( (* We return the guard as a new guard *)
+ gen_mcdc_cond_guard i;
+ let list = [i; t; e] in
+ let neg = List.map (compute_neg_expr cpt_pre) list in
+ combine (fun l ->
+ match l with
+ | [i'; t'; e'] -> {expr with expr_desc = Expr_ite(i', t', e')}
+ | _ -> assert false
+ ) neg list
+ )
+ | Expr_arrow (e1, e2) ->
+ let e1' = compute_neg_expr cpt_pre e1 in
+ let e2' = compute_neg_expr cpt_pre e2 in
+ combine (fun l -> match l with
+ | [x;y] -> { expr with expr_desc = Expr_arrow (x, y) }
+ | _ -> assert false
+ ) [e1'; e2'] [e1; e2]
+ | Expr_pre e ->
+ List.map
+ (fun (v, negv) -> (v, { expr with expr_desc = Expr_pre negv } ))
+ (compute_neg_expr (cpt_pre+1) e)
+
+ | Expr_appl (op_name, args, r) when List.mem op_name rel_op ->
+ [(expr, cpt_pre), mkpredef_call expr.expr_loc "not" [expr]]
+
+ | Expr_appl (op_name, args, r) ->
+ List.map
+ (fun (v, negv) -> (v, { expr with expr_desc = Expr_appl (op_name, negv, r) } ))
+ (compute_neg_expr cpt_pre args)
+
+ | Expr_ident _ when (Types.repr expr.expr_type).Types.tdesc = Types.Tbool ->
+ [(expr, cpt_pre), mkpredef_call expr.expr_loc "not" [expr]]
+ | _ -> []
+
+and
+ gen_mcdc_cond_var v expr =
+ report ~level:1 (fun fmt -> Format.fprintf fmt ".. Generating MC/DC cond for boolean flow %s and expression %a@." v Printers.pp_expr expr);
+ let leafs_n_neg_expr = compute_neg_expr 0 expr in
+ if List.length leafs_n_neg_expr > 1 then (
+ List.iter (fun ((vi, nb_pre), expr_neg_vi) ->
+ print_path (fun fmt -> Format.fprintf fmt "%a%a and (%s != %a)" print_pre nb_pre Printers.pp_expr vi v Printers.pp_expr expr_neg_vi);
+ print_path (fun fmt -> Format.fprintf fmt "(not %a%a) and (%s != %a)" print_pre nb_pre Printers.pp_expr vi v Printers.pp_expr expr_neg_vi)
+ ) leafs_n_neg_expr
+ )
+
+and gen_mcdc_cond_guard expr =
+ report ~level:1 (fun fmt -> Format.fprintf fmt".. Generating MC/DC cond for guard %a@." Printers.pp_expr expr);
+ let leafs_n_neg_expr = compute_neg_expr 0 expr in
+ if List.length leafs_n_neg_expr > 1 then (
+ List.iter (fun ((vi, nb_pre), expr_neg_vi) ->
+ print_path (fun fmt -> Format.fprintf fmt "%a%a and (%a != %a)" print_pre nb_pre Printers.pp_expr vi Printers.pp_expr expr Printers.pp_expr expr_neg_vi);
+ print_path (fun fmt -> Format.fprintf fmt "(not %a%a) and (%a != %a)" print_pre nb_pre Printers.pp_expr vi Printers.pp_expr expr Printers.pp_expr expr_neg_vi)
+
+ ) leafs_n_neg_expr
+ )
+
+
+let rec mcdc_expr cpt_pre expr =
+ match expr.expr_desc with
+ | Expr_tuple l -> List.iter (mcdc_expr cpt_pre) l
+ | Expr_ite (i,t,e) -> (gen_mcdc_cond_guard i; List.iter (mcdc_expr cpt_pre) [t; e])
+ | Expr_arrow (e1, e2) -> List.iter (mcdc_expr cpt_pre) [e1; e2]
+ | Expr_pre e -> mcdc_expr (cpt_pre+1) e
+ | Expr_appl (_, args, _) -> mcdc_expr cpt_pre args
+ | _ -> ()
+
+let mcdc_var_def v expr =
+ match (Types.repr expr.expr_type).Types.tdesc with
+ | Types.Tbool -> gen_mcdc_cond_var v expr
+ | _ -> mcdc_expr 0 expr
+
+let mcdc_node_eq eq =
+ match eq.eq_lhs, (Types.repr eq.eq_rhs.expr_type).Types.tdesc, eq.eq_rhs.expr_desc with
+ | [lhs], Types.Tbool, _ -> gen_mcdc_cond_var lhs eq.eq_rhs
+ | _::_, Types.Ttuple tl, Expr_tuple rhs -> List.iter2 mcdc_var_def eq.eq_lhs rhs
+ | _ -> mcdc_expr 0 eq.eq_rhs
+
+let mcdc_node_stmt stmt =
+ match stmt with
+ | Eq eq -> mcdc_node_eq eq
+ | Aut aut -> assert false
+
+let mcdc_top_decl td =
+ match td.top_decl_desc with
+ | Node nd -> List.iter mcdc_node_stmt nd.node_stmts
+ | _ -> ()
+
+
+let mcdc prog =
+ (* If main node is provided add silly constraints to show in/out variables in the path condition *)
+ if !Options.main_node <> "" then (
+ inout_vars :=
+ let top = List.find
+ (fun td ->
+ match td.top_decl_desc with
+ | Node nd when nd.node_id = !Options.main_node -> true
+ | _ -> false)
+ prog
+ in
+ match top.top_decl_desc with
+ | Node nd -> nd.node_inputs @ nd.node_outputs
+ | _ -> assert false);
+ List.iter mcdc_top_decl prog
+
+(* Local Variables: *)
+(* compile-command:"make -C .." *)
+(* End: *)
+
+
diff --git a/src/pluginList.ml b/src/pluginList.ml
new file mode 100644
index 0000000000000000000000000000000000000000..c71b112259520756be7fac0a9494f3238bcb5715
--- /dev/null
+++ b/src/pluginList.ml
@@ -0,0 +1,5 @@
+let plugins =
+ [
+ (module Scopes.Plugin : PluginType.PluginType);
+ (module Salsa_plugin.Plugin : PluginType.PluginType);
+ ]
diff --git a/src/pluginList.ml.in b/src/pluginList.ml.in
new file mode 100644
index 0000000000000000000000000000000000000000..e9aa0b53070b30c49990e3e778e0aa8eee02e992
--- /dev/null
+++ b/src/pluginList.ml.in
@@ -0,0 +1,5 @@
+let plugins =
+ [
+ (module Scopes.Plugin : PluginType.PluginType);
+ @SALSA@
+ ]
diff --git a/src/pluginType.ml b/src/pluginType.ml
new file mode 100644
index 0000000000000000000000000000000000000000..fda050a671df8c8889ffad45f39c4ca4533e3453
--- /dev/null
+++ b/src/pluginType.ml
@@ -0,0 +1,17 @@
+module type PluginType =
+sig
+ val name: string
+ val activate: unit -> unit
+ val options: (string * Arg.spec * string) list
+ val check_force_stateful : unit -> bool
+ val refine_machine_code: LustreSpec.top_decl list ->
+ Machine_code.machine_t list -> Machine_code.machine_t list
+ val c_backend_main_loop_body_suffix : Format.formatter -> unit -> unit
+end
+
+module Default =
+struct
+ let check_force_stateful () = false
+ let refine_machine_code prog machines = machines
+ let c_backend_main_loop_body_suffix fmt () = ()
+end
diff --git a/src/plugins.ml b/src/plugins.ml
index 44fccd4b2805de3c30131d4f32dfd0a41dc8a3fd..76bd72d3a7c38c5ddef83b9c61a3c62d816d376b 100644
--- a/src/plugins.ml
+++ b/src/plugins.ml
@@ -1,11 +1,36 @@
open LustreSpec
-module type PluginType =
-sig
+open PluginList
-end
+let options () =
+ List.flatten (
+ List.map Options.plugin_opt (
+ List.map (fun m ->
+ let module M = (val m : PluginType.PluginType) in
+ (M.name, M.activate, M.options)
+ ) plugins
+ ))
+let check_force_stateful () =
+ List.exists (fun m ->
+ let module M = (val m : PluginType.PluginType) in
+ M.check_force_stateful ()
+ ) plugins
+
+let refine_machine_code prog machine_code =
+ List.fold_left (fun accu m ->
+ let module M = (val m : PluginType.PluginType) in
+ M.refine_machine_code prog accu
+ ) machine_code plugins
+
+
+let c_backend_main_loop_body_suffix fmt () =
+ List.iter (fun (m: (module PluginType.PluginType)) ->
+ let module M = (val m : PluginType.PluginType) in
+ M.c_backend_main_loop_body_suffix fmt ()) plugins
+
+(* Specific treatment of annotations when inlining, specific of declared plugins *)
let inline_annots rename_var_fun annot_list =
List.map (
diff --git a/src/plugins/mpfr/mpfr.ml b/src/plugins/mpfr/mpfr.ml
new file mode 100755
index 0000000000000000000000000000000000000000..2a42e9a7e5cf583e24fd441509c3b9ca8d5f44c7
--- /dev/null
+++ b/src/plugins/mpfr/mpfr.ml
@@ -0,0 +1,265 @@
+(********************************************************************)
+(* *)
+(* The LustreC compiler toolset / The LustreC Development Team *)
+(* Copyright 2012 - -- ONERA - CNRS - INPT *)
+(* *)
+(* LustreC is free software, distributed WITHOUT ANY WARRANTY *)
+(* under the terms of the GNU Lesser General Public License *)
+(* version 2.1. *)
+(* *)
+(********************************************************************)
+
+open Utils
+open LustreSpec
+open Corelang
+open Normalization
+open Machine_code
+
+let mpfr_module = mktop (Open(false, "mpfr_lustre"))
+
+let mpfr_rnd () = "MPFR_RNDN"
+
+let mpfr_prec () = !Options.mpfr_prec
+
+let inject_id = "MPFRId"
+
+let inject_copy_id = "mpfr_set"
+
+let inject_real_id = "mpfr_set_flt"
+
+let inject_init_id = "mpfr_init2"
+
+let inject_clear_id = "mpfr_clear"
+
+let mpfr_t = "mpfr_t"
+
+let unfoldable_value value =
+ not (Types.is_real_type value.value_type && is_const_value value)
+
+let inject_id_id expr =
+ let e = mkpredef_call expr.expr_loc inject_id [expr] in
+ { e with
+ expr_type = Type_predef.type_real;
+ expr_clock = expr.expr_clock;
+ }
+
+let pp_inject_real pp_var fmt var value =
+ Format.fprintf fmt "%s(%a, %a, %s);"
+ inject_real_id
+ pp_var var
+ pp_var value
+ (mpfr_rnd ())
+
+let inject_assign expr =
+ let e = mkpredef_call expr.expr_loc inject_copy_id [expr] in
+ { e with
+ expr_type = Type_predef.type_real;
+ expr_clock = expr.expr_clock;
+ }
+
+let pp_inject_copy pp_var fmt var value =
+ Format.fprintf fmt "%s(%a, %a, %s);"
+ inject_copy_id
+ pp_var var
+ pp_var value
+ (mpfr_rnd ())
+
+let rec pp_inject_assign pp_var fmt var value =
+ if is_const_value value
+ then
+ pp_inject_real pp_var fmt var value
+ else
+ pp_inject_copy pp_var fmt var value
+
+let pp_inject_init pp_var fmt var =
+ Format.fprintf fmt "%s(%a, %i);"
+ inject_init_id
+ pp_var var
+ (mpfr_prec ())
+
+let pp_inject_clear pp_var fmt var =
+ Format.fprintf fmt "%s(%a);"
+ inject_clear_id
+ pp_var var
+
+let base_inject_op id =
+ match id with
+ | "+" -> "MPFRPlus"
+ | "-" -> "MPFRMinus"
+ | "*" -> "MPFRTimes"
+ | "/" -> "MPFRDiv"
+ | "uminus" -> "MPFRUminus"
+ | "<=" -> "MPFRLe"
+ | "<" -> "MPFRLt"
+ | ">=" -> "MPFRGe"
+ | ">" -> "MPFRGt"
+ | "=" -> "MPFREq"
+ | "!=" -> "MPFRNeq"
+ | _ -> raise Not_found
+
+let inject_op id =
+ try
+ base_inject_op id
+ with Not_found -> id
+
+let homomorphic_funs =
+ List.fold_right (fun id res -> try base_inject_op id :: res with Not_found -> res) Basic_library.internal_funs []
+
+let is_homomorphic_fun id =
+ List.mem id homomorphic_funs
+
+let inject_call expr =
+ match expr.expr_desc with
+ | Expr_appl (id, args, None) when not (Basic_library.is_expr_internal_fun expr) ->
+ { expr with expr_desc = Expr_appl (inject_op id, args, None) }
+ | _ -> expr
+
+let expr_of_const_array expr =
+ match expr.expr_desc with
+ | Expr_const (Const_array cl) ->
+ let typ = Types.array_element_type expr.expr_type in
+ let expr_of_const c =
+ { expr_desc = Expr_const c;
+ expr_type = typ;
+ expr_clock = expr.expr_clock;
+ expr_loc = expr.expr_loc;
+ expr_delay = Delay.new_var ();
+ expr_annot = None;
+ expr_tag = new_tag ();
+ }
+ in { expr with expr_desc = Expr_array (List.map expr_of_const cl) }
+ | _ -> assert false
+
+(* inject_<foo> : defs * used vars -> <foo> -> (updated defs * updated vars) * normalized <foo> *)
+let rec inject_list alias node inject_element defvars elist =
+ List.fold_right
+ (fun t (defvars, qlist) ->
+ let defvars, norm_t = inject_element alias node defvars t in
+ (defvars, norm_t :: qlist)
+ ) elist (defvars, [])
+
+let rec inject_expr ?(alias=true) node defvars expr =
+let res=
+ match expr.expr_desc with
+ | Expr_const (Const_real _) -> mk_expr_alias_opt alias node defvars expr
+ | Expr_const (Const_array _) -> inject_expr ~alias:alias node defvars (expr_of_const_array expr)
+ | Expr_const (Const_struct _) -> assert false
+ | Expr_ident _
+ | Expr_const _ -> defvars, expr
+ | Expr_array elist ->
+ let defvars, norm_elist = inject_list alias node (fun _ -> inject_expr ~alias:true) defvars elist in
+ let norm_expr = { expr with expr_desc = Expr_array norm_elist } in
+ defvars, norm_expr
+ | Expr_power (e1, d) ->
+ let defvars, norm_e1 = inject_expr node defvars e1 in
+ let norm_expr = { expr with expr_desc = Expr_power (norm_e1, d) } in
+ defvars, norm_expr
+ | Expr_access (e1, d) ->
+ let defvars, norm_e1 = inject_expr node defvars e1 in
+ let norm_expr = { expr with expr_desc = Expr_access (norm_e1, d) } in
+ defvars, norm_expr
+ | Expr_tuple elist ->
+ let defvars, norm_elist =
+ inject_list alias node (fun alias -> inject_expr ~alias:alias) defvars elist in
+ let norm_expr = { expr with expr_desc = Expr_tuple norm_elist } in
+ defvars, norm_expr
+ | Expr_appl (id, args, r) ->
+ let defvars, norm_args = inject_expr node defvars args in
+ let norm_expr = { expr with expr_desc = Expr_appl (id, norm_args, r) } in
+ mk_expr_alias_opt alias node defvars (inject_call norm_expr)
+ | Expr_arrow _ -> defvars, expr
+ | Expr_pre e ->
+ let defvars, norm_e = inject_expr node defvars e in
+ let norm_expr = { expr with expr_desc = Expr_pre norm_e } in
+ defvars, norm_expr
+ | Expr_fby (e1, e2) ->
+ let defvars, norm_e1 = inject_expr node defvars e1 in
+ let defvars, norm_e2 = inject_expr node defvars e2 in
+ let norm_expr = { expr with expr_desc = Expr_fby (norm_e1, norm_e2) } in
+ defvars, norm_expr
+ | Expr_when (e, c, l) ->
+ let defvars, norm_e = inject_expr node defvars e in
+ let norm_expr = { expr with expr_desc = Expr_when (norm_e, c, l) } in
+ defvars, norm_expr
+ | Expr_ite (c, t, e) ->
+ let defvars, norm_c = inject_expr node defvars c in
+ let defvars, norm_t = inject_expr node defvars t in
+ let defvars, norm_e = inject_expr node defvars e in
+ let norm_expr = { expr with expr_desc = Expr_ite (norm_c, norm_t, norm_e) } in
+ defvars, norm_expr
+ | Expr_merge (c, hl) ->
+ let defvars, norm_hl = inject_branches node defvars hl in
+ let norm_expr = { expr with expr_desc = Expr_merge (c, norm_hl) } in
+ defvars, norm_expr
+in
+(*Format.eprintf "inject_expr %B %a = %a@." alias Printers.pp_expr expr Printers.pp_expr (snd res);*)
+res
+
+and inject_branches node defvars hl =
+ List.fold_right
+ (fun (t, h) (defvars, norm_q) ->
+ let (defvars, norm_h) = inject_expr node defvars h in
+ defvars, (t, norm_h) :: norm_q
+ )
+ hl (defvars, [])
+
+
+let rec inject_eq node defvars eq =
+ let (defs', vars'), norm_rhs = inject_expr ~alias:false node defvars eq.eq_rhs in
+ let norm_eq = { eq with eq_rhs = norm_rhs } in
+ norm_eq::defs', vars'
+
+(** normalize_node node returns a normalized node,
+ ie.
+ - updated locals
+ - new equations
+ -
+*)
+let inject_node node =
+ cpt_fresh := 0;
+ let inputs_outputs = node.node_inputs@node.node_outputs in
+ let is_local v =
+ List.for_all ((!=) v) inputs_outputs in
+ let orig_vars = inputs_outputs@node.node_locals in
+ let defs, vars =
+ List.fold_left (inject_eq node) ([], orig_vars) (get_node_eqs node) in
+ (* Normalize the asserts *)
+ let vars, assert_defs, asserts =
+ List.fold_left (
+ fun (vars, def_accu, assert_accu) assert_ ->
+ let assert_expr = assert_.assert_expr in
+ let (defs, vars'), expr =
+ inject_expr
+ ~alias:false
+ node
+ ([], vars) (* defvar only contains vars *)
+ assert_expr
+ in
+ vars', defs@def_accu, {assert_ with assert_expr = expr}::assert_accu
+ ) (vars, [], []) node.node_asserts in
+ let new_locals = List.filter is_local vars in
+ (* Compute traceability info:
+ - gather newly bound variables
+ - compute the associated expression without aliases
+ *)
+ (* let diff_vars = List.filter (fun v -> not (List.mem v node.node_locals)) new_locals in *)
+ let node =
+ { node with
+ node_locals = new_locals;
+ node_stmts = List.map (fun eq -> Eq eq) (defs @ assert_defs);
+ }
+ in ((*Printers.pp_node Format.err_formatter node;*) node)
+
+let inject_decl decl =
+ match decl.top_decl_desc with
+ | Node nd ->
+ {decl with top_decl_desc = Node (inject_node nd)}
+ | Open _ | ImportedNode _ | Const _ | TypeDef _ -> decl
+
+let inject_prog decls =
+ List.map inject_decl decls
+
+
+(* Local Variables: *)
+(* compile-command:"make -C .." *)
+(* End: *)
diff --git a/src/plugins/salsa/machine_salsa_opt.ml b/src/plugins/salsa/machine_salsa_opt.ml
new file mode 100644
index 0000000000000000000000000000000000000000..d37e295173079311e62ac72535f1c57ef3289c56
--- /dev/null
+++ b/src/plugins/salsa/machine_salsa_opt.ml
@@ -0,0 +1,574 @@
+
+(* We try to avoid opening modules here *)
+module ST = Salsa.SalsaTypes
+module SDT = SalsaDatatypes
+module LT = LustreSpec
+module MC = Machine_code
+
+(* Datatype for Salsa: FormalEnv, Ranges, Var set ... *)
+open SalsaDatatypes
+(******************************************************************)
+(* TODO Xavier: should those functions be declared more globally? *)
+
+let fun_types node =
+ try
+ match node.LT.top_decl_desc with
+ | LT.Node nd ->
+ let tin, tout = Types.split_arrow nd.LT.node_type in
+ Types.type_list_of_type tin, Types.type_list_of_type tout
+ | _ -> Format.eprintf "%a is not a node@.@?" Printers.pp_decl node; assert false
+ with Not_found -> Format.eprintf "Unable to find type def for function %s@.@?" (Corelang.node_name node); assert false
+
+let called_node_id m id =
+ let td, _ =
+ try
+ List.assoc id m.MC.mcalls (* TODO Xavier: mcalls or minstances ? *)
+ with Not_found -> assert false
+ in
+ td
+(******************************************************************)
+
+(* Returns the set of vars that appear in the expression *)
+let rec get_expr_real_vars e =
+ match e.LT.value_desc with
+ | LT.LocalVar v | LT.StateVar v when Types.is_real_type v.LT.var_type -> Vars.singleton v
+ | LT.LocalVar _| LT.StateVar _
+ | LT.Cst _ -> Vars.empty
+ | LT.Fun (_, args) ->
+ List.fold_left
+ (fun acc e -> Vars.union acc (get_expr_real_vars e))
+ Vars.empty args
+ | LT.Array _
+ | LT.Access _
+ | LT.Power _ -> assert false
+
+(* Extract the variables to appear as free variables in expressions (lhs) *)
+let rec get_read_vars instrs =
+ match instrs with
+ [] -> Vars.empty
+ | i::tl -> (
+ let vars_tl = get_read_vars tl in
+ match i with
+ | LT.MLocalAssign(_,e)
+ | LT.MStateAssign(_,e) -> Vars.union (get_expr_real_vars e) vars_tl
+ | LT.MStep(_, _, el) -> List.fold_left (fun accu e -> Vars.union (get_expr_real_vars e) accu) vars_tl el
+ | LT.MBranch(e, branches) -> (
+ let vars = Vars.union (get_expr_real_vars e) vars_tl in
+ List.fold_left (fun vars (_, b) -> Vars.union vars (get_read_vars b) ) vars branches
+ )
+ | LT.MReset _
+ | LT.MNoReset _
+ | LT.MComment _ -> Vars.empty
+ )
+
+let rec get_written_vars instrs =
+ match instrs with
+ [] -> Vars.empty
+ | i::tl -> (
+ let vars_tl = get_written_vars tl in
+ match i with
+ | LT.MLocalAssign(v,_)
+ | LT.MStateAssign(v,_) -> Vars.add v vars_tl
+ | LT.MStep(vdl, _, _) -> List.fold_left (fun accu v -> Vars.add v accu) vars_tl vdl
+ | LT.MBranch(_, branches) -> (
+ List.fold_left (fun vars (_, b) -> Vars.union vars (get_written_vars b) ) vars_tl branches
+ )
+ | LT.MReset _
+ | LT.MNoReset _
+ | LT.MComment _ -> Vars.empty
+ )
+
+
+(* Optimize a given expression. It returns another expression and a computed range. *)
+let optimize_expr nodename constEnv printed_vars vars_env ranges formalEnv e : LT.value_t * RangesInt.t option =
+ let rec opt_expr ranges formalEnv e =
+ match e.LT.value_desc with
+ | LT.Cst cst ->
+ Format.eprintf "optmizing constant expr ? @ ";
+ (* the expression is a constant, we optimize it directly if it is a real
+ constant *)
+ let typ = Typing.type_const Location.dummy_loc cst in
+ if Types.is_real_type typ then
+ opt_num_expr ranges formalEnv e
+ else e, None
+ | LT.LocalVar v
+ | LT.StateVar v ->
+ if not (Vars.mem v printed_vars) &&
+ (* TODO xAvier: comment recuperer le type de l'expression? Parfois e.value_type vaut 'd *)
+ (Types.is_real_type e.LT.value_type || Types.is_real_type v.LT.var_type)
+ then
+ opt_num_expr ranges formalEnv e
+ else
+ e, None (* Nothing to optimize for expressions containing a single non real variable *)
+ (* (\* optimize only numerical vars *\) *)
+ (* if Type_predef.is_real_type v.LT.var_type then opt_num_expr ranges formalEnv e *)
+ (* else e, None *)
+ | LT.Fun (fun_id, args) -> (
+ (* necessarily, this is a basic function (ie. + - * / && || mod ... ) *)
+ (* if the return type is real then optimize it, otherwise call recusrsively on arguments *)
+ if Types.is_real_type e.LT.value_type then
+ opt_num_expr ranges formalEnv e
+ else (
+ (* We do not care for computed local ranges. *)
+ let args' = List.map (fun arg -> let arg', _ = opt_expr ranges formalEnv arg in arg') args in
+ { e with LT.value_desc = LT.Fun(fun_id, args')}, None
+ )
+ )
+ | LT.Array _
+ | LT.Access _
+ | LT.Power _ -> assert false
+ and opt_num_expr ranges formalEnv e =
+ if debug then Format.eprintf "Optimizing expression %a@ " MC.pp_val e;
+ let fresh_id = "toto" in (* TODO more meaningful name *)
+ (* Convert expression *)
+ List.iter (fun (l,c) -> Format.eprintf "%s -> %a@ " l Printers.pp_const c) constEnv;
+ let e_salsa : Salsa.SalsaTypes.expression = value_t2salsa_expr constEnv e in
+ Format.eprintf "apres deplaige constantes ok%a @." MC.pp_val (salsa_expr2value_t vars_env [](* constEnv *) e_salsa) ;
+
+ (* Convert formalEnv *)
+ if debug then Format.eprintf "Formal env is [%a]@ " FormalEnv.pp formalEnv;
+ let formalEnv_salsa =
+ FormalEnv.fold (fun id expr accu ->
+ (id, value_t2salsa_expr constEnv expr)::accu
+ ) formalEnv [] in
+ if debug then Format.eprintf "Formal env converted to salsa@ ";
+ (* Substitute all occurences of variables by their definition in env *)
+ let (e_salsa: Salsa.SalsaTypes.expression), _ =
+ Salsa.Rewrite.substVars
+ e_salsa
+ formalEnv_salsa
+ 0 (* TODO: Nasrine, what is this integer value for ? *)
+ in
+ if debug then Format.eprintf "Substituted def in expr@ ";
+ let abstractEnv = Hashtbl.fold
+ (fun id value accu -> (id,value)::accu)
+ ranges
+ []
+ in
+ (* List.iter (fun (id, _) -> Format.eprintf "absenv: %s@." id) abstractEnv; *)
+ (* The expression is partially evaluated by the available ranges
+ valEnv2ExprEnv remplce les paires id, abstractVal par id, Cst itv - on
+ garde evalPartExpr remplace les variables e qui sont dans env par la cst
+ - on garde *)
+ if debug then Format.eprintf "avant avant eval part@ ";
+ Format.eprintf "avant evalpart: %a@." MC.pp_val (salsa_expr2value_t vars_env constEnv e_salsa);
+ let e_salsa =
+ Salsa.Float.evalPartExpr
+ e_salsa
+ (Salsa.Float.valEnv2ExprEnv abstractEnv)
+ ([] (* no blacklisted variables *))
+ in
+ Format.eprintf "apres evalpart: %a@." MC.pp_val (salsa_expr2value_t vars_env constEnv e_salsa);
+ (* Checking if we have all necessary information *)
+
+ let free_vars = get_salsa_free_vars vars_env constEnv abstractEnv e_salsa in
+
+ if Vars.cardinal free_vars > 0 then (
+ Format.eprintf "Warning: unbounded free vars (%a) in expression %a. We do not optimize it.@ "
+ Vars.pp (Vars.fold (fun v accu -> let v' = {v with LT.var_id = nodename ^ "." ^ v.LT.var_id } in Vars.add v' accu) free_vars Vars.empty)
+ MC.pp_val (salsa_expr2value_t vars_env constEnv e_salsa);
+ if debug then Format.eprintf "Some free vars, not optimizing@.";
+ let new_e = try salsa_expr2value_t vars_env constEnv e_salsa with Not_found -> assert false in
+ new_e, None
+ )
+ else (
+ try
+ if debug then
+ Format.eprintf "Analyzing expression %a with env: @[<v>%a@ @]@ "
+ MC.pp_val (salsa_expr2value_t vars_env constEnv e_salsa)
+ (Utils.fprintf_list ~sep:",@ "(fun fmt (l,r) -> Format.fprintf fmt "%s -> %a" l FloatIntSalsa.pp r)) abstractEnv
+ ;
+
+ let new_e_salsa, e_val =
+ Salsa.MainEPEG.transformExpression fresh_id e_salsa abstractEnv
+ in
+ let new_e = try salsa_expr2value_t vars_env constEnv new_e_salsa with Not_found -> assert false in
+ if debug then Format.eprintf "@ @[<v>old: %a@ new: %a@ range: %a@]" MC.pp_val e MC.pp_val new_e RangesInt.pp_val e_val;
+ new_e, Some e_val
+ with Not_found -> assert false
+ | Salsa.Epeg_types.EPEGError _ -> (
+ Format.eprintf "BECAUSE OF AN ERROR, Expression %a was not optimized@ " MC.pp_val e;
+ e, None
+ )
+ )
+
+
+
+ in
+ if debug then
+ Format.eprintf "@[<v 2>Optimizing expression %a in environment %a and ranges %a@ "
+ MC.pp_val e
+ FormalEnv.pp formalEnv
+ RangesInt.pp ranges;
+ let res = opt_expr ranges formalEnv e in
+ Format.eprintf "@]@ ";
+ res
+
+
+
+(* Returns a list of assign, for each var in vars_to_print, that produce the
+ definition of it according to formalEnv, and driven by the ranges. *)
+let assign_vars nodename constEnv vars_env printed_vars ranges formalEnv vars_to_print =
+ (* We print thhe expression in the order of definition *)
+
+ let ordered_vars =
+ List.stable_sort
+ (FormalEnv.get_sort_fun formalEnv)
+ (Vars.elements vars_to_print)
+ in
+ Format.eprintf "Printing vars in the following order: [%a]@ " (Utils.fprintf_list ~sep:", " Printers.pp_var) ordered_vars ;
+ List.fold_right (
+ fun v (accu_instr, accu_ranges) ->
+ if debug then Format.eprintf "Printing assign for variable %s@ " v.LT.var_id;
+ try
+ (* Obtaining unfold expression of v in formalEnv *)
+ let v_def = FormalEnv.get_def formalEnv v in
+ let e, r = optimize_expr nodename constEnv printed_vars vars_env ranges formalEnv v_def in
+ let instr =
+ if try (get_var vars_env v.LT.var_id).is_local with Not_found -> assert false then
+ LT.MLocalAssign(v, e)
+ else
+ LT.MStateAssign(v, e)
+ in
+ instr::accu_instr,
+ (match r with
+ | None -> ranges
+ | Some v_r -> RangesInt.add_def ranges v.LT.var_id v_r)
+ with FormalEnv.NoDefinition _ -> (
+ (* It should not happen with C backend, but may happen with Lustre backend *)
+ if !Options.output = "lustre" then accu_instr, ranges else (Format.eprintf "@?"; assert false)
+ )
+ ) ordered_vars ([], ranges)
+
+(* Main recursive function: modify the instructions list while preserving the
+ order of assigns for state variables. Returns a quintuple: (new_instrs,
+ ranges, formalEnv, printed_vars, and remaining vars to be printed) *)
+let rec rewrite_instrs nodename constEnv vars_env m instrs ranges formalEnv printed_vars vars_to_print =
+ let assign_vars = assign_vars nodename constEnv vars_env in
+ if debug then (
+ Format.eprintf "------------@ ";
+ Format.eprintf "Current printed_vars: [%a]@ " Vars.pp printed_vars;
+ Format.eprintf "Formal env is [%a]@ " FormalEnv.pp formalEnv;
+ );
+ match instrs with
+ | [] ->
+ (* End of instruction list: we produce the definition of each variable that
+ appears in vars_to_print. Each of them should be defined in formalEnv *)
+ if debug then Format.eprintf "Producing definitions %a@ " Vars.pp vars_to_print;
+ let instrs, ranges' = assign_vars printed_vars ranges formalEnv vars_to_print in
+ instrs,
+ ranges',
+ formalEnv,
+ Vars.union printed_vars vars_to_print, (* We should have printed all required vars *)
+ [] (* No more vars to be printed *)
+
+ | hd_instr::tl_instrs ->
+ (* We reformulate hd_instr, producing or not a fresh instruction, updating
+ formalEnv, possibly ranges and vars_to_print *)
+ begin
+ let hd_instrs, ranges, formalEnv, printed_vars, vars_to_print =
+ match hd_instr with
+ | LT.MLocalAssign(vd,vt) when Types.is_real_type vd.LT.var_type && not (Vars.mem vd vars_to_print) ->
+ (* LocalAssign are injected into formalEnv *)
+ if debug then Format.eprintf "Registering local assign %a@ " MC.pp_instr hd_instr;
+ let formalEnv' = FormalEnv.def formalEnv vd vt in (* formelEnv updated with vd = vt *)
+ [], (* no instr generated *)
+ ranges, (* no new range computed *)
+ formalEnv',
+ printed_vars, (* no new printed vars *)
+ vars_to_print (* no more or less variables to print *)
+
+ | LT.MLocalAssign(vd,vt) when Types.is_real_type vd.LT.var_type && Vars.mem vd vars_to_print ->
+
+ if debug then Format.eprintf "Registering and producing state assign %a@ " MC.pp_instr hd_instr;
+ let formalEnv' = FormalEnv.def formalEnv vd vt in (* formelEnv updated with vd = vt *)
+ let instrs', ranges' = (* printing vd = optimized vt *)
+ assign_vars printed_vars ranges formalEnv' (Vars.singleton vd)
+ in
+ instrs',
+ ranges', (* no new range computed *)
+ formalEnv', (* formelEnv already updated *)
+ Vars.add vd printed_vars, (* adding vd to new printed vars *)
+ Vars.remove vd vars_to_print (* removed vd from variables to print *)
+
+ | LT.MStateAssign(vd,vt) when Types.is_real_type vd.LT.var_type && Vars.mem vd vars_to_print ->
+
+ (* StateAssign are produced since they are required by the function. We still
+ keep their definition in the formalEnv in case it can optimize later
+ outputs. vd is removed from remaining vars_to_print *)
+ if debug then Format.eprintf "Registering and producing state assign %a@ " MC.pp_instr hd_instr;
+ let formalEnv' = FormalEnv.def formalEnv vd vt in (* formelEnv updated with vd = vt *)
+ let instrs', ranges' = (* printing vd = optimized vt *)
+ assign_vars printed_vars ranges formalEnv' (Vars.singleton vd)
+ in
+ instrs',
+ ranges', (* no new range computed *)
+ formalEnv, (* formelEnv already updated *)
+ Vars.add vd printed_vars, (* adding vd to new printed vars *)
+ Vars.remove vd vars_to_print (* removed vd from variables to print *)
+
+ | (LT.MLocalAssign(vd,vt) | LT.MStateAssign(vd,vt)) ->
+ (* We have to produce the instruction. But we may have to produce as
+ well its dependencies *)
+ let required_vars = get_expr_real_vars vt in
+ let required_vars = Vars.diff required_vars printed_vars in (* remove
+ already
+ produced
+ variables *)
+ let prefix_instr, ranges =
+ assign_vars printed_vars ranges formalEnv required_vars in
+ let vt', _ = optimize_expr nodename constEnv (Vars.union required_vars printed_vars) vars_env ranges formalEnv vt in
+ let new_instr =
+ match hd_instr with
+ | LT.MLocalAssign _ -> LT.MLocalAssign(vd,vt')
+ | _ -> LT.MStateAssign(vd,vt')
+ in
+ let written_vars = Vars.add vd required_vars in
+ prefix_instr@[new_instr],
+ ranges, (* no new range computed *)
+ formalEnv, (* formelEnv untouched *)
+ Vars.union written_vars printed_vars, (* adding vd + dependencies to
+ new printed vars *)
+ Vars.diff vars_to_print written_vars (* removed vd + dependencies from
+ variables to print *)
+
+ | LT.MStep(vdl,id,vtl) ->
+ if debug then Format.eprintf "Call to a node %a@ " MC.pp_instr hd_instr;
+ (* Call of an external function. Input expressions have to be
+ optimized, their free variables produced. A fresh range has to be
+ computed for each output variable in vdl. Output of the function
+ call are removed from vars to be printed *)
+ let node = called_node_id m id in
+ let node_id = Corelang.node_name node in
+ let tin, tout = (* special care for arrow *)
+ if node_id = "_arrow" then
+ match vdl with
+ | [v] -> let t = v.LT.var_type in
+ [t; t], [t]
+ | _ -> assert false (* should not happen *)
+ else
+ fun_types node
+ in
+ if debug then Format.eprintf "@[<v 2>... optimizing arguments@ ";
+ let vtl', vtl_ranges = List.fold_right2 (
+ fun e typ_e (exprl, range_l)->
+ if Types.is_real_type typ_e then
+ let e', r' = optimize_expr nodename constEnv printed_vars vars_env ranges formalEnv e in
+ e'::exprl, r'::range_l
+ else
+ e::exprl, None::range_l
+ ) vtl tin ([], [])
+ in
+ if debug then Format.eprintf "... done@ @]@ ";
+ let required_vars =
+ List.fold_left2
+ (fun accu e typ_e ->
+ if Types.is_real_type typ_e then
+ Vars.union accu (get_expr_real_vars e)
+ else (* we do not consider non real expressions *)
+ accu
+ )
+ Vars.empty
+ vtl' tin
+ in
+ if debug then Format.eprintf "Required vars: [%a]@ Printed vars: [%a]@ Remaining required vars: [%a]@ "
+ Vars.pp required_vars
+ Vars.pp printed_vars
+ Vars.pp (Vars.diff required_vars printed_vars)
+ ;
+ let required_vars = Vars.diff required_vars printed_vars in (* remove
+ already
+ produced
+ variables *)
+ let written_vars = Vars.union required_vars (Vars.of_list vdl) in
+ let instrs', ranges' = assign_vars (Vars.union written_vars printed_vars) ranges formalEnv required_vars in
+ instrs' @ [LT.MStep(vdl,id,vtl')], (* New instrs *)
+ RangesInt.add_call ranges' vdl id vtl_ranges, (* add information bounding each vdl var *)
+ formalEnv,
+ Vars.union written_vars printed_vars, (* adding vdl to new printed vars *)
+ Vars.diff vars_to_print written_vars
+
+ | LT.MBranch(vt, branches) ->
+ (* Required variables to compute vt are introduced.
+ Then each branch is refactored specifically
+ *)
+ if debug then Format.eprintf "Branching %a@ " MC.pp_instr hd_instr;
+ let required_vars = get_expr_real_vars vt in
+ let required_vars = Vars.diff required_vars printed_vars in (* remove
+ already
+ produced
+ variables *)
+ let prefix_instr, ranges =
+ assign_vars (Vars.union required_vars printed_vars) ranges formalEnv required_vars in
+
+ let printed_vars = Vars.union printed_vars required_vars in
+
+ let vt', _ = optimize_expr nodename constEnv printed_vars vars_env ranges formalEnv vt in
+
+ let read_vars_tl = get_read_vars tl_instrs in
+ if debug then Format.eprintf "@[<v 2>Dealing with branches@ ";
+ let branches', written_vars, merged_ranges = List.fold_right (
+ fun (b_l, b_instrs) (new_branches, written_vars, merged_ranges) ->
+ let b_write_vars = get_written_vars b_instrs in
+ let b_vars_to_print = Vars.inter b_write_vars (Vars.union read_vars_tl vars_to_print) in
+ let b_fe = formalEnv in (* because of side effect
+ data, we copy it for
+ each branch *)
+ let b_instrs', b_ranges, b_formalEnv, b_printed, b_vars =
+ rewrite_instrs nodename constEnv vars_env m b_instrs ranges b_fe printed_vars b_vars_to_print
+ in
+ (* b_vars should be empty *)
+ let _ = if b_vars != [] then assert false in
+
+ (* Producing the refactored branch *)
+ (b_l, b_instrs') :: new_branches,
+ Vars.union b_printed written_vars, (* They should coincides. We
+ use union instead of
+ inter to ease the
+ bootstrap *)
+ RangesInt.merge merged_ranges b_ranges
+
+ ) branches ([], required_vars, ranges) in
+ if debug then Format.eprintf "dealing with branches done@ @]@ ";
+ prefix_instr@[LT.MBranch(vt', branches')],
+ merged_ranges, (* Only step functions call within branches
+ may have produced new ranges. We merge this data by
+ computing the join per variable *)
+ formalEnv, (* Thanks to the computation of var_to_print in each
+ branch, no new definition should have been computed
+ without being already printed *)
+ Vars.union written_vars printed_vars,
+ Vars.diff vars_to_print written_vars (* We remove vars that have been
+ produced within branches *)
+
+
+ | LT.MReset(_) | LT.MNoReset _ | LT.MComment _ ->
+ if debug then Format.eprintf "Untouched %a (non real)@ " MC.pp_instr hd_instr;
+
+ (* Untouched instruction *)
+ [ hd_instr ], (* unmodified instr *)
+ ranges, (* no new range computed *)
+ formalEnv, (* no formelEnv update *)
+ printed_vars,
+ vars_to_print (* no more or less variables to print *)
+
+ in
+ let tl_instrs, ranges, formalEnv, printed_vars, vars_to_print =
+ rewrite_instrs
+ nodename
+ constEnv
+ vars_env
+ m
+ tl_instrs
+ ranges
+ formalEnv
+ printed_vars
+ vars_to_print
+ in
+ hd_instrs @ tl_instrs,
+ ranges,
+ formalEnv,
+ printed_vars,
+ vars_to_print
+ end
+
+
+
+
+
+
+(* TODO: deal with new variables, ie. tmp *)
+let salsaStep constEnv m s =
+ let ranges = RangesInt.empty (* empty for the moment, should be build from
+ machine annotations or externally provided information *) in
+ let annots = List.fold_left (
+ fun accu annl ->
+ List.fold_left (
+ fun accu (key, range) ->
+ match key with
+ | ["salsa"; "ranges"; var] -> (var, range)::accu
+ | _ -> accu
+ ) accu annl.LT.annots
+ ) [] m.MC.mannot
+ in
+ let ranges =
+ List.fold_left (fun ranges (v, value) ->
+ match value.LT.eexpr_qfexpr.LT.expr_desc with
+ | LT.Expr_tuple [minv; maxv] -> (
+ let get_cst e = match e.LT.expr_desc with
+ | LT.Expr_const (LT.Const_real (c,e,s)) ->
+ (* calculer la valeur c * 10^e *)
+ Num.float_of_num (Num.div_num c (Num.power_num (Num.num_of_int 10) (Num.num_of_int e)))
+ | _ ->
+ Format.eprintf
+ "Invalid scala range: %a. It should be a pair of constant floats.@."
+ Printers.pp_expr value.LT.eexpr_qfexpr;
+ assert false
+ in
+ let minv, maxv = get_cst minv, get_cst maxv in
+ if debug then Format.eprintf "%s in [%f, %f]@ " v minv maxv;
+ RangesInt.enlarge ranges v (Salsa.SalsaTypes.I(minv, maxv),Salsa.SalsaTypes.J(0.,0.))
+ )
+ | _ ->
+ Format.eprintf
+ "Invalid scala range: %a. It should be a pair of floats.@."
+ Printers.pp_expr value.LT.eexpr_qfexpr;
+ assert false
+ ) ranges annots
+ in
+ let formal_env = FormalEnv.empty () in
+ let vars_to_print =
+ Vars.real_vars
+ (
+ Vars.union
+ (Vars.of_list m.MC.mmemory)
+ (Vars.of_list s.MC.step_outputs)
+ )
+ in
+ (* TODO: should be at least step output + may be memories *)
+ let vars_env = compute_vars_env m in
+ let new_instrs, _, _, printed_vars, _ =
+ rewrite_instrs
+ m.MC.mname.LT.node_id
+ constEnv
+ vars_env
+ m
+ s.MC.step_instrs
+ ranges
+ formal_env
+ (Vars.real_vars (Vars.of_list s.MC.step_inputs (* printed_vars : real
+ inputs are considered as
+ already printed *)))
+ vars_to_print
+ in
+ let all_local_vars = Vars.real_vars (Vars.of_list s.MC.step_locals) in
+ let unused = (Vars.diff all_local_vars printed_vars) in
+ let locals =
+ if not (Vars.is_empty unused) then (
+ Format.eprintf "Unused local vars: [%a]. Removing them.@.@?"
+ Vars.pp unused;
+ List.filter (fun v -> not (Vars.mem v unused)) s.MC.step_locals
+ )
+ else
+ s.MC.step_locals
+ in
+ { s with MC.step_instrs = new_instrs; MC.step_locals = locals } (* we have also to modify local variables to declare new vars *)
+
+
+let machine_t2machine_t_optimized_by_salsa constEnv mt =
+ try
+ if debug then Format.eprintf "@[<v 2>------------------ Optimizing machine %s@ " mt.MC.mname.LT.node_id;
+ let new_step = salsaStep constEnv mt mt.MC.mstep in
+ if debug then Format.eprintf "@]@.";
+ { mt with MC.mstep = new_step }
+
+
+ with FormalEnv.NoDefinition v as exp ->
+ Format.eprintf "No definition for variable %a@.@?" Printers.pp_var v;
+ raise exp
+
+
+(* Local Variables: *)
+(* compile-command:"make -C ../../.." *)
+(* End: *)
+
diff --git a/src/plugins/salsa/salsaDatatypes.ml b/src/plugins/salsa/salsaDatatypes.ml
new file mode 100644
index 0000000000000000000000000000000000000000..e169354e4491eaf4ce86aa98823a84c3e34c6581
--- /dev/null
+++ b/src/plugins/salsa/salsaDatatypes.ml
@@ -0,0 +1,337 @@
+module LT = LustreSpec
+module MC = Machine_code
+module ST = Salsa.SalsaTypes
+module Float = Salsa.Float
+
+let debug = true
+
+let pp_hash ~sep f fmt r =
+ Format.fprintf fmt "[@[<v>";
+ Hashtbl.iter (fun k v -> Format.fprintf fmt "%t%s@ " (f k v) sep) r;
+ Format.fprintf fmt "]@]";
+
+module FormalEnv =
+struct
+ type fe_t = (LT.ident, (int * LT.value_t)) Hashtbl.t
+ let cpt = ref 0
+
+ exception NoDefinition of LT.var_decl
+ (* Returns the expression associated to v in env *)
+ let get_def (env: fe_t) v =
+ try
+ snd (Hashtbl.find env v.LT.var_id)
+ with Not_found -> raise (NoDefinition v)
+
+ let def (env: fe_t) d expr =
+ incr cpt;
+ let fresh = Hashtbl.copy env in
+ Hashtbl.add fresh d.LT.var_id (!cpt, expr); fresh
+
+ let empty (): fe_t = Hashtbl.create 13
+
+ let pp fmt env = pp_hash ~sep:";" (fun k (_,v) fmt -> Format.fprintf fmt "%s -> %a" k MC.pp_val v) fmt env
+
+ let fold f = Hashtbl.fold (fun k (_,v) accu -> f k v accu)
+
+ let get_sort_fun env =
+ let order = Hashtbl.fold (fun k (cpt, _) accu -> (k,cpt)::accu) env [] in
+ fun v1 v2 ->
+ if List.mem_assoc v1.LT.var_id order && List.mem_assoc v2.LT.var_id order then
+ if (List.assoc v1.LT.var_id order) <= (List.assoc v2.LT.var_id order) then
+ -1
+ else
+ 1
+ else
+ assert false
+
+end
+
+module Ranges =
+ functor (Value: sig type t val union: t -> t -> t val pp: Format.formatter -> t -> unit end) ->
+struct
+ type t = Value.t
+ type r_t = (LT.ident, Value.t) Hashtbl.t
+
+ let empty: r_t = Hashtbl.create 13
+
+ (* Look for def of node i with inputs living in vtl_ranges, reinforce ranges
+ to bound vdl: each output of node i *)
+ let add_call ranges vdl id vtl_ranges = ranges (* TODO assert false. On est
+ pas obligé de faire
+ qqchose. On peut supposer
+ que les ranges sont donnés
+ pour chaque noeud *)
+
+
+ let pp = pp_hash ~sep:";" (fun k v fmt -> Format.fprintf fmt "%s -> %a" k Value.pp v)
+ let pp_val = Value.pp
+
+ let add_def ranges name r =
+ (* Format.eprintf "%s: declare %a@." *)
+ (* x.LT.var_id *)
+ (* Value.pp r ; *)
+
+ let fresh = Hashtbl.copy ranges in
+ Hashtbl.add fresh name r; fresh
+
+ let enlarge ranges name r =
+ let fresh = Hashtbl.copy ranges in
+ if Hashtbl.mem fresh name then
+ Hashtbl.replace fresh name (Value.union r (Hashtbl.find fresh name))
+ else
+ Hashtbl.add fresh name r;
+ fresh
+
+
+ (* Compute a join per variable *)
+ let merge ranges1 ranges2 =
+ Format.eprintf "Mergeing rangesint %a with %a@." pp ranges1 pp ranges2;
+ let ranges = Hashtbl.copy ranges1 in
+ Hashtbl.iter (fun k v ->
+ if Hashtbl.mem ranges k then (
+ (* Format.eprintf "%s: %a union %a = %a@." *)
+ (* k *)
+ (* Value.pp v *)
+ (* Value.pp (Hashtbl.find ranges k) *)
+ (* Value.pp (Value.union v (Hashtbl.find ranges k)); *)
+ Hashtbl.replace ranges k (Value.union v (Hashtbl.find ranges k))
+ )
+ else
+ Hashtbl.add ranges k v
+ ) ranges2;
+ Format.eprintf "Merge result %a@." pp ranges;
+ ranges
+
+end
+
+module FloatIntSalsa =
+struct
+ type t = ST.abstractValue
+
+ let pp fmt (f,r) =
+ match f, r with
+ | ST.I(a,b), ST.J(c,d) ->
+ Format.fprintf fmt "[%f, %f] + [%f, %f]" a b c d
+ | ST.I(a,b), ST.JInfty -> Format.fprintf fmt "[%f, %f] + oo" a b
+ | ST.Empty, _ -> Format.fprintf fmt "???"
+
+ | _ -> assert false
+
+ let union v1 v2 =
+ match v1, v2 with
+ |(ST.I(x1, x2), ST.J(y1, y2)), (ST.I(x1', x2'), ST.J(y1', y2')) ->
+ ST.(I(min x1 x1', max x2 x2'), J(min y1 y1', max y2 y2'))
+ | _ -> Format.eprintf "%a cup %a failed@.@?" pp v1 pp v2; assert false
+
+ let inject cst = match cst with
+ | LT.Const_int(i) -> Salsa.Builder.mk_cst (ST.I(float_of_int i,float_of_int i),ST.J(0.0,0.0))
+ | LT.Const_real (c,e,s) -> (* TODO: this is incorrect. We should rather
+ compute the error associated to the float *)
+ let r = float_of_string s in
+ if r = 0. then
+ Salsa.Builder.mk_cst (ST.I(-. min_float, min_float),Float.ulp (ST.I(-. min_float, min_float)))
+ else
+ Salsa.Builder.mk_cst (ST.I(r*.(1.-.epsilon_float),r*.(1.+.epsilon_float)),Float.ulp (ST.I(r,r)))
+ | _ -> assert false
+end
+
+module RangesInt = Ranges (FloatIntSalsa)
+
+module Vars =
+struct
+ module VarSet = Set.Make (struct type t = LT.var_decl let compare x y = compare x.LT.var_id y.LT.var_id end)
+ let real_vars vs = VarSet.filter (fun v -> Types.is_real_type v.LT.var_type) vs
+ let of_list = List.fold_left (fun s e -> VarSet.add e s) VarSet.empty
+
+ include VarSet
+
+ let remove_list (set:t) (v_list: elt list) : t = List.fold_right VarSet.remove v_list set
+ let pp fmt vs = Utils.fprintf_list ~sep:", " Printers.pp_var fmt (VarSet.elements vs)
+end
+
+
+
+
+
+
+
+
+
+
+(*************************************************************************************)
+(* Converting values back and forth *)
+(*************************************************************************************)
+
+let rec value_t2salsa_expr constEnv vt =
+ let value_t2salsa_expr = value_t2salsa_expr constEnv in
+ let res =
+ match vt.LT.value_desc with
+ (* | LT.Cst(LT.Const_tag(t) as c) -> *)
+ (* Format.eprintf "v2s: cst tag@."; *)
+ (* if List.mem_assoc t constEnv then ( *)
+ (* Format.eprintf "trouvé la constante %s: %a@ " t Printers.pp_const c; *)
+ (* FloatIntSalsa.inject (List.assoc t constEnv) *)
+ (* ) *)
+ (* else ( *)
+ (* Format.eprintf "Const tag %s unhandled@.@?" t ; *)
+ (* raise (Salsa.Prelude.Error ("Entschuldigung6, constant tag not yet implemented")) *)
+ (* ) *)
+ | LT.Cst(cst) -> Format.eprintf "v2s: cst tag 2: %a@." Printers.pp_const cst; FloatIntSalsa.inject cst
+ | LT.LocalVar(v)
+ | LT.StateVar(v) -> Format.eprintf "v2s: var %s@." v.LT.var_id;
+ let sel_fun = (fun (vname, _) -> v.LT.var_id = vname) in
+ if List.exists sel_fun constEnv then
+ let _, cst = List.find sel_fun constEnv in
+ FloatIntSalsa.inject cst
+ else
+ let id = v.LT.var_id in
+ Salsa.Builder.mk_id id
+ | LT.Fun(binop, [x;y]) -> let salsaX = value_t2salsa_expr x in
+ let salsaY = value_t2salsa_expr y in
+ let op = (
+ let pred f x y = Salsa.Builder.mk_int_of_bool (f x y) in
+ match binop with
+ | "+" -> Salsa.Builder.mk_plus
+ | "-" -> Salsa.Builder.mk_minus
+ | "*" -> Salsa.Builder.mk_times
+ | "/" -> Salsa.Builder.mk_div
+ | "=" -> pred Salsa.Builder.mk_eq
+ | "<" -> pred Salsa.Builder.mk_lt
+ | ">" -> pred Salsa.Builder.mk_gt
+ | "<=" -> pred Salsa.Builder.mk_lte
+ | ">=" -> pred Salsa.Builder.mk_gte
+ | _ -> assert false
+ )
+ in
+ op salsaX salsaY
+ | LT.Fun(unop, [x]) -> let salsaX = value_t2salsa_expr x in
+ Salsa.Builder.mk_uminus salsaX
+
+ | LT.Fun(f,_) -> raise (Salsa.Prelude.Error
+ ("Unhandled function "^f^" in conversion to salsa expression"))
+
+ | LT.Array(_)
+ | LT.Access(_)
+ | LT.Power(_) -> raise (Salsa.Prelude.Error ("Unhandled construct in conversion to salsa expression"))
+ in
+ (* if debug then *)
+ (* Format.eprintf "value_t2salsa_expr: %a -> %a@ " *)
+ (* MC.pp_val vt *)
+ (* (fun fmt x -> Format.fprintf fmt "%s" (Salsa.Print.printExpression x)) res; *)
+ res
+
+type var_decl = { vdecl: LT.var_decl; is_local: bool }
+module VarEnv = Map.Make (struct type t = LT.ident let compare = compare end )
+
+(* let is_local_var vars_env v = *)
+(* try *)
+(* (VarEnv.find v vars_env).is_local *)
+(* with Not_found -> Format.eprintf "Impossible to find var %s@.@?" v; assert false *)
+
+let get_var vars_env v =
+try
+ VarEnv.find v vars_env
+ with Not_found -> Format.eprintf "Impossible to find var %s@.@?" v; assert false
+
+let compute_vars_env m =
+ let env = VarEnv.empty in
+ let env =
+ List.fold_left
+ (fun accu v -> VarEnv.add v.LT.var_id {vdecl = v; is_local = false; } accu)
+ env
+ m.MC.mmemory
+ in
+ let env =
+ List.fold_left (
+ fun accu v -> VarEnv.add v.LT.var_id {vdecl = v; is_local = true; } accu
+ )
+ env
+ MC.(m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals)
+ in
+env
+
+let rec salsa_expr2value_t vars_env cst_env e =
+ let salsa_expr2value_t = salsa_expr2value_t vars_env cst_env in
+ let binop op e1 e2 t =
+ let x = salsa_expr2value_t e1 in
+ let y = salsa_expr2value_t e2 in
+ MC.mk_val (LT.Fun (op, [x;y])) t
+ in
+ match e with
+ ST.Cst((ST.I(f1,f2),_),_) -> (* We project ranges into constants. We
+ forget about errors and provide the
+ mean/middle value of the interval
+ *)
+ let new_float =
+ if f1 = f2 then
+ f1
+ else
+ (f1 +. f2) /. 2.0
+ in
+ Format.eprintf "Converting [%.45f, %.45f] in %.45f@." f1 f2 new_float;
+ let cst =
+ let s =
+ if new_float = 0. then "0." else
+ (* We have to convert it into our format: int * int * real *)
+ let _ = Format.flush_str_formatter () in
+ Format.fprintf Format.str_formatter "%.50f" new_float;
+ Format.flush_str_formatter ()
+ in
+ Parser_lustre.signed_const Lexer_lustre.token (Lexing.from_string s)
+ in
+ MC.mk_val (LT.Cst(cst)) Type_predef.type_real
+ | ST.Id(id, _) ->
+ Format.eprintf "Looking for id=%s@.@?" id;
+ if List.mem_assoc id cst_env then (
+ let cst = List.assoc id cst_env in
+ Format.eprintf "Found cst = %a@.@?" Printers.pp_const cst;
+ MC.mk_val (LT.Cst cst) Type_predef.type_real
+ )
+ else
+ (* if is_const salsa_label then *)
+ (* MC.Cst(LT.Const_tag(get_const salsa_label)) *)
+ (* else *)
+ let var_id = try get_var vars_env id with Not_found -> assert false in
+ if var_id.is_local then
+ MC.mk_val (LT.LocalVar(var_id.vdecl)) var_id.vdecl.LT.var_type
+ else
+ MC.mk_val (LT.StateVar(var_id.vdecl)) var_id.vdecl.LT.var_type
+ | ST.Plus(x, y, _) -> binop "+" x y Type_predef.type_real
+ | ST.Minus(x, y, _) -> binop "-" x y Type_predef.type_real
+ | ST.Times(x, y, _) -> binop "*" x y Type_predef.type_real
+ | ST.Div(x, y, _) -> binop "/" x y Type_predef.type_real
+ | ST.Uminus(x,_) -> let x = salsa_expr2value_t x in
+ MC.mk_val (LT.Fun("uminus",[x])) Type_predef.type_real
+ | ST.IntOfBool(ST.Eq(x, y, _),_) -> binop "=" x y Type_predef.type_bool
+ | ST.IntOfBool(ST.Lt(x,y,_),_) -> binop "<" x y Type_predef.type_bool
+ | ST.IntOfBool(ST.Gt(x,y,_),_) -> binop ">" x y Type_predef.type_bool
+ | ST.IntOfBool(ST.Lte(x,y,_),_) -> binop "<=" x y Type_predef.type_bool
+ | ST.IntOfBool(ST.Gte(x,y,_),_) -> binop ">=" x y Type_predef.type_bool
+ | _ -> raise (Salsa.Prelude.Error "Entschuldigung, salsaExpr2value_t case not yet implemented")
+
+
+let rec get_salsa_free_vars vars_env constEnv absenv e =
+ let f = get_salsa_free_vars vars_env constEnv absenv in
+ match e with
+ | ST.Id (id, _) ->
+ if not (List.mem_assoc id absenv) && not (List.mem_assoc id constEnv) then
+ Vars.singleton ((try VarEnv.find id vars_env with Not_found -> assert false).vdecl)
+ else
+ Vars.empty
+ | ST.Plus(x, y, _)
+ | ST.Minus(x, y, _)
+ | ST.Times(x, y, _)
+ | ST.Div(x, y, _)
+ | ST.IntOfBool(ST.Eq(x, y, _),_)
+ | ST.IntOfBool(ST.Lt(x,y,_),_)
+ | ST.IntOfBool(ST.Gt(x,y,_),_)
+ | ST.IntOfBool(ST.Lte(x,y,_),_)
+ | ST.IntOfBool(ST.Gte(x,y,_),_)
+ -> Vars.union (f x) (f y)
+ | ST.Uminus(x,_) -> f x
+ | ST.Cst _ -> Vars.empty
+ | _ -> assert false
+
+(* Local Variables: *)
+(* compile-command:"make -C ../../.." *)
+(* End: *)
diff --git a/src/plugins/salsa/salsa_plugin.ml b/src/plugins/salsa/salsa_plugin.ml
new file mode 100644
index 0000000000000000000000000000000000000000..ca713ab90787f0570466c11e1583d838fca58793
--- /dev/null
+++ b/src/plugins/salsa/salsa_plugin.ml
@@ -0,0 +1,42 @@
+open Format
+open LustreSpec
+
+let salsa_enabled = ref false
+ (* "-salsa", Arg.Set salsa_enabled, "activate Salsa optimization <default>"; *)
+ (* "-no-salsa", Arg.Clear salsa_enabled, "deactivate Salsa optimization"; *)
+
+
+module Plugin =
+(struct
+ include PluginType.Default
+ let name = "salsa"
+
+ let options = [
+
+ ]
+
+ let activate () = salsa_enabled := true
+
+ let refine_machine_code prog machine_code =
+ if !salsa_enabled then
+ begin
+ Compiler_common.check_main ();
+ Log.report ~level:1 (fun fmt -> fprintf fmt ".. salsa machines optimization (phase 3)@ ");
+ (* Selecting float constants for Salsa *)
+ let constEnv = List.fold_left (
+ fun accu c_topdecl ->
+ match c_topdecl.top_decl_desc with
+ | Const c when Types.is_real_type c.const_type ->
+ (c.const_id, c.const_value) :: accu
+ | _ -> accu
+ ) [] (Corelang.get_consts prog)
+ in
+ List.map
+ (Machine_salsa_opt.machine_t2machine_t_optimized_by_salsa constEnv)
+ machine_code
+ end
+ else
+ machine_code
+
+
+ end: PluginType.PluginType)
diff --git a/src/plugins/scopes/scopes.ml b/src/plugins/scopes/scopes.ml
index 1f1920bd991002af04991afec8857e99d94669f7..dd934ecf0571ce00efeea47b8f7b8b53cc5946b1 100644
--- a/src/plugins/scopes/scopes.ml
+++ b/src/plugins/scopes/scopes.ml
@@ -227,7 +227,11 @@ let update_machine machine =
}
-module Plugin =
+module Plugin : (
+ sig
+ include PluginType.PluginType
+ val show_scopes: unit -> bool
+ end) =
struct
let name = "scopes"
let is_active () =
@@ -250,7 +254,8 @@ struct
let activate () =
option_scopes := true;
Options.optimization := 0; (* no optimization *)
- Options.salsa_enabled := false; (* No salsa *)
+
+ (* Options.salsa_enabled := false; (\* No salsa *\) TODO *)
()
let rec is_valid_path path nodename prog machines =
@@ -312,6 +317,31 @@ struct
let pp fmt = pp_scopes fmt !scopes_map
+ let check_force_stateful () = !option_scopes
+
+ let refine_machine_code prog machine_code =
+ if show_scopes () then
+ begin
+ let all_scopes = compute_scopes prog !Options.main_node in
+ (* Printing scopes *)
+ if !Options.verbose_level >= 1 then
+ Format.printf "Possible scopes are:@ ";
+ Format.printf "@[<v>%a@ @]@.@?" print_scopes all_scopes;
+ exit 0
+ end;
+ if is_active () then
+ process_scopes !Options.main_node prog machine_code
+ else
+ machine_code
+
+
+
+ let c_backend_main_loop_body_suffix fmt () =
+ if is_active () then
+ begin
+ Format.fprintf fmt "@ %t" pp
+ end;
+
end
(* Local Variables: *)
diff --git a/src/printers.ml b/src/printers.ml
index 431092527079dcbc1ba743414ff4d0ca29bcd1ab..424d78d61c22289aa193cd6672ecb4f213fe12b9 100644
--- a/src/printers.ml
+++ b/src/printers.ml
@@ -71,16 +71,16 @@ and pp_const fmt c =
let rec pp_expr fmt expr =
(match expr.expr_annot with
| None -> fprintf fmt "%t"
- | Some ann -> fprintf fmt "(%a %t)" pp_expr_annot ann)
+ | Some ann -> fprintf fmt "@[(%a %t)@]" pp_expr_annot ann)
(fun fmt ->
match expr.expr_desc with
| Expr_const c -> pp_const fmt c
- | Expr_ident id -> Format.fprintf fmt "%s" id
+ | Expr_ident id -> fprintf fmt "%s" id
| Expr_array a -> fprintf fmt "[%a]" pp_tuple a
| Expr_access (a, d) -> fprintf fmt "%a[%a]" pp_expr a Dimension.pp_dimension d
| Expr_power (a, d) -> fprintf fmt "(%a^%a)" pp_expr a Dimension.pp_dimension d
| Expr_tuple el -> fprintf fmt "(%a)" pp_tuple el
- | Expr_ite (c, t, e) -> fprintf fmt "(if %a then %a else %a)" pp_expr c pp_expr t pp_expr e
+ | Expr_ite (c, t, e) -> fprintf fmt "@[<hov 1>(if %a then@ @[<hov 2>%a@]@ else@ @[<hov 2>%a@]@])" pp_expr c pp_expr t pp_expr e
| Expr_arrow (e1, e2) -> fprintf fmt "(%a -> %a)" pp_expr e1 pp_expr e2
| Expr_fby (e1, e2) -> fprintf fmt "%a fby %a" pp_expr e1 pp_expr e2
| Expr_pre e -> fprintf fmt "pre %a" pp_expr e
@@ -257,9 +257,9 @@ let pp_typedec fmt ty =
let pp_spec fmt spec =
fprintf fmt "@[<hov 2>(*@@ ";
- fprintf_list ~sep:"@;@@ " (fun fmt r -> fprintf fmt "requires %a;" pp_eexpr r) fmt spec.requires;
- fprintf_list ~sep:"@;@@ " (fun fmt r -> fprintf fmt "ensures %a; " pp_eexpr r) fmt spec.ensures;
- fprintf_list ~sep:"@;" (fun fmt (name, assumes, ensures, _) ->
+ fprintf_list ~sep:"@,@@ " (fun fmt r -> fprintf fmt "requires %a;" pp_eexpr r) fmt spec.requires;
+ fprintf_list ~sep:"@,@@ " (fun fmt r -> fprintf fmt "ensures %a; " pp_eexpr r) fmt spec.ensures;
+ fprintf_list ~sep:"@," (fun fmt (name, assumes, ensures, _) ->
fprintf fmt "behavior %s:@[@ %a@ %a@]"
name
(fprintf_list ~sep:"@ " (fun fmt r -> fprintf fmt "assumes %a;" pp_eexpr r)) assumes
@@ -281,9 +281,9 @@ let pp_asserts fmt asserts =
| _ -> ()
let pp_node fmt nd =
-fprintf fmt "@[<v 0>%a%t%s %s (%a) returns (%a)@.%a%alet@.@[<h 2> @ @[<v>%a@ %a@ %a@]@ @]@.tel@]@."
+fprintf fmt "@[<v 0>%a%t%s %s (%a) returns (%a)@ %a%alet@[<h 2> @ @[<v>%a@ %a@ %a@]@]@ tel@]@ "
(fun fmt s -> match s with Some s -> pp_spec fmt s | _ -> ()) nd.node_spec
- (fun fmt -> match nd.node_spec with None -> () | Some _ -> Format.fprintf fmt "@.")
+ (fun fmt -> match nd.node_spec with None -> () | Some _ -> Format.fprintf fmt "@ ")
(if nd.node_dec_stateless then "function" else "node")
nd.node_id
pp_node_args nd.node_inputs
@@ -349,10 +349,12 @@ let pp_lusi fmt decl =
| Node _ -> assert false
let pp_lusi_header fmt basename prog =
- fprintf fmt "(* Generated Lustre Interface file from %s.lus *)@." basename;
- fprintf fmt "(* by Lustre-C compiler version %s, %a *)@." Version.number pp_date (Unix.gmtime (Unix.time ()));
- fprintf fmt "(* Feel free to mask some of the definitions by removing them from this file. *)@.@.";
- List.iter (fprintf fmt "%a@." pp_lusi) prog
+ fprintf fmt "@[<v 0>";
+ fprintf fmt "(* Generated Lustre Interface file from %s.lus *)@ " basename;
+ fprintf fmt "(* by Lustre-C compiler version %s, %a *)@ " Version.number pp_date (Unix.gmtime (Unix.time ()));
+ fprintf fmt "(* Feel free to mask some of the definitions by removing them from this file. *)@ @ ";
+ List.iter (fprintf fmt "%a@ " pp_lusi) prog;
+ fprintf fmt "@]"
let pp_offset fmt offset =
match offset with
diff --git a/src/typing.ml b/src/typing.ml
index f6948d537d3e83db26943a12e6ee87b06c0d1f3d..283f41f07fe7f53dd011c3990b097a99086a745a 100755
--- a/src/typing.ml
+++ b/src/typing.ml
@@ -367,10 +367,8 @@ and type_dependent_call env in_main loc const f targs =
begin
List.iter2 (fun (a,t) ti ->
let t' = type_add_const env (const || Types.get_static_value ti <> None) a t
- in try_unify ~sub:true ti t' a.expr_loc;
- ) targs tins;
-(*Format.eprintf "Typing.type_dependent_call END@.";*)
- touts;
+ in try_unify ~sub:true ti t' a.expr_loc) targs tins;
+ touts
end
(* type a simple call without dependent types
@@ -418,7 +416,7 @@ and type_expr env in_main const expr =
expr.expr_type <- ty;
ty
| Expr_access (e1, d) ->
- type_subtyping_arg env in_main true (expr_of_dimension d) Type_predef.type_int;
+ type_subtyping_arg env in_main false (* not necessary a constant *) (expr_of_dimension d) Type_predef.type_int;
let ty_elt = new_var () in
let d = Dimension.mkdim_var () in
type_subtyping_arg env in_main const e1 (Type_predef.type_array d ty_elt);
@@ -679,19 +677,19 @@ let type_top_consts env clist =
let rec type_top_decl env decl =
match decl.top_decl_desc with
| Node nd -> (
- try
- type_node env nd decl.top_decl_loc
- with Error (loc, err) as exc -> (
- (*if !Options.global_inline then
- Format.eprintf "Type error: failing node@.%a@.@?"
- Printers.pp_node nd
- ;*)
- raise exc)
+ try
+ type_node env nd decl.top_decl_loc
+ with Error (loc, err) as exc -> (
+ if !Options.global_inline then
+ Format.eprintf "Type error: failing node@.%a@.@?"
+ Printers.pp_node nd
+ ;
+ raise exc)
)
| ImportedNode nd ->
- type_imported_node env nd decl.top_decl_loc
+ type_imported_node env nd decl.top_decl_loc
| Const c ->
- type_top_const env c
+ type_top_const env c
| TypeDef _ -> List.fold_left type_top_decl env (consts_of_enum_type decl)
| Open _ -> env
diff --git a/src/utils.ml b/src/utils.ml
index 35b0c94c663c1a2ff3685a71b4495e7701a1ecff..c5a33c45daa036a25390e3b91ddc001b3a12d828 100755
--- a/src/utils.ml
+++ b/src/utils.ml
@@ -33,7 +33,7 @@ struct (* Node module *)
end
module IMap = Map.Make(IdentModule)
-
+
module ISet = Set.Make(IdentModule)
exception DeSome
@@ -298,6 +298,13 @@ let pp_iset fmt t =
Format.fprintf fmt "}@."
end
+let pp_imap pp_val fmt m =
+ begin
+ Format.fprintf fmt "@[{@ ";
+ IMap.iter (fun key v -> Format.fprintf fmt "%s -> %a@ " key pp_val v) m;
+ Format.fprintf fmt "}@ @]"
+ end
+
let pp_hashtbl t pp_fun beg_str end_str sep_str =
if (beg_str="\n") then
print_newline ()
@@ -326,7 +333,7 @@ let pp_longident lid =
pp_list lid pp_fun "" "." "."
let pp_date fmt tm =
- Format.fprintf fmt "%i/%i/%i, %i:%i:%i"
+ Format.fprintf fmt "%i/%i/%i, %02i:%02i:%02i"
(tm.Unix.tm_year + 1900)
tm.Unix.tm_mon
tm.Unix.tm_mday
@@ -340,12 +347,6 @@ let var_id_cpt = ref 0
let get_new_id () = incr var_id_cpt;!var_id_cpt
-let track_exception () =
- if !Options.track_exceptions
- then (Printexc.print_backtrace stdout; flush stdout)
- else ()
-
-
(* for lexing purposes *)
(* Update line number for location info *)
diff --git a/src/version.ml.in b/src/version.ml.in
index 41f1823e4230917d4ae00c2daad652849ad2c609..19e9233c49a8dd9129bcd7dde86c4ae2128b56d4 100644
--- a/src/version.ml.in
+++ b/src/version.ml.in
@@ -1,5 +1,5 @@
-let number = "@PACKAGE_VERSION@"
+let number = "@PACKAGE_VERSION@-@GITBRANCH@"
let codename ="@VERSION_CODENAME@"
diff --git a/test/Makefile b/test/Makefile
deleted file mode 100644
index e576624e403095f2b23657ccb0078a0bbb5e0c7c..0000000000000000000000000000000000000000
--- a/test/Makefile
+++ /dev/null
@@ -1,13 +0,0 @@
-TOPFILES=../sandbox
-
-test-compile:
- @bash ./test-compile.sh -a -v 2 tests_ok.list
- @rm build/*.o
-
-clean:
- @rm -rf build
- @for i in `find . -iname *.lusi`; do grep generated $$i > /dev/null; if [ $$? -eq 0 ]; then rm $$i; fi; done
-
-distclean: clean
- @rm -rf report*
-
diff --git a/test/horn_regression.list b/test/horn_regression.list
deleted file mode 100644
index 159f97dc915a7c1175719e272e94f0ebd0941f31..0000000000000000000000000000000000000000
--- a/test/horn_regression.list
+++ /dev/null
@@ -1,5 +0,0 @@
-../regression_tests/check_validity.lus,top
-../regression_tests/local_inline.lus,top
-../regression_tests/stateful_assert.lus,top
-../regression_tests/traffic.lus,top
-
diff --git a/test/regression.sh b/test/regression.sh
deleted file mode 100755
index eee6bfb94306ee0f2e43f0ccdb34e543735e8732..0000000000000000000000000000000000000000
--- a/test/regression.sh
+++ /dev/null
@@ -1,79 +0,0 @@
-#!/bin/bash
-
-#eval set -- $(getopt -n $0 "-aciwvh:" -- "$@")
-
-declare c i w h a v r
-declare -a files
-
-#SRC_PREFIX="../.."
-#SRC_PREFIX=`svn info --xml | grep wcroot | sed "s/<[^>]*>//g"`/lustre_compiler
-NOW=`date "+%y-%m-%d-%H:%M"`
-report=`pwd`/horn-report-$NOW
-#LUSTREC="../../_build/src/lustrec"
-LUSTREC=../bin/lustrec
-mkdir -p build-$NOW
-build=`pwd`/build-$NOW
-
-
-check_horn () {
- while IFS=, read -r file main opts
- do
- name=`basename "$file" .lus`
- if [ "$name" = "$file" ]; then
- return 0
- fi
- dir=${SRC_PREFIX}`dirname "$file"`
- pushd $dir > /dev/null
-
- # Checking horn backend
- if [ "$main" != "" ]; then
- $LUSTREC -horn-traces -horn-query -d $build -verbose 0 $opts -node $main "$name".lus
- else
- $LUSTREC -horn-traces -horn-query -d $build -verbose 0 $opts "$name".lus
- fi
- if [ $? -ne 0 ]; then
- rlustrec="ERROR";
- else
- rlustrec="OK"
- fi
- if [ $verbose -gt 0 ]; then
- echo "lustrec ($rlustrec), $dir, ${name}.lus, node $main" | column -t -s',' | tee -a $report;
- else
- echo "lustrec ($rlustrec), $dir, ${name}.lus, node $main" | column -t -s',' | tee -a $report | grep "INVALID\|ERROR\|UNKNOWN"
- fi
- popd > /dev/null
-done < $file_list
-}
-
-usage () {
-echo "usage: $0 [-aciwh] file_list"
-echo "-r: regression test for horn backend"
-echo "-v <int>: verbose level"
-}
-
-verbose=0
-nobehavior=1
-
-while [ $# -gt 0 ] ; do
- case "$1" in
- -v) shift ; verbose="$1"; shift ;;
- -r) nobehavior=0; r=1 ; shift ;;
- --) shift ;;
- -*) echo "bad option '$1'" ; exit 1 ;;
- *) files=("${files[@]}" "$1") ; shift ;;
- esac
-done
-
-file_list=${files[0]}
-
-
-if [ ${#files} -eq 0 ] ; then
- echo input list required
- usage
- exit 1
-fi
-
-[ ! -z "$r" ] && check_horn
-mv $report $build
-[ "$nobehavior" -eq 1 ] && echo "Must provide an argument in [aciwh]" && usage
-echo "DONE"
diff --git a/test/test-compile.sh.in b/test/test-compile.sh.in
deleted file mode 100755
index 6ff6838d211a9b4975315cf7a59de1486afac664..0000000000000000000000000000000000000000
--- a/test/test-compile.sh.in
+++ /dev/null
@@ -1,271 +0,0 @@
-#!/bin/bash
-
-eval set -- $(getopt -n $0 -o "-aciwvh:" -- "$@")
-
-declare c i w h a v
-declare -a files
-
-SRC_PREFIX=@SRC_PATH@-tests/
-#SRC_PREFIX=`svn info --xml | grep wcroot | sed "s/<[^>]*>//g"`/lustre_compiler
-NOW=`date "+%y%m%d%H%M"`
-report=`pwd`/report-@PACKAGE_VERSION@-$NOW
-LUSTREC=lustrec
-mkdir -p build
-build=`pwd`"/build"
-
-gcc_compile() {
- if [ $verbose -gt 1 ]; then
- echo "gcc -c -Wall -Wno-unused-but-set-variable -I ../../include/ $1.c > /dev/null"
- fi
- gcc -c -Wall -Wno-unused-but-set-variable -I ../../include/ "$1".c > /dev/null;
- if [ $? -ne 0 ]; then
- rgcc="INVALID";
- else
- rgcc="VALID"
- fi
-}
-
-lustrec_compile() {
- if [ $verbose -gt 1 ]; then
- echo "$LUSTREC $@"
- fi
- $LUSTREC "$@";
- if [ $? -ne 0 ]; then
- rlustrec="INVALID";
- else
- rlustrec="VALID"
- fi
-}
-
-base_compile() {
- while IFS=, read -r file main opts
- do
- name=`basename "$file" .lus`
- ext=".lus"
- if [ `dirname "$file"`/"$name" = "$file" ]; then
- name=`basename "$file" .lusi`
- ext=".lusi"
- fi
- dir=${SRC_PREFIX}/`dirname "$file"`
- pushd $dir > /dev/null
-
- if [ "$main" != "" ]; then
- lustrec_compile -d $build -verbose 0 $opts -node $main $name$ext;
- else
- lustrec_compile -d $build -verbose 0 $opts $name$ext
- fi
- pushd $build > /dev/null
-
- if [ $ext = ".lus" ] && [ "$opts" != "-lusi" ]; then
- gcc_compile "$name";
- else
- rgcc="NONE"
- fi
- popd > /dev/null
- popd > /dev/null
-
- if [ $verbose -gt 0 ]; then
- echo "lustrec ($rlustrec), gcc($rgcc), $dir, ${name}${ext}, node $main" | column -t -s',' | tee -a $report;
- else
- echo "lustrec ($rlustrec), gcc($rgcc), $dir, ${name}${ext}, node $main" | column -t -s',' | tee -a $report | grep "INVALID\|ERROR\|UNKNOWN"
- fi;
- done < $file_list
-}
-
-inline_compile () {
- while IFS=, read -r file main opts
- do
- name=`basename "$file" .lus`
- ext=".lus"
- if [ `dirname "$file"`/"$name" = "$file" ]; then
- name=`basename "$file" .lusi`
- ext=".lusi"
- fi
- dir=${SRC_PREFIX}/`dirname "$file"`
- pushd $dir > /dev/null
-
- if [ "$main" != "" ]; then
- lustrec_compile -d $build -verbose 0 $opts -inline -witnesses -node $main $name$ext;
- else
- if [ "$ext" = ".lusi" ]; then
- lustrec_compile -d $build -verbose 0 $opts $name$ext;
- else
- rlustrec="NONE"
- rgcc="NONE"
- fi
- fi
- pushd $build > /dev/null
-
- if [ "$main" != "" ] && [ $ext = ".lus" ] && [ "$opts" != "-lusi" ]; then
- gcc_compile "$name";
- else
- rgcc="NONE"
- fi
- popd > /dev/null
- popd > /dev/null
-
- if [ $verbose -gt 0 ]; then
- echo "lustrec inlined ($rlustrec), gcc ($rgcc), $dir, ${name}${ext}, node $main" | column -t -s',' | tee -a $report;
- else
- echo "lustrec inlined ($rlustrec), gcc ($rgcc), $dir, ${name}${ext}, node $main" | column -t -s',' | tee -a $report | grep "INVALID\|ERROR\|UNKNOWN"
- fi;
- done < $file_list
-}
-
-inline_compile_with_check () {
-# Checking inlining
- while IFS=, read -r file main opts
- do
- name=`basename "$file" .lus`
- ext=".lus"
- if [ `dirname "$file"`/"$name" = "$file" ]; then
- name=`basename "$file" .lusi`
- ext=".lusi"
- fi
- dir=${SRC_PREFIX}/`dirname "$file"`
- pushd $dir > /dev/null
-
- if [ "$main" != "" ]; then
- lustrec_compile -d $build -verbose 0 $opts -inline -witnesses -node $main $name$ext;
- else
- if [ "$ext" = ".lusi" ]; then
- lustrec_compile -d $build -verbose 0 $opts $name$ext;
- else
- rlustrec="NONE"
- rgcc="NONE"
- fi
- fi
- popd > /dev/null
- pushd $build > /dev/null
-
- if [ "$main" != "" ] && [ $ext = ".lus" ] && [ "$opts" != "-lusi" ]; then
- gcc_compile "$name";
- else
- rgcc="NONE"
- fi
- # Cheching witness
-
- if [ "$main" != "" ] && [ $ext = ".lus" ] && [ "$opts" != "-lusi" ]; then
- mv ${name}_witnesses/inliner_witness.lus ${name}_inliner_witness.lus
- lustrec_compile -verbose 0 -horn-traces -node check ${name}_inliner_witness.lus
- z3="`z3 -T:10 ${name}_inliner_witness.smt2 | xargs`"
- if [ "x`echo $z3 | grep -o unsat`" == "xunsat" ]; then
- rinlining="VALID";
- elif [ "x`echo $z3 | xargs | grep -o error`" == "xerror" ]; then
- rinlining="ERROR";
- elif [ "x`echo $z3 | xargs | grep -o unknown`" == "xunknown" ]; then
- rinlining="UNKNOWN";
- elif [ "x`echo $z3 | xargs | grep -o timeout`" == "xtimeout" ]; then
- rinlining="TIMEOUT"
- else
- rinlining="INVALID"
- fi
- else
- rinlining="NONE"
- fi
- popd > /dev/null
-
- if [ $verbose -gt 0 ]; then
- echo "lustrec inlined ($rlustrec), gcc ($rgcc), inlining check ($rinlining), $dir, ${name}${ext}, node $main" | column -t -s',' | tee -a $report;
- else
- echo "lustrec inlined ($rlustrec), gcc ($rgcc), inlining check ($rinlining), $dir, ${name}${ext}, node $main" | column -t -s',' | tee -a $report | grep "TIMEOUT\|INVALID\|ERROR\|UNKNOWN"
- fi
-done < $file_list
-
-}
-
-check_prop () {
- while IFS=, read -r file main opts
- do
- name=`basename "$file" .lus`
- if [ "$name" = "$file" ]; then
- return 0
- fi
- dir=${SRC_PREFIX}/`dirname "$file"`
- pushd $dir > /dev/null
-
- # Checking horn backend
- if [ "$main" != "" ]; then
- lustrec_compile -horn-traces -horn-query -d $build -verbose 0 $opts -node $main $name".lus";
- else
- lustrec_compile -horn-traces -horn-query -d $build -verbose 0 $opts $name".lus"
- fi
-
- # echo "z3 $build/$name".smt2
- # TODO: This part of the script has to be optimized
- z3="`z3 -T:10 ${build}/${name}.smt2 | xargs`"
- if [ "x`echo $z3 | grep -o unsat`" == "xunsat" ]; then
- rhorn="VALID";
- elif [ "x`echo $z3 | xargs | grep -o error`" == "xerror" ]; then
- rhorn="ERROR";
- elif [ "x`echo $z3 | xargs | grep -o unknown`" == "xunknown" ]; then
- rhorn="UNKNOWN";
- elif [ "x`echo $z3 | xargs | grep -o timeout`" == "xtimeout" ]; then
- rhorn="TIMEOUT"
- else
- rhorn="INVALID"
- fi
- if [ $verbose -gt 0 ]; then
- echo "lustrec ($rlustrec), horn-pdr ($rhorn), $dir, ${name}.lus, node $main" | column -t -s',' | tee -a $report;
- else
- echo "lustrec ($rlustrec), horn-pdr ($rhorn), $dir, ${name}.lus, node $main" | column -t -s',' | tee -a $report | grep "INVALID\|ERROR\|UNKNOWN"
- fi
- popd > /dev/null
-done < $file_list
-}
-
-usage () {
-echo "usage: $0 [-aciwh] file_list"
-echo "-a: perform all steps"
-echo "-c: basic compilation"
-echo "-i: compile with inline mode"
-echo "-w: compile with inline mode. Check the inlining with z3"
-echo "-h: check files with the horn-pdf backend (requires z3)"
-echo "-v <int>: verbose level"
-}
-
-verbose=0
-nobehavior=1
-
-while [ $# -gt 0 ] ; do
- case "$1" in
- -v) shift ; verbose="$1"; shift ;;
- -a) nobehavior=0; c=1 ; w=1; h=1; shift ;;
- -c) nobehavior=0; c=1 ; shift ;;
- -i) nobehavior=0; i=1 ; shift ;;
- -w) nobehavior=0; w=1 ; shift ;;
- -h) nobehavior=0; h=1 ; shift ;;
- --) shift ;;
- -*) echo "bad option '$1'" ; exit 1 ;;
- *) files=("${files[@]}" "$1") ; shift ;;
- esac
-done
-
-file_list=${files[0]}
-
-
-if [ ${#files} -eq 0 ] ; then
- echo input list required
- usage
- exit 1
-fi
-
-# cleaning directory $build
-
-rm -f "$build"/* 2> /dev/null
-
-# executing tests
-
-[ ! -z "$c" ] && base_compile
-[ ! -z "$i" ] && inline_compile
-[ ! -z "$w" ] && inline_compile_with_check
-[ ! -z "$h" ] && check_prop
-[ "$nobehavior" -eq 1 ] && echo "Must provide an argument in [aciwh]" && usage
-
-
- # Removing Generated lusi file
- #grep generated ../${file}i > /dev/null
- #if [ $? -ne 1 ];then
- # rm ../${file}i
- #fi
-
diff --git a/test/tests_ok.list b/test/tests_ok.list
deleted file mode 100644
index 0d2a2b8c26f43ad97ab063e7e150d278799b7d5f..0000000000000000000000000000000000000000
--- a/test/tests_ok.list
+++ /dev/null
@@ -1,962 +0,0 @@
-./tests/kind_fmcad08/misc/ex8_e8_376.lus,top
-./tests/kind_fmcad08/misc/_6counters_e8_371_e2_80.lus,top
-./tests/kind_fmcad08/misc/_6counters_e8_371_e1_448.lus,top
-./tests/kind_fmcad08/misc/_6counters.lus,top
-./tests/kind_fmcad08/misc/ex8_e7_74_e7_740.lus,top
-./tests/kind_fmcad08/misc/durationThm_1_e3_389_e5_5.lus,top
-./tests/kind_fmcad08/misc/two_counters_e2_3.lus,top
-./tests/kind_fmcad08/misc/stalmark.lus,top
-./tests/kind_fmcad08/misc/durationThm_3_e3_442.lus,top
-./tests/kind_fmcad08/misc/durationThm_1_e3_389.lus,top
-./tests/kind_fmcad08/misc/stalmark_e8_64_e7_80.lus,top
-./tests/kind_fmcad08/misc/durationThm_1.lus,top
-./tests/kind_fmcad08/misc/durationThm_3_e7_334_e2_62.lus,top
-./tests/kind_fmcad08/misc/switch2.lus,top
-./tests/kind_fmcad08/misc/durationThm_3_e1_71.lus,top
-./tests/kind_fmcad08/misc/_6counters_e8_371_e3_224.lus,top
-./tests/kind_fmcad08/misc/ticket3i_all_e8_505_e7_2450.lus,top
-./tests/kind_fmcad08/misc/durationThm_2_e7_145_e8_73.lus,top
-./tests/kind_fmcad08/misc/ex8_e7_74.lus,top
-./tests/kind_fmcad08/misc/ticket3i_3.lus,top
-./tests/kind_fmcad08/misc/_6counter.lus,top
-./tests/kind_fmcad08/misc/durationThm_2_e2_63.lus,top
-./tests/kind_fmcad08/misc/durationThm_3_e3_442_e4_165.lus,top
-./tests/kind_fmcad08/misc/ex8_e7_74_e8_302.lus,top
-./tests/kind_fmcad08/misc/durationThm_1_e7_217_e1_89.lus,top
-./tests/kind_fmcad08/misc/ticket3i_6_e7_1096_e7_2688.lus,top
-./tests/kind_fmcad08/misc/ticket3i_7_e1_2192_e1_1852.lus,top
-./tests/kind_fmcad08/misc/ticket3i_5_e7_3307.lus,top
-./tests/kind_fmcad08/misc/durationThm_1_e7_217_e3_132.lus,top
-./tests/kind_fmcad08/misc/ex3_e8_381_e8_477.lus,top
-./tests/kind_fmcad08/misc/ticket3i_3_e7_1312_e8_1916.lus,top
-./tests/kind_fmcad08/misc/durationThm_1_e1_350.lus,top
-./tests/kind_fmcad08/misc/ticket3i_all_e2_1117_e7_553.lus,top
-./tests/kind_fmcad08/misc/ticket3i_4_e7_1775_e7_3320.lus,top
-./tests/kind_fmcad08/misc/ticket3i_2.lus,top
-./tests/kind_fmcad08/misc/durationThm_2_e3_329_e5_124.lus,top
-./tests/kind_fmcad08/misc/durationThm_3_e2_148.lus,top
-./tests/kind_fmcad08/misc/durationThm_3_e2_63.lus,top
-./tests/kind_fmcad08/misc/twisted_counters.lus,top
-./tests/kind_fmcad08/misc/stalmark_e7_27_e7_31.lus,top
-./tests/kind_fmcad08/misc/durationThm_2_e7_149.lus,top
-./tests/kind_fmcad08/misc/ticket3i_5.lus,top
-./tests/kind_fmcad08/misc/two_counters.lus,top
-./tests/kind_fmcad08/misc/ticket3i_all_e7_591.lus,top
-./tests/kind_fmcad08/misc/ticket3i_7_e2_2724_e7_524.lus,top
-./tests/kind_fmcad08/misc/durationThm_2_e1_301.lus,top
-./tests/kind_fmcad08/misc/ticket3i_3_e8_1788.lus,top
-./tests/kind_fmcad08/misc/switch.lus,top
-./tests/kind_fmcad08/misc/durationThm_2_e7_145_e2_169.lus,top
-./tests/kind_fmcad08/misc/ticket3i_7_e7_3176.lus,top
-./tests/kind_fmcad08/misc/durationThm_2_e3_329_e4_1.lus,top
-./tests/kind_fmcad08/misc/ticket3i_3_e8_1703_e8_2560.lus,top
-./tests/kind_fmcad08/misc/ex3_e8_381_e7_224.lus,top
-./tests/kind_fmcad08/misc/durationThm_1_e2_3.lus,top
-./tests/kind_fmcad08/misc/ex8_e8_220_e7_249.lus,top
-./tests/kind_fmcad08/misc/ticket3i_3_e7_1312_e7_1495.lus,top
-./tests/kind_fmcad08/misc/ex3_e7_590_e7_590.lus,top
-./tests/kind_fmcad08/misc/_6countern.lus,top
-./tests/kind_fmcad08/misc/ticket3i_3_e7_1312.lus,top
-./tests/kind_fmcad08/misc/stalmark_e8_64.lus,top
-./tests/kind_fmcad08/misc/ticket3i_1_e7_1669.lus,top
-./tests/kind_fmcad08/misc/ticket3i_1.lus,top
-./tests/kind_fmcad08/misc/ticket3i_3_e8_1703.lus,top
-./tests/kind_fmcad08/misc/ticket3i_7.lus,top
-./tests/kind_fmcad08/misc/durationThm_3_e3_442_e5_260.lus,top
-./tests/kind_fmcad08/misc/durationThm_1_e7_217_e2_352.lus,top
-./tests/kind_fmcad08/misc/ex3_e7_655.lus,top
-./tests/kind_fmcad08/misc/_6counters_e8_371_e7_304.lus,top
-./tests/kind_fmcad08/misc/ex8.lus,top
-./tests/kind_fmcad08/misc/ticket3i_4.lus,top
-./tests/kind_fmcad08/misc/ticket3i_7_e8_2126_e7_78.lus,top
-./tests/kind_fmcad08/misc/ticket3i_all_e7_1837.lus,top
-./tests/kind_fmcad08/misc/durationThm_3.lus,top
-./tests/kind_fmcad08/misc/traffic_e7_46_e7_171.lus,top
-./tests/kind_fmcad08/misc/ticket3i_3_e8_1703_e7_3491.lus,top
-./tests/kind_fmcad08/misc/ticket3i_all.lus,top
-./tests/kind_fmcad08/misc/durationThm_2_e7_145_e3_222.lus,top
-./tests/kind_fmcad08/misc/two_counters_e3_325.lus,top
-./tests/kind_fmcad08/misc/durationThm_2_e7_145_e1_343.lus,top
-./tests/kind_fmcad08/misc/ticket3i_all_e3_557_e7_3464.lus,top
-./tests/kind_fmcad08/misc/durationThm_3_e7_334.lus,top
-./tests/kind_fmcad08/misc/durationThm_3_e7_334_e1_431.lus,top
-./tests/kind_fmcad08/misc/two_counters_e7_222.lus,top
-./tests/kind_fmcad08/misc/two_counters_e1_268.lus,top
-./tests/kind_fmcad08/misc/traffic_e7_46.lus,top
-./tests/kind_fmcad08/misc/ex8_e8_220.lus,top
-./tests/kind_fmcad08/misc/ex3.lus,top
-./tests/kind_fmcad08/misc/ticket3i_6.lus,top
-./tests/kind_fmcad08/misc/ex3_e8_381.lus,top
-./tests/kind_fmcad08/misc/durationThm_3_e7_334_e7_118.lus,top
-./tests/kind_fmcad08/misc/durationThm_1_e3_389_e4_294.lus,top
-./tests/kind_fmcad08/misc/ticket3i_3_e7_99.lus,top
-./tests/kind_fmcad08/misc/durationThm_2_e3_99.lus,top
-./tests/kind_fmcad08/misc/stalmark_e7_76.lus,top
-./tests/kind_fmcad08/misc/durationThm_3_e7_334_e3_42.lus,top
-./tests/kind_fmcad08/misc/durationThm_3_e3_207.lus,top
-./tests/kind_fmcad08/misc/ticket3i_7_e3_59_e7_2122.lus,top
-./tests/kind_fmcad08/misc/stalmark_e7_27.lus,top
-./tests/kind_fmcad08/misc/_6counters_e3_140_e8_149.lus,top
-./tests/kind_fmcad08/misc/durationThm_2.lus,top
-./tests/kind_fmcad08/misc/_6counter2.lus,top
-./tests/kind_fmcad08/misc/stalmark_e8_48.lus,top
-./tests/kind_fmcad08/misc/durationThm_1_e7_217_e7_31.lus,top
-./tests/kind_fmcad08/misc/ticket3i_7_e7_3176_e1_2924.lus,top
-./tests/kind_fmcad08/misc/traffic.lus,top
-./tests/kind_fmcad08/misc/durationThm_2_e7_145_e7_154.lus,top
-./tests/kind_fmcad08/misc/durationThm_3_e1_36.lus,top
-./tests/kind_fmcad08/misc/stalmark_e8_64_e8_207.lus,top
-./tests/kind_fmcad08/misc/durationThm_1_e7_217.lus,top
-./tests/kind_fmcad08/misc/ticket3i_all_e1_2706_e7_1776.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_2_e2_4481.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_5.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e3_671_e7_1882.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_6.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_rt_e2_3460.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all_e2_6104_e2_3308.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_2_e7_25_e1_154.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_2_e1_2316.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_4_e3_3511_e2_1923.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_3_e1_4783.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1a_e2_284_e7_998.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_4_e7_2329_e7_3856.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_10.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_6_e7_5046_e7_3623.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_rt_e1_913_e7_1403.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_6.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_11_e1_2450_e3_2330.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all_e3_5957.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_a3_e2_2086_e1_3235.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_13_e7_2336.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_4_e7_2329_e3_4574.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1a_e2_284_e1_2924.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_14_e2_3606.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_8_e3_786.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_2_e7_25.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_rt_e2_3460_e2_2670.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e3_3496.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e2_2924_e2_1767.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_3_e1_4783_e7_4070.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all_e1_4022_e7_2886.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_7_e7_3157_e2_2082.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_10_e1_3587_e7_872.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2_e7_5406_e1_6690.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_13_e3_1418_e3_2761.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e7_3191_e8_2830.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e1_1207_e1_1201.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_2_e7_25_e7_4469.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e3_671.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_a3_e1_3233_e1_3123.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_9_e7_1843_e7_2225.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_1_e1_3184_e7_1888.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_4_e2_2799_e7_2499.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_a3_e3_314_e1_1979.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_4_e1_4312.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_5_e1_2552_e7_1169.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_rt.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_4_e2_325.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_3_e7_4884.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e2_2924_e1_768.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_1_e1_1092_e7_1119.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_11_e1_3457.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_10_e3_144_e7_523.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_rt_e2_3460_e3_1333.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2_e7_5406_e7_6697.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_11.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_5_e7_2017_e2_664.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_7.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_12_e1_4640_e7_128.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all_e3_4821_e4_1791.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_4_e3_1540_e1_5048.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_4_e3_3511_e4_1464.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_4_e3_3511_e1_2375.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_2_e7_25_e2_5340.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_u1_e7_3318.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all_e1_4022_e3_3628.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_1_e2_1997_e7_3613_e2_3409.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_11_e1_2450_e2_1483.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e7_3191.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_u1_e2_3403_e2_957.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2_e3_4612_e1_6463.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_12_e2_1618_e7_4732.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_12_e2_1618_e3_2012.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2_e8_4626.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_8_e2_1711_e7_1962.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_8_e3_786_e7_4541.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_14_e3_5120.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2_e3_4612_e4_3719.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_11_e3_2076_e1_1270.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_11_e1_2450_e1_5887.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_11_e2_1678_e1_3565.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2_e8_5504.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_5_e1_1835.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_10_e7_3861_e2_1020.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2_e3_4612_e8_5861.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_4.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_a3_e3_314_e2_2812.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_4.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1a_e2_284_e3_3091.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all_e3_4821_e5_1536.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_10_e2_402.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_5_e7_2017.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e1_1691.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_5_e2_2884_e2_1492.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_3_e3_5422_e1_2288.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_rt_e1_913.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_6_e2_3302.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_3_e1_4783_e3_511.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_a3_e1_3233_e3_2970.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_5_e7_2017_e3_1763.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_2_e2_3183_e3_5972.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_8_e2_1711.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e2_2924_e3_3946.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_3_e1_2217_e3_1200.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_rt_e1_913_e2_3353.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all_e1_4037.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2_e8_5504_e2_1598.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_10_e3_3429.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_4_e3_3511_e7_3568.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_1.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_3.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e3_671_e3_941.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all_e7_1941_e2_6086.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e1_1207_e3_1928.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_5.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_10_e7_3861_e7_2180.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_rt_e2_3460_e7_471.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2_e2_2073_e8_3691.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e2_3049_e2_698.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_1_e1_5070.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_5_e2_2884_e1_2678.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_2_e2_3183_e2_3580.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_9.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_rt.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_3_e2_2236_e1_2305.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_u1.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e1_1139_e1_1565.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e3_671_e1_725.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_2.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_14_e7_3162_e2_753.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2_e7_5406.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_11_e3_382_e1_505.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_8_e2_1711_e3_1753.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all_e3_4821_e1_1318.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e2_3049_e3_2697.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all_e2_6104_e3_2607.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_9_e7_1843_e1_5434.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_1_e2_1997.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_12.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_5_e7_2017_e1_5832.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all_e2_6104_e1_6205.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_1_e1_1092_e3_389.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_11.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_10_e1_998.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_a3_e1_3233_e7_906.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e3_671_e2_2131.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e1_1207_e2_3220.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e2_3678.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e2_3049_e1_946.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_1_e1_14612_e2_2653_e7_4370.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_8_e7_3752.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_4_e3_3511_e5_3248.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e7_3191_e3_1250.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_a3_e2_2086_e3_2542.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2_e7_5406_e2_3084.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e3_1600_e5_84.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_8_e2_1711_e2_2673.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_3_e1_4783_e2_158.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e3_1600_e3_2055.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e3_1600_e7_1607.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_2_e7_25_e8_3171.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2_e8_5504_e7_579.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_3_e2_5343_e1_988.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_2_e3_151_e3_1540.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1a_e7_3042_e3_1213.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2_e7_5406_e3_506.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_8.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e1_1207_e7_156.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e7_3191_e7_2146.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_4_e2_2799_e1_1303.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_5_e2_2884_e3_1882.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_14_e7_3162.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all_e2_6104.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_rt_e3_1770_e2_637.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_12_e2_1618_e1_6030.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e7_2574.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_8_e2_1711_e1_1489.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_4_e2_2799_e3_1915.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_3_e1_4783_e1_3755.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_3_e3_5422_e2_3135.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_3_e3_3846.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_3_e2_2236_e2_1058.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_3_e2_2236_e3_2657.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e1_1139_e2_2893.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_1_e1_1092_e2_1853.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_13_e7_2336_e3_3117.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_2.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_2_e7_25_e3_829.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1a_e2_284_e2_2755.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e7_1909.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_5_e2_2884.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_a3_e3_314_e4_897.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_4_e2_2799.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_4_e3_3511_e3_422.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_3.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e1_3406.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1a.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_1_e3_11891_e7_4569_e4_4881.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_4_e2_2799_e2_2251.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e1_1139_e3_1839.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_13_e7_2336_e2_1255.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_3_e2_2236.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_12_e2_1618.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_10_e2_2785_e3_1744.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_9_e7_1843_e3_5316.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_2_e2_3183_e1_2644.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_14_e7_3162_e3_4298.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_5_e2_2884_e7_3594.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_14_e7_3162_e1_3998.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_rt_e1_913_e1_1993.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e3_1600_e2_676.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e3_671_e5_1637.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2_e3_4612_e2_5774.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_11_e1_2450.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_9_e7_1843.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_11_e1_2450_e7_5791.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_2.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_14_e1_5710.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_8.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_4.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_4_e3_4133.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_9.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all_e1_4022_e2_267.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_a3_e2_2086_e2_2689.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_2_e2_1375_e1_418.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_rt_e3_1549.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_a3_e1_3233.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_4_e3_3511.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_13.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_11_e3_382_e4_4421.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2_e3_4612_e3_1543.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_13_e7_2336_e7_685.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_1.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_1_e1_1092.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_10_e1_3587_e3_2749.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_5_e2_2229.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_9_e7_1843_e2_1145.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_14_e3_1259_e1_5798.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_7_e2_2872_e3_2640.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_12_e2_1618_e2_138.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2_e3_4612_e5_3642.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e2_2924_e7_3371.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_3.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_a3_e1_3233_e2_2392.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_1_e1_14612_e1_268_e7_501.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all2_e8_5504_e1_4719.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_13_e7_2336_e1_541.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_rt_e2_3460_e1_1455.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_7.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all_e7_4065.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_11_e2_5396_e3_282.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_9_e7_170_e3_3647.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_a3_e2_2086_e7_2614.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_8_e2_3896_e3_3125.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_2_e7_1826_e8_126.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_1_e1_1092_e1_1486.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_5.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e3_671_e4_147.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all_e1_4022_e1_1759.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_14.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_5_e7_2017_e7_2326.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_all_e3_4821_e2_1089.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_7_e2_2872_e2_5844.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_10.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e3_1600_e4_2415.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_all_e3_1600_e1_667.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_5_e2_3018_e2_936.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_14_e7_3162_e7_3528.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_10_e3_144_e5_2046.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e3_671_e6_1974.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e2_3049.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_10_e7_919_e2_3192.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_rt_e1_913_e3_2128.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_a3_e2_2952.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e7_3191_e2_1864.lus,top
-./tests/kind_fmcad08/memory1/DRAGON_4_e7_2329.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_luke_1b_e7_3191_e1_1303.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_a3.lus,top
-./tests/kind_fmcad08/memory1/FIREFLY_3_e2_2236_e7_3681.lus,top
-./tests/kind_fmcad08/simulation/PRODUCER_CONSUMER_vt_e3_507.lus,top
-./tests/kind_fmcad08/simulation/metros_2_e1_1116.lus,top
-./tests/kind_fmcad08/simulation/car_6_e3_294_e3_47.lus,top
-./tests/kind_fmcad08/simulation/speed_e7_207_e7_538.lus,top
-./tests/kind_fmcad08/simulation/car_6_e1_152_e1_391.lus,top
-./tests/kind_fmcad08/simulation/car_3_e8_33_e2_1010.lus,top
-./tests/kind_fmcad08/simulation/metros_1_e7_1255_e7_12.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e3_1091_e2_1317.lus,top
-./tests/kind_fmcad08/simulation/metros_2_e1_190.lus,top
-./tests/kind_fmcad08/simulation/metros_1_e1_846_e3_1060.lus,top
-./tests/kind_fmcad08/simulation/fast_1_e8_751.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e3_1091.lus,top
-./tests/kind_fmcad08/simulation/ums_e8_1032.lus,top
-./tests/kind_fmcad08/simulation/fast_1_e7_2044_e7_1287.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e3_1091_e4_232.lus,top
-./tests/kind_fmcad08/simulation/metros_3_e4_987.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e2_968_e2_1166.lus,top
-./tests/kind_fmcad08/simulation/car_3_e8_33.lus,top
-./tests/kind_fmcad08/simulation/Gas.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e2_968_e3_931.lus,top
-./tests/kind_fmcad08/simulation/production_cell.lus,top
-./tests/kind_fmcad08/simulation/production_cell_e8_792.lus,top
-./tests/kind_fmcad08/simulation/car_5_e7_244_e3_1071.lus,top
-./tests/kind_fmcad08/simulation/speed_e7_207.lus,top
-./tests/kind_fmcad08/simulation/car_1_e7_184_e3_299.lus,top
-./tests/kind_fmcad08/simulation/metros_3_e3_1275.lus,top
-./tests/kind_fmcad08/simulation/hysteresis_1.lus,top
-./tests/kind_fmcad08/simulation/car_6_e2_589_e3_349.lus,top
-./tests/kind_fmcad08/simulation/car_3_e1_586.lus,top
-./tests/kind_fmcad08/simulation/metros_3_e3_1275_e4_164.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e2_968_e4_801.lus,top
-./tests/kind_fmcad08/simulation/PRODUCER_CONSUMER_vt_e2_1352.lus,top
-./tests/kind_fmcad08/simulation/car_2.lus,top
-./tests/kind_fmcad08/simulation/car_4_e3_57_e4_1047.lus,top
-./tests/kind_fmcad08/simulation/metros_2_e1_1116_e2_617.lus,top
-./tests/kind_fmcad08/simulation/metros_3_e3_1275_e7_529.lus,top
-./tests/kind_fmcad08/simulation/metros_2_e2_968.lus,top
-./tests/kind_fmcad08/simulation/fast_1_e8_747_e7_692.lus,top
-./tests/kind_fmcad08/simulation/car_4_e3_556.lus,top
-./tests/kind_fmcad08/simulation/car_all.lus,top
-./tests/kind_fmcad08/simulation/PRODUCER_CONSUMMER_luke_2.lus,top
-./tests/kind_fmcad08/simulation/production_cell_e8_6_e8_427.lus,top
-./tests/kind_fmcad08/simulation/car_2_e8_491_e7_826.lus,top
-./tests/kind_fmcad08/simulation/car_all_e8_856_e1_217.lus,top
-./tests/kind_fmcad08/simulation/fast_1_e7_2044.lus,top
-./tests/kind_fmcad08/simulation/car_all_e8_856_e3_180.lus,top
-./tests/kind_fmcad08/simulation/car_all_e3_1068_e1_178.lus,top
-./tests/kind_fmcad08/simulation/car_all_e3_1068.lus,top
-./tests/kind_fmcad08/simulation/metros_3_e4_987_e3_291.lus,top
-./tests/kind_fmcad08/simulation/metros_2_e1_1116_e7_1440.lus,top
-./tests/kind_fmcad08/simulation/cd.lus,top
-./tests/kind_fmcad08/simulation/metros_4.lus,top
-./tests/kind_fmcad08/simulation/speed_e7_207_e8_507.lus,top
-./tests/kind_fmcad08/simulation/PRODUCER_CONSUMER_vt_e7_1059_e8_1111.lus,top
-./tests/kind_fmcad08/simulation/production_cell_e7_207_e8_241.lus,top
-./tests/kind_fmcad08/simulation/metros_1_e1_846_e1_1317.lus,top
-./tests/kind_fmcad08/simulation/metros_1_e2_1102_e7_1163.lus,top
-./tests/kind_fmcad08/simulation/metros_2_e1_1116_e3_287.lus,top
-./tests/kind_fmcad08/simulation/production_cell_e8_6_e7_651.lus,top
-./tests/kind_fmcad08/simulation/metros_1_e8_725_e1_919.lus,top
-./tests/kind_fmcad08/simulation/metros_3_e3_1275_e5_846.lus,top
-./tests/kind_fmcad08/simulation/car_4_e3_57_e5_999.lus,top
-./tests/kind_fmcad08/simulation/production_cell_e7_21.lus,top
-./tests/kind_fmcad08/simulation/car_5_e3_11_e1_429.lus,top
-./tests/kind_fmcad08/simulation/cd_e7_621_e7_669.lus,top
-./tests/kind_fmcad08/simulation/ums.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e2_968.lus,top
-./tests/kind_fmcad08/simulation/car_5.lus,top
-./tests/kind_fmcad08/simulation/metros_2_e1_1116_e1_556.lus,top
-./tests/kind_fmcad08/simulation/car_4_e8_118_e7_178.lus,top
-./tests/kind_fmcad08/simulation/fast_2_e7_2526_e7_2736.lus,top
-./tests/kind_fmcad08/simulation/car_all_e3_1068_e5_882.lus,top
-./tests/kind_fmcad08/simulation/fast_2_e7_2526.lus,top
-./tests/kind_fmcad08/simulation/tramway_e7_1834_e7_2363.lus,top
-./tests/kind_fmcad08/simulation/car_all_e2_142.lus,top
-./tests/kind_fmcad08/simulation/car_5_e2_405_e2_1083.lus,top
-./tests/kind_fmcad08/simulation/speed2_e8_449.lus,top
-./tests/kind_fmcad08/simulation/car_2_e7_1027_e7_359.lus,top
-./tests/kind_fmcad08/simulation/car_3_e7_626.lus,top
-./tests/kind_fmcad08/simulation/metros_2_e2_704_e3_76.lus,top
-./tests/kind_fmcad08/simulation/car_all_e8_856.lus,top
-./tests/kind_fmcad08/simulation/metros_1_e7_606.lus,top
-./tests/kind_fmcad08/simulation/cd_e7_8.lus,top
-./tests/kind_fmcad08/simulation/metros_1_e2_1102_e1_317.lus,top
-./tests/kind_fmcad08/simulation/PRODUCER_CONSUMMER_luke_2_e7_1068_e8_1019.lus,top
-./tests/kind_fmcad08/simulation/hysteresis_3.lus,top
-./tests/kind_fmcad08/simulation/metros_3_e3_1275_e1_1350.lus,top
-./tests/kind_fmcad08/simulation/car_5_e2_405_e8_1055.lus,top
-./tests/kind_fmcad08/simulation/car_all_e3_1068_e4_275.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e3_1091_e3_522.lus,top
-./tests/kind_fmcad08/simulation/PRODUCER_CONSUMER_1.lus,top
-./tests/kind_fmcad08/simulation/metros_1_e2_1102_e3_961.lus,top
-./tests/kind_fmcad08/simulation/fast_2_e8_460_e7_43.lus,top
-./tests/kind_fmcad08/simulation/car_6.lus,top
-./tests/kind_fmcad08/simulation/fast_1.lus,top
-./tests/kind_fmcad08/simulation/car_3_e7_626_e1_305.lus,top
-./tests/kind_fmcad08/simulation/metros_3_e4_987_e2_80.lus,top
-./tests/kind_fmcad08/simulation/tramway.lus,top
-./tests/kind_fmcad08/simulation/car_all_e8_856_e2_585.lus,top
-./tests/kind_fmcad08/simulation/car_4_e7_592_e7_265.lus,top
-./tests/kind_fmcad08/simulation/PRODUCER_CONSUMER_vt.lus,top
-./tests/kind_fmcad08/simulation/speed_e8_649_e7_709.lus,top
-./tests/kind_fmcad08/simulation/car_all_e3_1068_e3_163.lus,top
-./tests/kind_fmcad08/simulation/metros_3.lus,top
-./tests/kind_fmcad08/simulation/metros_2_e2_704_e7_810.lus,top
-./tests/kind_fmcad08/simulation/car_2_e7_1027_e1_1047.lus,top
-./tests/kind_fmcad08/simulation/speed2_e7_496.lus,top
-./tests/kind_fmcad08/simulation/car_3_e2_695.lus,top
-./tests/kind_fmcad08/simulation/metros_1_e1_846_e7_397.lus,top
-./tests/kind_fmcad08/simulation/car_5_e7_244.lus,top
-./tests/kind_fmcad08/simulation/car_all_e1_618_e3_303.lus,top
-./tests/kind_fmcad08/simulation/car_1.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e2_968_e6_236.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e2_968_e1_956.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e1_917.lus,top
-./tests/kind_fmcad08/simulation/car_6_e2_589_e2_506.lus,top
-./tests/kind_fmcad08/simulation/car_4_e8_118_e3_514.lus,top
-./tests/kind_fmcad08/simulation/metros_2_e2_704_e2_13.lus,top
-./tests/kind_fmcad08/simulation/metros_5.lus,top
-./tests/kind_fmcad08/simulation/car_3_e2_777.lus,top
-./tests/kind_fmcad08/simulation/speed2_e8_449_e7_353.lus,top
-./tests/kind_fmcad08/simulation/speed2_e8_449_e8_517.lus,top
-./tests/kind_fmcad08/simulation/car_4_e3_57_e6_784.lus,top
-./tests/kind_fmcad08/simulation/car_all_e1_618.lus,top
-./tests/kind_fmcad08/simulation/metros_1_e8_725_e2_1144.lus,top
-./tests/kind_fmcad08/simulation/metros_1_e2_1102_e2_943.lus,top
-./tests/kind_fmcad08/simulation/car_all_e3_1068_e2_13.lus,top
-./tests/kind_fmcad08/simulation/metros_2_e3_112.lus,top
-./tests/kind_fmcad08/simulation/fast_2_e8_976.lus,top
-./tests/kind_fmcad08/simulation/production_cell_e8_6.lus,top
-./tests/kind_fmcad08/simulation/speed2.lus,top
-./tests/kind_fmcad08/simulation/metros_1_e2_627.lus,top
-./tests/kind_fmcad08/simulation/metros_3_e3_1275_e3_640.lus,top
-./tests/kind_fmcad08/simulation/car_4_e3_57.lus,top
-./tests/kind_fmcad08/simulation/production_cell_e7_207_e7_41.lus,top
-./tests/kind_fmcad08/simulation/car_6_e2_893.lus,top
-./tests/kind_fmcad08/simulation/metros_3_e4_987_e1_1115.lus,top
-./tests/kind_fmcad08/simulation/ums_e7_1700.lus,top
-./tests/kind_fmcad08/simulation/car_4_e8_118.lus,top
-./tests/kind_fmcad08/simulation/fast_1_e8_747_e8_1041.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e3_1025.lus,top
-./tests/kind_fmcad08/simulation/fast_2.lus,top
-./tests/kind_fmcad08/simulation/car_3_e8_33_e1_856.lus,top
-./tests/kind_fmcad08/simulation/metros_1_e8_725.lus,top
-./tests/kind_fmcad08/simulation/speed_e8_649.lus,top
-./tests/kind_fmcad08/simulation/car_5_e7_244_e2_693.lus,top
-./tests/kind_fmcad08/simulation/metros_2_e2_704_e1_389.lus,top
-./tests/kind_fmcad08/simulation/metros_5_e4_1208_e1_337.lus,top
-./tests/kind_fmcad08/simulation/car_5_e3_661.lus,top
-./tests/kind_fmcad08/simulation/PRODUCER_CONSUMMER_luke_1.lus,top
-./tests/kind_fmcad08/simulation/tramway_e7_3304.lus,top
-./tests/kind_fmcad08/simulation/car_3.lus,top
-./tests/kind_fmcad08/simulation/car_6_e1_152.lus,top
-./tests/kind_fmcad08/simulation/PRODUCER_CONSUMER_all.lus,top
-./tests/kind_fmcad08/simulation/car_3_e1_924.lus,top
-./tests/kind_fmcad08/simulation/car_6_e3_294_e5_979.lus,top
-./tests/kind_fmcad08/simulation/car_5_e7_244_e1_823.lus,top
-./tests/kind_fmcad08/simulation/metros_1_e1_846_e2_1394.lus,top
-./tests/kind_fmcad08/simulation/metros_1_e8_725_e3_556.lus,top
-./tests/kind_fmcad08/simulation/speed_e7_492.lus,top
-./tests/kind_fmcad08/simulation/speed2_e8_750.lus,top
-./tests/kind_fmcad08/simulation/car_6_e3_294_e1_956.lus,top
-./tests/kind_fmcad08/simulation/car_5_e2_405_e3_473.lus,top
-./tests/kind_fmcad08/simulation/car_all_e8_856_e7_578.lus,top
-./tests/kind_fmcad08/simulation/metros_3_e3_1275_e6_1315.lus,top
-./tests/kind_fmcad08/simulation/speed2_e7_223_e8_329.lus,top
-./tests/kind_fmcad08/simulation/metros_1.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e5_1150.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e1_821_e5_911.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e2_968_e7_860.lus,top
-./tests/kind_fmcad08/simulation/tramway_e7_1834.lus,top
-./tests/kind_fmcad08/simulation/metros_2.lus,top
-./tests/kind_fmcad08/simulation/speed2_e7_223_e7_213.lus,top
-./tests/kind_fmcad08/simulation/PRODUCER_CONSUMER_2.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e3_1091_e1_1044.lus,top
-./tests/kind_fmcad08/simulation/hysteresis_2.lus,top
-./tests/kind_fmcad08/simulation/PRODUCER_CONSUMER_3.lus,top
-./tests/kind_fmcad08/simulation/car_5_e3_11_e5_24.lus,top
-./tests/kind_fmcad08/simulation/tramway_e7_1834_e8_3192.lus,top
-./tests/kind_fmcad08/simulation/car_3_e8_33_e7_220.lus,top
-./tests/kind_fmcad08/simulation/car_all_e2_142_e7_209.lus,top
-./tests/kind_fmcad08/simulation/car_4_e7_592_e3_442.lus,top
-./tests/kind_fmcad08/simulation/car_4_e7_592.lus,top
-./tests/kind_fmcad08/simulation/car_4.lus,top
-./tests/kind_fmcad08/simulation/fast_2_e8_460_e8_1920.lus,top
-./tests/kind_fmcad08/simulation/hysteresis_all.lus,top
-./tests/kind_fmcad08/simulation/car_all_e7_188_e7_743.lus,top
-./tests/kind_fmcad08/simulation/metros_3_e3_1275_e2_454.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e6_239_e2_307.lus,top
-./tests/kind_fmcad08/simulation/metros_4_e2_968_e5_991.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_2_e8_1118_e3_1216.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_2_e2_2367_e2_1561.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_4.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e7_2910_e7_1804.lus,top
-./tests/kind_fmcad08/memory2/MESI_4.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e2_155.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_3_e1_1416_e1_1675.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_123_e7_837_e3_135.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_3_e8_1708.lus,top
-./tests/kind_fmcad08/memory2/MESI_i1_e3_2145_e4_1717.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_2_e3_216.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_5.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_all_e8_251_e3_1472.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e3_929_e5_1826.lus,top
-./tests/kind_fmcad08/memory2/MESI_i1_e3_2145_e3_977.lus,top
-./tests/kind_fmcad08/memory2/MOESI_all_e3_2032_e3_2788.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e3_929.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_all_e8_251_e2_1053.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_all_e8_251.lus,top
-./tests/kind_fmcad08/memory2/MESI_3_e2_819_e7_1665.lus,top
-./tests/kind_fmcad08/memory2/MESI_i4_e8_1381_e4_313.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_3_e1_1416.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_3.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_2_e8_1118_e8_1177.lus,top
-./tests/kind_fmcad08/memory2/MESI_i2.lus,top
-./tests/kind_fmcad08/memory2/MOESI_1_e2_982_e7_492.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e3_929_e1_2319.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_2_e2_2367_e3_1601.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e2_1599_e1_2383.lus,top
-./tests/kind_fmcad08/memory2/MESI_all_e4_1147_e7_497.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e3_929_e8_1167.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_6_e2_1439_e1_954.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_3_e8_1329_e7_1062.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e3_929_e4_578.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_3_e8_1329_e3_421.lus,top
-./tests/kind_fmcad08/memory2/MESI_i1.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e2_1599_e3_1658.lus,top
-./tests/kind_fmcad08/memory2/MESI_3_e2_819_e3_2698.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_2_e1_1239_e2_74.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_6_e7_938_e2_1012.lus,top
-./tests/kind_fmcad08/memory2/MESI_3_e2_819_e8_1896.lus,top
-./tests/kind_fmcad08/memory2/MESI_4_e7_1140_e7_433.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_6.lus,top
-./tests/kind_fmcad08/memory2/MESI_i1_e4_1986.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_3_e3_2581_e7_3447.lus,top
-./tests/kind_fmcad08/memory2/MESI_i1_e4_1986_e1_1519.lus,top
-./tests/kind_fmcad08/memory2/MESI_i3_e1_447_e5_2444.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_all_e7_907_e7_1363.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_123_e8_953_e3_271.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_2_e1_834_e2_3395.lus,top
-./tests/kind_fmcad08/memory2/MESI_i3_e1_447_e2_1098.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e8_926_e3_1758.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_2.lus,top
-./tests/kind_fmcad08/memory2/MESI_i3_e1_447_e6_2281.lus,top
-./tests/kind_fmcad08/memory2/MESI_i3_e1_447.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e7_2607.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_123_e7_837_e2_1394.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e2_1599_e2_1815.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e7_2910_e8_2590.lus,top
-./tests/kind_fmcad08/memory2/MESI_i1_e3_2145_e5_2391.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_4.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_5_e2_1525.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_2_e8_1118_e2_237.lus,top
-./tests/kind_fmcad08/memory2/MESI_1.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_all_e3_1864_e4_34.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e8_926_e2_349.lus,top
-./tests/kind_fmcad08/memory2/MESI_3_e3_2669.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_2_e8_656.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_123_e8_953.lus,top
-./tests/kind_fmcad08/memory2/MESI_i1_e2_2656.lus,top
-./tests/kind_fmcad08/memory2/MESI_i1_e3_2145.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_6_e3_1666_e5_1558.lus,top
-./tests/kind_fmcad08/memory2/MOESI_all.lus,top
-./tests/kind_fmcad08/memory2/MESI_3_e2_819_e1_1145.lus,top
-./tests/kind_fmcad08/memory2/MESI_i4.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_r4a.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e8_101.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e8_926.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e3_929_e3_2294.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_4_e8_420_e8_1525.lus,top
-./tests/kind_fmcad08/memory2/MESI_i3_e1_447_e1_1292.lus,top
-./tests/kind_fmcad08/memory2/MESI_3_e2_819_e5_2554.lus,top
-./tests/kind_fmcad08/memory2/MESI_3_e2_819_e4_1595.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_all_e3_1864_e5_1637.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_3_e3_2581_e3_979.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_3.lus,top
-./tests/kind_fmcad08/memory2/MESI_i1_e3_2145_e2_2228.lus,top
-./tests/kind_fmcad08/memory2/MESI_i1_e2_1758_e8_12.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e1_1753.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e2_1599.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_3_e8_1329_e2_236.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_a1.lus,top
-./tests/kind_fmcad08/memory2/MESI_i3_e1_447_e7_2194.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_123_e3_302_e1_1141.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_5_e1_811.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_3_e1_1416_e7_193.lus,top
-./tests/kind_fmcad08/memory2/MESI_1_e2_162_e7_1545.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_123_e3_302.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_2_e2_2367_e7_2728.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_3_e3_2581.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_123_e7_856.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_2_e8_1118_e1_667.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_123.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e7_2910.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_all_e7_907.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_3_e3_2581_e4_958.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_5_e1_811_e2_1026.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e3_929_e6_2707.lus,top
-./tests/kind_fmcad08/memory2/MESI_i4_e6_2175.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_2_e1_834.lus,top
-./tests/kind_fmcad08/memory2/MESI_i1_e3_2145_e8_2325.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_5_e1_811_e1_823.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_4_e8_420_e7_572.lus,top
-./tests/kind_fmcad08/memory2/MESI_i3.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_4_e8_974.lus,top
-./tests/kind_fmcad08/memory2/MESI_3.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e7_2910_e2_611.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_all_e8_251_e1_1852.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_2_e8_1118_e7_1043.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e2_1599_e8_1334.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_2_e1_834_e1_1895.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e8_926_e1_1065.lus,top
-./tests/kind_fmcad08/memory2/MESI_3_e2_819.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_2_e1_1239.lus,top
-./tests/kind_fmcad08/memory2/MESI_i4_e7_1017_e6_1132.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_all_e3_1864_e3_495.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e3_929_e7_619.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_123_e8_953_e1_1128.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_3_e8_1329_e1_1270.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e1_1753_e1_1510.lus,top
-./tests/kind_fmcad08/memory2/MESI_3_e2_819_e6_1459.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_all.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_3_e7_1444_e7_638.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e8_926_e8_2138.lus,top
-./tests/kind_fmcad08/memory2/MESI_i4_e4_1689.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_4_e7_2651_e7_2847.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_123_e8_953_e8_941.lus,top
-./tests/kind_fmcad08/memory2/MESI_2.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_1.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_5_e7_692_e7_2865.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_i1.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_123_e7_837_e7_1262.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_1.lus,top
-./tests/kind_fmcad08/memory2/MESI_i4_e8_1381_e1_1837.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_123_e8_953_e7_1465.lus,top
-./tests/kind_fmcad08/memory2/MOESI_1.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e1_1753_e3_2021.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_123_e8_953_e2_458.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_2_e2_2367_e1_3182.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_2_e1_834_e3_2931.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_2.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e1_1753_e2_615.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_3_e8_1329_e8_320.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_2_e2_876.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_123_e2_1653.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_3_e3_2581_e5_4006.lus,top
-./tests/kind_fmcad08/memory2/MOESI_1_e3_1884_e7_1875.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_3_e3_2581_e2_2545.lus,top
-./tests/kind_fmcad08/memory2/MESI_all.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_3_e1_1416_e3_1191.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_2_e1_834_e7_3738.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_3_e7_425.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_all_e3_1750.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_3_e1_1416_e2_753.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e7_2910_e3_2002.lus,top
-./tests/kind_fmcad08/memory2/MESI_3_e2_819_e2_562.lus,top
-./tests/kind_fmcad08/memory2/MESI_i1_e3_2145_e7_1847.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e8_926_e7_961.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e3_1523.lus,top
-./tests/kind_fmcad08/memory2/MESI_i1_e3_2145_e1_2667.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_all.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_5.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e3_929_e2_2421.lus,top
-./tests/kind_fmcad08/memory2/MESI_i3_e1_447_e3_1180.lus,top
-./tests/kind_fmcad08/memory2/ILLINOIS_3_e3_2581_e1_1130.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_all_e3_1864_e7_251.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_3_e3_1041.lus,top
-./tests/kind_fmcad08/memory2/MOESI_2_e7_2910_e1_1021.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_2_e1_1239_e1_1331.lus,top
-./tests/kind_fmcad08/memory2/SYNAPSE_6_e8_1147_e2_1326.lus,top
-./tests/kind_fmcad08/memory2/MESI_3_e1_2517_e8_2163.lus,top
-./tests/kind_fmcad08/protocol/rtp_vt.lus,top
-./tests/kind_fmcad08/protocol/rtp_8.lus,top
-./tests/kind_fmcad08/protocol/rtp_all.lus,top
-./tests/kind_fmcad08/protocol/rtp_all_e7_2500.lus,top
-./tests/kind_fmcad08/protocol/swimmingpool_6_e7_399.lus,top
-./tests/kind_fmcad08/protocol/peterson_1.lus,top
-./tests/kind_fmcad08/protocol/swimmingpool_5.lus,top
-./tests/kind_fmcad08/protocol/swimmingpool_1_e7_1621.lus,top
-./tests/kind_fmcad08/protocol/peterson_3.lus,top
-./tests/kind_fmcad08/protocol/swimmingpool_6.lus,top
-./tests/kind_fmcad08/protocol/swimmingpool_8.lus,top
-./tests/kind_fmcad08/protocol/rtp_4.lus,top
-./tests/kind_fmcad08/protocol/rtp_3.lus,top
-./tests/kind_fmcad08/protocol/rtp_10_e7_106_e7_2564.lus,top
-./tests/kind_fmcad08/protocol/peterson_2.lus,top
-./tests/kind_fmcad08/protocol/rtp_9.lus,top
-./tests/kind_fmcad08/protocol/rtp_5_e7_3972.lus,top
-./tests/kind_fmcad08/protocol/swimmingpool_1.lus,top
-./tests/kind_fmcad08/protocol/swimmingpool_6_e7_10_e7_341.lus,top
-./tests/kind_fmcad08/protocol/peterson_1_e7_4234.lus,top
-./tests/kind_fmcad08/protocol/swimmingpool_9.lus,top
-./tests/kind_fmcad08/protocol/peterson_vt.lus,top
-./tests/kind_fmcad08/protocol/rtp_5.lus,top
-./tests/kind_fmcad08/protocol/rtp_2.lus,top
-./tests/kind_fmcad08/protocol/peterson_4.lus,top
-./tests/kind_fmcad08/protocol/rtp_6.lus,top
-./tests/kind_fmcad08/protocol/readwrit.lus,top
-./tests/kind_fmcad08/protocol/rtp_10.lus,top
-./tests/kind_fmcad08/protocol/peterson_all.lus,top
-./tests/kind_fmcad08/protocol/swimmingpool_4_e7_2197.lus,top
-./tests/kind_fmcad08/protocol/swimmingpool_3.lus,top
-./tests/kind_fmcad08/protocol/swimmingpool_4.lus,top
-./tests/kind_fmcad08/protocol/rtp_7.lus,top
-./tests/kind_fmcad08/protocol/swimmingpool_2.lus,top
-./tests/kind_fmcad08/protocol/rtp_1.lus,top
-./tests/kind_fmcad08/protocol/swimmingpool_7.lus,top
-./tests/kind_fmcad08/large/microwave06.lus,top
-./tests/kind_fmcad08/large/ccp23.lus,top
-./tests/kind_fmcad08/large/cruise_controller_07.lus,top
-./tests/kind_fmcad08/large/cruise_controller_19.lus,top
-./tests/kind_fmcad08/large/microwave28.lus,top
-./tests/kind_fmcad08/large/microwave09.lus,top
-./tests/kind_fmcad08/large/microwave21.lus,top
-./tests/kind_fmcad08/large/cruise_controller_05.lus,top
-./tests/kind_fmcad08/large/microwave13.lus,top
-./tests/kind_fmcad08/large/microwave32.lus,top
-./tests/kind_fmcad08/large/ccp09.lus,top
-./tests/kind_fmcad08/large/microwave04.lus,top
-./tests/kind_fmcad08/large/microwave34.lus,top
-./tests/kind_fmcad08/large/ccp13.lus,top
-./tests/kind_fmcad08/large/microwave37.lus,top
-./tests/kind_fmcad08/large/ccp14.lus,top
-./tests/kind_fmcad08/large/cruise_controller_01.lus,top
-./tests/kind_fmcad08/large/ccp16.lus,top
-./tests/kind_fmcad08/large/microwave03.lus,top
-./tests/kind_fmcad08/large/steam_boiler_no_arr2_e7_12307.lus,top
-./tests/kind_fmcad08/large/cruise_controller_09.lus,top
-./tests/kind_fmcad08/large/cruise_controller_20.lus,top
-./tests/kind_fmcad08/large/ccp06.lus,top
-./tests/kind_fmcad08/large/ccp01.lus,top
-./tests/kind_fmcad08/large/cruise_controller_16.lus,top
-./tests/kind_fmcad08/large/cruise_controller_06.lus,top
-./tests/kind_fmcad08/large/microwave27.lus,top
-./tests/kind_fmcad08/large/microwave35.lus,top
-./tests/kind_fmcad08/large/microwave11.lus,top
-./tests/kind_fmcad08/large/ccp02.lus,top
-./tests/kind_fmcad08/large/microwave07.lus,top
-./tests/kind_fmcad08/large/ccp05.lus,top
-./tests/kind_fmcad08/large/ccp17.lus,top
-./tests/kind_fmcad08/large/ccp12.lus,top
-./tests/kind_fmcad08/large/ccp15.lus,top
-./tests/kind_fmcad08/large/ccp03.lus,top
-./tests/kind_fmcad08/large/microwave05.lus,top
-./tests/kind_fmcad08/large/microwave40.lus,top
-./tests/kind_fmcad08/large/ccp18.lus,top
-./tests/kind_fmcad08/large/ccp22.lus,top
-./tests/kind_fmcad08/large/steam_boiler_no_arr2.lus,top
-./tests/kind_fmcad08/large/microwave02.lus,top
-./tests/kind_fmcad08/large/microwave30.lus,top
-./tests/kind_fmcad08/large/steam_boiler_no_arr1.lus,top
-./tests/kind_fmcad08/large/microwave20.lus,top
-./tests/kind_fmcad08/large/cruise_controller_24.lus,top
-./tests/kind_fmcad08/large/ccp24.lus,top
-./tests/kind_fmcad08/large/microwave18.lus,top
-./tests/kind_fmcad08/large/steam_boiler_no_arr2_e6_3003_e4_15091.lus,top
-./tests/kind_fmcad08/large/cruise_controller_04.lus,top
-./tests/kind_fmcad08/large/cruise_controller_10.lus,top
-./tests/kind_fmcad08/large/cruise_controller_18.lus,top
-./tests/kind_fmcad08/large/cruise_controller_14.lus,top
-./tests/kind_fmcad08/large/microwave10.lus,top
-./tests/kind_fmcad08/large/ccp07.lus,top
-./tests/kind_fmcad08/large/ccp10.lus,top
-./tests/kind_fmcad08/large/cruise_controller_03.lus,top
-./tests/kind_fmcad08/large/microwave29.lus,top
-./tests/kind_fmcad08/large/cruise_controller_17.lus,top
-./tests/kind_fmcad08/large/microwave15.lus,top
-./tests/kind_fmcad08/large/microwave24.lus,top
-./tests/kind_fmcad08/large/ccp04.lus,top
-./tests/kind_fmcad08/large/microwave08.lus,top
-./tests/kind_fmcad08/large/ccp08.lus,top
-./tests/kind_fmcad08/large/cruise_controller_08.lus,top
-./tests/kind_fmcad08/large/cruise_controller_15.lus,top
-./tests/kind_fmcad08/large/steam_boiler_no_arr2_e3_514_e4_11150.lus,top
-./tests/kind_fmcad08/large/cruise_controller_12.lus,top
-./tests/kind_fmcad08/large/cruise_controller_22.lus,top
-./tests/kind_fmcad08/large/microwave22.lus,top
-./tests/kind_fmcad08/large/microwave23.lus,top
-./tests/kind_fmcad08/large/microwave17.lus,top
-./tests/kind_fmcad08/large/microwave33.lus,top
-./tests/kind_fmcad08/large/microwave14.lus,top
-./tests/kind_fmcad08/large/microwave38.lus,top
-./tests/kind_fmcad08/large/ccp19.lus,top
-./tests/kind_fmcad08/large/microwave36.lus,top
-./tests/kind_fmcad08/large/microwave16.lus,top
-./tests/kind_fmcad08/large/ccp21.lus,top
-./tests/kind_fmcad08/large/microwave12.lus,top
-./tests/kind_fmcad08/large/cruise_controller_11.lus,top
-./tests/kind_fmcad08/large/microwave25.lus,top
-./tests/kind_fmcad08/large/cruise_controller_13.lus,top
-./tests/kind_fmcad08/large/microwave01.lus,top
-./tests/kind_fmcad08/large/steam_boiler_no_arr2_e8_21449_e5_18210.lus,top
-./tests/kind_fmcad08/large/microwave26.lus,top
-./tests/kind_fmcad08/large/microwave19.lus,top
-./tests/kind_fmcad08/large/steam_boiler_no_arr1_e4_23904_e4_2384.lus,top
-./tests/kind_fmcad08/large/cruise_controller_02.lus,top
-./tests/kind_fmcad08/large/microwave39.lus,top
-./tests/kind_fmcad08/large/steam_boiler_no_arr2_e1_17214_e5_18600.lus,top
-./tests/kind_fmcad08/large/microwave31.lus,top
-./tests/kind_fmcad08/large/cruise_controller_23.lus,top
-./tests/kind_fmcad08/large/ccp20.lus,top
-./tests/kind_fmcad08/large/ccp11.lus,top
-./tests/kind_fmcad08/large/cruise_controller_21.lus,top
-./tests/tuples/tuples1.lus
-./tests/tuples/tuples2.lus
-./tests/arrays_arnaud/dummy_lib.lusi
-./tests/arrays_arnaud/arrays.lus,,-check-access
-./tests/arrays_arnaud/RelOpMatrix.lus
-./tests/arrays_arnaud/access1.lus,,-check-access
-./tests/arrays_arnaud/generic1.lus,,-lusi
-./tests/arrays_arnaud/generic1.lusi
-./tests/arrays_arnaud/generic1.lus
-./tests/arrays_arnaud/generic2.lus
-./tests/arrays_arnaud/generic3.lus,top,-dynamic -check-access
-./tests/clocks/clocks1.lus,,-lusi
-./tests/clocks/clocks1.lusi
-./tests/clocks/clocks1.lus
-./tests/clocks/clocks2.lus
-./tests/clocks/clocks6.lus
-./tests/clocks/clocks7.lus
-./tests/clocks/clocks8.lus
-./tests/clocks/clocks9.lus
-./tests/clocks/oversampling0.lus,,-lusi
-./tests/clocks/oversampling0.lusi
-./tests/clocks/oversampling0.lus
-./tests/lusic/test2.lusi
-./tests/lusic/test1.lusi
-./tests/lusic/test1.lus,as_soon_as
-./tests/lusic/test2.lus
-./tests/automata/aut1.lus
-./tests/automata/heater3.lus
-./tests/automata/heater4.lus
-./tests/linear_ctl/libarrays.lusi
-./tests/linear_ctl/ex1_mat.lus
-./tests/linear_ctl/ex1_mat_xt.lus
-./tests/linear_ctl/ex8sat.lus,top
-./tests/linear_ctl/ex2reset.lus,top
-./tests/linear_ctl/lp_iir_9600_2.lus,top
-./tests/linear_ctl/ex4reset.lus,top
-./tests/linear_ctl/ex3.lus,top
-./tests/linear_ctl/ex6sat.lus,top
-./tests/linear_ctl/ex3reset.lus,top
-./tests/linear_ctl/ex7sat.lus,top
-./tests/linear_ctl/chain5_6.lus,top
-./tests/linear_ctl/ex4sat.lus,top
-./tests/linear_ctl/chain4_4.lus,top
-./tests/linear_ctl/ex3sat.lus,top
-./tests/linear_ctl/lp_iir_9600_6_elliptic.lus,top
-./tests/linear_ctl/ex2sat.lus,top
-./tests/linear_ctl/ex1reset.lus,top
-./tests/linear_ctl/ex5.lus,top
-./tests/linear_ctl/lp_iir_9600_4.lus,top
-./tests/linear_ctl/ex4.lus,top
-./tests/linear_ctl/chain4_1.lus,top
-./tests/linear_ctl/chain5_4.lus,top
-./tests/linear_ctl/ex6.lus,top
-./tests/linear_ctl/ex6reset.lus,top
-./tests/linear_ctl/ex7reset.lus,top
-./tests/linear_ctl/ex8.lus,top
-./tests/linear_ctl/lp_iir_9600_4_elliptic.lus,top
-./tests/linear_ctl/ex1.lus,top
-./tests/linear_ctl/ex2.lus,top
-./tests/linear_ctl/ex5reset.lus,top
-./tests/linear_ctl/chain4_l2.lus,top
-./tests/linear_ctl/chain6_l2.lus,top
-./tests/linear_ctl/ex1sat.lus,top
-./tests/linear_ctl/ex5sat.lus,top
-./tests/linear_ctl/ex8reset.lus,top
-./tests/linear_ctl/ex7.lus,top
diff --git a/test/tests_ok_dev.list b/test/tests_ok_dev.list
deleted file mode 100644
index 098d691fbc01586908cd26ea6c2c1520ef3ccec1..0000000000000000000000000000000000000000
--- a/test/tests_ok_dev.list
+++ /dev/null
@@ -1,34 +0,0 @@
-./tests/tuples/tuples1.lus
-./tests/tuples/tuples2.lus
-./tests/arrays_arnaud/dummy_lib.lusi
-./tests/arrays_arnaud/arrays.lusi
-./tests/arrays_arnaud/arrays.lus,,-check-access
-./tests/arrays_arnaud/RelOpMatrix.lus
-./tests/arrays_arnaud/access1.lus,,-check-access
-./tests/arrays_arnaud/generic1.lus,,-lusi
-./tests/arrays_arnaud/generic1.lusi
-./tests/arrays_arnaud/generic1.lus
-./tests/arrays_arnaud/generic2.lus
-./tests/arrays_arnaud/generic3.lus,top,-dynamic -check-access
-./tests/clocks/clocks1.lus,,-lusi
-./tests/clocks/clocks1.lusi
-./tests/clocks/clocks1.lus
-./tests/clocks/clocks2.lus
-./tests/clocks/clocks6.lus
-./tests/clocks/clocks7.lus
-./tests/clocks/clocks8.lus
-./tests/clocks/clocks9.lus
-./tests/clocks/oversampling0.lus,,-lusi
-./tests/clocks/oversampling0.lusi
-./tests/clocks/oversampling0.lus
-./tests/clocks/oversampling0.lus,,-O 3
-./tests/lusic/test2.lusi
-./tests/lusic/test1.lusi
-./tests/lusic/test1.lus,as_soon_as
-./tests/lusic/test2.lus
-./tests/automata/aut1.lus
-./tests/automata/heater3.lus
-./tests/automata/heater4.lus
-./tests/linear_ctl/libarrays.lusi
-./tests/linear_ctl/ex1_mat.lus
-./tests/linear_ctl/ex1_mat_xt.lus