Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / modules.ml @ fc476249

History | View | Annotate | Download (7.91 KB)

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 LustreSpec
14
open Corelang
15

    
16
let add_symbol loc msg hashtbl name value =
17
 if Hashtbl.mem hashtbl name
18
 then raise (Error (loc, Already_bound_symbol msg))
19
 else Hashtbl.add hashtbl name value
20

    
21
let check_symbol loc msg hashtbl name =
22
 if not (Hashtbl.mem hashtbl name)
23
 then raise (Error (loc, Unbound_symbol msg))
24
 else ()
25

    
26
let add_imported_node name value =
27
(*Format.eprintf "add_imported_node %s %a (owner=%s)@." name Printers.pp_imported_node (imported_node_of_top value) value.top_decl_owner;*)
28
  try
29
    let value' = Hashtbl.find node_table name in
30
    let owner' = value'.top_decl_owner in
31
    let itf' = value'.top_decl_itf in
32
    let owner = value.top_decl_owner in
33
    let itf = value.top_decl_itf in
34
    match value'.top_decl_desc, value.top_decl_desc with
35
    | Node _        , ImportedNode _  when owner = owner' && itf' && (not itf) -> Hashtbl.add node_table name value
36
    | ImportedNode _, ImportedNode _            -> raise (Error (value.top_decl_loc, Already_bound_symbol ("node " ^ name)))
37
    | _                                         -> assert false
38
  with
39
    Not_found                                   -> Hashtbl.add node_table name value
40

    
41
let add_node name value =
42
(*Format.eprintf "add_node %s %a (owner=%s)@." name Printers.pp_imported_node (get_node_interface (node_of_top value)) value.top_decl_owner;*)
43
  try
44
    let value' = Hashtbl.find node_table name in
45
    let owner' = value'.top_decl_owner in
46
    let itf' = value'.top_decl_itf in
47
    let owner = value.top_decl_owner in
48
    let itf = value.top_decl_itf in
49
    match value'.top_decl_desc, value.top_decl_desc with
50
    | ImportedNode _, Node _          when owner = owner' && itf' && (not itf) -> ()
51
    | Node _        , Node _                    -> raise (Error (value.top_decl_loc, Already_bound_symbol ("node " ^ name)))
52
    | _                                         -> assert false
53
  with
54
    Not_found                                   -> Hashtbl.add node_table name value
55

    
56

    
57
let add_tag loc name typ =
58
  if Hashtbl.mem tag_table name then
59
    raise (Error (loc, Already_bound_symbol ("enum tag " ^ name)))
60
  else Hashtbl.add tag_table name typ
61

    
62
let add_field loc name typ =
63
  if Hashtbl.mem field_table name then
64
    raise (Error (loc, Already_bound_symbol ("struct field " ^ name)))
65
  else Hashtbl.add field_table name typ
66

    
67
let import_typedef name tydef =
68
  let loc = tydef.top_decl_loc in
69
  let rec import ty =
70
    match ty with
71
    | Tydec_enum tl   ->
72
       List.iter (fun tag -> add_tag loc tag tydef) tl
73
    | Tydec_struct fl -> 
74
       List.iter (fun (field, ty) -> add_field loc field tydef; import ty) fl
75
    | Tydec_clock ty      -> import ty
76
    | Tydec_const c       ->
77
       if not (Hashtbl.mem type_table (Tydec_const c))
78
       then raise (Error (loc, Unbound_symbol ("type " ^ c)))
79
       else ()
80
    | Tydec_array (c, ty) -> import ty
81
    | _                   -> ()
82
  in import ((typedef_of_top tydef).tydef_desc)
83

    
84
let add_type itf name value =
85
(*Format.eprintf "Modules.add_type %B %s %a (owner=%s)@." itf name Printers.pp_typedef (typedef_of_top value) value.top_decl_owner;*)
86
  try
87
    let value' = Hashtbl.find type_table (Tydec_const name) in
88
    let owner' = value'.top_decl_owner in
89
    let itf' = value'.top_decl_itf in
90
    let owner = value.top_decl_owner in
91
    let itf = value.top_decl_itf in
92
    match value'.top_decl_desc, value.top_decl_desc with
93
    | TypeDef ty', TypeDef ty when coretype_equal ty'.tydef_desc ty.tydef_desc && owner' = owner && itf' && (not itf) -> ()
94
    | TypeDef ty', TypeDef ty -> raise (Error (value.top_decl_loc, Already_bound_symbol ("type " ^ name)))
95
    | _       -> assert false
96
  with Not_found -> (import_typedef name value; Hashtbl.add type_table (Tydec_const name) value)
