Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / compiler_common.ml @ 53206908

History | View | Annotate | Download (8.75 KB)

1
(********************************************************************)
2
(*                                                                  *)
3
(*  The LustreC compiler toolset   /  The LustreC Development Team  *)
4
(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)
5
(*                                                                  *)
6
(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)
7
(*  under the terms of the GNU Lesser General Public License        *)
8
(*  version 2.1.                                                    *)
9
(*                                                                  *)
10
(********************************************************************)
11

    
12
open Utils
13
open Format 
14
open LustreSpec
15
open Corelang
16

    
17
let check_main () =
18
  if !Options.main_node = "" then
19
    begin
20
      eprintf "Code generation error: %a@." pp_error No_main_specified;
21
      raise (Error (Location.dummy_loc, No_main_specified))
22
    end
23

    
24
let create_dest_dir () =
25
  begin
26
    if not (Sys.file_exists !Options.dest_dir) then
27
      begin
28
	Log.report ~level:1 (fun fmt -> fprintf fmt ".. creating destination directory@,");
29
	Unix.mkdir !Options.dest_dir (Unix.stat ".").Unix.st_perm
30
      end;
31
    if (Unix.stat !Options.dest_dir).Unix.st_kind <> Unix.S_DIR then
32
      begin
33
	eprintf "Failure: destination %s is not a directory.@.@." !Options.dest_dir;
34
	exit 1
35
      end
36
  end
37

    
38
(* Loading Lusi file and filling type tables with parsed
39
   functions/nodes *)
40
let parse_header own filename =
41
  Location.set_input filename;
42
  let h_in = open_in filename in
43
  let lexbuf = Lexing.from_channel h_in in
44
  Location.init lexbuf filename;
45
  (* Parsing *)
46
  Log.report ~level:1 (fun fmt -> fprintf fmt ".. parsing header file %s@ " filename);
47
    try
48
      let header = Parse.header Parser_lustre.header Lexer_lustre.token lexbuf in
49
      (*ignore (Modules.load_header ISet.empty header);*)
50
      close_in h_in;
51
      header
52
    with
53
    | (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
54
      Parse.report_error err;
55
      raise exc
56
    | Corelang.Error (loc, err) as exc -> (
57
      eprintf "Parsing error: %a%a@."
58
	Corelang.pp_error err
59
	Location.pp_loc loc;
60
      raise exc
61
    )
62

    
63
let parse_source source_name =
64
  (* Loading the input file *)
65
  Location.set_input source_name;
66
  let s_in = open_in source_name in
67
  let lexbuf = Lexing.from_channel s_in in
68
  Location.init lexbuf source_name;
69

    
70
  (* Parsing *)
71
  Log.report ~level:1 
72
    (fun fmt -> fprintf fmt ".. parsing source file %s@," source_name);
73
  try
74
    let prog = Parse.prog Parser_lustre.prog Lexer_lustre.token lexbuf in
75
    (*ignore (Modules.load_program ISet.empty prog);*)
76
    close_in s_in;
77
    prog
78
  with
79
  | (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
80
    Parse.report_error err;
81
    raise exc
82
  | Corelang.Error (loc, err) as exc ->
83
    eprintf "Parsing error: %a%a@."
84
      Corelang.pp_error err
85
      Location.pp_loc loc;
86
    raise exc
87

    
88
let check_stateless_decls decls =
89
  Log.report ~level:1 (fun fmt -> fprintf fmt ".. checking stateless/stateful status@ ");
90
  try
91
    Stateless.check_prog decls
92
  with (Stateless.Error (loc, err)) as exc ->
93
    eprintf "Stateless status error: %a%a@."
94
      Stateless.pp_error err
95
      Location.pp_loc loc;
96
    raise exc
97

    
98
let force_stateful_decls decls =
99
  Log.report ~level:1 (fun fmt -> fprintf fmt ".. forcing stateful status@ ");
100
  try
101
    Stateless.force_prog decls
102
  with (Stateless.Error (loc, err)) as exc ->
103
    eprintf "Stateless status error: %a%a@."
104
      Stateless.pp_error err
105
      Location.pp_loc loc;
106
    raise exc
107

    
108
let type_decls env decls =  
109
  Log.report ~level:1 (fun fmt -> fprintf fmt ".. typing@ ");
110
  let new_env = 
111
    begin
112
      try
113
	Typing.type_prog env decls
114
      with (Types.Error (loc,err)) as exc ->
115
	eprintf "Typing error: %a%a@."
116
	  Types.pp_error err
117
	  Location.pp_loc loc;
118
	raise exc
119
    end 
120
  in
121
  if !Options.print_types then
122
    Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>  %a@]@ " Corelang.pp_prog_type decls);
123
  new_env
124
      
125
let clock_decls env decls = 
126
  Log.report ~level:1 (fun fmt -> fprintf fmt ".. clock calculus@ ");
127
  let new_env =
128
    begin
129
      try
130
	Clock_calculus.clock_prog env decls
131
      with (Clocks.Error (loc,err)) as exc ->
132
	eprintf "Clock calculus error: %a%a@." Clocks.pp_error err Location.pp_loc loc;
133
	raise exc
134
    end
135
  in
136
  if !Options.print_clocks then
137
    Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>  %a@]@ " Corelang.pp_prog_clock decls);
138
  new_env
