-
Erwan Jahier authored
profiles constain only named types. Typically, instead of printing: node toto(x: int ^ 4) ... print something like : type int4 = int ^ 4 node toto(x: int4) ... Moreover, in order to avoid name clashes, we prefix all user name type by "_".Erwan Jahier authoredprofiles constain only named types. Typically, instead of printing: node toto(x: int ^ 4) ... print something like : type int4 = int ^ 4 node toto(x: int4) ... Moreover, in order to avoid name clashes, we prefix all user name type by "_".
main.ml 7.66 KiB
(** Time-stamp: <modified the 04/07/2008 (at 16:31) by Erwan Jahier> *)
(** Here follows a description of the different modules used by this lus2lic compiler.
(1) First of all, the Lustre files are parsed,
lexer.mll
parser.mly
parserUtils.ml
lxm.mli/ml
which results into a parse tree containing raw source expressions.
syntaxTree.ml -> should rather be called rawSyntaxTab.ml ?
syntaxTreedump.ml
(2) Then, we perform reference checking at module level + model expansion.
syntaxTab.mli/ml
syntaxTabUtil.ml/mli
expandPack.mli/ml
symbolTab.mli/ml (type/const/node)
syntaxTab is a kind of layer above syntaxTree to make things easier afterwards.
(3) Finally, the compilation (type checking+const/type evaluation) is performed.
compile.ml
lazyCompiler.mli/ml
evalConst.mli/ml
evalType.mli/ml
compiledData.ml
Some misc (eponymous) modules are used along the way.
errors.ml
verbose.mli/ml
version.ml
ident.ml
*)
open Verbose
open SyntaxTree
open SyntaxTreeCore
open Lxm
open Errors
open Parsing
open Format
(*---------------------------------------------------------
Les args sont des variables GLOBALES
---------------------------------------------------------*)
let print_version = function (x: unit) -> (
print_string (Version.str ^ "\n")
)
let usage_msg =
"usage: "^(Version.tool)^" [options] <lustre files> | "^(Version.tool)^" -help"
let rec arg_list = [
( "--version", Arg.Unit(fun x -> print_version () ; exit 0),
"\tPrint the current version then exit"
);
( "--output-file", Arg.String(fun x -> Global.outfile := x), "<file>"
);
( "-o", Arg.String(fun x -> Global.outfile := x), "<file>\tSet the output file name"
);
( "--node", Arg.String(fun x -> Global.main_node := x),
"<node>"
);
( "-n", Arg.String(fun x -> Global.main_node := x),
"<node>\tSet the main node (all items are compiled if unset)"
);
( "--compile-all-items", Arg.Unit
(function x -> Global.compile_all_items := true),
"\t"
);
( "-all", Arg.Unit
(function x -> Global.compile_all_items := true),
"\t\tCompile all items of the program"
);
( "-unit", Arg.Unit (fun x -> Global.run_unit_test := true),
"\tRun some (internal) unit tests"
);
( "--verbose", Arg.Unit (fun vl -> Verbose.set_level 1 ),
""
);
( "-v", Arg.Unit (fun vl -> Verbose.set_level 1 ),
"\t\tSet verbose mode on (i.e., verbose level = 1)"
);
( "--verbose-level", Arg.Int(fun vl -> Verbose.set_level vl ), "<int>"
);
( "-vl", Arg.Int(fun vl -> Verbose.set_level vl ),
"<int>\tSet verbose level"
);
("-h", Arg.Unit (fun _ -> (Arg.usage arg_list usage_msg; exit 0)), "" );
("-help", Arg.Unit (fun _ -> (Arg.usage arg_list usage_msg; exit 0)),"" );
("--help", Arg.Unit (fun _ -> (Arg.usage arg_list usage_msg; exit 0)),
"\tDisplay this list of options" )
]
and
parse_args () = (
Arg.parse arg_list (* liste des options *)
Global.add_infile (* arg par defaut = fichier d'entree *)
usage_msg (* message d'erreur *)
;
()
)
let test_lex ( lexbuf ) = (
let tk = ref (Lexer.lexer lexbuf) in (
while !tk <> Parser.TK_EOF do
match (Lexer.token_code !tk) with
( co , lxm ) ->
printf "%s : %15s = \"%s\"\n"
(Lxm.position lxm) co (Lxm.str lxm) ;
tk := (Lexer.lexer lexbuf)
done
)
)
(* Retourne un parse_tree *)
let lus_load lexbuf = (
SolveIdent.recognize_predef_op
(Parser.sxLusFile Lexer.lexer lexbuf)
)
(* Dump d'un packbody *)
let dump_body (pkg: SyntaxTree.packbody) = (
let os = Format.formatter_of_out_channel stdout in
SyntaxTreeDump.packbody os pkg
)
(* Dump d'un name-space, pack ou modele ... *)
let dump_ns (ns: SyntaxTree.pack_or_model) = ( let os = Format.formatter_of_out_channel stdout in
match ns with
NSPack pf -> (
(* Verbose.printf (lazy ("DUMP PACKDEF\n")); *)
SyntaxTreeDump.packinfo os pf
)
| NSModel mf -> (
(* Verbose.printf (lazy ("DUMP MODDEF\n")); *)
SyntaxTreeDump.modelinfo os mf
)
)
(*
Lance le parser et renvoie la liste name-spaces d'entre.
Dans le cas d'un fichier sans package, on lui donne
comme nom le basename de infile.
*)
type maybe_packed =
| Packed of SyntaxTree.pack_or_model list
| Unpacked of SyntaxTree.pack_or_model
let (get_source_list : string list -> SyntaxTree.pack_or_model list) =
fun infile_list ->
let (get_one_source : string -> string list * maybe_packed) =
fun infile ->
let lexbuf = Global.lexbuf_of_file_name infile in
match (lus_load lexbuf) with
| PRPackBody(incl_files, pbdy) ->
let nme =
try Filename.chop_extension (Filename.basename infile)
with _ -> print_string ("*** '"^infile^"': bad file name.\n"); exit 1
in
let pi =
SyntaxTree.give_pack_this_name (Ident.pack_name_of_string nme) pbdy
in
incl_files, Unpacked (NSPack (Lxm.flagit pi (Lxm.dummy nme)))
| PRPack_or_models(incl_files, nsl) -> incl_files, Packed nsl
in
let rec (get_remaining_source_list : maybe_packed * string list * string list ->
maybe_packed * string list * string list) =
fun (maybe_pack, compiled, to_be_compiled) ->
match to_be_compiled with
| [] -> (maybe_pack, compiled, [])
| infile::tail ->
if List.mem infile compiled then
get_remaining_source_list (maybe_pack, compiled, tail)
else
let included_files, pack = get_one_source infile in
let new_maybe_pack =
match maybe_pack, pack with
| Unpacked _, _
| _, Unpacked _ ->
print_string ("old-style (un-packaged) lustre files can " ^
" not be mixed with packages, nor be " ^
" defined in more than 1 file.");
exit 1
| Packed l1, Packed l2 -> Packed (l1@l2)
in
get_remaining_source_list(
new_maybe_pack,
infile::compiled,
tail@included_files)
in
let first_file = assert (infile_list <> []); List.hd infile_list in
let included_files, first_pack = get_one_source first_file in
let (pack_list,_,_) = get_remaining_source_list
(first_pack, [first_file], (List.tl infile_list) @ included_files)
in
match pack_list with
| Packed l -> l | Unpacked pack -> [pack]
let my_exit i =
close_out !Global.oc;
if Sys.file_exists !Global.outfile then Sys.remove !Global.outfile;
exit i
let main = (
(* Compile.init_appli () ; *)
parse_args ();
if !Global.run_unit_test then (
UnifyType.unit_test ()
);
if (!Global.infiles = []) then (
Arg.usage arg_list usage_msg ;
exit 1
);
try (
let nsl = get_source_list !Global.infiles in
let main_node =
if !Global.main_node = "" then None else
Some (Ident.idref_of_string !Global.main_node)
in
if !Global.outfile <> "" then Global.oc := open_out !Global.outfile;
Compile.doit nsl main_node;
CompiledDataDump.dump_type_alias !Global.oc;
close_out !Global.oc
) with
Sys_error(s) ->
prerr_string (s^"\n");
my_exit 1
| Global_error s ->
print_global_error s ;
my_exit 1
| Parse_error ->
print_compile_error (Lxm.last_made ()) "syntax error";
my_exit 1
| Compile_error(lxm,msg) ->
print_compile_error lxm msg ;
my_exit 1
| Assert_failure (file, line, col) ->
prerr_string (
"\n*** oops: an internal error occurred in file "^ file ^ ", line " ^
(string_of_int line) ^ ", column " ^
(string_of_int col) ^ "\n*** when compiling lustre program" ^
(if List.length !Global.infiles > 1 then "s " else " ") ^
(String.concat ", " !Global.infiles) ^ "\n") ;
my_exit 2
(* | Compile_node_error(nkey,lxm,msg) -> ( *)
(* print_compile_node_error nkey lxm msg ; *)
(* exit 1 *)
(* ) *)
(* | Global_node_error(nkey,msg) -> ( *)
(* print_global_node_error nkey msg ; *)
(* exit 1 *)
(* ) *)
)