Project

General

Profile

Revision 21485807

View differences:

src/corelang.ml
149 149
    Main_not_found
150 150
  | Main_wrong_kind
151 151
  | No_main_specified
152
  | Unbound_symbol of ident
153
  | Already_bound_symbol of ident
152 154

  
155
exception Error of error * Location.t
153 156

  
154 157
module VDeclModule =
155 158
struct (* Node module *)
......
230 233

  
231 234

  
232 235
(***********************************************************)
233
exception Error of error
234
exception Unbound_type of type_dec_desc*Location.t
235
exception Already_bound_label of label*type_dec_desc*Location.t
236

  
237 236
(* Fast access to nodes, by name *)
238 237
let (node_table : (ident, top_decl) Hashtbl.t) = Hashtbl.create 30
239 238
let consts_table = Hashtbl.create 30
......
729 728
      !Options.main_node
730 729
  | No_main_specified ->
731 730
    fprintf fmt "No main node specified@."
731
  | Unbound_symbol sym ->
732
    fprintf fmt
733
      "%s is undefined.@."
734
      sym
735
  | Already_bound_symbol sym -> 
736
    fprintf fmt
737
      "%s is already defined.@."
738
      sym
732 739

  
733 740
(* filling node table with internal functions *)
734 741
let vdecls_of_typ_ck cpt ty =
src/corelang.mli
149 149
    Main_not_found
150 150
  | Main_wrong_kind
151 151
  | No_main_specified
152
  | Unbound_symbol of ident
153
  | Already_bound_symbol of ident
152 154

  
153
exception Error of error
154
exception Unbound_type of type_dec_desc*Location.t
155
exception Already_bound_label of label*type_dec_desc*Location.t
155
exception Error of error * Location.t
156 156

  
157 157
val mktyp: Location.t -> type_dec_desc -> type_dec
158 158
val mkclock: Location.t -> clock_dec_desc -> clock_dec
src/main_lustre_compiler.ml
63 63
    report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?" Corelang.pp_prog_clock decls);
64 64
  new_env
65 65

  
66
(* Loading Lusi file and filing type tables with parsed
66
(* Loading Lusi file and filling type tables with parsed
67 67
   functions/nodes *)
68 68
let load_lusi filename =
69 69
  Location.input_name := filename;
......
94 94
  let prog =
95 95
    try
96 96
      Parse.prog Parser_lustre.prog Lexer_lustre.token lexbuf
97
    with (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
97
    with
98
    | (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
98 99
      Parse.report_error err;
99 100
      raise exc
101
    | Corelang.Error (err, loc) as exc ->
102
      Format.eprintf "Parsing error at loc %a: %a@]@."
103
	Location.pp_loc loc
104
	Corelang.pp_error err;
105
      raise exc
100 106
  in
101 107
  (* Extracting dependencies *)
102 108
  report ~level:1 (fun fmt -> fprintf fmt ".. extracting dependencies@,@?");
src/parse.ml
34 34
    Parsing.clear_parser ();
35 35
    ast
36 36
  with
37
    Parsing.Parse_error ->
38
      let loc = Location.curr lexbuf in
39
      raise (Syntax_err loc)
37
  | Parsing.Parse_error ->
38
    let loc = Location.curr lexbuf in
39
    raise (Syntax_err loc)
40 40

  
41 41
let prog parse lex = wrap parse lex
42 42

  
src/parserLustreSpec.mly
189 189
| IDENT {
190 190
  try 
191 191
    mktyp (Hashtbl.find Corelang.type_table (Tydec_const $1))
192
  with Not_found -> raise (Corelang.Unbound_type ((Tydec_const $1),Location.symbol_rloc()))
192
  with Not_found -> raise (Corelang.Error (Corelang.Unbound_symbol ("type " ^ $1), Location.symbol_rloc()))
193 193
}
194 194
| TFLOAT {mktyp Tydec_float}
195 195
| TREAL {mktyp Tydec_real}
src/parser_lustre.mly
42 42
let mkdim_appl f args = mkdim_appl (Location.symbol_rloc ()) f args
43 43
let mkdim_ite i t e = mkdim_ite (Location.symbol_rloc ()) i t e
44 44

  
45
let add_symbol msg hashtbl name value =
46
 if Hashtbl.mem hashtbl name
47
 then raise (Corelang.Error (Corelang.Already_bound_symbol msg, Location.symbol_rloc ()))
48
 else Hashtbl.add hashtbl name value
49

  
50
let check_symbol msg hashtbl name =
51
 if not (Hashtbl.mem hashtbl name)
52
 then raise (Corelang.Error (Corelang.Unbound_symbol msg, Location.symbol_rloc ()))
53
 else ()
54

  
45 55
%}
46 56

  
47 57
%token <int> INT
......
130 140
			     nodei_stateless = $12;
131 141
			     nodei_spec = None})
