diff --git a/src/checks/stateless.ml b/src/checks/stateless.ml
index e58bb639d7b5f40fbdaec54b5938ed04cc699348..5972ce8476e6f861f0cf72b732387615d0b39382 100644
--- a/src/checks/stateless.ml
+++ b/src/checks/stateless.ml
@@ -34,8 +34,16 @@ let rec check_expr expr =
| Expr_when (e', i, l)-> check_expr e'
| Expr_merge (i, hl) -> List.for_all (fun (t, h) -> check_expr h) hl
| Expr_appl (i, e', i') ->
- check_expr e' &&
- (Basic_library.is_stateless_fun i || check_node (node_from_name i))
+ check_expr e' &&
+ (Basic_library.is_stateless_fun i || (
+ try
+ check_node (node_from_name i)
+ with Not_found ->
+ let loc = expr.expr_loc in
+ Error.pp_error loc (fun fmt -> Format.fprintf fmt "Unable to find node %s in expression %a" i Printers.pp_expr expr);
+ raise (Corelang.Error (loc, Error.Unbound_symbol i))
+ ))
+
and compute_node nd = (* returns true iff the node is stateless.*)
let eqs, aut = get_node_eqs nd in
aut = [] && (* A node containinig an automaton will be stateful *)
diff --git a/src/corelang.ml b/src/corelang.ml
index 1a9a8174b30190decc780ee8647336f0a90eba7d..20b338c926febe35abeb0341af0e7207d2ea1ad2 100644
--- a/src/corelang.ml
+++ b/src/corelang.ml
@@ -314,9 +314,7 @@ let node_inputs td =
let node_from_name id =
Hashtbl.find node_table id
- (* with Not_found -> (Format.eprintf "Unable to find any node named %s@ @?" id;
- * assert false) *)
-
+
let update_node id top =
Hashtbl.replace node_table id top
diff --git a/src/location.ml b/src/location.ml
index 3292e690d9caf28322b545b27fb6a2639dc30b52..8c32603cd213c36b9c557af12535c8b1e8c17d46 100644
--- a/src/location.ml
+++ b/src/location.ml
@@ -36,23 +36,20 @@ let init lexbuf fname =
}
let shift_pos pos1 pos2 =
- assert (pos1.Lexing.pos_fname = pos2.Lexing.pos_fname);
+ (* Format.eprintf "Shift pos %s by pos %s@." pos1.Lexing.pos_fname pos2.Lexing.pos_fname;
+ * assert (pos1.Lexing.pos_fname = pos2.Lexing.pos_fname); *)
{Lexing.pos_fname = pos1.Lexing.pos_fname;
- Lexing.pos_lnum = pos1.Lexing.pos_lnum + pos2.Lexing.pos_lnum;
+ Lexing.pos_lnum = pos1.Lexing.pos_lnum + pos2.Lexing.pos_lnum -1;
+
+ (* New try *)
+ Lexing.pos_bol = pos2.Lexing.pos_bol;
+ Lexing.pos_cnum = pos2.Lexing.pos_cnum;
+ (*
Lexing.pos_bol = pos1.Lexing.pos_bol + pos2.Lexing.pos_bol;
Lexing.pos_cnum =if pos2.Lexing.pos_lnum = 1 then pos1.Lexing.pos_cnum + pos2.Lexing.pos_cnum else pos2.Lexing.pos_cnum
- }
+ *)
+}
-let shift loc1 loc2 =
- {loc_start = shift_pos loc1.loc_start loc2.loc_start;
- loc_end = shift_pos loc1.loc_start loc2.loc_end
- }
-
-let symbol_rloc () =
- {
- loc_start = Parsing.symbol_start_pos ();
- loc_end = Parsing.symbol_end_pos ()
- }
open Format
@@ -93,13 +90,57 @@ let pp_loc fmt loc =
let (start_char, end_char) =
if start_char < 0 then (0,1) else (start_char, end_char)
in
- Format.fprintf fmt "File \"%s\", line %i, characters %i-%i:" filename line start_char end_char
+ Format.fprintf fmt "File \"%s\", line %i, characters %i-%i:" filename line start_char end_char;
+ (* Format.fprintf fmt "@.loc1=(%i,%i,%i) loc2=(%i,%i,%i)@."
+ * loc.loc_start.Lexing.pos_lnum
+ * loc.loc_start.Lexing.pos_bol
+ * loc.loc_start.Lexing.pos_cnum
+ * loc.loc_end.Lexing.pos_lnum
+ * loc.loc_end.Lexing.pos_bol
+ * loc.loc_end.Lexing.pos_cnum;
+ * () *)
+ ()
+
let pp_c_loc fmt loc =
let filename = loc.loc_start.Lexing.pos_fname in
let line = loc.loc_start.Lexing.pos_lnum in
Format.fprintf fmt "#line %i \"%s\"" line filename
-(* Local Variables: *)
-(* compile-command:"make -C .." *)
-(* End: *)
+let shift loc1 loc2 =
+ let new_loc =
+ {loc_start = shift_pos loc1.loc_start loc2.loc_start;
+ loc_end = shift_pos loc1.loc_start loc2.loc_end
+ }
+ in
+ (* Format.eprintf "loc1: %a@.loc2: %a@.nloc: %a@."
+ * pp_loc loc1
+ * pp_loc loc2
+ * pp_loc new_loc
+ * ; *)
+ new_loc
+
+let loc_pile = ref []
+let push_loc l =
+ loc_pile := l::!loc_pile
+let pop_loc () = loc_pile := List.tl !loc_pile
+
+let symbol_rloc () =
+ let curr_loc =
+ {
+ loc_start = Parsing.symbol_start_pos ();
+ loc_end = Parsing.symbol_end_pos ()
+ }
+ in
+
+ let res =
+ if List.length !loc_pile > 0 then
+ shift (List.hd !loc_pile) curr_loc
+ else
+ curr_loc
+ in
+ (* Format.eprintf "Loc: %a@." pp_loc res; *)
+ res
+ (* Local Variables: *)
+ (* compile-command:"make -C .." *)
+ (* End: *)
diff --git a/src/main_lustre_compiler.ml b/src/main_lustre_compiler.ml
index 41e645a4a4a6f7985a25add4df0637ee6d54c8f7..231ac3ce6e5e4897502498d36a4a99d2b775bb1b 100644
--- a/src/main_lustre_compiler.ml
+++ b/src/main_lustre_compiler.ml
@@ -140,7 +140,9 @@ let _ =
with
| Parse.Error _
| Types.Error (_,_) | Clocks.Error (_,_) -> exit 1
- | Corelang.Error (_ (* loc *), kind) (*| Task_set.Error _*) -> exit (Error.return_code kind)
+ | Corelang.Error (loc , kind) (*| Task_set.Error _*) ->
+ Error.pp_error loc (fun fmt -> Error.pp_error_msg fmt kind);
+ exit (Error.return_code kind)
(* | Causality.Error _ -> exit (Error.return_code Error.AlgebraicLoop) *)
| Sys_error msg -> (eprintf "Failure: %s@." msg); exit 1
| exc -> (track_exception (); raise exc)
diff --git a/src/modules.ml b/src/modules.ml
index 949f8d755d6e06a727a785697bb54edc8dba6f5d..c170bbace9c3f17b659ece0a3ee346f7541e63d7 100644
--- a/src/modules.ml
+++ b/src/modules.ml
@@ -13,6 +13,14 @@ open Utils
open Lustre_types
open Corelang
+let name_dependency loc (local, dep) ext =
+ try
+ Options_management.name_dependency (local, dep) ext
+ with Not_found ->
+ (* Error.pp_error loc (fun fmt -> Format.fprintf fmt "Unknown library %s" dep); *)
+ raise (Error (loc, Error.Unknown_library dep))
+
+
let add_symbol loc msg hashtbl name value =
if Hashtbl.mem hashtbl name
then raise (Error (loc, Error.Already_bound_symbol msg))
@@ -141,13 +149,13 @@ let get_lusic decl =
| Open (local, dep) -> (
let loc = decl.top_decl_loc in
let extension = ".lusic" in
- let basename = Options_management.name_dependency (local, dep) extension in
+ let basename = name_dependency loc (local, dep) extension in
try
let lusic = Lusic.read_lusic basename extension in
Lusic.check_obsolete lusic basename;
lusic
with
- | Sys_error msg ->
+ | Sys_error _ ->
raise (Error (loc, Error.Unknown_library basename))
)
| _ -> assert false (* should not happen *)
@@ -180,77 +188,84 @@ let get_envs_from_top_decls header =
| ImportedNode nd -> not nd.nodei_stateless
| _ -> false
-let rec load_rec ~is_header accu program =
- List.fold_left (fun ((accu_prog, accu_dep, typ_env, clk_env) as accu) decl ->
- (* Precompute the updated envs, will not be used in the Open case *)
- let typ_env', clk_env' = get_envs_from_top_decl (typ_env, clk_env) decl in
- match decl.top_decl_desc with
- | Open (local, dep) ->
- (* loading the dep *)
- let basename = Options_management.name_dependency (local, dep) ".lusic" in
- if List.exists
- (fun dep -> basename = Options_management.name_dependency (dep.local, dep.name) ".lusic")
- accu_dep
- then
- (* Library already imported. Just skip *)
- accu
- else (
- Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@ .. Library %s@ " basename);
- let lusic = get_lusic decl in
- (* Recursive call with accumulator on lusic *)
- let (accu_prog, accu_dep, typ_env, clk_env) =
- load_rec ~is_header:true accu lusic.Lusic.contents in
- (* Building the dep *)
- let is_stateful = List.exists is_stateful lusic.Lusic.contents in
- let new_dep = { local = local;
- name = dep;
- content = lusic.Lusic.contents;
- is_stateful = is_stateful } in
-
- (* Returning the prog while keeping the Open, the deps with the new
+ let rec load_rec ~is_header accu program =
+ List.fold_left (fun ((accu_prog, accu_dep, typ_env, clk_env) as accu) decl ->
+ (* Precompute the updated envs, will not be used in the Open case *)
+ let typ_env', clk_env' = get_envs_from_top_decl (typ_env, clk_env) decl in
+ match decl.top_decl_desc with
+ | Open (local, dep) -> (
+ (* loading the dep *)
+ try
+ let basename = name_dependency decl.top_decl_loc (local, dep) ".lusic" in
+ if List.exists
+ (fun dep -> basename = name_dependency decl.top_decl_loc (dep.local, dep.name) ".lusic")
+ accu_dep
+ then
+ (* Library already imported. Just skip *)
+ accu
+ else (
+ Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@ .. Library %s@ " basename);
+ let lusic = get_lusic decl in
+ (* Recursive call with accumulator on lusic *)
+ let (accu_prog, accu_dep, typ_env, clk_env) =
+ load_rec ~is_header:true accu lusic.Lusic.contents in
+ (* Building the dep *)
+ let is_stateful = List.exists is_stateful lusic.Lusic.contents in
+ let new_dep = { local = local;
+ name = dep;
+ content = lusic.Lusic.contents;
+ is_stateful = is_stateful } in
+
+ (* Returning the prog while keeping the Open, the deps with the new
elements and the updated envs *)
- decl::accu_prog, (new_dep::accu_dep), typ_env, clk_env
- )
- | Include name ->
- let basename = Options_management.name_dependency (true, name) "" in
- if Filename.check_suffix basename ".lus" then
- let include_src = Compiler_common.parse basename ".lus" in
- let (accu_prog, accu_dep, typ_env, clk_env) =
- load_rec ~is_header:false accu include_src
- in
- decl::accu_prog, accu_dep, typ_env, clk_env
- else
- raise (Error (decl.top_decl_loc, LoadError("include requires a lustre file")))
-
- | Node nd ->
- if is_header then
- raise (Error(decl.top_decl_loc,
- LoadError ("node " ^ nd.node_id ^ " declared in a header file")))
- else (
- (* Registering node *)
- add_node nd.node_id decl;
- (* Updating the type/clock env *)
- decl::accu_prog, accu_dep, typ_env', clk_env'
- )
-
- | ImportedNode ind ->
- if is_header then (
- add_imported_node ind.nodei_id decl;
- decl::accu_prog, accu_dep, typ_env', clk_env'
- )
- else
- raise (Error(decl.top_decl_loc,
- LoadError ("imported node " ^ ind.nodei_id ^
- " declared in a regular Lustre file")))
- | Const c -> (
- add_const is_header c.const_id decl;
- decl::accu_prog, accu_dep, typ_env', clk_env'
- )
- | TypeDef tdef -> (
- add_type is_header tdef.tydef_id decl;
- decl::accu_prog, accu_dep, typ_env', clk_env'
- )
- ) accu program
+ decl::accu_prog, (new_dep::accu_dep), typ_env, clk_env
+ )
+ with
+ | Not_found ->
+ let loc = decl.top_decl_loc in
+ Error.pp_error loc (fun fmt -> Format.fprintf fmt "Unknown library %s" dep);
+ raise (Error (loc, Error.Unknown_library dep (*basename*)))
+ )
+ | Include name ->
+ let basename = name_dependency decl.top_decl_loc (true, name) "" in
+ if Filename.check_suffix basename ".lus" then
+ let include_src = Compiler_common.parse basename ".lus" in
+ let (accu_prog, accu_dep, typ_env, clk_env) =
+ load_rec ~is_header:false accu include_src
+ in
+ decl::accu_prog, accu_dep, typ_env, clk_env
+ else
+ raise (Error (decl.top_decl_loc, LoadError("include requires a lustre file")))
+
+ | Node nd ->
+ if is_header then
+ raise (Error(decl.top_decl_loc,
+ LoadError ("node " ^ nd.node_id ^ " declared in a header file")))
+ else (
+ (* Registering node *)
+ add_node nd.node_id decl;
+ (* Updating the type/clock env *)
+ decl::accu_prog, accu_dep, typ_env', clk_env'
+ )
+
+ | ImportedNode ind ->
+ if is_header then (
+ add_imported_node ind.nodei_id decl;
+ decl::accu_prog, accu_dep, typ_env', clk_env'
+ )
+ else
+ raise (Error(decl.top_decl_loc,
+ LoadError ("imported node " ^ ind.nodei_id ^
+ " declared in a regular Lustre file")))
+ | Const c -> (
+ add_const is_header c.const_id decl;
+ decl::accu_prog, accu_dep, typ_env', clk_env'
+ )
+ | TypeDef tdef -> (
+ add_type is_header tdef.tydef_id decl;
+ decl::accu_prog, accu_dep, typ_env', clk_env'
+ )
+ ) accu program
(* Iterates through lusi definitions and records them in the hashtbl. Open instructions are evaluated and update these hashtbl as well. node_table/type/table/consts_table *)
let load ~is_header program =
@@ -267,8 +282,11 @@ let load ~is_header program =
List.rev prog, List.rev deps, (typ_env, clk_env)
with
Corelang.Error (loc, err) as exc -> (
- Format.eprintf "Import error: %a%a@."
+ (* Format.eprintf "Import error: %a%a@."
+ * Error.pp_error_msg err
+ * Location.pp_loc loc; *)
+ Format.eprintf "Import error: %a@."
Error.pp_error_msg err
- Location.pp_loc loc;
+ ;
raise exc
);;
diff --git a/src/options_management.ml b/src/options_management.ml
index b49e0999048edd628b82b4b1f450ce5bb2f356ae..480fbb29189af28d97517133419a951f62c2465d 100644
--- a/src/options_management.ml
+++ b/src/options_management.ml
@@ -51,7 +51,9 @@ let search_lib_path (local, full_file_name) =
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
+ | 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 *)
diff --git a/src/parsers/lexer_lustre.mll b/src/parsers/lexer_lustre.mll
index 24f130714269d998af3a557069a6f1f147e49382..d842911aa52d563a4989529d27d6ac3d36df09db 100644
--- a/src/parsers/lexer_lustre.mll
+++ b/src/parsers/lexer_lustre.mll
@@ -81,17 +81,23 @@ let keyword_table =
(* Buffer for parsing specification/annotation *)
let buf = Buffer.create 1024
-let make_annot lexbuf s =
+let make_annot lexbuf s =
+ let orig_loc = Location.curr lexbuf in
try
+ Location.push_loc orig_loc;
let ann = LexerLustreSpec.annot s in
+ Location.pop_loc ();
ANNOT ann
- with LexerLustreSpec.Error loc -> raise (Parse.Error (Location.shift (Location.curr lexbuf) loc, Parse.Annot_error s))
+ with LexerLustreSpec.Error loc -> raise (Parse.Error (Location.shift orig_loc loc, Parse.Annot_error s))
-let make_spec lexbuf s =
+let make_spec orig_loc lexbuf s =
+ Format.eprintf "make spec loc %a" Location.pp_loc orig_loc;
try
+ Location.push_loc orig_loc;
let ns = LexerLustreSpec.spec s in
+ Location.pop_loc ();
NODESPEC ns
- with LexerLustreSpec.Error loc -> raise (Parse.Error (Location.shift (Location.curr lexbuf) loc, Parse.Node_spec_error s))
+ with LexerLustreSpec.Error loc -> raise (Parse.Error (Location.shift orig_loc loc, Parse.Node_spec_error s))
}
@@ -101,9 +107,11 @@ let blank = [' ' '\009' '\012']
rule token = parse
| "--@" { Buffer.clear buf;
- spec_singleline lexbuf }
+ let loc = Location.curr lexbuf in
+ spec_singleline loc lexbuf }
| "(*@" { Buffer.clear buf;
- spec_multiline 0 lexbuf }
+ let loc = Location.curr lexbuf in
+ spec_multiline loc 0 lexbuf }
| "--!" { Buffer.clear buf;
annot_singleline lexbuf }
| "(*!" { Buffer.clear buf;
@@ -200,18 +208,18 @@ and annot_multiline n = parse
| newline as s { incr_line lexbuf; Buffer.add_string buf s; annot_multiline n lexbuf }
| _ as c { Buffer.add_char buf c; annot_multiline n lexbuf }
-and spec_singleline = parse
- | eof { make_spec lexbuf (Buffer.contents buf) }
- | newline { incr_line lexbuf; make_spec lexbuf (Buffer.contents buf) }
- | _ as c { Buffer.add_char buf c; spec_singleline lexbuf }
+and spec_singleline loc = parse
+ | eof { make_spec loc lexbuf (Buffer.contents buf) }
+ | newline { incr_line lexbuf; make_spec loc lexbuf (Buffer.contents buf) }
+ | _ as c { Buffer.add_char buf c; spec_singleline loc lexbuf }
-and spec_multiline n = parse
+and spec_multiline loc n = parse
| eof { raise (Parse.Error (Location.curr lexbuf, Parse.Unfinished_node_spec)) }
| "*)" as s { if n > 0 then
- (Buffer.add_string buf s; spec_multiline (n-1) lexbuf)
+ (Buffer.add_string buf s; spec_multiline loc (n-1) lexbuf)
else
- make_spec lexbuf (Buffer.contents buf) }
- | "(*" as s { Buffer.add_string buf s; spec_multiline (n+1) lexbuf }
- | newline as s { incr_line lexbuf; Buffer.add_string buf s; spec_multiline n lexbuf }
- | _ as c { Buffer.add_char buf c; spec_multiline n lexbuf }
+ make_spec loc lexbuf (Buffer.contents buf) }
+ | "(*" as s { Buffer.add_string buf s; spec_multiline loc (n+1) lexbuf }
+ | newline as s { incr_line lexbuf; Buffer.add_string buf s; spec_multiline loc n lexbuf }
+ | _ as c { Buffer.add_char buf c; spec_multiline loc n lexbuf }
diff --git a/src/parsers/parser_lustre.mly b/src/parsers/parser_lustre.mly
index a5caaa928afd36ae8cedb3672df07991cb955b16..d526d17f79cccabe86ee91d5178d3e87aa2afafe 100644
--- a/src/parsers/parser_lustre.mly
+++ b/src/parsers/parser_lustre.mly
@@ -16,6 +16,7 @@ open Corelang
open Dimension
open Parse
+
let get_loc () = Location.symbol_rloc ()
let mkident x = x, get_loc ()
@@ -705,7 +706,7 @@ cdecl:
(fun itf ->
let c = mktop_decl itf (Const {
const_id = $1;
- const_loc = Location.symbol_rloc ();
+ const_loc = get_loc ();
const_type = Types.new_var ();
const_value = $3})
in