Project

General

Profile

Revision b616fe7a

View differences:

src/basic_library.ml
118 118
let is_internal_fun x =
119 119
  List.mem x internal_funs
120 120

  
121
(*
122
let imported_node name inputs outputs sl spec =
123
  mktop_decl Location.dummy_loc
124
    (
125
      ImportedNode
126
	{nodei_id = name;
127
	 nodei_type = Types.new_var ();
128
	 nodei_clock = Clocks.new_var true;
129
	 nodei_inputs = inputs;
130
	 nodei_outputs = outputs;
131
	 nodei_stateless = sl;
132
	nodei_spec = spec})
133
    
134
let mk_new_var id =
135
  let loc = Location.dummy_loc in
136
  mkvar_decl loc (id, mktyp loc Tydec_any, mkclock loc Ckdec_any, false)
137

  
138
let _ = 
139
  let binary_fun id = id, [mk_new_var "x"; mk_new_var "y"], [mk_new_var "z"] in
140
  let unary_fun id = id, [mk_new_var "x"], [mk_new_var "y"] in
141
  (* All following functions are stateless *)
142
  let st = true in
143
  List.iter (fun (n,i,o) -> Hashtbl.add node_table n (imported_node n i o st None))
144
    (
145
(*("ite", [mk_new_var "g"; mk_new_var "x"; mk_new_var "y"], [mk_new_var "z"])::*)
146
    (List.map binary_fun
147
	["+";"-";"*";"/";"mod";"&&";"||";"xor";"impl";"<";">";"<=";">=";"!=";"="])
148
     @(List.map unary_fun ["uminus";"not"]))
149
*)  
121

  
150 122
let pp_c i pp_val fmt vl =
151 123
  match i, vl with
152 124
  (*  | "ite", [v1; v2; v3] -> Format.fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2 pp_val v3 *)
src/clock_calculus.ml
572 572

  
573 573
(* computes clocks for node application *)
574 574
and clock_appl env f args clock_reset loc =
575
 let args = expr_list_of_expr args in
576
  if Basic_library.is_internal_fun f && List.exists is_tuple_expr args
577
  then
578
      let args = Utils.transpose_list (List.map expr_list_of_expr args) in
579
      Clocks.clock_of_clock_list (List.map (fun args -> clock_call env f args clock_reset loc) args)
580
  else
581
    clock_call env f args clock_reset loc
582

  
583
and clock_call env f args clock_reset loc =
575 584
  let cfun = clock_ident false env f loc in
576 585
  let cins, couts = split_arrow cfun in
577 586
  let cins = clock_list_of_clock cins in
578
  let args = expr_list_of_expr args in
579 587
  List.iter2 (clock_subtyping_arg env) args cins;
580 588
  unify_imported_clock (Some clock_reset) cfun;
581 589
  couts
......
716 724
      expr.expr_clock <- ck;
717 725
      ck
718 726
  in
719
  Log.report ~level:3 (fun fmt -> Format.fprintf fmt "Clock of expr %a: %a@." Printers.pp_expr expr Clocks.print_ck resulting_ck);
727
  Log.report ~level:4 (fun fmt -> Format.fprintf fmt "Clock of expr %a: %a@." Printers.pp_expr expr Clocks.print_ck resulting_ck);
720 728
  resulting_ck
721 729

  
722 730
let clock_of_vlist vars =
src/corelang.ml
225 225
let mkpredef_call loc funname args =
226 226
  mkexpr loc (Expr_appl (funname, mkexpr loc (Expr_tuple args), None))
227 227

  
228
let mkpredef_unary_call loc funname arg =
229
  mkexpr loc (Expr_appl (funname, arg, None))
230

  
231

  
232 228
(***********************************************************)
233 229
(* Fast access to nodes, by name *)
234 230
let (node_table : (ident, top_decl) Hashtbl.t) = Hashtbl.create 30
......
369 365
   expr_loc = loc;
370 366
   expr_annot = None}
371 367

  
368
let is_tuple_expr expr =
369
 match expr.expr_desc with
370
  | Expr_tuple _ -> true
