Project

General

Profile

Download (12 KB) Statistics
| Branch: | Tag: | Revision:
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 Lustre_types
14
open Corelang
15

    
16
let name_dependency loc (local, dep) ext =
17
  try Options_management.name_dependency (local, dep) ext
18
  with Not_found ->
19
    (* Error.pp_error loc (fun fmt -> Format.fprintf fmt "Unknown library %s"
20
       dep); *)
21
    raise (Error.Error (loc, Error.Unknown_library dep))
22

    
23
(* let add_symbol loc msg hashtbl name value =
24
 *  if Hashtbl.mem hashtbl name
25
 *  then raise (Error.Error (loc, Error.Already_bound_symbol msg))
26
 *  else Hashtbl.add hashtbl name value *)
27

    
28
(* let check_symbol loc msg hashtbl name =
29
 *  if not (Hashtbl.mem hashtbl name)
30
 *  then raise (Error.Error (loc, Error.Unbound_symbol msg))
31
 *  else () *)
32

    
33
let add_imported_node name value =
34
  (*Format.eprintf "add_imported_node %s %a (owner=%s)@." name
35
    Printers.pp_imported_node (imported_node_of_top value) value.top_decl_owner;*)
36
  try
37
    let value' = node_from_name name in
38
    let owner' = value'.top_decl_owner in
39
    let itf' = value'.top_decl_itf in
40
    let owner = value.top_decl_owner in
41
    let itf = value.top_decl_itf in
42
    match value'.top_decl_desc, value.top_decl_desc with
43
    | Node _, ImportedNode _ when owner = owner' && itf' && not itf ->
44
      update_node name value
45
    | ImportedNode _, ImportedNode _ ->
46
      raise
47
        (Error.Error
48
           (value.top_decl_loc, Error.Already_bound_symbol ("node " ^ name)))
49
    | _ ->
50
      assert false
51
  with Not_found -> update_node name value
52

    
53
let add_node name value =
54
  (*Format.eprintf "add_node %s %a (owner=%s)@." name Printers.pp_imported_node
55
    (get_node_interface (node_of_top value)) value.top_decl_owner;*)
56
  try
57
    let value' = node_from_name name in
58
    let owner' = value'.top_decl_owner in
59
    let itf' = value'.top_decl_itf in
60
    let owner = value.top_decl_owner in
61
    let itf = value.top_decl_itf in
62
    match value'.top_decl_desc, value.top_decl_desc with
63
    | ImportedNode _, Node _ when owner = owner' && itf' && not itf ->
64
      ()
65
    | Node _, Node _ ->
66
      raise
67
        (Error.Error
68
           (value.top_decl_loc, Error.Already_bound_symbol ("node " ^ name)))
69
    | _ ->
70
      assert false
71
  with Not_found -> update_node name value
72

    
73
let add_tag loc name typ =
74
  if Hashtbl.mem tag_table name then
75
    raise (Error.Error (loc, Error.Already_bound_symbol ("enum tag " ^ name)))
76
  else Hashtbl.add tag_table name typ
77

    
78
let add_field loc name typ =
79
  if Hashtbl.mem field_table name then
80
    raise
81
      (Error.Error (loc, Error.Already_bound_symbol ("struct field " ^ name)))
82
  else Hashtbl.add field_table name typ
83

    
84
let import_typedef tydef =
85
  let loc = tydef.top_decl_loc in
86
  let rec import ty =
87
    match ty with
88
    | Tydec_enum tl ->
89
      List.iter (fun tag -> add_tag loc tag tydef) tl
90
    | Tydec_struct fl ->
91
      List.iter
92
        (fun (field, ty) ->
93
          add_field loc field tydef;
94
          import ty)
95
        fl
96
    | Tydec_clock ty ->
97
      import ty
98
    | Tydec_const c ->
99
      if not (Hashtbl.mem type_table (Tydec_const c)) then
100
        raise (Error.Error (loc, Error.Unbound_symbol ("type " ^ c)))
101
      else ()
102
    | Tydec_array (_, ty) ->
103
      import ty
104
    | _ ->
105
      ()
106
  in
107
  import (typedef_of_top tydef).tydef_desc
108

    
109
let add_type _itf name value =
110
  (*Format.eprintf "Modules.add_type %B %s %a (owner=%s)@." itf name
111
    Printers.pp_typedef (typedef_of_top value) value.top_decl_owner;*)
112
  try
113
    let value' = Hashtbl.find type_table (Tydec_const name) in
114
    let owner' = value'.top_decl_owner in
115
    let itf' = value'.top_decl_itf in
116
    let owner = value.top_decl_owner in
117
    let itf = value.top_decl_itf in
118
    match value'.top_decl_desc, value.top_decl_desc with
