jeltz/heptagon
1
0
Fork 0
Code Issues Pull requests Releases Activity

Fixed stupid bug #1

Browse source
This commit is contained in:
Cédric Pasteur 2011-04-18 17:14:50 +02:00
parent c0602c6df6
commit 03f0d5d89a
1 changed files with 15 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

24
compiler/heptagon/transformations/normalize.ml
View file

@ -101,12 +101,12 @@ let rec whenc context e c n =
type kind = ExtValue | Any type kind = ExtValue | Any
(** Creates an equation and add it to the context if necessary. *) (** Creates an equation and add it to the context if necessary. *)
let add context expected_kind ({ e_desc = de } as e) = let add context expected_kind e =
let up = match de, expected_kind with let up = match e.e_desc, expected_kind with
| (Evar _ | Eapp ({ a_op = Efield }, _, _) | Ewhen _ | (Evar _ | Eapp ({ a_op = Efield }, _, _) | Ewhen _
| Eapp ({ a_op = Etuple }, _, _) | Econst _) , ExtValue -> false | Eapp ({ a_op = Etuple }, _, _) | Econst _) , ExtValue -> false
| _ , ExtValue -> true | _ , ExtValue -> true
| _ -> false in | _ -> Format.printf "Not normalizing \n"; false in
if up then if up then
let context, n = equation context e in let context, n = equation context e in
context, { e with e_desc = n } context, { e with e_desc = n }
@ -114,7 +114,7 @@ let add context expected_kind ({ e_desc = de } as e) =
context, e context, e
let rec translate kind context e = let rec translate kind context e =
let context, e = match e.e_desc with let context, e' = match e.e_desc with
| Econst _ | Econst _
| Evar _ -> context, e | Evar _ -> context, e
| Epre(v, e1) -> fby kind context e v e1 | Epre(v, e1) -> fby kind context e v e1
@ -143,7 +143,7 @@ let rec translate kind context e =
flatten_e_list e_list, reset) } flatten_e_list e_list, reset) }
| Elast _ | Efby _ -> | Elast _ | Efby _ ->
Error.message e.e_loc Error.Eunsupported_language_construct Error.message e.e_loc Error.Eunsupported_language_construct
in add context kind e in add context kind e'
and translate_list kind context e_list = and translate_list kind context e_list =
match e_list with match e_list with
@ -196,7 +196,7 @@ and ifthenelse context e e1 e2 e3 =
{ e with e_desc = Eapp(mk_app Etuple, e_list, None) } { e with e_desc = Eapp(mk_app Etuple, e_list, None) }
in in
if is_list e2 then ( if is_list e2 then (
context, mk_ite_list (e_to_e_list e2) (e_to_e_list e2) context, mk_ite_list (e_to_e_list e2) (e_to_e_list e3)
) else ) else
context, { e with e_desc = Eapp (mk_app Eifthenelse, [e1; e2; e3], None) } context, { e with e_desc = Eapp (mk_app Eifthenelse, [e1; e2; e3], None) }
@ -244,13 +244,19 @@ and distribute ((d_list, eq_list) as context) eq pat e =
dist_e_list pat_list e_list dist_e_list pat_list e_list
| Etuplepat(pat_list), Econst { se_desc = Stuple se_list } -> | Etuplepat(pat_list), Econst { se_desc = Stuple se_list } ->
dist_e_list pat_list (exp_list_of_static_exp_list se_list) dist_e_list pat_list (exp_list_of_static_exp_list se_list)
| _ -> d_list, eq :: eq_list | _ ->
let eq = { eq with eq_desc = Eeq(pat, e) } in
d_list, eq :: eq_list
and translate_eq context eq = match eq.eq_desc with and translate_eq ((d_list, eq_list) as context) eq = match eq.eq_desc with
| Eeq (pat, e) -> | Eeq (pat, e) ->
let context, e = translate Any context e in let context, e = translate Any context e in
distribute context eq pat e distribute context eq pat e
| _ -> raise Errors.Fallback | Eblock b ->
let v, eqs = translate_eq_list [] b.b_equs in
let eq = { eq with eq_desc = Eblock { b with b_local = v @ b.b_local; b_equs = eqs} } in
d_list, eq :: eq_list
| _ -> Misc.internal_error "normalize" 0
and translate_eq_list d_list eq_list = and translate_eq_list d_list eq_list =
List.fold_left List.fold_left