Project

General

Profile

Revision 12af4908

View differences:

src/c_backend.ml
208 208
(* Prints a constant value *)
209 209
let rec pp_c_const fmt c =
210 210
  match c with
211
    | Const_int i    -> pp_print_int fmt i
212
    | Const_real r   -> pp_print_string fmt r
213
    | Const_float r  -> pp_print_float fmt r
214
    | Const_tag t    -> pp_c_tag fmt t
215
    | Const_array ca -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:"," pp_c_const) ca
211
    | Const_int i     -> pp_print_int fmt i
212
    | Const_real r    -> pp_print_string fmt r
213
    | Const_float r   -> pp_print_float fmt r
214
    | Const_tag t     -> pp_c_tag fmt t
215
    | Const_array ca  -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " pp_c_const) ca
216
    | Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> pp_c_const fmt c)) fl
216 217

  
217 218
(* Prints a value expression [v], with internal function calls only.
218 219
   [pp_var] is a printer for variables (typically [pp_c_var_read]),
src/corelang.ml
39 39
  | Const_float of float
40 40
  | Const_array of constant list
41 41
  | Const_tag of label
42
  | Const_struct of (label * constant) list
42 43

  
43 44
type type_dec = LustreSpec.type_dec
44 45

  
src/corelang.mli
34 34
  | Const_float of float
35 35
  | Const_array of constant list
36 36
  | Const_tag  of label
37
  | Const_struct of (label * constant) list
37 38

  
38 39
val dummy_type_dec: type_dec
39 40

  
src/env.ml
37 37
  IMap.mem ident env
38 38

  
39 39
let iter env f = IMap.iter f env
40
 
40

  
41
(* Merges x and y. In case of conflicting definitions,
42
   overwrites definitions in x by definitions in y *)
41 43
let overwrite x y =
42 44
  IMap.merge (
43 45
    fun k _old _new -> match _new with
src/horn_backend.ml
95 95
    | Const_real r   -> pp_print_string fmt r
96 96
    | Const_float r  -> pp_print_float fmt r
97 97
    | Const_tag t    -> pp_horn_tag fmt t
98
    | Const_array ca -> assert false
98
    | _              -> assert false
99 99

  
100 100
(* Prints a value expression [v], with internal function calls only.
101 101
   [pp_var] is a printer for variables (typically [pp_c_var_read]),
src/main_lustre_compiler.ml
180 180
      let _, declared_types_env, declared_clocks_env = check_lusi header in
181 181
      (* checking type compatibility with computed types*)
182 182
      Typing.check_env_compat header declared_types_env computed_types_env;
183
      (* checking clocks compatibilty with computed clocks*)
183
      (* checking clocks compatibility with computed clocks*)
184 184
      Clock_calculus.check_env_compat header declared_clocks_env computed_clocks_env;
185 185
      Typing.uneval_prog_generics prog
186 186
    with Sys_error _ -> ( 
src/parser_lustre.mly
422 422
| signed_const { [$1] }
423 423
| signed_const COMMA signed_const_array { $1 :: $3 }
424 424

  
425
signed_const_struct:
426
| IDENT EQ signed_const { [ ($1, $3) ] }
427
| IDENT EQ signed_const COMMA signed_const_struct { ($1, $3) :: $5 }
428

  
425 429
signed_const:
426 430
  INT {Const_int $1}
427 431
| REAL {Const_real $1}
......
430 434
| MINUS INT {Const_int (-1 * $2)}
431 435
| MINUS REAL {Const_real ("-" ^ $2)}
432 436
| MINUS FLOAT {Const_float (-1. *. $2)}
437
| LCUR signed_const_struct RCUR { Const_struct $2 }
433 438
| LBRACKET signed_const_array RBRACKET { Const_array $2 }
434 439

  
435 440
dim:
src/printers.ml
40 40

  
41 41
let pp_eq_lhs = fprintf_list ~sep:", " pp_print_string
42 42

  
43
let rec pp_const fmt c = 
43
let rec pp_struct_const_field fmt (label, c) =
44
  fprintf fmt "%a = %a;" pp_print_string label pp_const c
45
and pp_const fmt c = 
44 46
  match c with
45 47
    | Const_int i -> pp_print_int fmt i
46 48
    | Const_real r -> pp_print_string fmt r
47 49
    | Const_float r -> pp_print_float fmt r
48 50
    | Const_tag  t -> pp_print_string fmt t
49 51
    | Const_array ca -> Format.fprintf fmt "[%a]" (Utils.fprintf_list ~sep:"," pp_const) ca
52
    | Const_struct fl -> Format.fprintf fmt "{%a }" (Utils.fprintf_list ~sep:" " pp_struct_const_field) fl
50 53

  
51 54
and pp_var fmt id = fprintf fmt "%s%s: %a" (if id.var_dec_const then "const " else "") id.var_id Types.print_ty id.var_type
52 55

  
src/type_predef.ml
29 29
let type_clock ty = new_ty (Tclock ty)
30 30
let type_const tname = new_ty (Tconst tname)
31 31
let type_enum taglist = new_ty (Tenum taglist)
32
let type_struct fieldlist = new_ty (Tstruct fieldlist)
32 33
let type_tuple tl = new_ty (Ttuple tl)
33 34
let type_arrow ty1 ty2 = new_ty (Tarrow (ty1, ty2))
34 35
let type_array d ty = new_ty (Tarray (d, ty))
src/types.ml
39 39
  | Tarrow of type_expr * type_expr
40 40
  | Ttuple of type_expr list
41 41
  | Tenum of ident list
42
  | Tstruct of (ident * type_expr) list
42 43
  | Tarray of dim_expr * type_expr
43 44
  | Tstatic of dim_expr * type_expr (* a type carried by a dimension expression *)
44 45
  | Tlink of type_expr (* During unification, make links instead of substitutions *)
......
62 63

  
63 64
(* Pretty-print*)
64 65
open Format
65
  
66
let rec print_ty fmt ty =
66

  
67
let rec print_struct_ty_field fmt (label, ty) =
68
  fprintf fmt "%a : %a" pp_print_string label print_ty ty
69
and print_ty fmt ty =
67 70
  match ty.tdesc with
68 71
  | Tvar ->
69 72
    fprintf fmt "_%s" (name_of_type ty.tid)
......
87 90
    fprintf fmt "(%a)"
88 91
      (Utils.fprintf_list ~sep:"*" print_ty) tylist
89 92
  | Tenum taglist ->
90
    fprintf fmt "(%a)"
91
      (Utils.fprintf_list ~sep:" + " pp_print_string) taglist
93
    fprintf fmt "enum {%a }"
94
      (Utils.fprintf_list ~sep:", " pp_print_string) taglist
95
  | Tstruct fieldlist ->
96
    fprintf fmt "struct {%a }"
97
      (Utils.fprintf_list ~sep:"; " print_struct_ty_field) fieldlist
92 98
  | Tarray (e, ty) ->
93 99
    fprintf fmt "%a^%a" print_ty ty Dimension.pp_dimension e
94 100
  | Tlink ty ->
......
96 102
  | Tunivar ->
97 103
    fprintf fmt "'%s" (name_of_type ty.tid)
98 104

  
99
let rec print_node_ty fmt ty =
105
let rec print_node_struct_ty_field fmt (label, ty) =
106
  fprintf fmt "%a : %a" pp_print_string label print_node_ty ty
107
and print_node_ty fmt ty =
100 108
  match ty.tdesc with
101 109
  | Tint ->
102 110
    fprintf fmt "int"
......
118 126
    fprintf fmt "(%a)"
119 127
      (Utils.fprintf_list ~sep:"*" print_ty) tylist
120 128
  | Tenum taglist ->
121
    fprintf fmt "(%a)"
122
      (Utils.fprintf_list ~sep:" + " pp_print_string) taglist
129
    fprintf fmt "enum {%a }"
130
      (Utils.fprintf_list ~sep:", " pp_print_string) taglist
131
  | Tstruct fieldlist ->
132
    fprintf fmt "struct {%a }"
133
      (Utils.fprintf_list ~sep:"; " print_node_struct_ty_field) fieldlist
123 134
  | Tarray (e, ty) ->
124 135
    fprintf fmt "%a^%a" print_ty ty Dimension.pp_dimension e
125 136
  | Tlink ty ->
......
172 183
  | t -> t
173 184

  
174 185
let get_static_value ty =
175
 match (repr ty).tdesc with
176
 | Tstatic (d, _) -> Some d
177
 | _              -> None
186
  match (repr ty).tdesc with
187
  | Tstatic (d, _) -> Some d
188
  | _              -> None
189

  
190
let get_field_type ty label =
191
  match (repr ty).tdesc with
192
  | Tstruct fl -> (try Some (List.assoc label fl) with Not_found -> None)
193
  | _          -> None
178 194

  
179 195
let is_clock_type ty =
180 196
 match (repr ty).tdesc with
......
263 279
  | Tclock ty -> is_polymorphic ty
264 280
  | Tarrow (ty1,ty2) -> (is_polymorphic ty1) || (is_polymorphic ty2)
265 281
  | Ttuple tl -> List.exists (fun t -> is_polymorphic t) tl
282
  | Tstruct fl -> List.exists (fun (_, t) -> is_polymorphic t) fl
266 283
  | Tlink t' -> is_polymorphic t'
267 284
  | Tarray (d, ty)
268 285
  | Tstatic (d, ty) -> Dimension.is_polymorphic d || is_polymorphic ty
src/typing.ml
48 48
  | Tarrow (t1, t2) ->
49 49
      (occurs tvar t1) || (occurs tvar t2)
50 50
  | Ttuple tl ->
51
      List.exists (occurs tvar) tl
51
     List.exists (occurs tvar) tl
52
  | Tstruct fl ->
53
     List.exists (fun (f, t) -> occurs tvar t) fl
52 54
  | Tarray (_, t)
53 55
  | Tstatic (_, t)
54 56
  | Tclock t
......
64 66
      ty.tdesc <- Tunivar
65 67
  | Tarrow (t1,t2) ->
66 68
      generalize t1; generalize t2
67
  | Ttuple tlist ->
68
      List.iter generalize tlist
69
  | Ttuple tl ->
70
     List.iter generalize tl
71
  | Tstruct fl ->
72
     List.iter (fun (f, t) -> generalize t) fl
69 73
  | Tstatic (d, t)
70 74
  | Tarray (d, t) -> Dimension.generalize d; generalize t
71 75
  | Tclock t
......
83 87
       Tarrow ((instantiate inst_vars inst_dim_vars t1), (instantiate inst_vars inst_dim_vars t2))}
84 88
  | Ttuple tlist ->
85 89
      {ty with tdesc = Ttuple (List.map (instantiate inst_vars inst_dim_vars) tlist)}
90
  | Tstruct flist ->
91
      {ty with tdesc = Tstruct (List.map (fun (f, t) -> (f, instantiate inst_vars inst_dim_vars t)) flist)}
86 92
  | Tclock t ->
87 93
	{ty with tdesc = Tclock (instantiate inst_vars inst_dim_vars t)}
88 94
  | Tstatic (d, t) ->
......
111 117
  | Tydec_clock ty -> Type_predef.type_clock (type_coretype type_dim ty)
112 118
  | Tydec_const c -> Type_predef.type_const c
113 119
  | Tydec_enum tl -> Type_predef.type_enum tl
114
  | Tydec_struct fl -> assert false (*Type_predef.type_struct fl*)
120
  | Tydec_struct fl -> Type_predef.type_struct (List.map (fun (f, ty) -> (f, type_coretype type_dim ty)) fl)
115 121
  | Tydec_array (d, ty) ->
116 122
    begin
117 123
      type_dim d;
......
128 134
 | Tconst c       -> Tydec_const c
129 135
 | Tclock t       -> Tydec_clock (coretype_type t)
130 136
 | Tenum tl       -> Tydec_enum tl
137
 | Tstruct fl     -> Tydec_struct (List.map (fun (f, t) -> (f, coretype_type t)) fl)
131 138
 | Tarray (d, t)  -> Tydec_array (d, coretype_type t)
132 139
 | Tstatic (_, t) -> coretype_type t
133 140
 | _         -> assert false
......
163 170
        unify t1 t1';
164 171
	unify t2 t2'
165 172
      end
166
    | Ttuple tlist1, Ttuple tlist2 ->
167
        if (List.length tlist1) <> (List.length tlist2) then
168
	  raise (Unify (t1, t2))
169
	else
170
          List.iter2 unify tlist1 tlist2
173
    | Ttuple tl, Ttuple tl' when List.length tl = List.length tl' ->
174
      List.iter2 unify tl tl'
175
    | Tstruct fl, Tstruct fl' when List.map fst fl = List.map fst fl' ->
176
      List.iter2 (fun (_, t) (_, t') -> unify t t') fl fl'
171 177
    | Tclock _, Tstatic _
172 178
    | Tstatic _, Tclock _ -> raise (Unify (t1, t2))
173 179
    | Tclock t1', _ -> unify t1' t2
......
216 222
        semi_unify t1 t1';
217 223
	semi_unify t2 t2'
218 224
      end
219
    | Ttuple tlist1, Ttuple tlist2 ->
220
        if (List.length tlist1) <> (List.length tlist2) then
221
	  raise (Unify (t1, t2))
222
	else
223
          List.iter2 semi_unify tlist1 tlist2
225
    | Ttuple tl, Ttuple tl' when List.length tl = List.length tl' ->
226
      List.iter2 semi_unify tl tl'
227
    | Tstruct fl, Tstruct fl' when List.map fst fl = List.map fst fl' ->
228
      List.iter2 (fun (_, t) (_, t') -> semi_unify t t') fl fl'
224 229
    | Tclock _, Tstatic _
225 230
    | Tstatic _, Tclock _ -> raise (Unify (t1, t2))
226 231
    | Tclock t1', _ -> semi_unify t1' t2
......
234 239
      let def_t = get_type_definition t in
235 240
      semi_unify t1 def_t
236 241
    | Tenum tl, Tenum tl' when tl == tl' -> ()
242

  
237 243
    | Tstatic (e1, t1'), Tstatic (e2, t2')
238 244
    | Tarray (e1, t1'), Tarray (e2, t2') ->
239 245
      begin
......
244 250
      end
245 251
    | _,_ -> raise (Unify (t1, t2))
246 252

  
253
(* Expected type ty1, got type ty2 *)
247 254
let try_unify ty1 ty2 loc =
248 255
  try
249 256
    unify ty1 ty2
......
262 269
  | Dimension.Unify _ ->
263 270
    raise (Error (loc, Type_clash (ty1,ty2)))
264 271

  
272
(* ty1 is a subtype of ty2 *)
273
let rec sub_unify sub ty1 ty2 =
274
  match (repr ty1).tdesc, (repr ty2).tdesc with
275
  | Ttuple [t1]        , Ttuple [t2]        -> sub_unify sub t1 t2
276
  | Ttuple tl1         , Ttuple tl2         ->
277
    if List.length tl1 <> List.length tl2
278
    then raise (Unify (ty1, ty2))
279
    else List.iter2 (sub_unify sub) tl1 tl2
280
  | Ttuple [t1]        , _                  -> sub_unify sub t1 ty2
281
  | _                  , Ttuple [t2]        -> sub_unify sub ty1 t2
282
  | Tstruct tl1        , Tstruct tl2        ->
283
    if List.map fst tl1 <> List.map fst tl2
284
    then raise (Unify (ty1, ty2))
285
    else List.iter2 (fun (_, t1) (_, t2) -> sub_unify sub t1 t2) tl1 tl2
286
  | Tstatic (d1, t1)   , Tstatic (d2, t2)   ->
287
    begin
288
      sub_unify sub t1 t2;
289
      Dimension.eval Basic_library.eval_env (fun c -> None) d1;
290
      Dimension.eval Basic_library.eval_env (fun c -> None) d2;
291
      Dimension.unify d1 d2
292
    end
293
  | Tstatic (r_d, t1)  , _         when sub -> sub_unify sub ty2 t1
294
  | _                                       -> unify ty2 ty1
295

  
296
let try_sub_unify sub ty1 ty2 loc =
297
  try
298
    sub_unify sub ty1 ty2
299
  with
300
  | Unify _ ->
301
    raise (Error (loc, Type_clash (ty1,ty2)))
302
  | Dimension.Unify _ ->
303
    raise (Error (loc, Type_clash (ty1,ty2)))
304

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

  
265 316
let rec type_const loc c = 
266 317
  match c with
267
  | Const_int _ -> Type_predef.type_int
268
  | Const_real _ -> Type_predef.type_real
269
  | Const_float _ -> Type_predef.type_real
270
  | Const_array ca -> let d = Dimension.mkdim_int loc (List.length ca) in
318
  | Const_int _     -> Type_predef.type_int
319
  | Const_real _    -> Type_predef.type_real
320
  | Const_float _   -> Type_predef.type_real
321
  | Const_array ca  -> let d = Dimension.mkdim_int loc (List.length ca) in
271 322
		      let ty = new_var () in
272
		      List.iter (fun e -> try_unify (type_const loc e) ty loc) ca;
323
		      List.iter (fun e -> try_unify ty (type_const loc e) loc) ca;
273 324
		      Type_predef.type_array d ty
274
  | Const_tag t  ->
325
  | Const_tag t     ->
275 326
    if Hashtbl.mem tag_table t
276 327
    then type_coretype (fun d -> ()) (Hashtbl.find tag_table t)
277 328
    else raise (Error (loc, Unbound_value ("enum tag " ^ t)))
329
  | Const_struct fl ->
330
    let ty_struct = new_var () in
331
    begin
332
      List.iter (fun f -> try_unify ty_struct (type_struct_field loc type_const f) loc) fl;
333
      ty_struct
334
    end
278 335

  
279 336
(* The following typing functions take as parameter an environment [env]
280 337
   and whether the element being typed is expected to be constant [const]. 
......
317 374
	 real_static_type
318 375
    else real_type in
319 376
(*Format.eprintf "subtyping const %B real %a:%a vs formal %a@." const Printers.pp_expr real_arg Types.print_ty real_type Types.print_ty formal_type;*)
377
  try_sub_unify sub real_type formal_type loc
378
(*
379
and type_subtyping_tuple loc real_type formal_type =
320 380
  let real_types   = type_list_of_type real_type in
321 381
  let formal_types = type_list_of_type formal_type in
322 382
  if (List.length real_types) <> (List.length formal_types)
......
328 388
  | Tstatic _          , Tstatic _ when sub -> try_unify formal_type real_type loc
329 389
  | Tstatic (r_d, r_ty), _         when sub -> try_unify formal_type r_ty loc
330 390
  | _                                       -> try_unify formal_type real_type loc
331

  
391
*)
332 392
and type_ident env in_main loc const id =
333 393
  type_expr env in_main const (expr_of_ident id loc)
334 394

  

Also available in: Unified diff