139

    
140
let check_top_decls header =
141
  let new_tenv = type_decls Basic_library.type_env header in   (* Typing *)
142
  let new_cenv = clock_decls Basic_library.clock_env header in   (* Clock calculus *)
143
  header, new_tenv, new_cenv
144

    
145
let get_envs_from_const const_decl (ty_env, ck_env) =
146
  (Env.add_value ty_env const_decl.const_id const_decl.const_type,
147
   Env.add_value ck_env const_decl.const_id (Clocks.new_var true))
148

    
149
let get_envs_from_consts const_decls (ty_env, ck_env) =
150
  List.fold_right get_envs_from_const const_decls (ty_env, ck_env)
151

    
152
let rec get_envs_from_top_decl (ty_env, ck_env) top_decl =
153
 match top_decl.top_decl_desc with
154
 | Node nd          -> (Env.add_value ty_env nd.node_id nd.node_type,
155
			Env.add_value ck_env nd.node_id nd.node_clock)
156
 | ImportedNode ind -> (Env.add_value ty_env ind.nodei_id ind.nodei_type,
157
			Env.add_value ck_env ind.nodei_id ind.nodei_clock)
158
 | Const c          -> get_envs_from_const c (ty_env, ck_env)
159
 | TypeDef _        -> List.fold_left get_envs_from_top_decl (ty_env, ck_env) (consts_of_enum_type top_decl)
160
 | Open _           -> (ty_env, ck_env)
161

    
162
(* get type and clock environments from a header *)
163
let get_envs_from_top_decls header =
164
  List.fold_left get_envs_from_top_decl (Env.initial, Env.initial) header
165

    
166
(*
167
 List.fold_right
168
   (fun top_decl (ty_env, ck_env) ->
169
     match top_decl.top_decl_desc with
170
     | Node nd          -> (Env.add_value ty_env nd.node_id nd.node_type,
171
			    Env.add_value ck_env nd.node_id nd.node_clock)
172
     | ImportedNode ind -> (Env.add_value ty_env ind.nodei_id ind.nodei_type,
173
			    Env.add_value ck_env ind.nodei_id ind.nodei_clock)
174
     | Const c          -> get_envs_from_const c (ty_env, ck_env)
175
     | TypeDef _        -> List.fold_left (fun envs top -> consts_of_enum_type top_decl
176
     | Open _           -> (ty_env, ck_env))
177
   header
178
   (Env.initial, Env.initial)
179
 *)
180

    
181
let check_compatibility (prog, computed_types_env, computed_clocks_env) (header, declared_types_env, declared_clocks_env) =
182
  try
183
    (* checking defined types are compatible with declared types*)
184
    Typing.check_typedef_compat header;
185

    
186
    (* checking type compatibility with computed types*)
187
    Typing.check_env_compat header declared_types_env computed_types_env;
188

    
189
    (* checking clocks compatibility with computed clocks*)
190
    Clock_calculus.check_env_compat header declared_clocks_env computed_clocks_env;
191

    
192
    (* checking stateless status compatibility *)
193
    Stateless.check_compat header
194
  with
195
  | (Types.Error (loc,err)) as exc ->
196
    eprintf "Type mismatch between computed type and declared type in lustre interface file: %a%a@."
197
      Types.pp_error err
198
      Location.pp_loc loc;
199
    raise exc
200
  | Clocks.Error (loc, err) as exc ->
201
    eprintf "Clock mismatch between computed clock and declared clock in lustre interface file: %a%a@."
202
      Clocks.pp_error err
203
      Location.pp_loc loc;
204
    raise exc
205
  | Stateless.Error (loc, err) as exc ->
206
    eprintf "Stateless status mismatch between defined status and declared status in lustre interface file: %a%a@."
207
      Stateless.pp_error err
208
      Location.pp_loc loc;
209
    raise exc
210

    
211
let is_stateful topdecl =
212
  match topdecl.top_decl_desc with
213
  | Node nd -> (match nd.node_stateless with Some b -> not b | None -> not nd.node_dec_stateless)
214
  | ImportedNode nd -> not nd.nodei_stateless 
215
  | _ -> false
216

    
217

    
218
let import_dependencies prog =
219
  Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>.. extracting dependencies@,");
220
  let dependencies = Corelang.get_dependencies prog in
221
  let deps =
222
  List.fold_left
223
    (fun (compilation_dep, type_env, clock_env) dep ->
224
      let (local, s) = Corelang.dependency_of_top dep in
225
      let basename = Modules.name_dependency (local, s) in
226
      Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@[<v 0>Library %s@," basename);
227
      let lusic = Modules.import_dependency dep.top_decl_loc (local, s) in
228
      Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@]@ ");
229
      let (lusi_type_env, lusi_clock_env) = get_envs_from_top_decls lusic.Lusic.contents in
230
      let is_stateful = List.exists is_stateful lusic.Lusic.contents in
231
      let new_dep = Dep (local, s, lusic.Lusic.contents, is_stateful ) in
232
      new_dep::compilation_dep,
233
      Env.overwrite type_env lusi_type_env,
234
      Env.overwrite clock_env lusi_clock_env)
235
    ([], Basic_library.type_env, Basic_library.clock_env)
236
    dependencies in
237
  begin
238
    Log.report ~level:1 (fun fmt -> fprintf fmt "@]@ ");
239
    deps
240
  end
241