This commit is contained in:
Léonard Gérard 2011-01-24 16:07:26 +01:00
parent df469db394
commit 09419a77a5
21 changed files with 346 additions and 226 deletions

View file

@ -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

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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 ]

View 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

View file

@ -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"

View file

@ -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

View file

@ -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; }

View file

@ -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

View file

@ -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

View file

@ -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]

View file

@ -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) ->

View file

@ -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 =

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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;

View file

@ -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" ...