119
    | TypeDef ty', TypeDef ty
120
      when coretype_equal ty'.tydef_desc ty.tydef_desc
121
           && owner' = owner && itf' && not itf ->
122
      ()
123
    | TypeDef _, TypeDef _ ->
124
      raise
125
        (Error.Error
126
           (value.top_decl_loc, Error.Already_bound_symbol ("type " ^ name)))
127
    | _ ->
128
      assert false
129
  with Not_found ->
130
    import_typedef value;
131
    Hashtbl.add type_table (Tydec_const name) value
132

    
133
(* let check_type loc name =
134
 *  if not (Hashtbl.mem type_table (Tydec_const name))
135
 *  then raise (Error.Error (loc, Error.Unbound_symbol ("type " ^ name)))
136
 *  else () *)
137

    
138
let add_const name value =
139
  try
140
    let value' = Hashtbl.find consts_table name in
141
    let owner' = value'.top_decl_owner in
142
    let itf' = value'.top_decl_itf in
143
    let owner = value.top_decl_owner in
144
    let itf = value.top_decl_itf in
145
    match value'.top_decl_desc, value.top_decl_desc with
146
    | Const c', Const c
147
      when c.const_value = c'.const_value && owner' = owner && itf' && not itf
148
      ->
149
      ()
150
    | Const _, Const _ ->
151
      raise
152
        (Error.Error
153
           (value.top_decl_loc, Error.Already_bound_symbol ("const " ^ name)))
154
    | _ ->
155
      assert false
156
  with Not_found -> Hashtbl.add consts_table name value
157

    
158
(* let import_dependency_aux loc (local, dep) =
159
 *   let basename = Options_management.name_dependency (local, dep) in
160
 *   let extension = ".lusic" in 
161
 *   try
162
 *     let lusic = Lusic.read_lusic basename extension in
163
 *     Lusic.check_obsolete lusic basename;
164
 *     lusic
165
 *   with
166
 *   | Sys_error msg ->
167
 *       raise (Error (loc, Error.Unknown_library basename))
168
 *     
169
 * let import_dependency loc (local, dep) =
170
 *   try
171
 *     import_dependency_aux loc (local, dep)
172
 *   with
173
 *   | Corelang.Error (_, err) as exc -> (
174
 *     Format.eprintf "Import error: %a%a@."
175
 *       Error.pp_error_msg err
176
 *       Location.pp_loc loc;
177
 *     raise exc
178
 *   ) *)
179

    
180
let get_lusic decl =
181
  match decl.top_decl_desc with
182
  | Open (local, dep) -> (
183
    let loc = decl.top_decl_loc in
184
    let extension = ".lusic" in
185
    let basename = name_dependency loc (local, dep) extension in
186
    try
187
      let lusic = Lusic.read_lusic basename extension in
188
      Lusic.check_obsolete lusic basename;
189
      lusic
190
    with Sys_error _ ->
191
      raise (Error.Error (loc, Error.Unknown_library basename)))
192
  | _ ->
193
    assert false
194
(* should not happen *)
195

    
196
let get_envs_from_const const_decl (ty_env, ck_env) =
197
  ( Env.add_value ty_env const_decl.const_id const_decl.const_type,
198
    Env.add_value ck_env const_decl.const_id (Clocks.new_var true) )
199

    
200
(* let get_envs_from_consts const_decls (ty_env, ck_env) =
201
 *   List.fold_right get_envs_from_const const_decls (ty_env, ck_env) *)
202

    
203
let rec get_envs_from_top_decl (ty_env, ck_env) top_decl =
204
  match top_decl.top_decl_desc with
205
  | Node nd ->
206
    ( Env.add_value ty_env nd.node_id nd.node_type,
207
      Env.add_value ck_env nd.node_id nd.node_clock )
208
  | ImportedNode ind ->
209
    ( Env.add_value ty_env ind.nodei_id ind.nodei_type,
210
      Env.add_value ck_env ind.nodei_id ind.nodei_clock )
211
  | Const c ->
212
    get_envs_from_const c (ty_env, ck_env)
213
  | TypeDef _ ->
214
    List.fold_left get_envs_from_top_decl (ty_env, ck_env)
215
      (consts_of_enum_type top_decl)
216
  | Include _ | Open _ ->
217
    ty_env, ck_env
218

    
219
(* get type and clock environments from a header *)
220
let get_envs_from_top_decls header =
221
  List.fold_left get_envs_from_top_decl (Env.initial, Env.initial) header
222

    
223
let is_stateful topdecl =
224
  match topdecl.top_decl_desc with
225
  | Node nd -> (
226
    match nd.node_stateless with
227
    | Some b ->
228
      not b
229
    | None ->
230
      not nd.node_dec_stateless)
231
  | ImportedNode nd ->
