Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / modules.ml @ 04a188ec

History | View | Annotate | Download (12.1 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 8446bf03 ploc
open Lustre_types
14 ef34b4ae xthirioux
open Corelang
15
16 94a9e2c3 ploc
let name_dependency loc (local, dep) ext =
17
  try
18
    Options_management.name_dependency (local, dep) ext 
19
  with Not_found ->
20
    (* Error.pp_error loc (fun fmt -> Format.fprintf fmt "Unknown library %s" dep); *)
21 04a188ec ploc
    raise (Error.Error (loc, Error.Unknown_library dep))
22 94a9e2c3 ploc
23
  
24 ef34b4ae xthirioux
let add_symbol loc msg hashtbl name value =
25
 if Hashtbl.mem hashtbl name
26 04a188ec ploc
 then raise (Error.Error (loc, Error.Already_bound_symbol msg))
27 ef34b4ae xthirioux
 else Hashtbl.add hashtbl name value
28
29
let check_symbol loc msg hashtbl name =
30
 if not (Hashtbl.mem hashtbl name)
31 04a188ec ploc
 then raise (Error.Error (loc, Error.Unbound_symbol msg))
32 ef34b4ae xthirioux
 else ()
33
34 5fccce23 ploc
35 ef34b4ae xthirioux
let add_imported_node name value =
36
(*Format.eprintf "add_imported_node %s %a (owner=%s)@." name Printers.pp_imported_node (imported_node_of_top value) value.top_decl_owner;*)
37
  try
38 95944ba1 ploc
    let value' = node_from_name name in
39 ef34b4ae xthirioux
    let owner' = value'.top_decl_owner in
40
    let itf' = value'.top_decl_itf in
41
    let owner = value.top_decl_owner in
42
    let itf = value.top_decl_itf in
43
    match value'.top_decl_desc, value.top_decl_desc with
44 95944ba1 ploc
    | Node _        , ImportedNode _  when owner = owner' && itf' && (not itf) -> update_node name value
45 04a188ec ploc
    | ImportedNode _, ImportedNode _            -> raise (Error.Error (value.top_decl_loc, Error.Already_bound_symbol ("node " ^ name)))
46 ef34b4ae xthirioux
    | _                                         -> assert false
47
  with
48 95944ba1 ploc
    Not_found                                   -> update_node name value
49 ef34b4ae xthirioux
50
let add_node name value =
51
(*Format.eprintf "add_node %s %a (owner=%s)@." name Printers.pp_imported_node (get_node_interface (node_of_top value)) value.top_decl_owner;*)
52
  try
53 95944ba1 ploc
    let value' = node_from_name name in
54 ef34b4ae xthirioux
    let owner' = value'.top_decl_owner in
55
    let itf' = value'.top_decl_itf in
56
    let owner = value.top_decl_owner in
57
    let itf = value.top_decl_itf in
58
    match value'.top_decl_desc, value.top_decl_desc with
59
    | ImportedNode _, Node _          when owner = owner' && itf' && (not itf) -> ()
60 04a188ec ploc
    | Node _        , Node _                    -> raise (Error.Error (value.top_decl_loc, Error.Already_bound_symbol ("node " ^ name)))
61 ef34b4ae xthirioux
    | _                                         -> assert false
62
  with
63 95944ba1 ploc
    Not_found                                   -> update_node name value
64 ef34b4ae xthirioux
65
66
let add_tag loc name typ =
67
  if Hashtbl.mem tag_table name then
68 04a188ec ploc
    raise (Error.Error (loc, Error.Already_bound_symbol ("enum tag " ^ name)))
69 ef34b4ae xthirioux
  else Hashtbl.add tag_table name typ
70
71
let add_field loc name typ =
72
  if Hashtbl.mem field_table name then
73 04a188ec ploc
    raise (Error.Error (loc, Error.Already_bound_symbol ("struct field " ^ name)))
74 ef34b4ae xthirioux
  else Hashtbl.add field_table name typ
75
76
let import_typedef name tydef =
77
  let loc = tydef.top_decl_loc in
78
  let rec import ty =
79
    match ty with
80
    | Tydec_enum tl   ->
81
       List.iter (fun tag -> add_tag loc tag tydef) tl
82
    | Tydec_struct fl -> 
83
       List.iter (fun (field, ty) -> add_field loc field tydef; import ty) fl
84
    | Tydec_clock ty      -> import ty
85
    | Tydec_const c       ->
86
       if not (Hashtbl.mem type_table (Tydec_const c))
87 04a188ec ploc
       then raise (Error.Error (loc, Error.Unbound_symbol ("type " ^ c)))
88 ef34b4ae xthirioux
       else ()
89
    | Tydec_array (c, ty) -> import ty
90
    | _                   -> ()
91
  in import ((typedef_of_top tydef).tydef_desc)
92
93
let add_type itf name value =
94 54d032f5 xthirioux
(*Format.eprintf "Modules.add_type %B %s %a (owner=%s)@." itf name Printers.pp_typedef (typedef_of_top value) value.top_decl_owner;*)
95 ef34b4ae xthirioux
  try
96
    let value' = Hashtbl.find type_table (Tydec_const name) in
97
    let owner' = value'.top_decl_owner in
98
    let itf' = value'.top_decl_itf in
99
    let owner = value.top_decl_owner in
100
    let itf = value.top_decl_itf in
101
    match value'.top_decl_desc, value.top_decl_desc with
102
    | TypeDef ty', TypeDef ty when coretype_equal ty'.tydef_desc ty.tydef_desc && owner' = owner && itf' && (not itf) -> ()
103 04a188ec ploc
    | TypeDef ty', TypeDef ty -> raise (Error.Error (value.top_decl_loc, Error.Already_bound_symbol ("type " ^ name)))
104 ef34b4ae xthirioux
    | _       -> assert false
105
  with Not_found -> (import_typedef name value; Hashtbl.add type_table (Tydec_const name) value)
106
107
let check_type loc name =
108
 if not (Hashtbl.mem type_table (Tydec_const name))
109 04a188ec ploc
 then raise (Error.Error (loc, Error.Unbound_symbol ("type " ^ name)))
110 ef34b4ae xthirioux
 else ()
111
112
let add_const itf name value =
113
  try
114
    let value' = Hashtbl.find consts_table name in
115
    let owner' = value'.top_decl_owner in
116
    let itf' = value'.top_decl_itf in
117
    let owner = value.top_decl_owner in
118
    let itf = value.top_decl_itf in
119
    match value'.top_decl_desc, value.top_decl_desc with
120
    | Const c', Const c when c.const_value = c'.const_value && owner' = owner && itf' && (not itf) -> ()
121 04a188ec ploc
    | Const c', Const c -> raise (Error.Error (value.top_decl_loc, Error.Already_bound_symbol ("const " ^ name)))
122 ef34b4ae xthirioux
    | _       -> assert false
123
  with Not_found -> Hashtbl.add consts_table name value
124
125 19a1e66b ploc
(* let import_dependency_aux loc (local, dep) =
126
 *   let basename = Options_management.name_dependency (local, dep) in
127
 *   let extension = ".lusic" in 
128
 *   try
129
 *     let lusic = Lusic.read_lusic basename extension in
130
 *     Lusic.check_obsolete lusic basename;
131
 *     lusic
132
 *   with
133
 *   | Sys_error msg ->
134
 *       raise (Error (loc, Error.Unknown_library basename))
135
 *     
136
 * let import_dependency loc (local, dep) =
137
 *   try
138
 *     import_dependency_aux loc (local, dep)
139
 *   with
140
 *   | Corelang.Error (_, err) as exc -> (
141
 *     Format.eprintf "Import error: %a%a@."
142
 *       Error.pp_error_msg err
143
 *       Location.pp_loc loc;
144
 *     raise exc
145
 *   ) *)
146 a28d1ba7 xthirioux
147 5fccce23 ploc
let get_lusic decl =
148
  match decl.top_decl_desc with
149
  | Open (local, dep) -> (
150
    let loc = decl.top_decl_loc in
151
    let extension = ".lusic" in 
152 94a9e2c3 ploc
    let basename = name_dependency loc (local, dep) extension in
153 5fccce23 ploc
    try
154
      let lusic = Lusic.read_lusic basename extension in
155
      Lusic.check_obsolete lusic basename;
156
      lusic
157
    with
158 94a9e2c3 ploc
    | Sys_error _  ->
159 04a188ec ploc
       raise (Error.Error (loc, Error.Unknown_library basename))
160 ec433d69 xthirioux
  )
161 5fccce23 ploc
  | _ -> assert false (* should not happen *)
162
163 ef34b4ae xthirioux
164 5fccce23 ploc
let get_envs_from_const const_decl (ty_env, ck_env) =
165
  (Env.add_value ty_env const_decl.const_id const_decl.const_type,
166
   Env.add_value ck_env const_decl.const_id (Clocks.new_var true))
167 d1baac41 xthirioux
168 5fccce23 ploc
let get_envs_from_consts const_decls (ty_env, ck_env) =
169
  List.fold_right get_envs_from_const const_decls (ty_env, ck_env)
170
171
let rec get_envs_from_top_decl (ty_env, ck_env) top_decl =
172
  match top_decl.top_decl_desc with
173
  | Node nd          -> (Env.add_value ty_env nd.node_id nd.node_type,
174
			 Env.add_value ck_env nd.node_id nd.node_clock)
175
  | ImportedNode ind -> (Env.add_value ty_env ind.nodei_id ind.nodei_type,
176
			 Env.add_value ck_env ind.nodei_id ind.nodei_clock)
177
  | Const c          -> get_envs_from_const c (ty_env, ck_env)
178
  | TypeDef _        -> List.fold_left get_envs_from_top_decl (ty_env, ck_env) (consts_of_enum_type top_decl)
179 19a1e66b ploc
  | Include _ | Open _           -> (ty_env, ck_env)
180 5fccce23 ploc
181
(* get type and clock environments from a header *)
182
let get_envs_from_top_decls header =
183
  List.fold_left get_envs_from_top_decl (Env.initial, Env.initial) header
184
185
  let is_stateful topdecl =
186
  match topdecl.top_decl_desc with
187
  | Node nd -> (match nd.node_stateless with Some b -> not b | None -> not nd.node_dec_stateless)
188
  | ImportedNode nd -> not nd.nodei_stateless 
189
  | _ -> false
190
191 94a9e2c3 ploc
  let rec load_rec ~is_header accu program =
192
    List.fold_left (fun ((accu_prog, accu_dep, typ_env, clk_env) as accu) decl ->
193
        (* Precompute the updated envs, will not be used in the Open case *)
194
        let typ_env', clk_env' = get_envs_from_top_decl (typ_env, clk_env) decl in
195
        match decl.top_decl_desc with
196
        | Open (local, dep) -> (
197
          (* loading the dep *)
198
          try
199
            let basename = name_dependency decl.top_decl_loc (local, dep) ".lusic" in
200
            if List.exists
201
                 (fun dep -> basename = name_dependency decl.top_decl_loc  (dep.local, dep.name) ".lusic")
202
                 accu_dep
203
            then
204
              (* Library already imported. Just skip *)
205
              accu
206
            else (
207
              Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@ .. Library %s@ " basename);
208
              let lusic = get_lusic decl in
209
              (* Recursive call with accumulator on lusic *)
210
              let (accu_prog, accu_dep, typ_env, clk_env) =
211
                load_rec ~is_header:true accu lusic.Lusic.contents in
212
              (* Building the dep *)
213
              let is_stateful = List.exists is_stateful lusic.Lusic.contents in
214
              let new_dep = { local = local;
215
                              name = dep;
216
                              content = lusic.Lusic.contents;
217
                              is_stateful = is_stateful } in
218
              
219
              (* Returning the prog while keeping the Open, the deps with the new
220 3050ca8f ploc
            elements and the updated envs *)
221 94a9e2c3 ploc
              decl::accu_prog, (new_dep::accu_dep), typ_env, clk_env
222
            )
223
          with
224
          | Not_found ->
225
             let loc = decl.top_decl_loc in
226
             Error.pp_error loc (fun fmt -> Format.fprintf fmt "Unknown library %s" dep);
227 04a188ec ploc
             raise (Error.Error (loc, Error.Unknown_library dep (*basename*)))
228 94a9e2c3 ploc
        )
229
        | Include name ->
230
           let basename = name_dependency decl.top_decl_loc (true, name) "" in
231
           if Filename.check_suffix basename ".lus" then
232
             let include_src = Compiler_common.parse basename ".lus" in
233
             let (accu_prog, accu_dep, typ_env, clk_env) =
234
               load_rec ~is_header:false accu include_src
235
             in
236
             decl::accu_prog, accu_dep, typ_env, clk_env
237
           else
238 04a188ec ploc
             raise (Error.Error (decl.top_decl_loc, LoadError("include requires a lustre file")))
239 94a9e2c3 ploc
           
240
        | Node nd ->
241
           if is_header then
242 04a188ec ploc
             raise (Error.Error(decl.top_decl_loc,
243 94a9e2c3 ploc
                          LoadError ("node " ^ nd.node_id ^ " declared in a header file")))  
244
           else (
245
             (* Registering node *)
246
             add_node nd.node_id decl;
247
             (* Updating the type/clock env *)
248
             decl::accu_prog, accu_dep, typ_env', clk_env'                   
249
           )
250
          
251
        | ImportedNode ind ->
252
           if is_header then (
253
             add_imported_node ind.nodei_id decl;
254
             decl::accu_prog, accu_dep, typ_env', clk_env'                   
255
           )
256
           else
257 04a188ec ploc
             raise (Error.Error(decl.top_decl_loc,
258 94a9e2c3 ploc
                          LoadError ("imported node " ^ ind.nodei_id ^
259
                                       " declared in a regular Lustre file")))  
260
        | Const c -> (
261
          add_const is_header c.const_id decl;
262
          decl::accu_prog, accu_dep, typ_env', clk_env' 
263
        )
264
        | TypeDef tdef -> (
265
          add_type is_header tdef.tydef_id decl;
266
          decl::accu_prog, accu_dep, typ_env', clk_env'
267
        )
268
      ) accu program
269 f9f06e7d ploc
270
(* 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 *)
271 5fccce23 ploc
let load ~is_header program =
272 f9f06e7d ploc
  
273 d1baac41 xthirioux
  try
274 5fccce23 ploc
    let prog, deps, typ_env, clk_env =  
275
      load_rec ~is_header
276
        ([], (* accumulator for program elements *)
277
         [], (* accumulator for dependencies *)
278
         Env.initial, (* empty type env *)
279
         Env.initial  (* empty clock env *)
280
        ) program
281
    in
282
    List.rev prog, List.rev deps, (typ_env, clk_env)
283 d1baac41 xthirioux
  with
284 04a188ec ploc
    Error.Error (loc, err) as exc -> (
285 94a9e2c3 ploc
    (* Format.eprintf "Import error: %a%a@."
286
     *   Error.pp_error_msg err
287
     *   Location.pp_loc loc; *)
288
    Format.eprintf "Import error: %a@."
289 5fccce23 ploc
      Error.pp_error_msg err
290 94a9e2c3 ploc
      ;
291 5fccce23 ploc
    raise exc
292
  );;