132 142
    in
133
    Hashtbl.add node_table $2 nd; nd}
143
    add_symbol ("node " ^ $2) node_table $2 nd; nd}
134 144

  
135 145
| nodespec_list NODE IDENT LPAR vdecl_list SCOL_opt RPAR RETURNS LPAR vdecl_list SCOL_opt RPAR stateless_opt SCOL
136 146
    {let nd = mktop_decl (ImportedNode
......
142 152
			     nodei_stateless = $13;
143 153
			     nodei_spec = Some $1})
144 154
    in
145
    Hashtbl.add node_table $3 nd; nd}
155
    add_symbol ("node " ^ $3) node_table $3 nd; nd}
146 156

  
147 157
| FUNCTION IDENT LPAR vdecl_list SCOL_opt RPAR RETURNS LPAR vdecl_list SCOL_opt RPAR SCOL
148 158
    {let nd = mktop_decl (ImportedNode
......
154 164
			     nodei_stateless = true;
155 165
			     nodei_spec = None})
156 166
     in
157
     Hashtbl.add node_table $2 nd; nd}
167
     add_symbol ("function " ^ $2) node_table $2 nd; nd}
158 168

  
159 169
| nodespec_list FUNCTION IDENT LPAR vdecl_list SCOL_opt RPAR RETURNS LPAR vdecl_list SCOL_opt RPAR SCOL
160 170
    {let nd = mktop_decl (ImportedNode
......
166 176
			     nodei_stateless = true;
167 177
			     nodei_spec = Some $1})
168 178
     in
169
    Hashtbl.add node_table $3 nd; nd}
179
    add_symbol ("function " ^ $3) node_table $3 nd; nd}
170 180

  
171 181
top_decl:
172 182
| CONST cdecl_list { mktop_decl (Consts (List.rev $2)) }
......
187 197
			     node_spec = None;
188 198
			     node_annot = match annots with [] -> None | _ -> Some annots})
189 199
    in
190
    Hashtbl.add node_table $2 nd; nd}
200
    add_symbol ("node " ^ $2) node_table $2 nd; nd}
191 201

  
192 202
| nodespec_list NODE IDENT LPAR vdecl_list SCOL_opt RPAR RETURNS LPAR vdecl_list SCOL_opt RPAR SCOL_opt locals LET eq_list TEL 
193 203
    {let eqs, asserts, annots = $16 in
......
205 215
			     node_spec = Some $1;
206 216
			     node_annot = match annots with [] -> None | _ -> Some annots})
207 217
    in
208
    Hashtbl.add node_table $3 nd; nd}
218
    add_symbol ("node " ^ $3) node_table $3 nd; nd}
209 219

  
210 220
nodespec_list:
211 221
NODESPEC { $1 }
......
222 232
typ_def:
223 233
  TYPE IDENT EQ typeconst {
224 234
    try
225
      Hashtbl.add type_table (Tydec_const $2) (Corelang.get_repr_type $4)
226
    with Not_found-> raise (Corelang.Unbound_type ($4, Location.symbol_rloc())) }
235
      add_symbol ("type " ^ $2) type_table (Tydec_const $2) (Corelang.get_repr_type $4)
236
    with Not_found-> assert false }
227 237
| TYPE IDENT EQ ENUM LCUR tag_list RCUR { Hashtbl.add type_table (Tydec_const $2) (Tydec_enum ($6 (Tydec_const $2))) }
228 238
| TYPE IDENT EQ STRUCT LCUR field_list RCUR { Hashtbl.add type_table (Tydec_const $2) (Tydec_struct ($6 (Tydec_const $2))) }
229 239

  
......
236 246
| TBOOL array_typ_decl { $2 Tydec_bool  }
237 247
| TREAL array_typ_decl { $2 Tydec_real  }
238 248
| TFLOAT array_typ_decl { $2 Tydec_float }
239
| IDENT array_typ_decl { $2 (Tydec_const $1) }
249
| IDENT array_typ_decl { check_symbol ("type " ^ $1) type_table (Tydec_const $1); $2 (Tydec_const $1) }
240 250
| TBOOL TCLOCK  { Tydec_clock Tydec_bool }
241 251
| IDENT TCLOCK  { Tydec_clock (Tydec_const $1) }
242 252

  
243 253
tag_list:
244 254
  IDENT