371
  | _            -> false
372

  
372 373
let expr_list_of_expr expr =
373 374
  match expr.expr_desc with
374 375
  | Expr_tuple elist ->
src/corelang.mli
173 173
val mkassert: Location.t -> expr -> assert_t
174 174
val mktop_decl: Location.t -> top_decl_desc -> top_decl
175 175
val mkpredef_call: Location.t -> ident -> expr list -> expr
176
val mkpredef_unary_call: Location.t -> ident -> expr -> expr
177 176
val mk_new_name: var_decl list -> ident -> ident
178 177

  
179 178

  
......
218 217
val pp_error :  Format.formatter -> error -> unit
219 218

  
220 219
(* Caution, returns an untyped, unclocked, etc, expression *)
220
val is_tuple_expr : expr -> bool
221 221
val expr_of_ident : ident -> Location.t -> expr
222 222
val expr_list_of_expr : expr -> expr list
223 223
val expr_of_expr_list : Location.t -> expr list -> expr
src/parser_lustre.mly
34 34
let mkassert x = mkassert (Location.symbol_rloc ()) x
35 35
let mktop_decl x = mktop_decl (Location.symbol_rloc ()) x
36 36
let mkpredef_call x = mkpredef_call (Location.symbol_rloc ()) x
37
let mkpredef_unary_call x = mkpredef_unary_call (Location.symbol_rloc ()) x
38 37

  
39 38
let mkdim_int i = mkdim_int (Location.symbol_rloc ()) i
40 39
let mkdim_bool b = mkdim_bool (Location.symbol_rloc ()) b
......
360 359
| expr XOR expr 
361 360
    {mkpredef_call "xor" [$1;$3]}
362 361
| NOT expr 
363
    {mkpredef_unary_call "not" $2}
362
    {mkpredef_call "not" [$2]}
364 363
| expr IMPL expr 
365 364
    {mkpredef_call "impl" [$1;$3]}
366 365

  
......
388 387
| expr DIV expr 
389 388
    {mkpredef_call "/" [$1;$3]}
390 389
| MINUS expr %prec UMINUS
391
  {mkpredef_unary_call "uminus" $2}
390
  {mkpredef_call "uminus" [$2]}
392 391
| expr MOD expr 
393 392
    {mkpredef_call "mod" [$1;$3]}
394 393

  
src/types.ml
56 56
  | Not_a_dimension
57 57
  | Not_a_constant
58 58
  | WrongArity of int * int
59
  | WrongMorphism of int * int
59 60
  | Type_clash of type_expr * type_expr
60 61
  | Poly_imported_node of ident
61 62

  
......
158 159
    fprintf fmt "This expression is not a valid dimension@."
159 160
  | WrongArity (ar1, ar2) ->
160 161
    fprintf fmt "Expecting %d argument(s), found %d@." ar1 ar2
162
  | WrongMorphism (ar1, ar2) ->
163
    fprintf fmt "Expecting %d argument(s) for homomorphic extension, found %d@." ar1 ar2
161 164
  | Undefined_var vmap ->
162 165
    fprintf fmt "No definition provided for variable(s): %a@."
163 166
      (Utils.fprintf_list ~sep:"," pp_print_string)
