Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / compiler_common.ml @ e8250987

History | View | Annotate | Download (6.88 KB)

1 ef34b4ae xthirioux
(********************************************************************)
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 8446bf03 ploc
open Lustre_types
15 ef34b4ae xthirioux
open Corelang
16
17 04a63d25 xthirioux
let check_main () =
18
  if !Options.main_node = "" then
19
    begin
20 e7cc5186 ploc
      eprintf "Code generation error: %a@." Error.pp_error_msg Error.No_main_specified;
21
      raise (Error (Location.dummy_loc, Error.No_main_specified))
22 04a63d25 xthirioux
    end
23
24 ef34b4ae xthirioux
let create_dest_dir () =
25
  begin
26
    if not (Sys.file_exists !Options.dest_dir) then
27
      begin
28 521e2a6b ploc
	Log.report ~level:1 (fun fmt -> fprintf fmt ".. creating destination directory@ ");
29 ef34b4ae xthirioux
	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 217837e2 ploc
(* Loading Lus/Lusi file and filling type tables with parsed
39 ef34b4ae xthirioux
   functions/nodes *)
40 217837e2 ploc
let parse filename extension =
41 ef34b4ae xthirioux
  Location.set_input filename;
42 217837e2 ploc
  let f_in = open_in filename in
43
  let lexbuf = Lexing.from_channel f_in in
44 ef34b4ae xthirioux
  Location.init lexbuf filename;
45
  (* Parsing *)
46 217837e2 ploc
  let prog = 
47 ef34b4ae xthirioux
    try
48 217837e2 ploc
      match extension with
49
        ".lusi" ->
50
        Log.report ~level:1
51
          (fun fmt -> fprintf fmt ".. parsing header file %s@ " filename);
52
        Parse.header Parser_lustre.header Lexer_lustre.token lexbuf 
53
      | ".lus" ->
54
         Log.report ~level:1 
55
           (fun fmt -> fprintf fmt ".. parsing source file %s@ " filename);
56
         Parse.prog Parser_lustre.prog Lexer_lustre.token lexbuf
57
      | _ -> assert false
58 ef34b4ae xthirioux
    with
59 04a63d25 xthirioux
    | (Parse.Error err) as exc -> 
60 217837e2 ploc
       Parse.report_error err;
61
       raise exc
62 ef34b4ae xthirioux
    | Corelang.Error (loc, err) as exc -> (
63
      eprintf "Parsing error: %a%a@."
64 217837e2 ploc
        Error.pp_error_msg err
65
        Location.pp_loc loc;
66 ef34b4ae xthirioux
      raise exc
67
    )
68 217837e2 ploc
  in
69
  close_in f_in;
70
  prog
71
    
72 ef34b4ae xthirioux
73 04a63d25 xthirioux
let expand_automata decls =
74
  Log.report ~level:1 (fun fmt -> fprintf fmt ".. expanding automata@ ");
75
  try
76
    Automata.expand_decls decls
77
  with (Corelang.Error (loc, err)) as exc ->
78
    eprintf "Automata error: %a%a@."
79 e7cc5186 ploc
      Error.pp_error_msg err
80 04a63d25 xthirioux
      Location.pp_loc loc;
81
    raise exc
82
83 ef34b4ae xthirioux
let check_stateless_decls decls =
84
  Log.report ~level:1 (fun fmt -> fprintf fmt ".. checking stateless/stateful status@ ");
85
  try
86
    Stateless.check_prog decls
87
  with (Stateless.Error (loc, err)) as exc ->
88 ec433d69 xthirioux
    eprintf "Stateless status error: %a%a@."
89 ef34b4ae xthirioux
      Stateless.pp_error err
90
      Location.pp_loc loc;
91
    raise exc
92
93 04a63d25 xthirioux
let force_stateful_decls decls =
94
  Log.report ~level:1 (fun fmt -> fprintf fmt ".. forcing stateful status@ ");
95
  try
96
    Stateless.force_prog decls
97
  with (Stateless.Error (loc, err)) as exc ->
98
    eprintf "Stateless status error: %a%a@."
99
      Stateless.pp_error err
100
      Location.pp_loc loc;
101
    raise exc
102
103 ef34b4ae xthirioux
let type_decls env decls =  
104
  Log.report ~level:1 (fun fmt -> fprintf fmt ".. typing@ ");
105
  let new_env = 
106
    begin
107
      try
108
	Typing.type_prog env decls
109
      with (Types.Error (loc,err)) as exc ->
110 ec433d69 xthirioux
	eprintf "Typing error: %a%a@."
111 ef34b4ae xthirioux
	  Types.pp_error err
112
	  Location.pp_loc loc;
113
	raise exc
114
    end 
