Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / modules.ml @ 5fccce23

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