......
211 214
 | Tstatic (_, ty') -> is_dimension_type ty'
212 215
 | _                -> false
213 216

  
214
let rec dynamic_type ty =
217
let dynamic_type ty =
215 218
  let ty = repr ty in
216 219
  match ty.tdesc with
217 220
  | Tstatic (_, ty') -> ty'
218 221
  | _                -> ty
219 222

  
223
let is_tuple_type ty =
224
 match (repr ty).tdesc with
225
 | Ttuple _         -> true
226
 | _                -> false
227

  
228
let rec is_nested_tuple_type ty =
229
 match (repr ty).tdesc with
230
 | Ttuple tl        -> List.exists is_tuple_type tl
231
 | _                -> false
232

  
220 233
let map_tuple_type f ty =
221 234
  let ty = dynamic_type ty in
222 235
  match ty.tdesc with
223 236
  | (Ttuple ty_list) -> { ty with tdesc = Ttuple (List.map f ty_list) }
224 237
  | _                -> f ty
225 238

  
226
let rec is_struct_type ty =
239
let is_struct_type ty =
227 240
 match (repr ty).tdesc with
228 241
 | Tstruct _        -> true
229 242
 | _                -> false
src/typing.ml
417 417
(* typing an application implies:
418 418
   - checking that const formal parameters match real const (maybe symbolic) arguments
419 419
   - checking type adequation between formal and real arguments
420
   An application may embed an homomorphic/internal function, in which case we need to split
421
   it in many calls
420 422
*)
421 423
and type_appl env in_main loc const f args =
424
  let args = expr_list_of_expr args in
425
  if Basic_library.is_internal_fun f && List.exists is_tuple_expr args
426
  then
427
    try
428
      let args = Utils.transpose_list (List.map expr_list_of_expr args) in
429
      Types.type_of_type_list (List.map (type_call env in_main loc const f) args)
430
    with
431
      Utils.TransposeError (l, l') -> raise (Error (loc, WrongMorphism (l, l')))
432
  else
433
    type_call env in_main loc const f args
434

  
435
(* type a (single) call. [args] is here a list of arguments. *)
436
and type_call env in_main loc const f args =
422 437
  let tfun = type_ident env in_main loc const f in
423 438
  let tins, touts = split_arrow tfun in
424 439
  let tins = type_list_of_type tins in
425
  let args = expr_list_of_expr args in
426 440
  if List.length args <> List.length tins then
427 441
    raise (Error (loc, WrongArity (List.length args, List.length tins)))
428 442
  else
......
432 446
(** [type_expr env in_main expr] types expression [expr] in environment
433 447
    [env], expecting it to be [const] or not. *)
434 448
and type_expr env in_main const expr =
435
  let res = 
449
  let resulting_ty = 
436 450
  match expr.expr_desc with
437 451
  | Expr_const c ->
438 452
    let ty = type_const expr.expr_loc c in
......
541 555
      let ty = type_expr env in_main const e in
542 556
      expr.expr_type <- ty;
543 557
      ty
544
  in (*Format.eprintf "typing %B %a at %a = %a@." const Printers.pp_expr expr Location.pp_loc expr.expr_loc Types.print_ty res;*) res
558
  in 
559
  Log.report ~level:3 (fun fmt -> Format.fprintf fmt "Type of expr %a: %a@." Printers.pp_expr expr Types.print_ty resulting_ty);
560
  resulting_ty
545 561

  
546 562
and type_branches env in_main loc const hl =
547 563
  let typ_in = new_var () in
src/utils.ml
26 26
type tag = int
27 27
type longident = (string * tag) list
28 28

  
29
exception TransposeError of int*int
30

  
29 31
(** General utility functions. *)
30 32
let create_hashtable size init =
31 33
  let tbl = Hashtbl.create size in
......
69 71
let rec repeat n f x =
70 72
 if n <= 0 then x else repeat (n-1) f (f x)
71 73

  
72
let rec transpose_list ll =
73
 match ll with
74
 | []   -> []
75
 | [l]  -> List.map (fun el -> [el]) l
76
 | l::q -> 
77
   let length_l = List.length l in
78
   if not (List.for_all (fun l' -> List.length l' = length_l) q) then
79
     assert false
80
   ;
81
   List.map2 (fun el eq -> el::eq) l (transpose_list q)
74
let transpose_list ll =
75
  let rec transpose ll =
76
    match ll with
77
    | []   -> []
78
    | [l]  -> List.map (fun el -> [el]) l
79
    | l::q -> List.map2 (fun el eq -> el::eq) l (transpose q)
80
  in match ll with
81
  | []   -> []
82
  | l::q -> let length_l = List.length l in
83
	    List.iter (fun l' -> let length_l' = List.length l'
84
				 in if length_l <> length_l' then raise (TransposeError (length_l, length_l'))) q;
85
	    transpose ll
82 86

  
83 87
let rec filter_upto p n l =
84 88
 if n = 0 then [] else

Also available in: Unified diff