again
This commit is contained in:
Léonard Gérard
parent
df469db394
commit
09419a77a5
21 changed files with 346 additions and 226 deletions
|
|
@ -48,6 +48,7 @@ and print_static_exp_tuple ff l =
|
|||
fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "("","")") l
|
||||
|
||||
and print_type ff = function
|
||||
| Tprod [] -> fprintf ff "INVALID TYPE"
|
||||
| Tprod ty_list ->
|
||||
fprintf ff "@[<hov2>%a@]" (print_list_r print_type "(" " *" ")") ty_list
|
||||
| Tid id -> print_qualname ff id
|
||||
|
|
|
|||
|
|
@ -15,22 +15,26 @@ let tglobal = []
|
|||
let cglobal = []
|
||||
|
||||
let pbool = { qual = "Pervasives"; name = "bool" }
|
||||
let tbool = Types.Tid pbool
|
||||
let ptrue = { qual = "Pervasives"; name = "true" }
|
||||
let pfalse = { qual = "Pervasives"; name = "false" }
|
||||
let por = { qual = "Pervasives"; name = "or" }
|
||||
let pint = { qual = "Pervasives"; name = "int" }
|
||||
let tint = Types.Tid pint
|
||||
let pfloat = { qual = "Pervasives"; name = "float" }
|
||||
let tfloat = Types.Tid pfloat
|
||||
|
||||
|
||||
let mk_pervasives s = { qual = "Pervasives"; name = s }
|
||||
|
||||
let mk_static_int_op op args =
|
||||
mk_static_exp ~ty:(Tid pint) (Sop (op,args))
|
||||
mk_static_exp ~ty:tint (Sop (op,args))
|
||||
|
||||
let mk_static_int i =
|
||||
mk_static_exp ~ty:(Tid pint) (Sint i)
|
||||
mk_static_exp ~ty:tint (Sint i)
|
||||
|
||||
let mk_static_bool b =
|
||||
mk_static_exp ~ty:(Tid pbool) (Sbool b)
|
||||
mk_static_exp ~ty:tbool (Sbool b)
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -42,6 +42,11 @@ let prod = function
|
|||
| [ty] -> ty
|
||||
| ty_list -> Tprod ty_list
|
||||
|
||||
let unprod = function
|
||||
| Tprod l -> l
|
||||
| t -> [t]
|
||||
|
||||
|
||||
let asyncify async ty_list = match async with
|
||||
| None -> ty_list
|
||||
| Some a -> List.map (fun ty -> Tasync (a,ty)) ty_list
|
||||
|
|
|
|||
|
|
@ -19,21 +19,29 @@ open Obc_mapfold
|
|||
open Initial
|
||||
|
||||
|
||||
let fresh_it () = Idents.gen_var "mls2obc" "i"
|
||||
let fresh_it () =
|
||||
let id = Idents.gen_var "mls2obc" "i" in
|
||||
id, mk_var_dec id Initial.tint
|
||||
|
||||
let gen_obj_ident n = Idents.gen_var "mls2obc" ((shortname n) ^ "_inst")
|
||||
|
||||
let op_from_string op = { qual = "Pervasives"; name = op; }
|
||||
|
||||
let rec lhs_of_idx_list e = function
|
||||
| [] -> e | idx :: l -> mk_lhs (Larray (lhs_of_idx_list e l, idx))
|
||||
let rec pattern_of_idx_list p l =
|
||||
let rec aux ty l = match ty, l with
|
||||
| _, [] -> p
|
||||
| Tarray (ty',_), idx :: l -> mk_pattern ty (Larray (aux ty' l, idx))
|
||||
| _ -> internal_error "mls2obc" 1
|
||||
in
|
||||
aux p.pat_ty l
|
||||
|
||||
let array_elt_of_exp idx e =
|
||||
match e.e_desc with
|
||||
| Econst ({ se_desc = Sarray_power (c, _) }) ->
|
||||
mk_exp (Econst c)
|
||||
| _ ->
|
||||
mk_lhs_exp (Larray(lhs_of_exp e, mk_exp (Elhs idx)))
|
||||
match e.e_desc, Modules.unalias_type e.e_ty with
|
||||
| Econst ({ se_desc = Sarray_power (c, _) }), Tarray (ty,_) ->
|
||||
mk_exp ty (Econst c)
|
||||
| _, Tarray (ty,_) ->
|
||||
mk_pattern_exp ty (Larray(pattern_of_exp e, mk_exp Initial.tint (Epattern idx)))
|
||||
| _ -> internal_error "mls2obc" 2
|
||||
|
||||
(** Creates the expression that checks that the indices
|
||||
in idx_list are in the bounds. If idx_list=[e1;..;ep]
|
||||
|
|
@ -41,15 +49,11 @@ let array_elt_of_exp idx e =
|
|||
e1 <= n1 && .. && ep <= np *)
|
||||
let rec bound_check_expr idx_list bounds =
|
||||
match (idx_list, bounds) with
|
||||
| [idx], [n] ->
|
||||
mk_exp (Eop (op_from_string "<",
|
||||
[idx; mk_exp (Econst n)]))
|
||||
| [idx], [n] -> mk_exp_bool (Eop (op_from_string "<", [idx; mk_exp_int (Econst n)]))
|
||||
| (idx :: idx_list, n :: bounds) ->
|
||||
let e = mk_exp (Eop (op_from_string "<",
|
||||
[idx; mk_exp (Econst n)])) in
|
||||
mk_exp (Eop (op_from_string "&",
|
||||
[e; bound_check_expr idx_list bounds]))
|
||||
| (_, _) -> assert false
|
||||
let e = mk_exp_bool (Eop (op_from_string "<", [idx; mk_exp_int (Econst n)])) in
|
||||
mk_exp_bool (Eop (op_from_string "&", [e; bound_check_expr idx_list bounds]))
|
||||
| (_, _) -> internal_error "mls2obc" 3
|
||||
|
||||
let reinit o =
|
||||
Acall ([], o, Mreset, [])
|
||||
|
|
@ -70,7 +74,7 @@ let translate_var_dec l =
|
|||
let rec translate map e =
|
||||
let desc = match e.Minils.e_desc with
|
||||
| Minils.Econst v -> Econst v
|
||||
| Minils.Evar n -> Elhs (Control.var_from_name map n)
|
||||
| Minils.Evar n -> Epattern (Control.var_from_name map n)
|
||||
| Minils.Eapp ({ Minils.a_op = Minils.Eequal }, e_list, _) ->
|
||||
Eop (op_from_string "=", List.map (translate map ) e_list)
|
||||
| Minils.Eapp ({ Minils.a_op = Minils.Efun n }, e_list, _) when Mls_utils.is_op n ->
|
||||
|
|
@ -85,17 +89,17 @@ let rec translate map e =
|
|||
let f_e_list = List.map (fun (f, e) -> (f, (translate map e))) f_e_list in
|
||||
Estruct (type_name, f_e_list)
|
||||
| Minils.Eapp ({ Minils.a_op = Minils.Efield; Minils.a_params = params }, e_list, _) ->
|
||||
let f = match (assert_1 params).se_desc with Sfield f -> f | _ -> assert false in
|
||||
let f = match (assert_1 params).se_desc with Sfield f -> f | _ -> internal_error "mls2obc" 4 in
|
||||
let e = translate map (assert_1 e_list) in
|
||||
Elhs (mk_lhs (Lfield (lhs_of_exp e, f)))
|
||||
Epattern (mk_pattern e.e_ty (Lfield (pattern_of_exp e, f)))
|
||||
(*Remaining array operators*)
|
||||
| Minils.Eapp ({ Minils.a_op = Minils.Earray }, e_list, _) ->
|
||||
Earray (List.map (translate map ) e_list)
|
||||
| Minils.Eapp ({ Minils.a_op = Minils.Eselect;
|
||||
Minils.a_params = idx }, e_list, _) ->
|
||||
let e = translate map (assert_1 e_list) in
|
||||
let idx_list = List.map (fun idx -> mk_exp (Econst idx)) idx in
|
||||
Elhs (lhs_of_idx_list (lhs_of_exp e) idx_list)
|
||||
let idx_list = List.map (fun idx -> mk_exp tint (Econst idx)) idx in
|
||||
Epattern (pattern_of_idx_list (pattern_of_exp e) idx_list)
|
||||
(* Async operators *)
|
||||
| Minils.Eapp ({Minils.a_op = Minils.Ebang }, e_list, _) ->
|
||||
let e = translate map (assert_1 e_list) in
|
||||
|
|
@ -105,11 +109,12 @@ let rec translate map e =
|
|||
| Minils.Eapp ({Minils.a_op=(Minils.Enode _|Minils.Efun _|Minils.Econcat|Minils.Eupdate|Minils.Eselect_dyn
|
||||
|Minils.Eselect_slice|Minils.Earray_fill|Minils.Efield_update|Minils.Eifthenelse
|
||||
|Minils.Etuple)}, _, _) ->
|
||||
Format.eprintf "%aThis should not be treated as an exp in mls2obc : %a@."
|
||||
(*Format.eprintf "%aThis should not be treated as an exp in mls2obc : %a@."
|
||||
Location.print_location e.Minils.e_loc Mls_printer.print_exp e;
|
||||
assert false
|
||||
assert false*)
|
||||
internal_error "mls2obc" 5
|
||||
in
|
||||
mk_exp ~ty:e.Minils.e_ty desc
|
||||
mk_exp e.Minils.e_ty desc
|
||||
|
||||
(* [translate pat act = si, d] *)
|
||||
and translate_act map pat
|
||||
|
|
@ -124,54 +129,53 @@ and translate_act map pat
|
|||
| pat, Minils.Ewhen (e, _, _) ->
|
||||
translate_act map pat e
|
||||
| pat, Minils.Emerge (x, c_act_list) ->
|
||||
let lhs = Control.var_from_name map x in
|
||||
[Acase (mk_exp (Elhs lhs), translate_c_act_list map pat c_act_list)]
|
||||
let pattern = Control.var_from_name map x in
|
||||
[Acase (mk_exp pattern.pat_ty (Epattern pattern), translate_c_act_list map pat c_act_list)]
|
||||
(* Array ops *)
|
||||
| Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Econcat }, [e1; e2], _) ->
|
||||
let cpt1 = fresh_it () in
|
||||
let cpt2 = fresh_it () in
|
||||
let cpt1, cpt1d = fresh_it () in
|
||||
let cpt2, cpt2d = fresh_it () in
|
||||
let x = Control.var_from_name map x in
|
||||
let t = x.pat_ty in
|
||||
(match e1.Minils.e_ty, e2.Minils.e_ty with
|
||||
| Tarray (_, n1), Tarray (_, n2) ->
|
||||
| Tarray (t1, n1), Tarray (t2, n2) ->
|
||||
let e1 = translate map e1 in
|
||||
let e2 = translate map e2 in
|
||||
let a1 =
|
||||
Afor (cpt1, mk_static_int 0, n1,
|
||||
mk_block [Aassgn (mk_lhs (Larray (x, mk_evar cpt1)),
|
||||
mk_lhs_exp (Larray (lhs_of_exp e1,
|
||||
mk_evar cpt1)))] ) in
|
||||
let idx = mk_exp (Eop (op_from_string "+",
|
||||
[ mk_exp (Econst n1); mk_evar cpt2])) in
|
||||
Afor (cpt1d, mk_static_int 0, n1,
|
||||
mk_block [Aassgn (mk_pattern t (Larray (x, mk_evar_int cpt1)),
|
||||
mk_pattern_exp t1 (Larray (pattern_of_exp e1, mk_evar_int cpt1)))] ) in
|
||||
let idx = mk_exp_int (Eop (op_from_string "+", [ mk_exp_int (Econst n1); mk_evar_int cpt2])) in
|
||||
let a2 =
|
||||
Afor (cpt2, mk_static_int 0, n2,
|
||||
mk_block [Aassgn (mk_lhs (Larray (x, idx)),
|
||||
mk_lhs_exp (Larray (lhs_of_exp e2,
|
||||
mk_evar cpt2)))] )
|
||||
Afor (cpt2d, mk_static_int 0, n2,
|
||||
mk_block [Aassgn (mk_pattern t (Larray (x, idx)),
|
||||
mk_pattern_exp t2 (Larray (pattern_of_exp e2, mk_evar_int cpt2)))] )
|
||||
in
|
||||
[a1; a2]
|
||||
| _ -> assert false )
|
||||
| Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Earray_fill; Minils.a_params = [n] }, [e], _) ->
|
||||
let cpt = fresh_it () in
|
||||
let cpt, cptd = fresh_it () in
|
||||
let e = translate map e in
|
||||
[ Afor (cpt, mk_static_int 0, n,
|
||||
mk_block [Aassgn (mk_lhs (Larray (Control.var_from_name map x, mk_evar cpt)), e) ]) ]
|
||||
let x = Control.var_from_name map x in
|
||||
[ Afor (cptd, mk_static_int 0, n, mk_block [Aassgn (mk_pattern x.pat_ty (Larray (x, mk_evar_int cpt)), e) ]) ]
|
||||
| Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eselect_slice; Minils.a_params = [idx1; idx2] }, [e], _) ->
|
||||
let cpt = fresh_it () in
|
||||
let cpt, cptd = fresh_it () in
|
||||
let e = translate map e in
|
||||
let idx = mk_exp (Eop (op_from_string "+", [mk_evar cpt; mk_exp (Econst idx1) ])) in
|
||||
let x = Control.var_from_name map x in
|
||||
let idx = mk_exp_int (Eop (op_from_string "+", [mk_evar_int cpt; mk_exp_int (Econst idx1) ])) in
|
||||
(* bound = (idx2 - idx1) + 1*)
|
||||
let bound = mk_static_int_op (op_from_string "+")
|
||||
[ mk_static_int 1; mk_static_int_op (op_from_string "-") [idx2;idx1] ] in
|
||||
[ Afor (cpt, mk_static_int 0, bound,
|
||||
mk_block [Aassgn (mk_lhs (Larray (Control.var_from_name map x, mk_evar cpt)),
|
||||
mk_lhs_exp (Larray (lhs_of_exp e, idx)))] ) ]
|
||||
[ mk_static_int 1; mk_static_int_op (op_from_string "-") [idx2;idx1] ] in
|
||||
[ Afor (cptd, mk_static_int 0, bound,
|
||||
mk_block [Aassgn (mk_pattern x.pat_ty (Larray (x, mk_evar_int cpt)),
|
||||
mk_pattern_exp e.e_ty (Larray (pattern_of_exp e, idx)))] ) ]
|
||||
| Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eselect_dyn }, e1::e2::idx, _) ->
|
||||
let x = Control.var_from_name map x in
|
||||
let bounds = Mls_utils.bounds_list e1.Minils.e_ty in
|
||||
let e1 = translate map e1 in
|
||||
let idx = List.map (translate map) idx in
|
||||
let true_act =
|
||||
Aassgn (x, mk_exp (Elhs (lhs_of_idx_list (lhs_of_exp e1) idx))) in
|
||||
let p = pattern_of_idx_list (pattern_of_exp e1) idx in
|
||||
let true_act = Aassgn (x, mk_exp p.pat_ty (Epattern p)) in
|
||||
let false_act = Aassgn (x, translate map e2) in
|
||||
let cond = bound_check_expr idx bounds in
|
||||
[ Acase (cond, [ ptrue, mk_block [true_act]; pfalse, mk_block [false_act] ]) ]
|
||||
|
|
@ -179,7 +183,7 @@ and translate_act map pat
|
|||
let x = Control.var_from_name map x in
|
||||
let bounds = Mls_utils.bounds_list e1.Minils.e_ty in
|
||||
let idx = List.map (translate map) idx in
|
||||
let action = Aassgn (lhs_of_idx_list x idx,
|
||||
let action = Aassgn (pattern_of_idx_list x idx,
|
||||
translate map e2) in
|
||||
let cond = bound_check_expr idx bounds in
|
||||
let action = Acase (cond, [ ptrue, mk_block [action] ]) in
|
||||
|
|
@ -190,8 +194,8 @@ and translate_act map pat
|
|||
Minils.Eapp ({ Minils.a_op = Minils.Efield_update; Minils.a_params = [{ se_desc = Sfield f }] }, [e1; e2], _) ->
|
||||
let x = Control.var_from_name map x in
|
||||
let copy = Aassgn (x, translate map e1) in
|
||||
let action = Aassgn (mk_lhs (Lfield (x, f)), translate map e2) in
|
||||
[copy; action]
|
||||
let action = Aassgn (mk_pattern x.pat_ty (Lfield (x, f)), translate map e2) in
|
||||
[copy; action]
|
||||
|
||||
| Minils.Evarpat n, _ ->
|
||||
[Aassgn (Control.var_from_name map n, translate map act)]
|
||||
|
|
@ -233,7 +237,7 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e }
|
|||
let x = Control.var_from_name map n in
|
||||
let si = (match opt_c with
|
||||
| None -> si
|
||||
| Some c -> (Aassgn (x, mk_exp (Econst c))) :: si) in
|
||||
| Some c -> (Aassgn (x, mk_exp x.pat_ty (Econst c))) :: si) in
|
||||
let action = Aassgn (Control.var_from_name map n, translate map e) in
|
||||
v, si, j, (Control.control map ck action) :: s
|
||||
|
||||
|
|
@ -258,12 +262,10 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e }
|
|||
pfalse, mk_block ~locals:vf false_act]) in
|
||||
v, si, j, (Control.control map ck action) :: s
|
||||
|
||||
| pat, Minils.Eapp ({ Minils.a_op = Minils.Efun _ | Minils.Enode _ } as app,
|
||||
e_list, r) ->
|
||||
| pat, Minils.Eapp ({ Minils.a_op = Minils.Efun _ | Minils.Enode _ } as app, e_list, r) ->
|
||||
let name_list = translate_pat map pat in
|
||||
let c_list = List.map (translate map) e_list in
|
||||
let v', si', j', action = mk_node_call map call_context
|
||||
app loc name_list c_list in
|
||||
let v', si', j', action = mk_node_call map call_context app loc name_list c_list e.Minils.e_ty in
|
||||
let action = List.map (Control.control map ck) action in
|
||||
let s = (match r, app.Minils.a_op with
|
||||
| Some r, Minils.Enode _ ->
|
||||
|
|
@ -275,12 +277,10 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e }
|
|||
|
||||
| pat, Minils.Eiterator (it, app, n, e_list, reset) ->
|
||||
let name_list = translate_pat map pat in
|
||||
let c_list =
|
||||
List.map (translate map) e_list in
|
||||
let x = fresh_it () in
|
||||
let call_context = Some { oa_index = mk_lhs (Lvar x); oa_size = n} in
|
||||
let si', j', action = translate_iterator map call_context it
|
||||
name_list app loc n x c_list in
|
||||
let c_list = List.map (translate map) e_list in
|
||||
let x, xd = fresh_it () in
|
||||
let call_context = Some { oa_index = mk_pattern_int (Lvar x); oa_size = n} in
|
||||
let si', j', action = translate_iterator map call_context it name_list app loc n x xd c_list e.Minils.e_ty in
|
||||
let action = List.map (Control.control map ck) action in
|
||||
let s =
|
||||
(match reset, app.Minils.a_op with
|
||||
|
|
@ -299,18 +299,18 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e }
|
|||
and translate_eq_list map call_context act_list =
|
||||
List.fold_right (translate_eq map call_context) act_list ([], [], [], [])
|
||||
|
||||
and mk_node_call map call_context app loc name_list args =
|
||||
and mk_node_call map call_context app loc name_list args ty =
|
||||
match app.Minils.a_op with
|
||||
| Minils.Efun f when Mls_utils.is_op f ->
|
||||
let e = mk_exp (Eop(f, args)) in
|
||||
[], [], [], [Aassgn(List.hd name_list, e) ]
|
||||
let e = mk_exp ty (Eop(f, args)) in
|
||||
[], [], [], [Aassgn(List.hd name_list, e)]
|
||||
|
||||
| Minils.Enode f when Itfusion.is_anon_node f ->
|
||||
let add_input env vd = Env.add vd.Minils.v_ident (mk_lhs (Lvar vd.Minils.v_ident)) env in
|
||||
let add_input env vd = Env.add vd.Minils.v_ident (mk_pattern vd.Minils.v_type (Lvar vd.Minils.v_ident)) env in
|
||||
let build env vd a = Env.add vd.Minils.v_ident a env in
|
||||
let subst_act_list env act_list =
|
||||
let exp funs env e = match e.e_desc with
|
||||
| Elhs { pat_desc = Lvar x } ->
|
||||
| Epattern { pat_desc = Lvar x } ->
|
||||
let e =
|
||||
(try Env.find x env
|
||||
with Not_found -> e) in
|
||||
|
|
@ -346,61 +346,66 @@ and mk_node_call map call_context app loc name_list args =
|
|||
[], si, [obj], s
|
||||
| _ -> assert false
|
||||
|
||||
and translate_iterator map call_context it name_list app loc n x c_list =
|
||||
let array_of_output name_list =
|
||||
List.map (fun l -> mk_lhs (Larray (l, mk_evar x))) name_list in
|
||||
let array_of_input c_list =
|
||||
List.map (array_elt_of_exp (mk_lhs (Lvar x))) c_list in
|
||||
|
||||
and translate_iterator map call_context it name_list app loc n x xd c_list ty =
|
||||
let unarray ty = match ty with
|
||||
| Tarray (t,_) -> t
|
||||
| _ -> Format.eprintf "%a" Global_printer.print_type ty; internal_error "mls2obc" 6
|
||||
in
|
||||
let array_of_output name_list ty_list =
|
||||
List.map (fun l -> mk_pattern ty (Larray (l, mk_evar_int x))) name_list (* TODO not ty, but Tprod (ti...) -> ti *)
|
||||
in
|
||||
let array_of_input c_list = List.map (array_elt_of_exp (mk_pattern_int (Lvar x))) c_list in
|
||||
match it with
|
||||
| Minils.Imap ->
|
||||
let c_list = array_of_input c_list in
|
||||
let name_list = array_of_output name_list in
|
||||
let v, si, j, action = mk_node_call map call_context
|
||||
app loc name_list c_list in
|
||||
let ty_list = Types.unprod ty in
|
||||
let name_list = array_of_output name_list ty_list in
|
||||
let node_out_ty = Types.prod (List.map unarray ty_list) in
|
||||
let v, si, j, action = mk_node_call map call_context app loc name_list c_list node_out_ty in
|
||||
let v = translate_var_dec v in
|
||||
let b = mk_block ~locals:v action in
|
||||
si, j, [ Afor (x, mk_static_int 0, n, b) ]
|
||||
si, j, [ Afor (xd, mk_static_int 0, n, b) ]
|
||||
|
||||
| Minils.Imapfold ->
|
||||
let (c_list, acc_in) = split_last c_list in
|
||||
let c_list = array_of_input c_list in
|
||||
let ty_list = Types.unprod ty in
|
||||
let (name_list, acc_out) = split_last name_list in
|
||||
let name_list = array_of_output name_list in
|
||||
let v, si, j, action = mk_node_call map call_context
|
||||
app loc (name_list @ [ acc_out ])
|
||||
(c_list @ [ mk_exp (Elhs acc_out) ]) in
|
||||
let name_list = array_of_output name_list ty_list in
|
||||
let node_out_ty = Types.prod (Misc.map_butlast unarray ty_list) in
|
||||
let v, si, j, action = mk_node_call map call_context app loc (name_list @ [ acc_out ])
|
||||
(c_list @ [ mk_exp acc_out.pat_ty (Epattern acc_out) ]) node_out_ty
|
||||
in
|
||||
let v = translate_var_dec v in
|
||||
let b = mk_block ~locals:v action in
|
||||
si, j, [Aassgn (acc_out, acc_in);
|
||||
Afor (x, mk_static_int 0, n, b)]
|
||||
si, j, [Aassgn (acc_out, acc_in); Afor (xd, mk_static_int 0, n, b)]
|
||||
|
||||
| Minils.Ifold ->
|
||||
let (c_list, acc_in) = split_last c_list in
|
||||
let c_list = array_of_input c_list in
|
||||
let acc_out = last_element name_list in
|
||||
let v, si, j, action = mk_node_call map call_context
|
||||
app loc name_list (c_list @ [ mk_exp (Elhs acc_out) ]) in
|
||||
let v, si, j, action =
|
||||
mk_node_call map call_context app loc name_list (c_list @ [ mk_exp acc_out.pat_ty (Epattern acc_out) ]) ty
|
||||
in
|
||||
let v = translate_var_dec v in
|
||||
let b = mk_block ~locals:v action in
|
||||
si, j, [ Aassgn (acc_out, acc_in);
|
||||
Afor (x, mk_static_int 0, n, b) ]
|
||||
si, j, [ Aassgn (acc_out, acc_in); Afor (xd, mk_static_int 0, n, b) ]
|
||||
|
||||
| Minils.Ifoldi ->
|
||||
let (c_list, acc_in) = split_last c_list in
|
||||
let c_list = array_of_input c_list in
|
||||
let acc_out = last_element name_list in
|
||||
let v, si, j, action = mk_node_call map call_context
|
||||
app loc name_list (c_list @ [ mk_evar x; mk_exp (Elhs acc_out) ]) in
|
||||
let v, si, j, action = mk_node_call map call_context app loc name_list
|
||||
(c_list @ [ mk_evar_int x; mk_exp acc_out.pat_ty (Epattern acc_out) ]) ty
|
||||
in
|
||||
let v = translate_var_dec v in
|
||||
let b = mk_block ~locals:v action in
|
||||
si, j, [ Aassgn (acc_out, acc_in);
|
||||
Afor (x, mk_static_int 0, n, b) ]
|
||||
si, j, [ Aassgn (acc_out, acc_in); Afor (xd, mk_static_int 0, n, b) ]
|
||||
|
||||
let remove m d_list =
|
||||
List.filter (fun { Minils.v_ident = n } -> not (List.mem_assoc n m)) d_list
|
||||
|
||||
let translate_contract map mem_vars =
|
||||
let translate_contract map mem_var_tys =
|
||||
function
|
||||
| None -> ([], [], [], [])
|
||||
| Some
|
||||
|
|
@ -408,23 +413,22 @@ let translate_contract map mem_vars =
|
|||
Minils.c_eq = eq_list;
|
||||
Minils.c_local = d_list;
|
||||
} ->
|
||||
let (v, si, j, s_list) = translate_eq_list map
|
||||
empty_call_context eq_list in
|
||||
let (v, si, j, s_list) = translate_eq_list map empty_call_context eq_list in
|
||||
let d_list = translate_var_dec (v @ d_list) in
|
||||
let d_list = List.filter
|
||||
(fun vd -> not (List.mem vd.v_ident mem_vars)) d_list in
|
||||
(fun vd -> not (List.exists (fun (i,_) -> i = vd.v_ident) mem_var_tys)) d_list in
|
||||
(si, j, s_list, d_list)
|
||||
|
||||
(** Returns a map, mapping variables names to the variables
|
||||
where they will be stored. *)
|
||||
let subst_map inputs outputs locals mems =
|
||||
let subst_map inputs outputs locals mem_tys =
|
||||
(* Create a map that simply maps each var to itself *)
|
||||
let m =
|
||||
let map =
|
||||
List.fold_left
|
||||
(fun m { Minils.v_ident = x } -> Env.add x (mk_lhs (Lvar x)) m)
|
||||
(fun m { Minils.v_ident = x; Minils.v_type = ty } -> Env.add x (mk_pattern ty (Lvar x)) m)
|
||||
Env.empty (inputs @ outputs @ locals)
|
||||
in
|
||||
List.fold_left (fun m x -> Env.add x (mk_lhs (Lmem x)) m) m mems
|
||||
List.fold_left (fun map (x, x_ty) -> Env.add x (mk_pattern x_ty (Lmem x)) map) map mem_tys
|
||||
|
||||
let translate_node
|
||||
({
|
||||
|
|
@ -438,15 +442,15 @@ let translate_node
|
|||
Minils.n_loc = loc;
|
||||
} as n) =
|
||||
Idents.enter_node f;
|
||||
let mem_vars = Mls_utils.node_memory_vars n in
|
||||
let subst_map = subst_map i_list o_list d_list mem_vars in
|
||||
let mem_var_tys = Mls_utils.node_memory_vars n in
|
||||
let subst_map = subst_map i_list o_list d_list mem_var_tys in
|
||||
let (v, si, j, s_list) = translate_eq_list subst_map empty_call_context eq_list in
|
||||
let (si', j', s_list', d_list') = translate_contract subst_map mem_vars contract in
|
||||
let (si', j', s_list', d_list') = translate_contract subst_map mem_var_tys contract in
|
||||
let i_list = translate_var_dec i_list in
|
||||
let o_list = translate_var_dec o_list in
|
||||
let d_list = translate_var_dec (v @ d_list) in
|
||||
let m, d_list = List.partition
|
||||
(fun vd -> List.mem vd.v_ident mem_vars) d_list in
|
||||
(fun vd -> List.exists (fun (i,_) -> i = vd.v_ident) mem_var_tys) d_list in
|
||||
let s = Control.joinlist (s_list @ s_list') in
|
||||
let j = j' @ j in
|
||||
let si = Control.joinlist (si @ si') in
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ let write_obc_file p =
|
|||
comment "Generation of Obc code"
|
||||
|
||||
let targets = [ (*"c", Obc_no_params Cmain.program;*)
|
||||
"java", Obc_no_params Java_main.program;
|
||||
"java", Obc Java_main.program;
|
||||
"obc", Obc write_obc_file;
|
||||
"obc_np", Obc_no_params write_obc_file;
|
||||
"epo", Minils write_object_file ]
|
||||
|
|
|
|||
|
|
@ -135,10 +135,15 @@ struct
|
|||
| _ -> []
|
||||
end
|
||||
|
||||
(* Assumes normal form, all fby are solo rhs *)
|
||||
let node_memory_vars n =
|
||||
let eq _ acc ({ eq_lhs = pat; eq_rhs = e } as eq) =
|
||||
match e.e_desc with
|
||||
| Efby(_, _) -> eq, Vars.vars_pat acc pat
|
||||
| Efby(_, _) ->
|
||||
let v_l = Vars.vars_pat [] pat in
|
||||
let t_l = Types.unprod e.e_ty in
|
||||
let acc = (List.combine v_l t_l) @ acc in
|
||||
eq, acc
|
||||
| _ -> eq, acc
|
||||
in
|
||||
let funs = { Mls_mapfold.defaults with eq = eq } in
|
||||
|
|
|
|||
|
|
@ -274,7 +274,7 @@ let rec cexpr_of_static_exp se =
|
|||
let rec cexpr_of_exp var_env exp =
|
||||
match exp.e_desc with
|
||||
(** Obj expressions that form valid C lhs are translated via clhs_of_exp. *)
|
||||
| Elhs _ ->
|
||||
| Epattern _ ->
|
||||
Clhs (clhs_of_exp var_env exp)
|
||||
(** Constants, the easiest translation. *)
|
||||
| Econst lit ->
|
||||
|
|
@ -338,7 +338,7 @@ and clhss_of_lhss var_env lhss =
|
|||
List.map (clhs_of_lhs var_env) lhss
|
||||
|
||||
and clhs_of_exp var_env exp = match exp.e_desc with
|
||||
| Elhs l -> clhs_of_lhs var_env l
|
||||
| Epattern l -> clhs_of_lhs var_env l
|
||||
(** We were passed an expression that is not translatable to a valid C lhs?!*)
|
||||
| _ -> invalid_arg "clhs_of_exp: argument not a Var, Mem or Field"
|
||||
|
||||
|
|
|
|||
|
|
@ -38,12 +38,12 @@ let rec control map ck s =
|
|||
| Cvar { contents = Clink ck } -> control map ck s
|
||||
| Con(ck, c, n) ->
|
||||
let x = var_from_name map n in
|
||||
control map ck (Acase(mk_exp (Elhs x), [(c, mk_block [s])]))
|
||||
control map ck (Acase(mk_exp x.pat_ty (Epattern x), [(c, mk_block [s])]))
|
||||
|
||||
let is_deadcode = function
|
||||
| Aassgn (lhs, e) ->
|
||||
(match e.e_desc with
|
||||
| Elhs l -> l = lhs
|
||||
| Epattern l -> l = lhs
|
||||
| _ -> false
|
||||
)
|
||||
| Acase (_, []) -> true
|
||||
|
|
|
|||
|
|
@ -68,15 +68,15 @@ and act = Anewvar of var_dec * exp
|
|||
| Aif of exp * block
|
||||
| Aifelse of exp * block * block
|
||||
| Ablock of block
|
||||
| Afor of var_ident * exp * exp * block
|
||||
| Afor of var_dec * exp * exp * block (* TODO var_dec *)
|
||||
| Areturn of exp
|
||||
|
||||
and exp = Eval of pattern
|
||||
| Efun of op_name * exp list
|
||||
| Emethod_call of pattern * method_name * exp list
|
||||
| Enew of ty * exp list
|
||||
| Enew_array of ty * exp list
|
||||
| Evoid (*printed as nothing*)
|
||||
| Earray of exp list
|
||||
| Svar of const_name
|
||||
| Sint of int
|
||||
| Sfloat of float
|
||||
|
|
@ -90,6 +90,14 @@ and pattern = Pfield of pattern * field_name
|
|||
|
||||
type program = classe list
|
||||
|
||||
let mk_var x = Eval (Pvar x)
|
||||
|
||||
let mk_var_dec x ty =
|
||||
{ vd_type = ty; vd_ident = x }
|
||||
|
||||
let mk_block ?(locals=[]) b =
|
||||
{ b_locals = locals; b_body = b; }
|
||||
|
||||
let mk_methode ?(protection=Ppublic) ?(static=false) ?(args=[]) ?(returns=Tunit)
|
||||
body name =
|
||||
{ m_protection = protection; m_static = static; m_name = name; m_args = args; m_returns = returns; m_body = body; }
|
||||
|
|
|
|||
|
|
@ -2,10 +2,12 @@
|
|||
open Java
|
||||
open Java_printer
|
||||
open Obc2java
|
||||
open Compiler_utils
|
||||
|
||||
|
||||
let program p =
|
||||
let filename = filename_of_module p in
|
||||
let dirname = build_path filename in
|
||||
let filename = filename_of_name p.Obc.p_modname in
|
||||
let dirname = build_path (filename ^ "_java") in
|
||||
let dir = clean_dir dirname in
|
||||
Java.print dir o
|
||||
let p_java = Obc2java.program p in
|
||||
output_program dir p_java
|
||||
|
|
@ -13,6 +13,8 @@ open Java
|
|||
open Pp_tools
|
||||
open Format
|
||||
|
||||
(* TODO java faire des vrais qualname recursifs, bare_constructor doit être vraiment bare *)
|
||||
|
||||
let class_name = Global_printer.print_shortname
|
||||
let obj_ident = Global_printer.print_ident
|
||||
let constructor_name = Global_printer.print_qualname
|
||||
|
|
@ -54,22 +56,22 @@ let rec field ff f =
|
|||
final f.f_final
|
||||
ty f.f_type
|
||||
field_ident f.f_name
|
||||
(print_opt2 exp " =@ ") f.f_value
|
||||
(print_opt2 exp " = ") f.f_value
|
||||
|
||||
and exp ff = function
|
||||
| Eval p -> pattern ff p
|
||||
| Efun (f,e_l) -> fprintf ff "%a@[%a@]" op_name f args e_l
|
||||
| Emethod_call (o,m,e_l) -> fprintf ff "%a.%a%a" pattern o method_name m args e_l
|
||||
| Enew (c,e_l) -> fprintf ff "new %a%a" ty c args e_l
|
||||
| Enew_array (t,e_l) -> fprintf ff "new %a@[<2>%a@]" ty t (print_list_r exp "{"",""}") e_l
|
||||
| Evoid -> ()
|
||||
| Earray e_l -> fprintf ff "@[<2>%a@]" (print_list_r exp "{"",""}") e_l
|
||||
| Svar c -> const_name ff c
|
||||
| Sint i -> pp_print_int ff i
|
||||
| Sfloat f -> pp_print_float ff f
|
||||
| Sbool b -> pp_print_bool ff b
|
||||
| Sconstructor c -> constructor_name ff c
|
||||
|
||||
and args ff e_l = fprintf ff "@[%a@]" (print_list_r exp "("","")") e_l
|
||||
and args ff e_l = fprintf ff "@[(%a)@]" (print_list_r exp """,""") e_l
|
||||
|
||||
and pattern ff = function
|
||||
| Pfield (p,f) -> fprintf ff "%a.%a" pattern p field_name f
|
||||
|
|
@ -100,29 +102,37 @@ and act ff = function
|
|||
block bf
|
||||
| Ablock b -> fprintf ff "@[<2>{@ %a@ }]" block b
|
||||
| Afor (x, i1, i2, b) ->
|
||||
fprintf ff "@[<2>for %a = %a to %a {@ %a@ }@]"
|
||||
var_ident x
|
||||
fprintf ff "@[<2>for (%a = %a; %a<%a; %a++) {@ %a@ }@]"
|
||||
var_dec x
|
||||
exp i1
|
||||
var_ident x.vd_ident
|
||||
exp i2
|
||||
var_ident x.vd_ident
|
||||
block b
|
||||
| Areturn e -> fprintf ff "return %a" exp e
|
||||
|
||||
let methode ff m =
|
||||
fprintf ff "@[<4>%a%a%a %a @[<2>%a@] {@\n%a@]@\n}"
|
||||
fprintf ff "@[<4>%a%a%a %a @[<2>(%a)@] {@\n%a@]@\n}"
|
||||
protection m.m_protection
|
||||
static m.m_static
|
||||
ty m.m_returns
|
||||
method_name m.m_name
|
||||
(vd_list "("","")") m.m_args
|
||||
(vd_list """,""") m.m_args
|
||||
block m.m_body
|
||||
|
||||
let constructor ff m =
|
||||
fprintf ff "@[<4>%a%a @[<2>(%a)@] {@\n%a@]@\n}"
|
||||
protection m.m_protection
|
||||
method_name m.m_name
|
||||
(vd_list """,""") m.m_args
|
||||
block m.m_body
|
||||
|
||||
let rec class_desc ff cd =
|
||||
let pm = print_list methode """""" in
|
||||
fprintf ff "@[<v>%a@ %a@ %a@ %a@]"
|
||||
(print_list_r field """;"";") cd.cd_fields
|
||||
(print_list_r classe """""") cd.cd_classs
|
||||
pm cd.cd_constructors
|
||||
pm cd.cd_methodes
|
||||
(print_list constructor """""") cd.cd_constructors
|
||||
(print_list methode """""") cd.cd_methodes
|
||||
|
||||
and classe ff c = match c.c_kind with
|
||||
| Cenum c_l ->
|
||||
|
|
@ -143,8 +153,11 @@ let output_classe dir c =
|
|||
let file_name = file_name ^ ".java" in
|
||||
let oc = open_out (Filename.concat dir file_name) in
|
||||
let ff = Format.formatter_of_out_channel oc in
|
||||
fprintf ff "package %s;@\n" package_name;
|
||||
fprintf ff "package %s;@\n" (String.lowercase package_name);
|
||||
classe ff c;
|
||||
pp_print_flush ff ();
|
||||
close_out oc
|
||||
|
||||
let output_program dir (p:Java.program) =
|
||||
List.iter (output_classe dir) p
|
||||
|
||||
|
|
|
|||
|
|
@ -24,6 +24,16 @@ open Obc
|
|||
open Java
|
||||
|
||||
|
||||
let fresh_it () =
|
||||
let id = Idents.gen_var "obc2java" "i" in
|
||||
id, mk_var_dec id Tint
|
||||
|
||||
(** fresh Afor from 0 to [size] with [body] a function from [var_ident] (the iterator) to [act] list *)
|
||||
let fresh_for size body =
|
||||
let i, id = fresh_it () in
|
||||
Afor (id, Sint 0, size, mk_block (body i))
|
||||
|
||||
|
||||
(** a [Module] becomes a [package] *)
|
||||
let translate_qualname q = match q with
|
||||
| { qual = "Pervasives" } -> q
|
||||
|
|
@ -33,9 +43,9 @@ let translate_qualname q = match q with
|
|||
| _ -> { q with qual = String.lowercase q.qual }
|
||||
|
||||
(** a [Module.const] becomes a [module.CONSTANTES.CONST] *)
|
||||
let translate_const_name q =
|
||||
let q = translate_qualname q in
|
||||
{ qual = q.qual ^ ".CONSTANTES"; name = String.uppercase q.name }
|
||||
let translate_const_name q = match q with
|
||||
| { qual = m } when m = local_qualname -> { q with name = String.uppercase q.name }
|
||||
| _ -> { q with qual = (String.lowercase q.qual)^ ".CONSTANTES"; name = String.uppercase q.name }
|
||||
|
||||
(** a [Module.name] becomes a [module.Name]
|
||||
used for type_names, class_names, fun_names *)
|
||||
|
|
@ -44,17 +54,19 @@ let qualname_to_class_name q =
|
|||
{ q with name = String.capitalize q.name }
|
||||
|
||||
(** a [Module.Constr] of an [Module.enum] type becomes a [module.Enum.CONSTR] of the [module.Enum] class *)
|
||||
let _translate_constructor_name q q_ty =
|
||||
let _translate_constructor_name q q_ty = (* TODO java recursive qualname ! *)
|
||||
let classe = qualname_to_class_name q_ty in
|
||||
let classe_name = classe.qual ^ "." ^ classe.name in
|
||||
let constr = { qual = classe_name; name = q |> shortname |> String.uppercase } in
|
||||
constr
|
||||
let q = qualname_to_class_name q in
|
||||
{ q with name = classe.name ^ "." ^ q.name }
|
||||
|
||||
let translate_constructor_name q =
|
||||
match Modules.find_constrs c with
|
||||
| Tid c_ty -> _translate_constructor_name q q_ty
|
||||
match Modules.find_constrs q with
|
||||
| Types.Tid q_ty when q_ty = Initial.pbool -> q |> shortname |> local_qn
|
||||
| Types.Tid q_ty -> _translate_constructor_name q q_ty
|
||||
| _ -> assert false
|
||||
|
||||
let translate_field_name f = f |> Names.shortname |> String.lowercase
|
||||
|
||||
(** a [name] becomes a [package.Name] *)
|
||||
let name_to_classe_name n = n |> Modules.current_qual |> qualname_to_class_name
|
||||
|
||||
|
|
@ -68,16 +80,17 @@ let rec static_exp param_env se = match se.Types.se_desc with
|
|||
| Types.Sfloat f -> Sfloat f
|
||||
| Types.Sbool b -> Sbool b
|
||||
| Types.Sconstructor c -> let c = translate_constructor_name c in Sconstructor c
|
||||
| Types.Sfield f -> assert false;
|
||||
| Types.Stuple t -> assert false; (* TODO java ?? not too dificult if needed, return Tuplen<..>() *)
|
||||
| Types.Sarray_power _ -> assert false; (* TODO java array *)
|
||||
| Types.Sarray se_l -> Earray (List.map (static_exp param_env) se_l)
|
||||
| Types.Srecord _ -> assert false; (* TODO java *)
|
||||
| Types.Sfield f -> eprintf "ojSfield @."; assert false;
|
||||
| Types.Stuple t -> eprintf "ojStuple@."; assert false;
|
||||
(* TODO java ?? not too difficult if needed, return Tuplen<..>() *)
|
||||
| Types.Sarray_power _ -> eprintf "ojSarray_power@."; assert false; (* TODO java array *)
|
||||
| Types.Sarray se_l -> Enew_array (ty param_env se.Types.se_ty, List.map (static_exp param_env) se_l)
|
||||
| Types.Srecord _ -> eprintf "ojSrecord@."; assert false; (* TODO java *)
|
||||
| Types.Sop (f, se_l) -> Efun (qualname_to_class_name f, List.map (static_exp param_env) se_l)
|
||||
|
||||
and boxed_ty param_env t = match t with
|
||||
| Types.Tprod ty_l ->
|
||||
let ln = ty_l |> List.length |> Pervasives.char_of_int |> (String.make 1) in
|
||||
let ln = ty_l |> List.length |> Pervasives.string_of_int in
|
||||
Tgeneric ({ qual = "heptagon"; name = "Tuple"^ln }, List.map (boxed_ty param_env) ty_l)
|
||||
| Types.Tid t when t = Initial.pbool -> Tclass (Names.local_qn "Boolean")
|
||||
| Types.Tid t when t = Initial.pint -> Tclass (Names.local_qn "Integer")
|
||||
|
|
@ -89,7 +102,7 @@ and boxed_ty param_env t = match t with
|
|||
|
||||
and ty param_env t :Java.ty = match t with
|
||||
| Types.Tprod ty_l ->
|
||||
let ln = ty_l |> List.length |> Pervasives.char_of_int |> (String.make 1) in
|
||||
let ln = ty_l |> List.length |> Pervasives.string_of_int in
|
||||
Tgeneric ({ qual = "heptagon"; name = "Tuple"^ln }, List.map (boxed_ty param_env) ty_l)
|
||||
| Types.Tid t when t = Initial.pbool -> Tbool
|
||||
| Types.Tid t when t = Initial.pint -> Tint
|
||||
|
|
@ -99,42 +112,80 @@ and ty param_env t :Java.ty = match t with
|
|||
| Types.Tasync _ -> assert false; (* TODO async *)
|
||||
| Types.Tunit -> Tunit
|
||||
|
||||
let var_dec param_env vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident }
|
||||
|
||||
let var_dec_list param_env vd_l =
|
||||
let _vd vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident } in
|
||||
List.map _vd vd_l
|
||||
let var_dec_list param_env vd_l = List.map (var_dec param_env) vd_l
|
||||
|
||||
let act_list param_env act_l =
|
||||
let _act acts act = match act with
|
||||
let rec exp param_env e = match e.e_desc with
|
||||
| Obc.Epattern p -> Eval (pattern param_env p)
|
||||
| Obc.Econst se -> static_exp param_env se
|
||||
| Obc.Eop (op,e_l) -> Efun (op, exp_list param_env e_l)
|
||||
| Obc.Estruct _ -> eprintf "ojEstruct@."; assert false (* TODO java *)
|
||||
| Obc.Earray e_l -> Enew_array (ty param_env e.e_ty, exp_list param_env e_l)
|
||||
| Obc.Ebang _ -> eprintf "ojEbang@."; assert false (* TODO java async *)
|
||||
|
||||
and exp_list param_env e_l = List.map (exp param_env) e_l
|
||||
|
||||
and pattern param_env p = match p.pat_desc with
|
||||
| Obc.Lvar v -> Pvar v
|
||||
| Obc.Lmem v -> Pthis v
|
||||
| Obc.Lfield (p,f) -> Pfield (pattern param_env p, translate_field_name f)
|
||||
| Obc.Larray (p,e) -> Parray_elem (pattern param_env p, exp param_env e)
|
||||
|
||||
let obj_ref param_env o = match o with
|
||||
| Oobj id -> Pvar id
|
||||
| Oarray (id,p) -> Parray_elem (Pvar id, Eval (pattern param_env p))
|
||||
|
||||
let rec act_list param_env act_l acts =
|
||||
let _act act acts = match act with
|
||||
| Obc.Aassgn (p,e) -> (Aassgn (pattern param_env p, exp param_env e))::acts
|
||||
| Obc.Acall ([], obj, Mstep, e_l) ->
|
||||
let acall = Amethod_call (obj_ref param_env obj, "step", exp_list param_env e_l) in
|
||||
acall::acts
|
||||
| Obc.Acall ([p], obj, Mstep, e_l) ->
|
||||
let ecall = Emethod_call (obj_ref param_env obj, "step", exp_list param_env e_l) in
|
||||
let assgn = Aassgn (pattern param_env p, call) in
|
||||
let assgn = Aassgn (pattern param_env p, ecall) in
|
||||
assgn::acts
|
||||
| Obc.Acall (p_l, obj, _, e_l) ->
|
||||
| Obc.Acall (p_l, obj, Mstep, e_l) ->
|
||||
let return_ty = p_l |> pattern_list_to_type |> (ty param_env) in
|
||||
let return_id = Idents.gen_var "obc2java" "out" in
|
||||
let return_vd = { vd_type = return_ty; vd_ident = return_id } in
|
||||
let ecall = Emethod_call (obj_ref param_env obj, "step", exp_list param_env e_l) in
|
||||
let assgn = Anewvar (return_vd, ecall) in
|
||||
let copies = Misc.mapi (fun i p -> Aassgn (p, Eval (Pfield (return_id, "c"^(string_of_int i))))) p_l in
|
||||
let copy_return_to_var i p =
|
||||
Aassgn (pattern param_env p, Eval (Pfield (Pvar return_id, "c"^(string_of_int i))))
|
||||
in
|
||||
let copies = Misc.mapi copy_return_to_var p_l in
|
||||
assgn::(copies@acts)
|
||||
| Obc.Acall (_, obj, Mreset, _) ->
|
||||
let acall = Amethod_call (obj_ref param_env obj, "step", []) in
|
||||
let acall = Amethod_call (obj_ref param_env obj, "reset", []) in
|
||||
acall::acts
|
||||
| Obc.Async_call _ -> assert false (* TODO java async *)
|
||||
| Obc.Aasync_call _ -> assert false (* TODO java async *)
|
||||
| Obc.Acase (e, c_b_l) when e.e_ty = Types.Tid Initial.pbool ->
|
||||
(match c_b_l with
|
||||
| [] -> acts
|
||||
| [(c,b)] when c = Initial.ptrue ->
|
||||
(Aif (exp param_env e, block param_env b)):: acts
|
||||
| [(c,b)] when c = Initial.pfalse ->
|
||||
(Aifelse (exp param_env e, {b_locals = []; b_body = []}, block param_env b)) :: acts
|
||||
| _ ->
|
||||
let _, _then = List.find (fun (c,b) -> c = Initial.ptrue) c_b_l in
|
||||
let _, _else = List.find (fun (c,b) -> c = Initial.pfalse) c_b_l in
|
||||
(Aifelse (exp param_env e, block param_env _then, block param_env _else)) :: acts)
|
||||
| Obc.Acase (e, c_b_l) ->
|
||||
let _c_b (c,b) = translate_constructor_name
|
||||
Aswitch (exp param_env e,
|
||||
let _c_b (c,b) = translate_constructor_name c, block param_env b in
|
||||
let acase = Aswitch (exp param_env e, List.map _c_b c_b_l) in
|
||||
acase::acts
|
||||
| Obc.Afor (v, se, se', b) ->
|
||||
let afor = Afor (var_dec param_env v, static_exp param_env se, static_exp param_env se', block param_env b) in
|
||||
afor::acts
|
||||
in
|
||||
List.fold_right _act act_l acts
|
||||
|
||||
let block param_env ?(locals=[]) ?(end_acts=[]) ob =
|
||||
and block param_env ?(locals=[]) ?(end_acts=[]) ob =
|
||||
let blocals = var_dec_list param_env ob.Obc.b_locals in
|
||||
let locals = locals @ blocals in
|
||||
let bacts = act_list param_env ob.Obc.b_body in
|
||||
let acts = end_acts @ bacts in
|
||||
let acts = act_list param_env ob.Obc.b_body end_acts in
|
||||
{ b_locals = locals; b_body = acts }
|
||||
|
||||
let class_def_list classes cd_l =
|
||||
|
|
@ -144,7 +195,7 @@ let class_def_list classes cd_l =
|
|||
(* [param_env] is an env mapping local param name to ident *)
|
||||
let constructeur, param_env =
|
||||
let param_to_arg param_env p =
|
||||
let p_ident = Idents.gen_var "obc2java" p.Signature.p_name in
|
||||
let p_ident = Idents.gen_var "obc2java" (String.uppercase p.Signature.p_name) in
|
||||
let p_vd = { vd_ident = p_ident; vd_type = ty param_env p.Signature.p_type } in
|
||||
let param_env = NamesEnv.add p.Signature.p_name p_ident param_env in
|
||||
p_vd, param_env
|
||||
|
|
@ -156,11 +207,16 @@ let class_def_list classes cd_l =
|
|||
let obj_init_act acts od =
|
||||
let params = List.map (static_exp param_env) od.o_params in
|
||||
let act = match od.o_size with
|
||||
| None -> Aassgn (Pthis od.o_ident, Enew (Tclass od.o_class, params))
|
||||
| Some size -> assert false; (* TODO java :
|
||||
Aassgn (Pthis od.o_ident, Enew ( Tarray, Earray [Enew (Tclass, params)... ] ) ) cf node.java*)
|
||||
| None -> [ Aassgn (Pthis od.o_ident, Enew (Tclass od.o_class, params)) ]
|
||||
| Some size ->
|
||||
let size = static_exp param_env size in
|
||||
let assgn_elem i =
|
||||
[ Aassgn (Parray_elem (Pthis od.o_ident, mk_var i), Enew (Tclass od.o_class, params)) ]
|
||||
in
|
||||
[ Aassgn (Pthis od.o_ident, Enew (Tarray (Tclass od.o_class,size), []));
|
||||
fresh_for size assgn_elem ]
|
||||
in
|
||||
act::acts
|
||||
act@acts
|
||||
in
|
||||
let acts = List.map final_field_init_act args in
|
||||
let acts = List.fold_left obj_init_act acts cd.cd_objs in
|
||||
|
|
@ -170,7 +226,7 @@ let class_def_list classes cd_l =
|
|||
in
|
||||
let fields =
|
||||
let mem_to_field fields vd = (mk_field ~protection:Pprotected (ty param_env vd.v_type) vd.v_ident) :: fields in
|
||||
let obj_to_field fields od = (* TODO [o_params] are treated in the [reset] code *)
|
||||
let obj_to_field fields od =
|
||||
let jty = match od.o_size with
|
||||
| None -> Tclass (qualname_to_class_name od.o_class)
|
||||
| Some size -> Tarray (Tclass (qualname_to_class_name od.o_class), static_exp param_env size)
|
||||
|
|
@ -194,61 +250,53 @@ let class_def_list classes cd_l =
|
|||
| [vd] -> Eval (Pvar vd.vd_ident)
|
||||
| vd_l -> Enew (return_ty, List.map (fun vd -> Eval (Pvar vd.vd_ident)) vd_l))
|
||||
in
|
||||
let body = block param_env ~locals:vd_output ~end_acts:[return_act] ostep.m_body in
|
||||
mk_methode ~args:(var_dec_list ostep.m_inputs) ~returns:jreturn_ty body "step"
|
||||
let body = block param_env ~locals:vd_output ~end_acts:[return_act] ostep.Obc.m_body in
|
||||
mk_methode ~args:(var_dec_list param_env ostep.Obc.m_inputs) ~returns:return_ty body "step"
|
||||
in
|
||||
let reset =
|
||||
let oreset = find_reset_method cd in
|
||||
let body = block param_env oreset.m_body in
|
||||
let body = block param_env oreset.Obc.m_body in
|
||||
mk_methode body "reset"
|
||||
in
|
||||
let classe = mk_classe ~fields=fields ~constrs=[constructeur] ~methodes=[step;reset] class_name in
|
||||
let classe = mk_classe ~fields:fields ~constrs:[constructeur] ~methodes:[step;reset] class_name in
|
||||
classe::classes
|
||||
in
|
||||
List.fold_left classe_def classes cd_l
|
||||
List.fold_left class_def classes cd_l
|
||||
|
||||
|
||||
let type_dec_list classes td_l =
|
||||
let param_env = NamesEnv.empty in
|
||||
let _td classes td =
|
||||
let classe_name = td.t_name |> qualname_to_class_name |> Names.shortname in
|
||||
let classe, jty = match td.t_desc with
|
||||
| Type_abs -> eprintf "Abstract types not supported in Java backend"; assert false (* TODO java *)
|
||||
| Type_alias ot -> classes
|
||||
let classe_name = qualname_to_class_name td.t_name in
|
||||
match td.t_desc with
|
||||
| Type_abs -> Misc.unsupported "obc2java" 1 (* TODO java *)
|
||||
| Type_alias ot -> classes (* TODO java alias ?? *)
|
||||
| Type_enum c_l ->
|
||||
let mk_constr_enum oc =
|
||||
let jc = _translate_constructor_name oc td.t_name in
|
||||
add_constr_name oc jc;
|
||||
jc
|
||||
in
|
||||
(mk_enum (List.map mk_constr_enum oc_l) classe_name) :: classes
|
||||
let mk_constr_enum c = _translate_constructor_name c td.t_name in
|
||||
(mk_enum (List.map mk_constr_enum c_l) classe_name) :: classes
|
||||
| Type_struct f_l ->
|
||||
let mk_field_jfield { f_name = oname; f_type = oty } =
|
||||
let mk_field_jfield { Signature.f_name = oname; Signature.f_type = oty } =
|
||||
let jty = ty param_env oty in
|
||||
let name = oname |> Names.shortname |> String.lowercase in
|
||||
add_Field_name oname name;
|
||||
mk_field jty name
|
||||
let field = Idents.ident_of_name (translate_field_name oname) in (* TODO java pretty ugly *)
|
||||
mk_field jty field
|
||||
in
|
||||
(mk_classe ~fields:(List.map mk_field_jfield f_l) classe_name) :: classes
|
||||
in
|
||||
add_type_name td.t_name jty;
|
||||
classes
|
||||
in
|
||||
List.fold_left classes _td
|
||||
List.fold_left _td classes td_l
|
||||
|
||||
|
||||
let const_dec_list cd_l =
|
||||
let param_env = NamesEnv.empty in
|
||||
let mk_const_field { Obc.c_name = oname ; Obc.c_value = ovalue; Obc.c_type = otype } =
|
||||
let name = oname |> translate_const_name |> shortname in
|
||||
let value = static_exp ovalue in
|
||||
let name = oname |> translate_const_name |> shortname |> Idents.ident_of_name in (* TODO java pretty ugly*)
|
||||
let value = Some (static_exp param_env ovalue) in
|
||||
let t = ty param_env otype in
|
||||
mk_field ~static:true ~final:true ~value:value t name
|
||||
in
|
||||
match cd_l with
|
||||
| [] -> []
|
||||
| _ ->
|
||||
let classe_name = "CONSTANTES" |> name_to_classe_name |> shortname in
|
||||
let classe_name = "CONSTANTES" |> name_to_classe_name in
|
||||
let fields = List.map mk_const_field cd_l in
|
||||
[mk_classe ~fields:fields classe_name]
|
||||
|
||||
|
|
|
|||
|
|
@ -202,7 +202,7 @@ let rec print_lhs ff e avs single =
|
|||
|
||||
let rec print_exp ff e p avs ts single =
|
||||
match e.e_desc with
|
||||
| Elhs l -> print_lhs ff l avs single
|
||||
| Epattern l -> print_lhs ff l avs single
|
||||
| Econst c -> print_const ff c ts
|
||||
| Eop (op, es) -> print_op ff op es p avs ts single
|
||||
| Estruct (type_name,fields) ->
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ and pat_desc =
|
|||
and exp = { e_desc : exp_desc; e_ty : ty; e_loc : location }
|
||||
|
||||
and exp_desc =
|
||||
| Elhs of pattern
|
||||
| Epattern of pattern
|
||||
| Econst of static_exp
|
||||
| Eop of op_name * exp list
|
||||
| Estruct of type_name * (field_name * exp) list
|
||||
|
|
@ -68,7 +68,7 @@ type act =
|
|||
| Acall of pattern list * obj_ref * method_name * exp list
|
||||
| Aasync_call of async_t * pattern list * obj_ref * method_name * exp list
|
||||
| Acase of exp * (constructor_name * block) list
|
||||
| Afor of var_ident * static_exp * static_exp * block
|
||||
| Afor of var_dec * static_exp * static_exp * block
|
||||
|
||||
and block =
|
||||
{ b_locals : var_dec list;
|
||||
|
|
@ -107,21 +107,33 @@ type program =
|
|||
p_consts : const_dec list;
|
||||
p_defs : class_def list }
|
||||
|
||||
let mk_var_dec ?(loc=no_location) name ty =
|
||||
{ v_ident = name; v_type = ty; v_loc = loc }
|
||||
let mk_var_dec ?(loc=no_location) ident ty =
|
||||
{ v_ident = ident; v_type = ty; v_loc = loc }
|
||||
|
||||
let mk_exp ?(ty=invalid_type) ?(loc=no_location) desc = (* TODO master : remove the invalid_type *)
|
||||
let mk_exp ?(loc=no_location) ty desc =
|
||||
{ e_desc = desc; e_ty = ty; e_loc = loc }
|
||||
|
||||
let mk_lhs ?(ty=invalid_type) ?(loc=no_location) desc = (* TODO master : remove the invalid_type *)
|
||||
let mk_exp_int ?(loc=no_location) desc =
|
||||
{ e_desc = desc; e_ty = Initial.tint; e_loc = loc }
|
||||
|
||||
let mk_exp_bool ?(loc=no_location) desc =
|
||||
{ e_desc = desc; e_ty = Initial.tbool; e_loc = loc }
|
||||
|
||||
let mk_pattern ?(loc=no_location) ty desc =
|
||||
{ pat_desc = desc; pat_ty = ty; pat_loc = loc }
|
||||
|
||||
let mk_lhs_exp ?(ty=invalid_type) desc = (* TODO master : remove the invalid_type *)
|
||||
let lhs = mk_lhs ~ty:ty desc in
|
||||
mk_exp ~ty:ty (Elhs lhs)
|
||||
let mk_pattern_int ?(loc=no_location) desc =
|
||||
{ pat_desc = desc; pat_ty = Initial.tint; pat_loc = loc }
|
||||
|
||||
let mk_evar id =
|
||||
mk_exp (Elhs (mk_lhs (Lvar id)))
|
||||
let mk_pattern_exp ty desc =
|
||||
let pat = mk_pattern ty desc in
|
||||
mk_exp ty (Epattern pat)
|
||||
|
||||
let mk_evar ty id =
|
||||
mk_exp ty (Epattern (mk_pattern ty (Lvar id)))
|
||||
|
||||
let mk_evar_int id =
|
||||
mk_exp Initial.tint (Epattern (mk_pattern Initial.tint (Lvar id)))
|
||||
|
||||
let mk_block ?(locals=[]) eq_list =
|
||||
{ b_locals = locals;
|
||||
|
|
@ -156,10 +168,10 @@ let vd_list_to_type vd_l = match vd_l with
|
|||
let pattern_list_to_type p_l = match p_l with
|
||||
| [] -> Types.Tunit
|
||||
| [p] -> p.pat_ty
|
||||
| _ -> Tprod (List.map (fun p -> p.p_type) p_l)
|
||||
| _ -> Tprod (List.map (fun p -> p.pat_ty) p_l)
|
||||
|
||||
let lhs_of_exp e = match e.e_desc with
|
||||
| Elhs l -> l
|
||||
let pattern_of_exp e = match e.e_desc with
|
||||
| Epattern l -> l
|
||||
| _ -> assert false
|
||||
|
||||
let find_step_method cd =
|
||||
|
|
|
|||
|
|
@ -44,9 +44,9 @@ and edesc_it funs acc ed =
|
|||
try funs.edesc funs acc ed
|
||||
with Fallback -> edesc funs acc ed
|
||||
and edesc funs acc ed = match ed with
|
||||
| Elhs l ->
|
||||
| Epattern l ->
|
||||
let l, acc = lhs_it funs acc l in
|
||||
Elhs l, acc
|
||||
Epattern l, acc
|
||||
| Econst se ->
|
||||
let se, acc = static_exp_it funs.global_funs acc se in
|
||||
Econst se, acc
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ and print_exps ff e_list = print_list_r print_exp "" "," "" ff e_list
|
|||
|
||||
and print_exp ff e =
|
||||
match e.e_desc with
|
||||
| Elhs lhs -> print_lhs ff lhs
|
||||
| Epattern lhs -> print_lhs ff lhs
|
||||
| Econst c -> print_static_exp ff c
|
||||
| Eop(op, e_list) -> print_op ff op e_list
|
||||
| Estruct(_,f_e_list) ->
|
||||
|
|
@ -90,8 +90,8 @@ let rec print_act ff a =
|
|||
print_tag_act_list ff tag_act_list;
|
||||
fprintf ff "@]@,}@]"
|
||||
| Afor(x, i1, i2, act_list) ->
|
||||
fprintf ff "@[<v>@[<v 2>for %s = %a to %a {@ %a @]@,}@]"
|
||||
(name x)
|
||||
fprintf ff "@[<v>@[<v 2>for %a = %a to %a {@ %a @]@,}@]"
|
||||
print_vd x
|
||||
print_static_exp i1
|
||||
print_static_exp i2
|
||||
print_block act_list
|
||||
|
|
|
|||
|
|
@ -199,3 +199,14 @@ let split_string s separator = Str.split (separator |> Str.quote |> Str.regexp)
|
|||
|
||||
let file_extension s = split_string s "." |> last_element
|
||||
|
||||
exception Assert_false
|
||||
let internal_error passe code =
|
||||
Format.eprintf "@.---------\nInternal compiler error\nPasse : %s, Code : %d\n----------@." passe code;
|
||||
raise Assert_false
|
||||
|
||||
exception Unsupported
|
||||
let unsupported passe code =
|
||||
Format.eprintf "@.---------\nUnsupported feature, please report it\nPasse : %s, Code : %d\n----------@." passe code;
|
||||
raise Unsupported
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -90,3 +90,9 @@ val (|>) : 'a -> ('a -> 'b) -> 'b
|
|||
|
||||
(** Return the extension of a filename string *)
|
||||
val file_extension : string -> string
|
||||
|
||||
(** Internal error : Is used when an assertion wrong *)
|
||||
val internal_error : string -> int -> 'a
|
||||
|
||||
(** Unsupported : Is used when something should work but is not currently supported *)
|
||||
val unsupported : string -> int -> 'a
|
||||
|
|
|
|||
24
test/check
24
test/check
|
|
@ -114,18 +114,18 @@ launch_check () {
|
|||
fi
|
||||
fi
|
||||
# Compil. java ?
|
||||
if [[ ($echec == 0) && ($java == 1) ]]; then
|
||||
pushd "${base_f}" > /dev/null
|
||||
for java_file in *.java ; do
|
||||
if $JAVAC -warn:-unused -sourcepath .:..:../t1 ${java_file} > /dev/null
|
||||
then
|
||||
echec=0
|
||||
else
|
||||
echec=3
|
||||
fi
|
||||
done
|
||||
popd > /dev/null
|
||||
fi
|
||||
#if [[ ($echec == 0) && ($java == 1) ]]; then
|
||||
# pushd "${base_f}_java" > /dev/null
|
||||
# for java_file in *.java ; do
|
||||
# if $JAVAC -warn:-unused -sourcepath .:..:../t1 ${java_file} > /dev/null
|
||||
# then
|
||||
# echec=0
|
||||
# else
|
||||
# echec=3
|
||||
# fi
|
||||
# done
|
||||
# popd > /dev/null
|
||||
#fi
|
||||
# Compil. c ?
|
||||
if [[ ($echec == 0) && ($c == 1) ]]; then
|
||||
pushd ${base_f}_c >/dev/null
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
(* pour debugger
|
||||
set arguments -v test/good/t1.mls *)
|
||||
type t
|
||||
|
||||
node f(x,z:int) returns (o1:int)
|
||||
var o: int;
|
||||
|
|
|
|||
2
todo.txt
2
todo.txt
|
|
@ -1,6 +1,8 @@
|
|||
|
||||
Plus ou moins ordonné du plus urgent au moins urgent.
|
||||
|
||||
*- Bugs related to matching types without unaliasing it. In lots of parts. Use Modules.unalias_type.
|
||||
|
||||
*- Collision entre les noms de params et les idents dans les noeuds.
|
||||
|
||||
*- Optimisations du genre "if true then ... else ... " ou genre "x,y = if b then a,c else a2,c" qui devrait etre transformé en "x = if b then a else s2; y = c" ...
|
||||
|
|
|
|||
Loading…
Reference in a new issue