(** Time-stamp: <modified the 13/05/2008 (at 09:47) 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
open Global
let usage_msg =
"usage: "^(Version.tool)^" [options] <lustre files> | "^(Version.tool)^" -help"
(*---------------------------------------------------------
Les args sont des variables GLOBALES
---------------------------------------------------------*)
let print_version = function (x: unit) -> (
print_string (Version.str ^ "\n")
)
let rec set_infile = function (x:string) -> (
if ( _lus2lic_ARGS.main_node = "main" ) then (
(* default node name = file name *)
try
_lus2lic_ARGS.main_node <- Filename.chop_extension (Filename.basename x)
with _ ->
print_string ("*** '" ^ x ^ "': Bad file name\n");
exit 1
);
_lus2lic_ARGS.infiles <- _lus2lic_ARGS.infiles@[x]
)
and arg_list = [
( "-version", Arg.Unit(function x -> print_version () ; exit 0),
" print the current version then exit"
);
( "-o", Arg.String(function x -> _lus2lic_ARGS.outfile <- x),
" <file name> set the output file name"
);
( "-n", Arg.String(function x -> _lus2lic_ARGS.main_node <- x),
" <node> set the main node"
);
( "--compile-all-items", Arg.Unit
(function x -> _lus2lic_ARGS.compile_all_items <- true),
" compile all items of the program"
);
( "-v", Arg.Unit (function vl -> Verbose.set_level 1 ),
" set verbose mode on (i.e., verbose level = 1)"
);
( "-vl", Arg.Int(function vl -> Verbose.set_level vl ),
" <int> set verbose level"
)
]
and
parse_args () = (
Arg.parse arg_list (* liste des options *)
set_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 = (
(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'entr�e.
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 -> maybe_packed) =
fun infile ->
let inchannel = open_in infile in
let lexbuf = Lexing.from_channel inchannel in
Verbose.print_string ~level:3 ("Opening file " ^ infile ^ "\n");
_lus2lic_ARGS.current_file <- infile;
match (lus_load lexbuf) with
| PRPackBody 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
Unpacked (NSPack (Lxm.flagit pi (Lxm.dummy nme)))
| PRPack_or_models nsl -> Packed nsl
in
let (get_remaining_source_list : maybe_packed -> string -> maybe_packed) =
fun acc infile ->
match acc, get_one_source infile 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
let pack_list =
assert (infile_list <> []);
List.fold_left
get_remaining_source_list
(get_one_source (List.hd infile_list))
(List.tl infile_list)
in
match pack_list with
| Packed l -> l
| Unpacked pack -> [pack]
let my_exit i =
close_out !Global.oc;
if Sys.file_exists _lus2lic_ARGS.outfile then Sys.remove _lus2lic_ARGS.outfile;
exit i
let main = (
(* Compile.init_appli () ; *)
parse_args () ;
if (_lus2lic_ARGS.infiles = []) then (
Arg.usage arg_list usage_msg ;
exit 1
) ;
try (
let nsl = get_source_list _lus2lic_ARGS.infiles in
let main_node = Ident.idref_of_string _lus2lic_ARGS.main_node in
if _lus2lic_ARGS.outfile <> "" then
Global.oc := open_out _lus2lic_ARGS.outfile;
Compile.doit nsl main_node;
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 _lus2lic_ARGS.infiles > 1 then "s " else " ") ^
(String.concat ", " _lus2lic_ARGS.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 *)
(* ) *)
)