From 744aabf04adbc26baec01ac446217a804abda08d Mon Sep 17 00:00:00 2001
From: Erwan Jahier <jahier@imag.fr>
Date: Fri, 9 Apr 2010 14:03:03 +0200
Subject: [PATCH] Remove the limitation where we prevented several files to be
unpackaged. This is useful to be able to compile V4 program that uses
include.
---
src/main.ml | 114 ++++++++++++++++++++++++++++------------------
src/syntaxTree.ml | 6 +--
2 files changed, 72 insertions(+), 48 deletions(-)
diff --git a/src/main.ml b/src/main.ml
index 5d372851..44c73618 100644
--- a/src/main.ml
+++ b/src/main.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 08/04/2010 (at 16:57) by Erwan Jahier> *)
+(** Time-stamp: <modified the 09/04/2010 (at 13:44) by Erwan Jahier> *)
(** Here follows a description of the different modules used by this lus2lic compiler.
@@ -198,66 +198,90 @@ let lus_load lexbuf =
SolveIdent.recognize_predef_op tree
- (*
- 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
+ | Packed of SyntaxTree.pack_or_model
+ | Unpacked of SyntaxTree.packbody
let (get_source_list : string list -> SyntaxTree.pack_or_model list) =
fun infile_list ->
- let (get_one_source : string -> string list * maybe_packed) =
+ let (get_one_source : string -> string list * maybe_packed list) =
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
+ | PRPackBody(incl_files, pbdy) -> incl_files, [Unpacked pbdy]
+ | PRPack_or_models(incl_files, nsl) -> incl_files, (List.map (fun ns -> Packed ns) 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) ->
+ let rec (get_remaining_source_list : maybe_packed list * string list * string list ->
+ maybe_packed list * string list * string list) =
+ fun (pack_acc, compiled, to_be_compiled) ->
match to_be_compiled with
- | [] -> (maybe_pack, compiled, [])
+ | [] -> (pack_acc, 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 (pack_acc, compiled, tail)
+ else
+ let included_files, pack = get_one_source infile in
+ let new_pack_acc = pack_acc@pack in
get_remaining_source_list(
- new_maybe_pack,
+ new_pack_acc,
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)
+ let (pack_list, _compiled_files, included_files) =
+ 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 _ = assert (included_files=[]) in
+ let packed_list, unpacked_list =
+ List.fold_left
+ (fun (pl, upl) p ->
+ match p with
+ | Packed p -> p::pl, upl
+ | Unpacked up -> pl, up::upl
+ )
+ ([], [])
+ pack_list
+ in
+ let unpacked_merged_opt = (* All unpacked files are merged into one single package *)
+ List.fold_left
+ (fun acc pbody ->
+ match acc with
+ | None -> Some pbody
+ | Some pbody_acc ->
+ let add tbl x y =
+ (* Let's perform some clashes checks *)
+ if Hashtbl.mem tbl x then
+ let ybis = Hashtbl.find tbl x in
+ print_string ("*** Error: "^(Ident.to_string x)^" is defined twice: \n\t" ^
+ (Lxm.details y.src) ^ "\n\t" ^
+ (Lxm.details ybis.src) ^ ".\n");
+ exit 2
+ else
+ Hashtbl.add tbl x y
+ in
+ Hashtbl.iter (fun x y -> add pbody_acc.pk_const_table x y) pbody.pk_const_table;
+ Hashtbl.iter (fun x y -> add pbody_acc.pk_type_table x y) pbody.pk_type_table;
+ Hashtbl.iter (fun x y -> add pbody_acc.pk_node_table x y) pbody.pk_node_table;
+ Some { pbody_acc with
+ pk_def_list=pbody_acc.pk_def_list@pbody.pk_def_list;
+ }
+ )
+ None
+ unpacked_list
+ in
+ match unpacked_merged_opt with
+ | None -> packed_list
+ | Some unpacked_merged ->
+ let name =
+ try Filename.chop_extension (Filename.basename first_file)
+ with _ ->
+ print_string ("*** '"^first_file^"': bad file name.\n"); exit 1
+ in
+ let pi = SyntaxTree.give_pack_this_name (Ident.pack_name_of_string name) unpacked_merged in
+ let p = NSPack (Lxm.flagit pi (Lxm.dummy name)) in
+ p::packed_list
+
let dump_entete oc =
let time = Unix.localtime (Unix.time ()) in
@@ -342,12 +366,12 @@ let main = (
my_exit 1
| Assert_failure (file, line, col) ->
prerr_string (
- "\n*** oops: an internal error (lus2lic) occurred in file "^ file ^
+ "\n*** oops: an internal error (lus2lic) 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"^
- "\n*** You migth want to sent a bug report to jahier@imag.fr\n") ;
+ "\n*** You migth want to sent a bug report to jahier@imag.fr\n") ;
my_exit 2
(* | Compile_node_error(nkey,lxm,msg) -> ( *)
diff --git a/src/syntaxTree.ml b/src/syntaxTree.ml
index 40702f8b..176097ce 100644
--- a/src/syntaxTree.ml
+++ b/src/syntaxTree.ml
@@ -1,4 +1,4 @@
-(** Time-stamp: <modified the 22/01/2010 (at 14:30) by Erwan Jahier> *)
+(** Time-stamp: <modified the 09/04/2010 (at 09:59) by Erwan Jahier> *)
(** (Raw) Abstract syntax tree of source programs.
@@ -75,9 +75,9 @@ and
(**********************************************
Utilitaires pour fabriquer des packages
**********************************************)
-let give_pack_this_name nme pbdy = (
+let give_pack_this_name name pbdy = (
{
- pa_name = nme;
+ pa_name = name;
pa_def = PackGiven {
pg_uses = [];
pg_provides = None;
--
GitLab