Revision e7cc5186
Added by Pierre-Loïc Garoche almost 6 years ago
| src/modules.ml | ||
|---|---|---|
| 15 | 15 |
|
| 16 | 16 |
let add_symbol loc msg hashtbl name value = |
| 17 | 17 |
if Hashtbl.mem hashtbl name |
| 18 |
then raise (Error (loc, Already_bound_symbol msg)) |
|
| 18 |
then raise (Error (loc, Error.Already_bound_symbol msg))
|
|
| 19 | 19 |
else Hashtbl.add hashtbl name value |
| 20 | 20 |
|
| 21 | 21 |
let check_symbol loc msg hashtbl name = |
| 22 | 22 |
if not (Hashtbl.mem hashtbl name) |
| 23 |
then raise (Error (loc, Unbound_symbol msg)) |
|
| 23 |
then raise (Error (loc, Error.Unbound_symbol msg))
|
|
| 24 | 24 |
else () |
| 25 | 25 |
|
| 26 | 26 |
let add_imported_node name value = |
| ... | ... | |
| 33 | 33 |
let itf = value.top_decl_itf in |
| 34 | 34 |
match value'.top_decl_desc, value.top_decl_desc with |
| 35 | 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)))
|
|
| 36 |
| ImportedNode _, ImportedNode _ -> raise (Error (value.top_decl_loc, Error.Already_bound_symbol ("node " ^ name)))
|
|
| 37 | 37 |
| _ -> assert false |
| 38 | 38 |
with |
| 39 | 39 |
Not_found -> Hashtbl.add node_table name value |
| ... | ... | |
| 48 | 48 |
let itf = value.top_decl_itf in |
| 49 | 49 |
match value'.top_decl_desc, value.top_decl_desc with |
| 50 | 50 |
| ImportedNode _, Node _ when owner = owner' && itf' && (not itf) -> () |
| 51 |
| Node _ , Node _ -> raise (Error (value.top_decl_loc, Already_bound_symbol ("node " ^ name)))
|
|
| 51 |
| Node _ , Node _ -> raise (Error (value.top_decl_loc, Error.Already_bound_symbol ("node " ^ name)))
|
|
| 52 | 52 |
| _ -> assert false |
| 53 | 53 |
with |
| 54 | 54 |
Not_found -> Hashtbl.add node_table name value |
| ... | ... | |
| 56 | 56 |
|
| 57 | 57 |
let add_tag loc name typ = |
| 58 | 58 |
if Hashtbl.mem tag_table name then |
| 59 |
raise (Error (loc, Already_bound_symbol ("enum tag " ^ name)))
|
|
| 59 |
raise (Error (loc, Error.Already_bound_symbol ("enum tag " ^ name)))
|
|
| 60 | 60 |
else Hashtbl.add tag_table name typ |
| 61 | 61 |
|
| 62 | 62 |
let add_field loc name typ = |
| 63 | 63 |
if Hashtbl.mem field_table name then |
| 64 |
raise (Error (loc, Already_bound_symbol ("struct field " ^ name)))
|
|
| 64 |
raise (Error (loc, Error.Already_bound_symbol ("struct field " ^ name)))
|
|
| 65 | 65 |
else Hashtbl.add field_table name typ |
| 66 | 66 |
|
| 67 | 67 |
let import_typedef name tydef = |
| ... | ... | |
| 75 | 75 |
| Tydec_clock ty -> import ty |
| 76 | 76 |
| Tydec_const c -> |
| 77 | 77 |
if not (Hashtbl.mem type_table (Tydec_const c)) |
| 78 |
then raise (Error (loc, Unbound_symbol ("type " ^ c)))
|
|
| 78 |
then raise (Error (loc, Error.Unbound_symbol ("type " ^ c)))
|
|
| 79 | 79 |
else () |
| 80 | 80 |
| Tydec_array (c, ty) -> import ty |
| 81 | 81 |
| _ -> () |
| ... | ... | |
| 91 | 91 |
let itf = value.top_decl_itf in |
| 92 | 92 |
match value'.top_decl_desc, value.top_decl_desc with |
| 93 | 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)))
|
|
| 94 |
| TypeDef ty', TypeDef ty -> raise (Error (value.top_decl_loc, Error.Already_bound_symbol ("type " ^ name)))
|
|
| 95 | 95 |
| _ -> assert false |
| 96 | 96 |
with Not_found -> (import_typedef name value; Hashtbl.add type_table (Tydec_const name) value) |
| 97 | 97 |
|
| 98 | 98 |
let check_type loc name = |
| 99 | 99 |
if not (Hashtbl.mem type_table (Tydec_const name)) |
| 100 |
then raise (Error (loc, Unbound_symbol ("type " ^ name)))
|
|
| 100 |
then raise (Error (loc, Error.Unbound_symbol ("type " ^ name)))
|
|
| 101 | 101 |
else () |
| 102 | 102 |
|
| 103 | 103 |
let add_const itf name value = |
| ... | ... | |
| 109 | 109 |
let itf = value.top_decl_itf in |
| 110 | 110 |
match value'.top_decl_desc, value.top_decl_desc with |
| 111 | 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)))
|
|
| 112 |
| Const c', Const c -> raise (Error (value.top_decl_loc, Error.Already_bound_symbol ("const " ^ name)))
|
|
| 113 | 113 |
| _ -> assert false |
| 114 | 114 |
with Not_found -> Hashtbl.add consts_table name value |
| 115 | 115 |
|
| ... | ... | |
| 124 | 124 |
| Sys_error msg -> |
| 125 | 125 |
begin |
| 126 | 126 |
(*Format.eprintf "Error: %s@." msg;*) |
| 127 |
raise (Error (loc, Unknown_library basename)) |
|
| 127 |
raise (Error (loc, Error.Unknown_library basename))
|
|
| 128 | 128 |
end |
| 129 | 129 |
| Corelang.Error (_, msg) -> raise (Corelang.Error (loc, msg)) |
| 130 | 130 |
|
| ... | ... | |
| 134 | 134 |
with |
| 135 | 135 |
| Corelang.Error (_, err) as exc -> ( |
| 136 | 136 |
Format.eprintf "Import error: %a%a@." |
| 137 |
Corelang.pp_error err
|
|
| 137 |
Error.pp_error_msg err
|
|
| 138 | 138 |
Location.pp_loc loc; |
| 139 | 139 |
raise exc |
| 140 | 140 |
) |
| ... | ... | |
| 145 | 145 |
with |
| 146 | 146 |
| Corelang.Error (loc, err) as exc -> ( |
| 147 | 147 |
Format.eprintf "Import error: %a%a@." |
| 148 |
Corelang.pp_error err
|
|
| 148 |
Error.pp_error_msg err
|
|
| 149 | 149 |
Location.pp_loc loc; |
| 150 | 150 |
raise exc |
| 151 | 151 |
) |
| ... | ... | |
| 170 | 170 |
with |
| 171 | 171 |
Corelang.Error (loc, err) as exc -> ( |
| 172 | 172 |
Format.eprintf "Import error: %a%a@." |
| 173 |
Corelang.pp_error err
|
|
| 173 |
Error.pp_error_msg err
|
|
| 174 | 174 |
Location.pp_loc loc; |
| 175 | 175 |
raise exc |
| 176 | 176 |
);; |
| ... | ... | |
| 195 | 195 |
with |
| 196 | 196 |
Corelang.Error (loc, err) as exc -> ( |
| 197 | 197 |
Format.eprintf "Import error: %a%a@." |
| 198 |
Corelang.pp_error err
|
|
| 198 |
Error.pp_error_msg err
|
|
| 199 | 199 |
Location.pp_loc loc; |
| 200 | 200 |
raise exc |
| 201 | 201 |
);; |
Also available in: Unified diff
Refactor error printing.