97

    
98
let check_type loc name =
99
 if not (Hashtbl.mem type_table (Tydec_const name))
100
 then raise (Error (loc, Unbound_symbol ("type " ^ name)))
101
 else ()
102

    
103
let add_const itf name value =
104
  try
105
    let value' = Hashtbl.find consts_table name in
106
    let owner' = value'.top_decl_owner in
107
    let itf' = value'.top_decl_itf in
108
    let owner = value.top_decl_owner in
109
    let itf = value.top_decl_itf in
110
    match value'.top_decl_desc, value.top_decl_desc with
111
    | Const c', Const c when c.const_value = c'.const_value && owner' = owner && itf' && (not itf) -> ()
112
    | Const c', Const c -> raise (Error (value.top_decl_loc, Already_bound_symbol ("const " ^ name)))
113
    | _       -> assert false
114
  with Not_found -> Hashtbl.add consts_table name value
115

    
116
(*let name_dependency (local, dep) =
117
      ((if local then !Options.dest_dir else Version.include_path) ^ "/") ^ dep
118
      *)
119

    
120
let name_dependency (local, dep) =
121
  ((if local then !Options.dest_dir else !Options.include_dir) ^ "/") ^ dep
122
  
123
let import_dependency_aux loc (local, dep) =
124
  let basename = name_dependency (local, dep) in
125
  let extension = ".lusic" in 
126
  try
127
    let lusic = Lusic.read_lusic basename extension in
128
    Lusic.check_obsolete lusic basename;
129
    lusic
130
  with
131
  | Sys_error msg ->
132
    begin
133
      (*Format.eprintf "Error: %s@." msg;*)
134
      raise (Error (loc, Unknown_library basename))
135
    end
136
  | Corelang.Error (_, msg) -> raise (Corelang.Error (loc, msg))
137

    
138
let import_dependency loc (local, dep) =
139
  try
140
    import_dependency_aux loc (local, dep)
141
  with
142
  | Corelang.Error (_, err) as exc -> (
143
    Format.eprintf "Import error: %a%a@."
144
      Corelang.pp_error err
145
      Location.pp_loc loc;
146
    raise exc
147
  )
148

    
149
let check_dependency lusic basename =
150
  try
151
    Lusic.check_obsolete lusic basename
152
  with
153
  | Corelang.Error (loc, err) as exc -> (
154
    Format.eprintf "Import error: %a%a@."
155
      Corelang.pp_error err
156
      Location.pp_loc loc;
157
    raise exc
158
  )
159

    
160
let rec load_header_rec imported header =
161
  List.fold_left (fun imp decl ->
162
    match decl.top_decl_desc with
163
    | Node nd -> assert false
164
    | ImportedNode ind -> (add_imported_node ind.nodei_id decl; imp)
165
    | Const c -> (add_const true c.const_id decl; imp)
166
    | TypeDef tdef -> (add_type true tdef.tydef_id decl; imp)
167
    | Open (local, dep) ->
168
       let basename = name_dependency (local, dep) in
169
       if ISet.mem basename imported then imp else
170
	 let lusic = import_dependency_aux decl.top_decl_loc (local, dep)
171
	 in load_header_rec (ISet.add basename imported) lusic.Lusic.contents
172
		 ) imported header
173

    
174
let load_header imported header =
175
  try
176
    load_header_rec imported header
177
  with
178
    Corelang.Error (loc, err) as exc -> (
179
      Format.eprintf "Import error: %a%a@."
180
	Corelang.pp_error err
181
	Location.pp_loc loc;
182
      raise exc
183
    );;
184

    
185
let rec load_program_rec imported program =
186
  List.fold_left (fun imp decl ->
187
    match decl.top_decl_desc with
188
    | Node nd -> (add_node nd.node_id decl; imp)
189
    | ImportedNode ind -> assert false
190
    | Const c -> (add_const false c.const_id decl; imp)
191
    | TypeDef tdef -> (add_type false tdef.tydef_id decl; imp)
192
    | Open (local, dep) ->
193
       let basename = name_dependency (local, dep) in
194
       if ISet.mem basename imported then imp else
195
	 let lusic = import_dependency_aux decl.top_decl_loc (local, dep)
196
	 in load_header_rec (ISet.add basename imported) lusic.Lusic.contents
197
		 ) imported program
198

    
199
let load_program imported program =
200
  try
201
    load_program_rec imported program
202
  with
203
    Corelang.Error (loc, err) as exc -> (
204
      Format.eprintf "Import error: %a%a@."
205
	Corelang.pp_error err
206
	Location.pp_loc loc;
207
      raise exc
208
    );;