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

Fix for nested if and merge with tuples

Browse source
This commit is contained in:
Cédric Pasteur 2011-04-18 18:03:55 +02:00 committed by Cédric Pasteur
parent 8da5ce4648
commit 028dfe0468
2 changed files with 19 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -113,6 +113,13 @@ let add context expected_kind e =
else
context, e
let add_list context expected_kind e_list =
let aux context e =
let context, e = add context expected_kind e in
e, context
in
mapfold aux context e_list
let rec translate kind context e =
let context, e' = match e.e_desc with
| Econst _
@ -188,15 +195,17 @@ and ifthenelse context e e1 e2 e3 =
let context, e2 = translate ExtValue context e2 in
let context, e3 = translate ExtValue context e3 in
let mk_ite_list e2_list e3_list =
let mk_ite e2 e3 =
let mk_ite e'2 e'3 =
mk_exp ~loc:e.e_loc
(Eapp (mk_app Eifthenelse, [e1; e2; e3], None)) e2.e_ty
(Eapp (mk_app Eifthenelse, [e1; e'2; e'3], None)) e'2.e_ty
in
let e_list = List.map2 mk_ite e2_list e3_list in
{ e with e_desc = Eapp(mk_app Etuple, e_list, None) }
in
if is_list e2 then (
context, mk_ite_list (e_to_e_list e2) (e_to_e_list e3)
let e2_list, context = add_list context ExtValue (e_to_e_list e2) in
let e3_list, context = add_list context ExtValue (e_to_e_list e3) in
context, mk_ite_list e2_list e3_list
) else
context, { e with e_desc = Eapp (mk_app Eifthenelse, [e1; e2; e3], None) }
@ -220,6 +229,8 @@ and merge context e x c_e_list =
if is_list e then (
let c_list = List.map (fun (t,_) -> t) c_e_list in
let e_lists = List.map (fun (_,e) -> e_to_e_list e) c_e_list in
let e_lists, context =
mapfold (fun context e_list -> add_list context ExtValue e_list) context e_lists in
let e_list = List.map (mk_merge x c_list) e_lists in
context, { e with e_desc = Eapp(mk_app Etuple, e_list, None) }
) else

12
compiler/main/hept2mls.ml
View file

@ -89,25 +89,23 @@ let translate_app app =
mk_app ~params:app.Heptagon.a_params
~unsafe:app.Heptagon.a_unsafe (translate_op app.Heptagon.a_op)
let rec translate_extvalue
{ Heptagon.e_desc = desc; Heptagon.e_ty = ty;
Heptagon.e_loc = loc } =
let mk_extvalue = mk_extvalue ~loc:loc ~ty:ty in
match desc with
let rec translate_extvalue e =
let mk_extvalue = mk_extvalue ~loc:e.Heptagon.e_loc ~ty:e.Heptagon.e_ty in
match e.Heptagon.e_desc with
| Heptagon.Econst c -> mk_extvalue (Wconst c)
| Heptagon.Evar x -> mk_extvalue (Wvar x)
| Heptagon.Ewhen (e, c, ce) ->
(match ce.Heptagon.e_desc with
| Heptagon.Evar x ->
mk_extvalue (Wwhen (translate_extvalue e, c, x))
| _ -> Error.message loc Error.Enormalization)
| _ -> Error.message e.Heptagon.e_loc Error.Enormalization)
| Heptagon.Eapp({ Heptagon.a_op = Heptagon.Efield;
Heptagon.a_params = params }, e_list, reset) ->
let e = assert_1 e_list in
let f = assert_1 params in
let fn = match f.se_desc with Sfield fn -> fn | _ -> assert false in
mk_extvalue (Wfield (translate_extvalue e, fn))
| _ -> Error.message loc Error.Enormalization
| _ -> Error.message e.Heptagon.e_loc Error.Enormalization
let translate
({ Heptagon.e_desc = desc; Heptagon.e_ty = ty;