Project

General

Profile

Revision 70e1006b src/parse.ml

View differences:

src/parse.ml
15 15
open LustreSpec
16 16
open Corelang
17 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 18
let report_error loc =
85 19
  Location.print loc;
86 20
  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 =
21

  
22
let header parsing_fun token_fun lexbuf =
99 23
  try
100
    let ast = parsing_fun token_fun lexbuf own in
24
    let ast = parsing_fun token_fun lexbuf in
101 25
    Parsing.clear_parser ();
102 26
    ast
103 27
  with

Also available in: Unified diff