232
    not nd.nodei_stateless
233
  | _ ->
234
    false
235

    
236
let rec load_rec ~is_header accu program =
237
  List.fold_left
238
    (fun ((accu_prog, accu_dep, typ_env, clk_env) as accu) decl ->
239
      (* Precompute the updated envs, will not be used in the Open case *)
240
      let typ_env', clk_env' = get_envs_from_top_decl (typ_env, clk_env) decl in
241
      match decl.top_decl_desc with
242
      | Open (local, dep) -> (
243
        (* loading the dep *)
244
        try
245
          let basename =
246
            name_dependency decl.top_decl_loc (local, dep) ".lusic"
247
          in
248
          if
249
            List.exists
250
              (fun dep ->
251
                basename
252
                = name_dependency decl.top_decl_loc (dep.local, dep.name)
253
                    ".lusic")
254
              accu_dep
255
          then (* Library already imported. Just skip *)
256
            accu
257
          else (
258
            Log.report ~level:1 (fun fmt ->
259
                Format.fprintf fmt "@ .. Library %s@ " basename);
260
            let lusic = get_lusic decl in
261
            (* Recursive call with accumulator on lusic *)
262
            let accu_prog, accu_dep, typ_env, clk_env =
263
              load_rec ~is_header:true accu lusic.Lusic.contents
264
            in
265
            (* Building the dep *)
266
            let is_stateful = List.exists is_stateful lusic.Lusic.contents in
267
            let new_dep =
268
              { local; name = dep; content = lusic.Lusic.contents; is_stateful }
269
            in
270

    
271
            (* Returning the prog while keeping the Open, the deps with the new
272
               elements and the updated envs *)
273
            decl :: accu_prog, new_dep :: accu_dep, typ_env, clk_env)
274
        with Not_found ->
275
          let loc = decl.top_decl_loc in
276
          Error.pp_error loc (fun fmt ->
277
              Format.fprintf fmt "Unknown library %s" dep);
278
          raise (Error.Error (loc, Error.Unknown_library dep (*basename*))))
279
      | Include name ->
280
        let basename = name_dependency decl.top_decl_loc (true, name) "" in
281
        if Filename.check_suffix basename ".lus" then
282
          let include_src = Compiler_common.parse basename ".lus" in
283
          let accu_prog, accu_dep, typ_env, clk_env =
284
            load_rec ~is_header:false accu include_src
285
          in
286
          decl :: accu_prog, accu_dep, typ_env, clk_env
287
        else
288
          raise
289
            (Error.Error
290
               (decl.top_decl_loc, LoadError "include requires a lustre file"))
291
      | Node nd ->
292
        if is_header then
293
          raise
294
            (Error.Error
295
               ( decl.top_decl_loc,
296
                 LoadError ("node " ^ nd.node_id ^ " declared in a header file")
297
               ))
298
        else (
299
          (* Registering node *)
300
          add_node nd.node_id decl;
301
          (* Updating the type/clock env *)
302
          decl :: accu_prog, accu_dep, typ_env', clk_env')
303
      | ImportedNode ind ->
304
        if is_header then (
305
          add_imported_node ind.nodei_id decl;
306
          decl :: accu_prog, accu_dep, typ_env', clk_env')
307
        else
308
          raise
309
            (Error.Error
310
               ( decl.top_decl_loc,
311
                 LoadError
312
                   ("imported node " ^ ind.nodei_id
313
                  ^ " declared in a regular Lustre file") ))
314
      | Const c ->
315
        add_const c.const_id decl;
316
        decl :: accu_prog, accu_dep, typ_env', clk_env'
317
      | TypeDef tdef ->
318
        add_type is_header tdef.tydef_id decl;
319
        decl :: accu_prog, accu_dep, typ_env', clk_env')
320
    accu program
321

    
322
(* Iterates through lusi definitions and records them in the hashtbl. Open
323
   instructions are evaluated and update these hashtbl as well.
324
   node_table/type/table/consts_table *)
325
let load ~is_header program =
326
  try
327
    let prog, deps, typ_env, clk_env =
328
      load_rec ~is_header
329
        ( [],
330
          (* accumulator for program elements *)
331
          [],
332
          (* accumulator for dependencies *)
333
          Env.initial,
334
          (* empty type env *)
335
          Env.initial (* empty clock env *) )
336
        program
337
    in
338
    List.rev prog, List.rev deps, (typ_env, clk_env)
339
  with Error.Error (_, err) as exc ->
340
    (* Format.eprintf "Import error: %a%a@."
341
     *   Error.pp_error_msg err
342
     *   Location.pp_loc loc; *)
343
    Format.eprintf "Import error: %a@." Error.pp_error_msg err;
344
    raise exc
(40-40/66)