Project

General

Profile

« Previous | Next » 

Revision ca7ff3f7

Added by LĂ©lio Brun 8 months ago

reformatting

View differences:

src/modules.ml
14 14
open Corelang
15 15

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

  
23
  
24 23
(* let add_symbol loc msg hashtbl name value =
25 24
 *  if Hashtbl.mem hashtbl name
26 25
 *  then raise (Error.Error (loc, Error.Already_bound_symbol msg))
......
31 30
 *  then raise (Error.Error (loc, Error.Unbound_symbol msg))
32 31
 *  else () *)
33 32

  
34

  
35 33
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;*)
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;*)
37 36
  try
38 37
    let value' = node_from_name name in
39 38
    let owner' = value'.top_decl_owner in
......
41 40
    let owner = value.top_decl_owner in
42 41
    let itf = value.top_decl_itf in
43 42
    match value'.top_decl_desc, value.top_decl_desc with
44
    | Node _        , ImportedNode _  when owner = owner' && itf' && (not itf) -> update_node name value
45
    | ImportedNode _, ImportedNode _            -> raise (Error.Error (value.top_decl_loc, Error.Already_bound_symbol ("node " ^ name)))
46
    | _                                         -> assert false
47
  with
48
    Not_found                                   -> update_node name value
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
49 52

  
50 53
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;*)
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;*)
52 56
  try
53 57
    let value' = node_from_name name in
54 58
    let owner' = value'.top_decl_owner in
......
56 60
    let owner = value.top_decl_owner in
57 61
    let itf = value.top_decl_itf in
58 62
    match value'.top_decl_desc, value.top_decl_desc with
59
    | ImportedNode _, Node _          when owner = owner' && itf' && (not itf) -> ()
60
    | Node _        , Node _                    -> raise (Error.Error (value.top_decl_loc, Error.Already_bound_symbol ("node " ^ name)))
61
    | _                                         -> assert false
62
  with
63
    Not_found                                   -> update_node name value
64

  
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
65 72

  
66 73
let add_tag loc name typ =
67 74
  if Hashtbl.mem tag_table name then
......
70 77

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

  
76 84
let import_typedef tydef =
77 85
  let loc = tydef.top_decl_loc in
78 86
  let rec import ty =
79 87
    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
       then raise (Error.Error (loc, Error.Unbound_symbol ("type " ^ c)))
88
       else ()
89
    | Tydec_array (_, ty) -> import ty
90
    | _                   -> ()
91
  in import ((typedef_of_top tydef).tydef_desc)
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
92 108

  
93 109
let add_type _itf name value =
94
(*Format.eprintf "Modules.add_type %B %s %a (owner=%s)@." itf name Printers.pp_typedef (typedef_of_top value) value.top_decl_owner;*)
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;*)
95 112
  try
96 113
    let value' = Hashtbl.find type_table (Tydec_const name) in
97 114
    let owner' = value'.top_decl_owner in
......
99 116
    let owner = value.top_decl_owner in
100 117
    let itf = value.top_decl_itf in
101 118
    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
    | TypeDef _, TypeDef _ -> raise (Error.Error (value.top_decl_loc, Error.Already_bound_symbol ("type " ^ name)))
104
    | _       -> assert false
105
  with Not_found -> (import_typedef value; Hashtbl.add type_table (Tydec_const name) value)
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
106 132

  
107 133
(* let check_type loc name =
108 134
 *  if not (Hashtbl.mem type_table (Tydec_const name))
......
117 143
    let owner = value.top_decl_owner in
118 144
    let itf = value.top_decl_itf in
119 145
    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
    | Const _, Const _ -> raise (Error.Error (value.top_decl_loc, Error.Already_bound_symbol ("const " ^ name)))
122
    | _       -> assert false
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
123 156
  with Not_found -> Hashtbl.add consts_table name value
124 157

  
125 158
(* let import_dependency_aux loc (local, dep) =
......
148 181
  match decl.top_decl_desc with
149 182
  | Open (local, dep) -> (
150 183
    let loc = decl.top_decl_loc in
151
    let extension = ".lusic" in 
184
    let extension = ".lusic" in
152 185
    let basename = name_dependency loc (local, dep) extension in
153 186
    try
154 187
      let lusic = Lusic.read_lusic basename extension in
155 188
      Lusic.check_obsolete lusic basename;
156 189
      lusic
157
    with
158
    | Sys_error _  ->
159
       raise (Error.Error (loc, Error.Unknown_library basename))
160
  )
161
  | _ -> assert false (* should not happen *)
162

  
190
    with Sys_error _ ->
191
      raise (Error.Error (loc, Error.Unknown_library basename)))
192
  | _ ->
193
    assert false
194
(* should not happen *)
163 195

  
164 196
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))
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) )
167 199

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

  
171 203
let rec get_envs_from_top_decl (ty_env, ck_env) top_decl =
172 204
  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
  | Include _ | Open _           -> (ty_env, ck_env)
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
180 218

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

  
185
  let is_stateful topdecl =
223
let is_stateful topdecl =
186 224
  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
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
190 270

  
191
  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
            elements and the updated envs *)
221
              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
             raise (Error.Error (loc, Error.Unknown_library dep (*basename*)))
228
        )
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
             raise (Error.Error (decl.top_decl_loc, LoadError("include requires a lustre file")))
239
           
240
        | Node nd ->
241
           if is_header then
242
             raise (Error.Error(decl.top_decl_loc,
243
                          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
             raise (Error.Error(decl.top_decl_loc,
258
                          LoadError ("imported node " ^ ind.nodei_id ^
259
                                       " declared in a regular Lustre file")))  
260
        | Const c -> (
261
          add_const 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
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
269 321

  
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 *)
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 *)
271 325
let load ~is_header program =
272
  
273 326
  try
274
    let prog, deps, typ_env, clk_env =  
327
    let prog, deps, typ_env, clk_env =
275 328
      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
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
281 337
    in
282 338
    List.rev prog, List.rev deps, (typ_env, clk_env)
283
  with
284
    Error.Error (_, err) as exc -> (
339
  with Error.Error (_, err) as exc ->
285 340
    (* Format.eprintf "Import error: %a%a@."
286 341
     *   Error.pp_error_msg err
287 342
     *   Location.pp_loc loc; *)
288
    Format.eprintf "Import error: %a@."
289
      Error.pp_error_msg err
290
      ;
343
    Format.eprintf "Import error: %a@." Error.pp_error_msg err;
291 344
    raise exc
292
  );;

Also available in: Unified diff