lustrec / src / modules.ml @ 86ae18b7
History | View | Annotate | Download (7.91 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 | 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 | 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;*) |
| 86 | ef34b4ae | xthirioux | 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 | 86ae18b7 | Ploc | (*let name_dependency (local, dep) = |
| 117 | ((if local then !Options.dest_dir else Version.include_path) ^ "/") ^ dep |
||
| 118 | *) |
||
| 119 | ef34b4ae | xthirioux | |
| 120 | 86ae18b7 | Ploc | let name_dependency (local, dep) = |
| 121 | ((if local then !Options.dest_dir else !Options.include_dir) ^ "/") ^ dep |
||
| 122 | |||
| 123 | a28d1ba7 | xthirioux | let import_dependency_aux loc (local, dep) = |
| 124 | let basename = name_dependency (local, dep) in |
||
| 125 | let extension = ".lusic" in |
||
| 126 | ef34b4ae | xthirioux | try |
| 127 | a28d1ba7 | xthirioux | 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 | 9603460e | xthirioux | (*Format.eprintf "Error: %s@." msg;*) |
| 134 | a28d1ba7 | xthirioux | raise (Error (loc, Unknown_library basename)) |
| 135 | end |
||
| 136 | e39f5319 | xthirioux | | Corelang.Error (_, msg) -> raise (Corelang.Error (loc, msg)) |
| 137 | a28d1ba7 | xthirioux | |
| 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 | ec433d69 | xthirioux | with |
| 153 | | Corelang.Error (loc, err) as exc -> ( |
||
| 154 | a28d1ba7 | xthirioux | Format.eprintf "Import error: %a%a@." |
| 155 | ec433d69 | xthirioux | Corelang.pp_error err |
| 156 | Location.pp_loc loc; |
||
| 157 | raise exc |
||
| 158 | ) |
||
| 159 | ef34b4ae | xthirioux | |
| 160 | d1baac41 | xthirioux | let rec load_header_rec imported header = |
| 161 | ef34b4ae | xthirioux | 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 | a28d1ba7 | xthirioux | let lusic = import_dependency_aux decl.top_decl_loc (local, dep) |
| 171 | d1baac41 | xthirioux | in load_header_rec (ISet.add basename imported) lusic.Lusic.contents |
| 172 | ef34b4ae | xthirioux | ) imported header |
| 173 | |||
| 174 | d1baac41 | xthirioux | 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 | ef34b4ae | xthirioux | 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 | a28d1ba7 | xthirioux | let lusic = import_dependency_aux decl.top_decl_loc (local, dep) |
| 196 | d1baac41 | xthirioux | in load_header_rec (ISet.add basename imported) lusic.Lusic.contents |
| 197 | ef34b4ae | xthirioux | ) imported program |
| 198 | d1baac41 | xthirioux | |
| 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 | );; |