245
  { (fun t -> if Hashtbl.mem tag_table $1
246
              then raise (Corelang.Already_bound_label ($1, t, Location.symbol_rloc ()))
247
              else (Hashtbl.add tag_table $1 t; $1 :: [])) }
255
  { (fun t -> add_symbol ("tag " ^ $1) tag_table $1 t; $1 :: []) }
248 256
| tag_list COMMA IDENT
249
  { (fun t -> if Hashtbl.mem tag_table $3
250
              then raise (Corelang.Already_bound_label ($3, t, Location.symbol_rloc ()))
251
              else (Hashtbl.add tag_table $3 t; $3 :: ($1 t))) }
257
  { (fun t -> add_symbol ("tag " ^ $3)tag_table $3 t; $3 :: ($1 t)) }
252 258

  
253 259
field_list:
254 260
  { (fun t -> []) }
255 261
| field_list IDENT COL typeconst SCOL
256
  { (fun t -> if Hashtbl.mem field_table $2
257
              then raise (Corelang.Already_bound_label ($2, t, Location.symbol_rloc ()))
258
              else (Hashtbl.add field_table $2 t; ($1 t) @ [ ($2, $4) ])) }
262
  { (fun t -> add_symbol ("field " ^ $2) field_table $2 t; ($1 t) @ [ ($2, $4) ]) }
259 263

  
260 264
eq_list:
261 265
  { [], [], [] }
src/typing.ml
124 124
      Type_predef.type_array d (type_coretype type_dim ty)
125 125
    end
126 126

  
127
(* [coretype_type is the reciprocal of [type_typecore] *)
127
(* [coretype_type] is the reciprocal of [type_typecore] *)
128 128
let rec coretype_type ty =
129 129
 match (repr ty).tdesc with
130 130
 | Tvar           -> Tydec_any
......
303 303
  | Dimension.Unify _ ->
304 304
    raise (Error (loc, Type_clash (ty1,ty2)))
305 305

  
306
let type_struct_field loc ftyp (label, f) =
306
let rec type_struct_const_field loc (label, c) =
307 307
  if Hashtbl.mem field_table label
308 308
  then let tydec = Hashtbl.find field_table label in
309 309
       let tydec_struct = get_struct_type_fields tydec in
310 310
       let ty_label = type_coretype (fun d -> ()) (List.assoc label tydec_struct) in
311 311
       begin
312
	 try_unify ty_label (ftyp loc f) loc;
312
	 try_unify ty_label (type_const loc c) loc;
313 313
	 type_coretype (fun d -> ()) tydec
314 314
       end
315 315
  else raise (Error (loc, Unbound_value ("struct field " ^ label)))
316 316

  
317
let rec type_const loc c = 
317
and type_const loc c = 
318 318
  match c with
319 319
  | Const_int _     -> Type_predef.type_int
320 320
  | Const_real _    -> Type_predef.type_real
......
330 330
  | Const_struct fl ->
331 331
    let ty_struct = new_var () in
332 332
    begin
333
      List.iter (fun f -> try_unify ty_struct (type_struct_field loc type_const f) loc) fl;
334
      ty_struct
333
      let used =
334
	List.fold_left
335
	  (fun acc (l, c) ->
336
	    if List.mem l acc
337
	    then raise (Error (loc, Already_bound ("struct field " ^ l)))
338
	    else try_unify ty_struct (type_struct_const_field loc (l, c)) loc; l::acc)
339
	  [] fl in
340
      try
341
	let total = List.map fst (get_struct_type_fields (coretype_type ty_struct)) in
342
(*	List.iter (fun l -> Format.eprintf "total: %s@." l) total;
343
	List.iter (fun l -> Format.eprintf "used: %s@." l) used; *)
344
	let undef = List.find (fun l -> not (List.mem l used)) total
345
	in raise (Error (loc, Unbound_value ("struct field " ^ undef)))
346
      with Not_found -> 
347
	ty_struct
335 348
    end
336 349

  
337 350
(* The following typing functions take as parameter an environment [env]

Also available in: Unified diff