Newer
Older
(* Time-stamp: <modified the 12/02/2013 (at 18:03) by Erwan Jahier> *)
open List
(* XXX changer le nom de cette fonction *)
let (dump_long : Ident.long -> string) = fun x ->
Erwan Jahier
committed
if !Global.no_prefix then
Ident.no_pack_string_of_long x
else
Ident.string_of_long x
(* fun id -> *)
(* let str = Ident.string_of_long id in *)
(* Str.global_replace (Str.regexp "::") "__" str *)
(******************************************************************************)
(******************************************************************************)
let (get_rank : 'a -> 'a list -> int) =
fun x l ->
let rec aux i l =
match l with
| [] -> assert false
| y::l -> if x = y then i else aux (i+1) l
in
aux 1 l
let _ = assert (get_rank 5 [1;3;5] = 3)
(* check it is a non-singleton tuple *)
let rec is_a_tuple (e:Lic.val_exp) : bool =
| CallByPosLic ({ it = TUPLE }, OperLic [ve]) -> is_a_tuple ve
| CallByPosLic ({ it = TUPLE }, OperLic vel) -> List.length vel > 1
| _ -> false
(******************************************************************************)
let string_of_ident x =
if !Global.no_prefix
then Ident.no_pack_string_of_long x
else Ident.string_of_long2 x
let rec string_of_const_eff =
function
| Bool_const_eff true -> "true"
| Bool_const_eff false -> "false"
Erwan Jahier
committed
| Int_const_eff i -> (sprintf "%d" i)
Erwan Jahier
committed
| Real_const_eff r -> r
| Extern_const_eff (s,t) -> (dump_long s)
| Abstract_const_eff (s,t,v,_) ->
(string_of_const_eff v)
(* | Abstract_const_eff (s,t,v,false) -> (dump_long s) *)
Erwan Jahier
committed
| Enum_const_eff (s,t) -> (dump_long s)
let string_of_field =
function (id, veff) ->
(Ident.to_string id)^" = "^ (string_of_const_eff veff)
in
let flst = List.map string_of_field fl in
(string_of_type_eff t)^"{"^(String.concat "; " flst)^"}"
)
let vl = List.map string_of_const_eff ctab in
"["^(String.concat ", " vl)^"]"
)
function
| [c] -> string_of_const_eff c
| cl -> "(" ^ (String.concat ", " (List.map string_of_const_eff cl)) ^ ")"
(* modify numbers notations in such a way that they
become "valid" identifiers. Policy:
- minus (-) becomes "m"
- plus (+) becomes "p"
- dot (d) becomes "d"
*)
and correct_num_string s =
let res = String.copy s in
let cpt = ref 0 in
let f c = (
let _ = match c with
| '-' -> (res.[!cpt] <- 'm')
| '+' -> (res.[!cpt] <- 'p')
| '.' -> (res.[!cpt] <- 'd')
| _ -> ()
in incr cpt
) in
String.iter f s;
res
and string_ident_of_const_eff c =
(* that version generates a string that is a valid lic ident, in order to use it
to generate a node name using static parameters *)
match c with
| Int_const_eff _
| Real_const_eff _ ->
correct_num_string(string_of_const_eff c)
| Extern_const_eff _
| Abstract_const_eff _
| Enum_const_eff _ -> string_of_const_eff c
| Struct_const_eff (_, t) -> (
match t with
| Struct_type_eff (sn,_) -> Ident.no_pack_string_of_long sn
| _ -> assert false
)
| Array_const_eff (ctab, t) -> string_of_type_eff t
| Tuple_const_eff cl -> string_ident_of_const_eff_list cl
match cl with
| [c] -> string_ident_of_const_eff c
| _ -> "" ^ (String.concat "_" (List.map string_ident_of_const_eff cl)) ^ ""
and string_of_const_eff_opt = function
| None -> ""
| Some val_exp_eff -> string_of_const_eff val_exp_eff
and string_def_of_type_eff = function
| Bool_type_eff -> "bool"
| Int_type_eff -> "int"
| Real_type_eff -> "real"
| External_type_eff (i) -> dump_long i
| Abstract_type_eff (i, t) -> string_def_of_type_eff t
assert (sl <>[]);
let f sep acc s = acc ^ sep ^ (dump_long s) in
(List.fold_left (f ", ") (f "" "enum {" (List.hd sl)) (List.tl sl)) ^ "}"
| Array_type_eff (ty, sz) -> sprintf "%s^%d" (string_of_type_eff ty) sz
| Struct_type_eff (name, fl) ->
assert (fl <>[]);
let f sep acc (id, (type_eff, const_eff_opt)) =
acc ^ sep ^ (Ident.to_string id) ^ " : " ^
(string_of_type_eff type_eff) ^
match const_eff_opt with
None -> ""
| Some ce -> " = " ^ (string_of_const_eff ce)
in
"struct " ^
(List.fold_left (f "; ") (f "" " {" (List.hd fl)) (List.tl fl)) ^ "}"
| TypeVar Any -> "a"
| TypeVar AnyNum -> "o"
Erwan Jahier
committed
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
and string_of_type_eff = function
| Bool_type_eff -> "bool"
| Int_type_eff -> "int"
| Real_type_eff -> "real"
| External_type_eff (name) -> (string_of_ident name)
| Abstract_type_eff (name, t) -> (string_of_ident name)
| Enum_type_eff (name, _) -> (string_of_ident name)
| Array_type_eff (ty, sz) ->
Printf.sprintf "%s^%d" (string_of_type_eff ty) sz
| Struct_type_eff (name, _) -> (string_of_ident name)
| TypeVar Any -> "any"
| (TypeVar AnyNum) -> "anynum"
and string_of_type_list = function
| [] -> ""
| [x] -> string_of_type_eff x
| l -> String.concat " * " (List.map string_of_type_eff l)
and string_of_type_profile (i, o) =
(string_of_type_list i)^" -> "^(string_of_type_list o)
and string_of_const = function
| Bool_const_eff true -> "true"
| Bool_const_eff false -> "false"
| Int_const_eff i -> (sprintf "%d" i)
| Real_const_eff r -> r
| Extern_const_eff (s,_) -> (string_of_ident s)
| Abstract_const_eff (s,t,v,_) -> (string_of_ident s)
| Enum_const_eff (s,_) -> (string_of_ident s)
| Struct_const_eff (fl, t) ->
let string_of_field (id, veff) =
(Ident.to_string id)^" = "^ (string_of_const veff)
in
Printf.sprintf "%s{%s}"
(string_of_type_eff t)
(String.concat "; " (List.map string_of_field fl))
| Array_const_eff (ctab, t) ->
Printf.sprintf "[%s]"
(String.concat ", " (List.map string_of_const ctab))
| Tuple_const_eff cl ->
Printf.sprintf "(%s)"
(String.concat ", " (List.map string_of_const cl))
and string_of_var_info x =
(AstCore.string_of_var_nature x.var_nature_eff) ^ " " ^
(Ident.to_string x.var_name_eff) ^ ":"^(string_of_type_eff x.var_type_eff)^
(string_of_clock (snd x.var_clock_eff)^"("^ (Ident.to_string (fst x.var_clock_eff)) ^","^
(string_of_int x.var_number_eff)^")")
and string_of_var_list vl = String.concat " ; " (List.map string_of_var_info vl)
and string_of_node_key = function
| (ik, []) ->
(string_of_ident ik)
| (ik, sargs) -> Printf.sprintf "%s<<%s>>"
(string_of_ident ik)
(String.concat ", " (List.map string_of_static_arg sargs))
and string_of_static_arg = function
| ConstStaticArgLic(id, ceff) -> Printf.sprintf "const %s = %s" id (string_of_const ceff)
| TypeStaticArgLic (id, teff) -> Printf.sprintf "type %s = %s" id (string_of_type_eff teff)
(* | NodeStaticArgLic (id, ((long,sargs), _, _), _) -> *)
| NodeStaticArgLic (id, nk) ->
Printf.sprintf "node %s = %s" id (string_of_node_key nk)
and string_of_type_var tv = string_of_type_eff (TypeVar tv)
and string_of_type_matches pm =
let sotm (tv,t) = Printf.sprintf "%s <- %s"
(string_of_type_var tv) (string_of_type_eff t)
in
String.concat ", " (List.map sotm pm)
(* for printing recursive node *)
and string_of_node_key_rec (nkey: node_key) =
match nkey with
| (ik, []) -> dump_long ik
let astrings = List.map static_arg2string_bis salst in
let name = sprintf "%s_%s" (Ident.no_pack_string_of_long ik) (String.concat "_" astrings) in
(LicName.node_key nkey name)
and string_of_node_key_iter (nkey: node_key) =
match nkey with
| (ik, []) -> dump_long ik
| (ik, salst) ->
let astrings = List.map (static_arg2string) salst in
sprintf "%s<<%s>>" (Ident.string_of_long ik) (String.concat ", " astrings)
(* pour ecrire UN NIVEAU d'arg statique (cf. LicMetaOp *)
and string_of_node_key_def (nkey: node_key) =
match nkey with
| (ik, []) -> dump_long ik
| (ik, salst) ->
let astrings = List.map (string_of_static_arg) salst in
sprintf "%s<<%s>>" (Ident.string_of_long ik) (String.concat ", " astrings)
(* for inventing a name to parametrized nodes *)
and static_arg2string_bis (sa : Lic.static_arg) =
match sa with
| ConstStaticArgLic (id, ceff) -> sprintf "%s" (string_ident_of_const_eff ceff)
| TypeStaticArgLic (id, teff) -> sprintf "%s" (string_of_type_eff teff)
(* | NodeStaticArgLic (id, ((long, _sargs), _, _), _) -> *)
| NodeStaticArgLic (id, (long,_)) ->
sprintf "%s" (Ident.no_pack_string_of_long long)
Erwan Jahier
committed
(* for printing recursive node and iterators *)
and static_arg2string (sa : Lic.static_arg) =
match sa with
| ConstStaticArgLic (id, ceff) -> sprintf "%s" (string_ident_of_const_eff ceff)
| TypeStaticArgLic (id, teff) -> sprintf "%s" (string_of_type_eff teff)
(* | NodeStaticArgLic (id, ((long,sargs), _, _), _) -> *)
| NodeStaticArgLic (id, (long,sargs)) ->
(* sprintf "%s" (dump_long long) *)
and static_arg2string_rec (sa : Lic.static_arg) =
| ConstStaticArgLic (id, ceff) -> sprintf "%s" (string_ident_of_const_eff ceff)
| TypeStaticArgLic (id, teff) -> sprintf "%s" (string_of_type_eff teff)
(* | NodeStaticArgLic (id, ((long,sargs), _, _), _) -> *)
| NodeStaticArgLic (id, (long,sargs)) ->
and (string_of_var_info_eff: Lic.var_info -> string) =
(Ident.to_string x.var_name_eff) ^ ":"^(string_of_type_eff x.var_type_eff)
and (type_string_of_var_info_eff: Lic.var_info -> string) =
fun x -> (string_of_type_eff x.var_type_eff) ^
(string_of_clock2 (snd x.var_clock_eff))
and string_of_decl var_info_eff =
let vt_str =
(Ident.to_string var_info_eff.var_name_eff) ^ ":" ^
(string_of_type_eff var_info_eff.var_type_eff)
in
let clk_str = (string_of_clock (snd var_info_eff.var_clock_eff)) in
if !Global.ec then vt_str else vt_str ^ clk_str
and (string_of_type_decl_list : Lic.var_info list -> string -> string) =
fun tel sep ->
let str = String.concat sep (List.map string_of_decl tel) in
and string_of_slice_info_eff si_eff =
"[" ^ (string_of_int si_eff.se_first) ^ " .. " ^ (string_of_int si_eff.se_last) ^
(if si_eff.se_step = 1 then "" else " step " ^ (string_of_int si_eff.se_step)) ^
"]"
and (string_of_leff : Lic.left -> string) =
| LeftVarLic (vi_eff,_) -> Ident.to_string vi_eff.var_name_eff
| LeftFieldLic(leff,id,_) -> (string_of_leff leff) ^ "." ^ (Ident.to_string id)
| LeftArrayLic(leff,i,_) -> (string_of_leff leff) ^ "[" ^ (string_of_int i) ^ "]"
| LeftSliceLic(leff,si,_) -> (string_of_leff leff) ^ (string_of_slice_info_eff si)
and (string_of_leff_list : Lic.left list -> string) =
fun l ->
(if List.length l = 1 then "" else "(") ^
(String.concat ", " (List.map string_of_leff l)) ^
(if List.length l = 1 then "" else ")")
and sov ve = string_of_val_exp_eff ve
and (string_of_by_pos_op_eff: Lic.by_pos_op srcflagged -> Lic.val_exp list -> string) =
let tuple vel = (String.concat ", " (List.map string_of_val_exp_eff vel)) in
let tuple_par vel = "(" ^ (tuple vel) ^ ")" in
"[" ^ (String.concat ", " (List.map string_of_val_exp_eff vel)) ^ "]"
let str =
match posop.it,vel with
| PREDEF_CALL (AstPredef.NOT_n), [ve1] ->
((op2string AstPredef.NOT_n) ^ " " ^
(if is_a_tuple ve1 then (tuple_par [ve1]) else sov ve1))
| PREDEF_CALL (AstPredef.DIESE_n), [ve1] ->
if !Global.lv4
then sov ve1 (* lv4 does no accept to apply # on One var only! *)
else ((op2string AstPredef.DIESE_n) ^ (tuple_par [ve1]))
| PREDEF_CALL (AstPredef.IF_n), [ve1; ve2; ve3] ->
let ve2str = string_of_val_exp_eff ve2 in
let ve2str = if is_a_tuple ve2 then "("^ve2str^")" else ve2str in
let ve3str = string_of_val_exp_eff ve3 in
let ve3str = if is_a_tuple ve3 then "("^ve3str^")" else ve3str in
" if " ^ (string_of_val_exp_eff ve1) ^
" then " ^ ve2str ^ " else " ^ ve3str
| PREDEF_CALL(op), vel ->
if AstPredef.is_infix op then (
match vel with
| [ve1; ve2] ->
(string_of_val_exp_eff ve1) ^ " " ^ (op2string op) ^
" " ^ (string_of_val_exp_eff ve2)
| _ -> assert false
)
else
((op2string op) ^
(match op with
| AstPredef.ICONST_n _ | AstPredef.RCONST_n _ | AstPredef.NOT_n
| AstPredef.UMINUS_n | AstPredef.IUMINUS_n | AstPredef.RUMINUS_n
| AstPredef.FALSE_n | AstPredef.TRUE_n -> tuple vel
| _ -> tuple_par vel
)
)
let nk = nkl.it in
if !Global.lv4 then
(match nk with
(* predef op that are iterated are translated into node_exp ;
hence, we need to do (again) a particular threatment to have
a node ouput (i.e., "2>a" vs "Lustre::lt(2,a)")
*)
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
| ("Lustre","uminus"), [] -> " -" ^ sov (hd vel)
| ("Lustre","iuminus"), [] -> " -" ^ sov (hd vel)
| ("Lustre","ruminus"), [] -> " -" ^ sov (hd vel)
| ("Lustre","not"), [] -> " not " ^ sov (hd vel)
| ("Lustre","lt"), [] -> sov (hd vel) ^ " < " ^ sov (hd (tl vel))
| ("Lustre","lte"), [] -> sov (hd vel) ^ " <= " ^ sov (hd (tl vel))
| ("Lustre","gt"), [] -> sov (hd vel) ^ " > " ^ sov (hd (tl vel))
| ("Lustre","gte"), [] -> sov (hd vel) ^ " >= " ^ sov (hd (tl vel))
| ("Lustre","eq"), [] -> sov (hd vel) ^ " = " ^ sov (hd (tl vel))
| ("Lustre","neq"), [] -> sov (hd vel) ^ " <> " ^ sov (hd (tl vel))
| ("Lustre","diff"), [] -> sov (hd vel) ^ " <> " ^ sov (hd (tl vel))
| ("Lustre","plus"), [] -> sov (hd vel) ^ " + " ^ sov (hd (tl vel))
| ("Lustre","iplus"), [] -> sov (hd vel) ^ " + " ^ sov (hd (tl vel))
| ("Lustre","rplus"), [] -> sov (hd vel) ^ " + " ^ sov (hd (tl vel))
| ("Lustre","minus"), [] -> sov (hd vel) ^ " - " ^ sov (hd (tl vel))
| ("Lustre","iminus"), [] -> sov (hd vel) ^ " - " ^ sov (hd (tl vel))
| ("Lustre","rminus"), [] -> sov (hd vel) ^ " - " ^ sov (hd (tl vel))
| ("Lustre","div"), [] -> sov (hd vel) ^ " / " ^ sov (hd (tl vel))
| ("Lustre","idiv"), [] -> sov (hd vel) ^ " / " ^ sov (hd (tl vel))
| ("Lustre","rdiv"), [] -> sov (hd vel) ^ " / " ^ sov (hd (tl vel))
| ("Lustre","times"), [] -> sov (hd vel) ^ " * " ^ sov (hd (tl vel))
| ("Lustre","rtimes"), [] -> sov (hd vel) ^ " * " ^ sov (hd (tl vel))
| ("Lustre","itimes"), [] -> sov (hd vel) ^ " * " ^ sov (hd (tl vel))
| ("Lustre","slash"), [] -> sov (hd vel) ^ " / " ^ sov (hd (tl vel))
| ("Lustre","rslash"), [] -> sov (hd vel) ^ " / " ^ sov (hd (tl vel))
| ("Lustre","islash"), [] -> sov (hd vel) ^ " / " ^ sov (hd (tl vel))
| ("Lustre","impl"), [] -> sov (hd vel) ^ " => " ^ sov (hd (tl vel))
| ("Lustre","mod"), [] -> sov (hd vel) ^ " mod " ^ sov (hd (tl vel))
| ("Lustre","and"), [] -> sov (hd vel) ^ " and " ^ sov (hd (tl vel))
| ("Lustre","or"), [] -> sov (hd vel) ^ " or " ^ sov (hd (tl vel))
| ("Lustre","xor"), [] -> sov (hd vel) ^ " xor " ^ sov (hd (tl vel))
| ("Lustre","if"), [] ->
" if " ^ sov (hd vel) ^ " then " ^ sov (hd (tl vel))
^ " else " ^ sov (hd (tl (tl vel)))
| _ ->
((string_of_node_key nk) ^ (tuple_par vel))
) else
((string_of_node_key_rec nk) ^ (tuple_par vel))
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
| CONST_REF idl, _ -> dump_long idl
| VAR_REF id, _ -> id
| PRE, _ -> "pre " ^ (tuple_par vel)
| ARROW, [ve1; ve2] ->
(if is_a_tuple ve1 then tuple_par [ve1] else string_of_val_exp_eff ve1) ^
" -> " ^
(if is_a_tuple ve1 then tuple_par [ve2] else string_of_val_exp_eff ve2)
| FBY, [ve1; ve2] ->
if !Global.lv4 then
(if is_a_tuple ve1 then tuple_par [ve1] else string_of_val_exp_eff ve1)
^ " -> pre " ^
(if is_a_tuple ve1 then tuple_par [ve2] else string_of_val_exp_eff ve2)
else
(if is_a_tuple ve1 then tuple_par [ve1] else string_of_val_exp_eff ve1)
^ " fby " ^
(if is_a_tuple ve1 then tuple_par [ve2] else string_of_val_exp_eff ve2)
| WHEN clk, vel -> (tuple vel) ^ (string_of_clock_exp clk)
| CURRENT,_ -> "current " ^ tuple_par vel
| TUPLE,_ -> (tuple vel)
| CONCAT, [ve1; ve2] ->
(string_of_val_exp_eff ve1) ^ " | " ^ (string_of_val_exp_eff ve2)
| HAT (i, ve), _ -> (string_of_val_exp_eff ve) ^ "^" ^ (string_of_int i)
| ARRAY vel, _ -> tuple_square vel
| STRUCT_ACCESS(id), [ve1] ->
(string_of_val_exp_eff ve1) ^ "." ^ (Ident.to_string id)
| ARRAY_ACCES(i), [ve1] ->
(string_of_val_exp_eff ve1) ^ "[" ^ (string_of_int i) ^ "]"
| ARRAY_SLICE(si_eff), [ve1] ->
(string_of_val_exp_eff ve1) ^ (string_of_slice_info_eff si_eff)
| ARRAY_SLICE(_), _ -> assert false (* todo *)
(* Cannot happen *)
| ARROW, _ -> assert false
| FBY, _ -> assert false
| CONCAT, _ -> assert false
| STRUCT_ACCESS(_), _ -> assert false
| ARRAY_ACCES(i), _ -> assert false
in
let do_not_parenthesize = function
| VAR_REF _,_
| CONST_REF _,_
| PREDEF_CALL((AstPredef.ICONST_n _)),_
| PREDEF_CALL((AstPredef.RCONST_n _)),_
| PREDEF_CALL((AstPredef.FALSE_n)),_
| PREDEF_CALL((AstPredef.TRUE_n)),_
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
| ARRAY_ACCES _,_
| STRUCT_ACCESS _,_ -> true
| _,_ -> false
in
if
(* already parenthesized *)
( Str.string_match (Str.regexp "^(") str 0 &&
Str.string_match (Str.regexp ")$") str 0 )
||
(* ident or predef constants *)
(do_not_parenthesize (posop.it,vel))
||
!Global.one_op_per_equation
then
str
else
("(" ^ str ^ ")")
and string_of_val_exp_eff ve = string_of_val_exp_eff_core ve.ve_core
and string_of_val_exp_eff_core ve_core =
match ve_core with
| CallByPosLic (by_pos_op_eff, OperLic vel) ->
(* ICI : on pourrait afficher en commentaire l'éventuel type_matches ? *)
(string_of_by_pos_op_eff by_pos_op_eff vel)
| Merge (ve, [({it=Bool_const_eff true }, ct); ({it=Bool_const_eff false}, cf)])
| Merge (ve, [({it=Bool_const_eff false}, cf); ({it=Bool_const_eff true}, ct)]) ->
if !Global.lv4 then (
"if " ^ (Ident.to_string ve.it) ^ " then current (" ^
(string_of_val_exp_eff ct) ^ ") else current (" ^
(string_of_val_exp_eff cf) ^")"
) else (
"merge " ^ (Ident.to_string ve.it) ^ " (true -> " ^
(string_of_val_exp_eff ct) ^ ") (false -> "^ (string_of_val_exp_eff cf) ^")"
"merge " ^ (Ident.to_string ve.it) ^ " " ^
(fun (id,ve) -> "( "^(string_of_const_eff id.it) ^ " -> " ^
(string_of_val_exp_eff ve)^" )")
| CallByNameLic(by_name_op_eff, fl) ->
(match by_name_op_eff.it with
| STRUCT (long, _dft_opt) -> (Ident.string_of_long long)
"{" ^ (String.concat ";"
(List.map
(fun (id,veff) ->
let str = string_of_val_exp_eff veff in
(Ident.to_string id.it) ^ "=" ^
(if is_a_tuple veff then ("("^ str^")") else str)
)
fl)) ^
and wrap_long_line str =
if String.length str < 75 then str else
let str_list = Str.split (Str.regexp " ") str in
let new_str, reste =
List.fold_left
(fun (accl, acc_str) str ->
let new_acc_str = acc_str ^ " " ^ str in
if
String.length new_acc_str > 75
then
(accl ^ acc_str ^ "\n\t" , str)
else
(accl, new_acc_str)
)
("","")
str_list
in
new_str ^ " " ^ reste
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
and string_of_eq_info_eff (leff_list, vee) =
let str = string_of_val_exp_eff vee in
wrap_long_line (
(string_of_leff_list leff_list) ^ " = " ^
(if is_a_tuple vee then ("("^ str^")") else str) ^ ";")
and (string_of_assert : Lic.val_exp srcflagged -> string ) =
fun eq_eff ->
wrap_long_line (
"assert(" ^ string_of_val_exp_eff eq_eff.it ^ ");")
and (string_of_eq : Lic.eq_info srcflagged -> string) =
fun eq_eff ->
string_of_eq_info_eff eq_eff.it
and wrap_long_profile str =
if String.length str < 75 then str else
"\n"^(
Str.global_replace (Str.regexp "returns") "\nreturns"
(Str.global_replace (Str.regexp "(") "(\n\t"
(Str.global_replace (Str.regexp "; ") ";\n\t" str)))
and (profile_of_node_exp_eff: Lic.node_exp -> string) =
fun neff ->
("(" ^ (string_of_type_decl_list neff.inlist_eff "; ") ^ ") returns (" ^
(string_of_type_decl_list neff.outlist_eff "; ") ^ ")")
and (string_of_node_def : Lic.node_def -> string list) =
function
| ExternLic
| MetaOpLic _
| AbstractLic _ -> []
| BodyLic node_body_eff ->
List.append
(List.map string_of_assert node_body_eff.asserts_eff)
(List.map string_of_eq node_body_eff.eqs_eff)
and (type_decl: Ident.long -> Lic.type_ -> string) =
fun tname teff ->
"type " ^ (dump_long tname) ^
(match teff with
| Enum_type_eff (_) ->
" = " ^ (string_def_of_type_eff teff) ^ ";\n"
| External_type_eff (_)
| Abstract_type_eff(_,External_type_eff (_)) -> ";\n"
| _ -> " = " ^ (string_def_of_type_eff teff) ^ ";\n"
)
and (const_decl: Ident.long -> Lic.const -> string) =
fun tname ceff ->
let begin_str = ("const " ^ (dump_long tname)) in
let end_str = (string_of_const_eff ceff) ^ ";\n" in
(match ceff with
| Enum_const_eff(id, t) -> ""
| Extern_const_eff _
| Abstract_const_eff _ ->
begin_str ^ " : " ^ (string_of_type_eff (Lic.type_of_const ceff)) ^
(* (if !Global.ec then ".\n" else *)
(";\n")
| Struct_const_eff _
| Array_const_eff _
| Bool_const_eff _
| Int_const_eff _
| Real_const_eff _ -> begin_str ^ " = " ^ end_str
| Tuple_const_eff _ ->
print_internal_error "LicDump.const_decl" "should not have been called for a tuple";
assert false
Erwan Jahier
committed
)
: string =
wrap_long_profile (
(
if neff.def_eff = ExternLic && not (!Global.lv4)
(* no extern kwd in v4... *)
then "extern " else ""
)^(
if !Global.lv4 then (
(* node and function does not have the same meaning in v4... *)
if neff.def_eff = ExternLic then "function " else "node "
) else (
if neff.has_mem_eff then "node " else "function "
)
)^(
string_of_node_key_rec neff.node_key_eff
)^(
profile_of_node_exp_eff neff
)
)^(
match neff.def_eff with
| ExternLic -> ";\n"
| MetaOpLic nk -> (
| AbstractLic _ -> ";\n"
| BodyLic _ -> (
";\n"^
(
match neff.loclist_eff with
| None -> ""
| Some [] -> ""
| Some l ->
"var\n " ^ (string_of_type_decl_list l ";\n ") ^ ";\n"
) ^
"let\n " ^
(String.concat "\n " (string_of_node_def neff.def_eff)) ^
"\ntel\n-- end of node " ^
(string_of_node_key_rec neff.node_key_eff) ^ "\n"
)
and (string_of_clock_exp : AstCore.clock_exp -> string) =
| AstCore.Base -> ""
| AstCore.NamedClock clk ->
" when " ^ (string_of_ident_clk clk.it)
and (string_of_ident_clk : Ident.clk -> string) =
fun clk ->
let (cc,v) = clk in
let clk_exp_str =
match Ident.string_of_idref cc with
| "True" -> (Ident.to_string v)
| "False" -> "not " ^ (Ident.to_string v)
| _ ->
(* if !Global.lv4 then *)
(* raise (Errors.Global_error *)
(* ("*** Cannot generate V4 style Lustre for programs with enumerated "^ *)
(* "clocks (yet), sorry.")) *)
(* else *)
Ident.string_of_clk clk
in
clk_exp_str
and string_of_clock2 (ck : Lic.clock) =
match ck with
| On(clk_exp,ceff) ->
let clk_exp_str = string_of_ident_clk clk_exp in
" on " ^ clk_exp_str ^ (string_of_clock2 ceff)
| ClockVar i -> "'a" ^ string_of_int i
and string_of_clock (ck : Lic.clock) =
| On(clk_exp,_) ->
let clk_exp_str = string_of_ident_clk clk_exp in
" when " ^ clk_exp_str
| ClockVar _ ->
"" (* it migth occur that (unused) constant remain with a clock var.
But in that case, it is ok to consider then as on the base clock.
*)
(* | ClockVar i -> "_clock_var_" ^ (string_of_int i) *)
Erwan Jahier
committed
and op2string op =
(* Une verrue pour compatible avec les outils qui mangent du ec... *)
if !Global.ec && op = AstPredef.INT2REAL_n then "real" else
AstPredef.op2string op
(*---------------------------------------------------------------------
Formatage standard des erreurs de compil
----------------------------------------------------------------------*)
let node_error_string lxm nkey = (
Printf.sprintf "While checking %s" (string_of_node_key_iter nkey)
)
(*---------------------------------------------------------------------
Message d'erreur (associé à un lexeme) sur stderr
----------------------------------------------------------------------*)
let print_compile_node_error nkey lxm msg = (
Printf.eprintf "%s\n" (node_error_string lxm nkey);
Errors.print_compile_error lxm msg ;
flush stderr
)
let print_global_node_error lxm nkey msg = (
Printf.eprintf "%s\n" (node_error_string lxm nkey);
Errors.print_global_error msg ;
flush stderr
)