lustrec / src / parse.ml @ 6aeb3388
History | View | Annotate | Download (4.05 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 |
exception Syntax_err of Location.t |
13 |
|
14 |
open Format |
15 |
open LustreSpec |
16 |
open Corelang |
17 |
|
18 |
let add_symbol loc msg hashtbl name value = |
19 |
if Hashtbl.mem hashtbl name |
20 |
then raise (Error (loc, Already_bound_symbol msg)) |
21 |
else Hashtbl.add hashtbl name value |
22 |
|
23 |
let check_symbol loc msg hashtbl name = |
24 |
if not (Hashtbl.mem hashtbl name) |
25 |
then raise (Error (loc, Unbound_symbol msg)) |
26 |
else () |
27 |
|
28 |
let add_node own name value = |
29 |
try |
30 |
match (Hashtbl.find node_table name).top_decl_desc, value.top_decl_desc with |
31 |
| Node _ , ImportedNode _ when own -> () |
32 |
| ImportedNode _, _ -> Hashtbl.add node_table name value |
33 |
| Node _ , _ -> raise (Error (value.top_decl_loc, Already_bound_symbol ("node " ^ name))) |
34 |
| _ -> assert false |
35 |
with |
36 |
Not_found -> Hashtbl.add node_table name value |
37 |
|
38 |
|
39 |
let add_tag loc own name typ = |
40 |
if Hashtbl.mem tag_table name && (not own) then |
41 |
raise (Error (loc, Unbound_symbol ("enum tag " ^ name))) |
42 |
else Hashtbl.add tag_table name typ |
43 |
|
44 |
let add_field loc own name typ = |
45 |
if Hashtbl.mem field_table name && (not own) then |
46 |
raise (Error (loc, Unbound_symbol ("struct field " ^ name))) |
47 |
else Hashtbl.add field_table name typ |
48 |
|
49 |
let rec check_type_def loc own name ty = |
50 |
match ty with |
51 |
| Tydec_enum tl -> |
52 |
begin |
53 |
List.iter (fun tag -> add_tag loc own tag (Tydec_const name)) tl; |
54 |
ty |
55 |
end |
56 |
| Tydec_struct fl -> |
57 |
begin |
58 |
List.iter (fun (field, _) -> add_field loc own field (Tydec_const name)) fl; |
59 |
Tydec_struct (List.map (fun (f, ty) -> (f, check_type_def loc own name ty)) fl) |
60 |
end |
61 |
| Tydec_clock ty -> Tydec_clock (check_type_def loc own name ty) |
62 |
| Tydec_const c -> |
63 |
if not (Hashtbl.mem type_table (Tydec_const c)) |
64 |
then raise (Error (loc, Unbound_symbol ("type " ^ c))) |
65 |
else get_repr_type ty |
66 |
| Tydec_array (c, ty) -> Tydec_array (c, check_type_def loc own name ty) |
67 |
| _ -> ty |
68 |
|
69 |
let add_type own name value = |
70 |
(*Format.eprintf "add_type %B %s@." own name;*) |
71 |
match value.top_decl_desc with |
72 |
| Type ty -> |
73 |
let loc = value.top_decl_loc in |
74 |
if Hashtbl.mem type_table (Tydec_const name) && (not own) |
75 |
then raise (Error (loc, Already_bound_symbol ("type " ^ name))) |
76 |
else Hashtbl.add type_table (Tydec_const name) (check_type_def loc own name ty.ty_def_desc) |
77 |
| _ -> assert false |
78 |
|
79 |
let check_type loc name = |
80 |
if not (Hashtbl.mem type_table (Tydec_const name)) |
81 |
then raise (Error (loc, Unbound_symbol ("type " ^ name))) |
82 |
else () |
83 |
|
84 |
let report_error loc = |
85 |
Location.print loc; |
86 |
print_string "Syntax error\n" |
87 |
(* |
88 |
let wrap own parsing_fun token_fun lexbuf = |
89 |
try |
90 |
let ast = parsing_fun token_fun lexbuf own in |
91 |
Parsing.clear_parser (); |
92 |
ast |
93 |
with |
94 |
| Parsing.Parse_error -> |
95 |
let loc = Location.curr lexbuf in |
96 |
raise (Syntax_err loc) |
97 |
*) |
98 |
let header own parsing_fun token_fun lexbuf = |
99 |
try |
100 |
let ast = parsing_fun token_fun lexbuf own in |
101 |
Parsing.clear_parser (); |
102 |
ast |
103 |
with |
104 |
| Parsing.Parse_error -> |
105 |
let loc = Location.curr lexbuf in |
106 |
raise (Syntax_err loc) |
107 |
|
108 |
let prog parsing_fun token_fun lexbuf = |
109 |
try |
110 |
let ast = parsing_fun token_fun lexbuf in |
111 |
Parsing.clear_parser (); |
112 |
ast |
113 |
with |
114 |
| Parsing.Parse_error -> |
115 |
let loc = Location.curr lexbuf in |
116 |
raise (Syntax_err loc) |
117 |
|
118 |
(* Local Variables: *) |
119 |
(* compile-command:"make -C .." *) |
120 |
(* End: *) |