115
  in
116 e7cc5186 ploc
  if !Options.print_types || !Options.verbose_level > 2 then
117 ef34b4ae xthirioux
    Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>  %a@]@ " Corelang.pp_prog_type decls);
118
  new_env
119
      
120
let clock_decls env decls = 
121
  Log.report ~level:1 (fun fmt -> fprintf fmt ".. clock calculus@ ");
122
  let new_env =
123
    begin
124
      try
125
	Clock_calculus.clock_prog env decls
126
      with (Clocks.Error (loc,err)) as exc ->
127 ec433d69 xthirioux
	eprintf "Clock calculus error: %a%a@." Clocks.pp_error err Location.pp_loc loc;
128 ef34b4ae xthirioux
	raise exc
129
    end
130
  in
131 e7cc5186 ploc
  if !Options.print_clocks  || !Options.verbose_level > 2 then
132 ef34b4ae xthirioux
    Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>  %a@]@ " Corelang.pp_prog_clock decls);
133
  new_env
134
135 2d27eedd ploc
(* Typing/Clocking with an empty env *)
136 ef34b4ae xthirioux
let check_top_decls header =
137
  let new_tenv = type_decls Basic_library.type_env header in   (* Typing *)
138
  let new_cenv = clock_decls Basic_library.clock_env header in   (* Clock calculus *)
139
  header, new_tenv, new_cenv
140
141
142
(*
143
 List.fold_right
144
   (fun top_decl (ty_env, ck_env) ->
145
     match top_decl.top_decl_desc with
146
     | Node nd          -> (Env.add_value ty_env nd.node_id nd.node_type,
147
			    Env.add_value ck_env nd.node_id nd.node_clock)
148
     | ImportedNode ind -> (Env.add_value ty_env ind.nodei_id ind.nodei_type,
149
			    Env.add_value ck_env ind.nodei_id ind.nodei_clock)
150
     | Const c          -> get_envs_from_const c (ty_env, ck_env)
151
     | TypeDef _        -> List.fold_left (fun envs top -> consts_of_enum_type top_decl
152
     | Open _           -> (ty_env, ck_env))
153
   header
154
   (Env.initial, Env.initial)
155
 *)
156
157 e70326c9 ploc
	 
158
159
    
160 ef34b4ae xthirioux
let check_compatibility (prog, computed_types_env, computed_clocks_env) (header, declared_types_env, declared_clocks_env) =
161
  try
162
    (* checking defined types are compatible with declared types*)
163
    Typing.check_typedef_compat header;
164
165
    (* checking type compatibility with computed types*)
166
    Typing.check_env_compat header declared_types_env computed_types_env;
167
168
    (* checking clocks compatibility with computed clocks*)
169
    Clock_calculus.check_env_compat header declared_clocks_env computed_clocks_env;
170
171
    (* checking stateless status compatibility *)
172
    Stateless.check_compat header
173
  with
174
  | (Types.Error (loc,err)) as exc ->
175 6efbcb73 xthirioux
    eprintf "Type mismatch between computed type and declared type in lustre interface file: %a%a@."
176
      Types.pp_error err
177
      Location.pp_loc loc;
178 ef34b4ae xthirioux
    raise exc
179
  | Clocks.Error (loc, err) as exc ->
180 6efbcb73 xthirioux
    eprintf "Clock mismatch between computed clock and declared clock in lustre interface file: %a%a@."
181
      Clocks.pp_error err
182
      Location.pp_loc loc;
183 ef34b4ae xthirioux
    raise exc
184
  | Stateless.Error (loc, err) as exc ->
185 6efbcb73 xthirioux
    eprintf "Stateless status mismatch between defined status and declared status in lustre interface file: %a%a@."
186
      Stateless.pp_error err
187
      Location.pp_loc loc;
188 ef34b4ae xthirioux
    raise exc
189
190
191 990210f3 ploc
let track_exception () =
192
  if !Options.track_exceptions
193
  then (Printexc.print_backtrace stdout; flush stdout)
194
  else ()
195
196
197 66359a5e ploc
let update_vdecl_parents_prog prog =
198
  let update_vdecl_parents parent v =
199
    v.var_parent_nodeid <- Some parent
200
  in
201
  List.iter (
202
    fun top -> match top.top_decl_desc with
203
    | Node nd ->
204
       List.iter
205
	 (update_vdecl_parents nd.node_id)
206
	 (nd.node_inputs @ nd.node_outputs @ nd.node_locals )  
207
    | ImportedNode ind -> 
208
       List.iter
209
	 (update_vdecl_parents ind.nodei_id)
210
	 (ind.nodei_inputs @ ind.nodei_outputs )  
211
    | _ -> ()
212
  ) prog