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

New Java backend closing

Browse source
This commit is contained in:
Léonard Gérard 2011-01-20 23:05:18 +01:00
parent fc08753bd9
commit df469db394
22 changed files with 1174 additions and 650 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
compiler/global/global_printer.ml
View file

@ -13,6 +13,8 @@ let print_qualname ff qn = match qn with
| { qual = m; name = n } when m = local_qualname -> print_name ff n
| { qual = m; name = n } -> fprintf ff "%s.%a" m print_name n
let print_shortname ff {name = n} = print_name ff n
let print_async ff async = match async with
| None -> ()
| Some () -> fprintf ff "async "

6
compiler/global/idents.mli
View file

@ -2,6 +2,7 @@
open Names
(** This modules manages unique identifiers,
/!\ To be effective, [enter_node] has to be called when entering a node
[gen_fresh] generates an identifier
[name] returns a unique name (inside its node) from an identifier. *)
@ -11,7 +12,7 @@ type ident
(** Type to be used for local variables *)
type var_ident = ident
(** Comparision on idents with the same properties as [Pervasives.compare] *)
(** Comparison on idents with the same properties as [Pervasives.compare] *)
val ident_compare : ident -> ident -> int
(** Get the full name of an identifier (it is guaranteed to be unique) *)
@ -21,6 +22,9 @@ val name : ident -> string
generate a fresh ident with a sweet [name].
It should be used to define a [fresh] function specific to a pass. *)
val gen_fresh : string -> ('a -> string) -> 'a -> ident
(** [gen_var pass_name name]
generates a fresh ident with a sweet [name] *)
val gen_var : string -> string -> ident
(** [ident_of_name n] returns an identifier corresponding

1
compiler/global/names.ml
View file

@ -34,6 +34,7 @@ module S = Set.Make (struct type t = string let compare = compare end)
let shortname { name = n; } = n
let qualname { qual = n; } = n
let fullname { qual = qual; name = n; } = qual ^ "." ^ n

10
compiler/global/types.ml
View file

@ -29,13 +29,13 @@ and static_exp_desc =
| Sop of fun_name * static_exp list (** defined ops for now in pervasives *)
and ty =
| Tprod of ty list
| Tid of type_name
| Tarray of ty * static_exp
| Tasync of async_t * ty
| Tprod of ty list (** Product type used for tuples *)
| Tid of type_name (** Usable type_name are alias or pervasives {bool,int,float} (see [Initial]) *)
| Tarray of ty * static_exp (** [base_type] * [size] *)
| Tasync of async_t * ty (** [async_annotation] * [base_type] *)
| Tunit
let invalid_type = Tprod []
let invalid_type = Tprod [] (** Invalid type given to untyped expression etc. *)
let prod = function
| [] -> assert false

4
compiler/heptagon/transformations/every.ml
View file

@ -16,10 +16,10 @@ let edesc funs (v,acc_eq_list) ed =
let ed, (v, acc_eq_list) = Hept_mapfold.edesc funs (v,acc_eq_list) ed in
match ed with
| Eapp (op, e_list, Some re) when not (is_var re) ->
let re, vre, eqre = Reset.equation_from_exp re in
let re, vre, eqre = Reset.bool_var_from_exp re in
Eapp(op, e_list, Some re), (vre::v, eqre::acc_eq_list)
| Eiterator(it, op, n, e_list, Some re) when not (is_var re) ->
let re, vre, eqre = Reset.equation_from_exp re in
let re, vre, eqre = Reset.bool_var_from_exp re in
Eiterator(it, op, n, e_list, Some re), (vre::v, eqre::acc_eq_list)
| _ -> ed, (v, acc_eq_list)

1
compiler/heptagon/transformations/present.ml
View file

@ -7,6 +7,7 @@
(* *)
(**************************************************************************)
(* removing present statements *)
open Heptagon
open Hept_mapfold

12
compiler/heptagon/transformations/reset.ml
View file

@ -23,12 +23,12 @@ open Initial
let fresh = Idents.gen_fresh "reset" (fun () -> "r")
(* get e and return x, var_dec_x, x = e *)
let equation_from_exp e =
let n = fresh() in
{ e with e_desc = Evar n }, mk_var_dec n (Tid Initial.pbool), mk_equation (Eeq(Evarpat n, e))
(* get e and return r, var_dec_r, r = e *)
let bool_var_from_exp e =
let r = fresh() in
{ e with e_desc = Evar r }, mk_var_dec r (Tid Initial.pbool), mk_equation (Eeq(Evarpat r, e))
(** Merge two reset conditions *)
let merge_resets res1 res2 =
let mk_or e1 e2 = mk_op_app (Efun Initial.por) [e1;e2] in
match res1, res2 with
@ -82,7 +82,7 @@ let eqdesc funs (res,stateful) = function
if stateful
then (
let e, _ = Hept_mapfold.exp_it funs (res,true) e in
let e, vd, eq = equation_from_exp e in
let e, vd, eq = bool_var_from_exp e in
let r = merge_resets res (Some e) in
let b, _ = Hept_mapfold.block_it funs (r,true) b in
let b = { b with b_equs = eq::b.b_equs; b_local = vd::b.b_local; b_statefull = true } in

144
compiler/main/mls2obc.ml
View file

@ -14,15 +14,14 @@ open Idents
open Signature
open Obc
open Types
open Control
open Static
open Obc_mapfold
open Initial
let fresh_it () = Idents.gen_var "mls2obc" "i"
let gen_obj_name n =
(shortname n) ^ "_mem" ^ (gen_symbol ())
let gen_obj_ident n = Idents.gen_var "mls2obc" ((shortname n) ^ "_inst")
let op_from_string op = { qual = "Pervasives"; name = op; }
@ -56,7 +55,7 @@ let reinit o =
Acall ([], o, Mreset, [])
let rec translate_pat map = function
| Minils.Evarpat x -> [ var_from_name map x ]
| Minils.Evarpat x -> [ Control.var_from_name map x ]
| Minils.Etuplepat pat_list ->
List.fold_right (fun pat acc -> (translate_pat map pat) @ acc)
pat_list []
@ -71,7 +70,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 (var_from_name map n)
| Minils.Evar n -> Elhs (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 ->
@ -116,25 +115,22 @@ let rec translate map e =
and translate_act map pat
({ Minils.e_desc = desc } as act) =
match pat, desc with
| Minils.Etuplepat p_list,
Minils.Eapp ({ Minils.a_op = Minils.Etuple }, act_list, _) ->
| Minils.Etuplepat p_list, Minils.Eapp ({ Minils.a_op = Minils.Etuple }, act_list, _) ->
List.flatten (List.map2 (translate_act map) p_list act_list)
| Minils.Etuplepat p_list,
Minils.Econst { se_desc = Stuple se_list } ->
| Minils.Etuplepat p_list, Minils.Econst { se_desc = Stuple se_list } ->
let const_list = Mls_utils.exp_list_of_static_exp_list se_list in
List.flatten (List.map2 (translate_act map) p_list const_list)
List.flatten (List.map2 (translate_act map) p_list const_list)
(* When Merge *)
| pat, Minils.Ewhen (e, _, _) ->
translate_act map pat e
| pat, Minils.Emerge (x, c_act_list) ->
let lhs = var_from_name map x in
[Acase (mk_exp (Elhs lhs),
translate_c_act_list map pat c_act_list)]
| Minils.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Econcat }, [e1; e2], _) ->
let lhs = Control.var_from_name map x in
[Acase (mk_exp (Elhs lhs), 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 x = var_from_name map x in
let x = Control.var_from_name map x in
(match e1.Minils.e_ty, e2.Minils.e_ty with
| Tarray (_, n1), Tarray (_, n2) ->
let e1 = translate map e1 in
@ -154,36 +150,23 @@ and translate_act map pat
in
[a1; a2]
| _ -> assert false )
| Minils.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Earray_fill;
Minils.a_params = [n] }, [e], _) ->
| Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Earray_fill; Minils.a_params = [n] }, [e], _) ->
let cpt = fresh_it () in
let e = translate map e in
[ Afor (cpt, mk_static_int 0, n,
mk_block [Aassgn (mk_lhs (Larray (var_from_name map x,
mk_evar cpt)), e) ]) ]
| Minils.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Eselect_slice;
Minils.a_params = [idx1; idx2] }, [e], _) ->
[ Afor (cpt, mk_static_int 0, n,
mk_block [Aassgn (mk_lhs (Larray (Control.var_from_name map x, mk_evar 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 e = translate map e in
let idx = mk_exp (Eop (op_from_string "+",
[mk_evar cpt;
mk_exp (Econst idx1) ])) in
let idx = mk_exp (Eop (op_from_string "+", [mk_evar cpt; mk_exp (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
[ 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 (var_from_name map x,
mk_evar cpt)),
mk_lhs_exp (Larray (lhs_of_exp e, idx)))] ) ]
| Minils.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Eselect_dyn }, e1::e2::idx, _) ->
let x = var_from_name map x in
mk_block [Aassgn (mk_lhs (Larray (Control.var_from_name map x, mk_evar cpt)),
mk_lhs_exp (Larray (lhs_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
@ -191,13 +174,9 @@ and translate_act map pat
Aassgn (x, mk_exp (Elhs (lhs_of_idx_list (lhs_of_exp e1) idx))) 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] ]) ]
| Minils.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Eupdate },
e1::e2::idx, _) ->
let x = var_from_name map x in
[ Acase (cond, [ ptrue, mk_block [true_act]; pfalse, mk_block [false_act] ]) ]
| Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eupdate }, e1::e2::idx, _) ->
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,
@ -208,17 +187,14 @@ and translate_act map pat
[copy; action]
| Minils.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Efield_update;
Minils.a_params = [{ se_desc = Sfield f }] },
[e1; e2], _) ->
let x = var_from_name map x in
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
let action = Aassgn (mk_lhs (Lfield (x, f)), translate map e2) in
[copy; action]
| Minils.Evarpat n, _ ->
[Aassgn (var_from_name map n, translate map act)]
[Aassgn (Control.var_from_name map n, translate map act)]
| _ ->
Format.eprintf "%a The pattern %a should be a simple var to be translated to obc.@."
Location.print_location act.Minils.e_loc Mls_printer.print_pat pat;
@ -229,14 +205,21 @@ and translate_c_act_list map pat c_act_list =
(fun (c, act) -> (c, mk_block (translate_act map pat act)))
c_act_list
let mk_obj_call_from_context (o, _) n =
match o with
| Oobj _ -> Oobj n
| Oarray (_, lhs) -> Oarray(n, lhs)
(** In an iteration, objects used are element of object arrays *)
type obj_array = { oa_index : Obc.pattern; oa_size : static_exp }
let size_from_call_context (_, n) = n
(** A [None] context is normal, otherwise, we are in an iteration *)
type call_context = obj_array option
let empty_call_context = Oobj "n", None
let mk_obj_call_from_context c n = match c with
| None -> Oobj n
| Some oa -> Oarray (n, oa.oa_index)
let size_from_call_context c = match c with
| None -> None
| Some oa -> Some (oa.oa_size)
let empty_call_context = None
(** [si] is the initialization actions used in the reset method.
[j] obj decs
@ -247,12 +230,12 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e }
let { Minils.e_desc = desc; Minils.e_ck = ck; Minils.e_loc = loc } = e in
match (pat, desc) with
| Minils.Evarpat n, Minils.Efby (opt_c, e) ->
let x = var_from_name map n in
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
let action = Aassgn (var_from_name map n, translate map e) in
v, si, j, (control map ck action) :: s
let action = Aassgn (Control.var_from_name map n, translate map e) in
v, si, j, (Control.control map ck action) :: s
| Minils.Etuplepat p_list,
Minils.Eapp({ Minils.a_op = Minils.Etuple }, act_list, _) ->
@ -273,7 +256,7 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e }
let action =
Acase (cond, [ptrue, mk_block ~locals:vt true_act;
pfalse, mk_block ~locals:vf false_act]) in
v, si, j, (control map ck action) :: s
v, si, j, (Control.control map ck action) :: s
| pat, Minils.Eapp ({ Minils.a_op = Minils.Efun _ | Minils.Enode _ } as app,
e_list, r) ->
@ -281,11 +264,11 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e }
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 action = List.map (control map ck) action in
let action = List.map (Control.control map ck) action in
let s = (match r, app.Minils.a_op with
| Some r, Minils.Enode _ ->
let ck = Clocks.Con (ck, Initial.ptrue, r) in
let ra = List.map (control map ck) si' in
let ra = List.map (Control.control map ck) si' in
ra @ action @ s
| _, _ -> action @ s) in
v' @ v, si'@si, j'@j, s
@ -295,22 +278,22 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e }
let c_list =
List.map (translate map) e_list in
let x = fresh_it () in
let call_context = Oarray ("n", mk_lhs (Lvar x)), Some n 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 action = List.map (control map ck) action in
let action = List.map (Control.control map ck) action in
let s =
(match reset, app.Minils.a_op with
| Some r, Minils.Enode _ ->
let ck = Clocks.Con (ck, Initial.ptrue, r) in
let ra = List.map (control map ck) si' in
let ra = List.map (Control.control map ck) si' in
ra @ action @ s
| _, _ -> action @ s)
in (v, si' @ si, j' @ j, s)
| (pat, _) ->
let action = translate_act map pat e in
let action = List.map (control map ck) action in
let action = List.map (Control.control map ck) action in
v, si, j, action @ s
and translate_eq_list map call_context act_list =
@ -323,10 +306,8 @@ and mk_node_call map call_context app loc name_list args =
[], [], [], [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 build env vd a =
Env.add vd.Minils.v_ident a env in
let add_input env vd = Env.add vd.Minils.v_ident (mk_lhs (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 } ->
@ -350,9 +331,9 @@ and mk_node_call map call_context app loc name_list args =
v @ nd.Minils.n_local, si, j, subst_act_list env s
| Minils.Enode f | Minils.Efun f ->
let o = mk_obj_call_from_context call_context (gen_obj_name f) in
let o = mk_obj_call_from_context call_context (gen_obj_ident f) in
let obj =
{ o_name = obj_ref_name o; o_class = f;
{ o_ident = obj_ref_name o; o_class = f;
o_params = app.Minils.a_params;
o_size = size_from_call_context call_context; o_loc = loc } in
let si = (match app.Minils.a_op with
@ -456,20 +437,19 @@ let translate_node
Minils.n_params = params;
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 (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 (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 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
let s = joinlist (s_list @ s_list') in
let s = Control.joinlist (s_list @ s_list') in
let j = j' @ j in
let si = joinlist (si @ si') in
let si = Control.joinlist (si @ si') in
let stepm = {
m_name = Mstep; m_inputs = i_list; m_outputs = o_list;
m_body = mk_block ~locals:(d_list' @ d_list) s } in

2
compiler/minils/main/mls2seq.ml
View file

@ -38,7 +38,7 @@ let write_obc_file p =
close_out obc;
comment "Generation of Obc code"
let targets = [ "c", Obc_no_params Cmain.program;
let targets = [ (*"c", Obc_no_params Cmain.program;*)
"java", Obc_no_params Java_main.program;
"obc", Obc write_obc_file;
"obc_np", Obc_no_params write_obc_file;

6
compiler/minils/transformations/itfusion.ml
View file

@ -9,13 +9,13 @@ open Minils
(* Functions to temporarily store anonymous nodes*)
let mk_fresh_node_name () = Modules.fresh_value "itfusion" "temp"
let fresh_vd_of_arg =
let fresh_vd_of_arg a =
Idents.gen_fresh "itfusion"
(fun a -> match a.a_name with
| None -> "v"
| Some n -> n)
| Some n -> n) a
let fresh_var = Idents.gen_fresh "itfusion" (fun () -> "x")
let fresh_var () = Idents.gen_var "itfusion" "x"
let anon_nodes = ref QualEnv.empty

2
compiler/minils/transformations/normalize.ml
View file

@ -132,7 +132,7 @@ let const e c =
(* normal form for expressions and equations: *)
(* - e ::= op(e,...,e) | x | C | e when C(x) *)
(* - act ::= e | merge x (C1 -> act) ... (Cn -> act) | (act,...,act) *)
(* - eq ::= [x = v fby e] | [pat = act ] | [pat = f(e1,...,en) every n *)
(* - eq ::= [x = v fby e] | [pat = act] | [pat = f(e1,...,en) every n *)
(* - A-normal form: (e1,...,en) when c(x) = (e1 when c(x),...,en when c(x) *)
type kind = VRef | Exp | Act | Any

27
compiler/obc/c/c.ml
View file

@ -12,14 +12,7 @@ open List
open Modules
open Names
let rec print_list ff print sep l =
match l with
| [] -> ()
| [x] -> print ff x
| x :: l ->
print ff x;
fprintf ff "%s@ " sep;
print_list ff print sep l
let print_list ff print sep l = Pp_tools.print_list_r print "" sep "" ff l
(** [cname_of_name name] translates the string [name] to a valid C identifier.
Copied verbatim from the old C backend. *)
@ -56,6 +49,7 @@ type cty =
| Cty_ptr of cty (** C points-to-other-type type. *)
| Cty_arr of int * cty (** A static array of the specified size. *)
| Cty_void (** Well, [void] is not really a C type. *)
| Cty_future of cty (** async result as a future<t> *)
(** A C block: declarations and statements. In source code form, it begins with
variable declarations before a list of semicolon-separated statements, the
@ -81,19 +75,20 @@ and cexpr =
| Clhs of clhs (** Left-hand-side expressions are obviously expressions! *)
| Caddrof of clhs (** Take the address of a left-hand-side expression. *)
| Cstructlit of string * cexpr list (** Structure literal "{ f1, f2, ... }".*)
| Carraylit of cexpr list (** Array literal [e1, e2, ...]. *)
| Carraylit of cexpr list (** Array literal [\[e1, e2, ...\]]. *)
| Cmethod_call of cexpr * string * cexpr list (** Object member function call with parameters. *)
and cconst =
| Ccint of int (** Integer constant. *)
| Ccfloat of float (** Floating-point number constant. *)
| Ctag of string (** Tag, member of a previously declared enumeration. *)
| Cstrlit of string (** String literal, enclosed in double-quotes. *)
(** C left-hand-side (ie. affectable) expressions. *)
(** C left-hand-side (ie. affectable) expressions. *)
and clhs =
| Cvar of string (** A local variable. *)
| Cderef of clhs (** Pointer dereference, *ptr. *)
| Cfield of clhs * qualname (** Field access to left-hand-side. *)
| Carray of clhs * cexpr (** Array access clhs[cexpr] *)
(** C statements. *)
(** C statements. *)
and cstm =
| Csexpr of cexpr (** Expression evaluation, may cause side-effects! *)
| Csblock of cblock (** A local sub-block, can have its own private decls. **)
@ -179,6 +174,7 @@ let rec pp_cty fmt cty = match cty with
| Cty_ptr cty' -> fprintf fmt "%a*" pp_cty cty'
| Cty_arr (n, cty') -> fprintf fmt "%a[%d]" pp_cty cty' n
| Cty_void -> fprintf fmt "void"
| Cty_future cty' -> fprintf fmt "future<%a>" pp_cty cty'
(** [pp_array_decl cty] returns the base type of a (multidimensionnal) array
and the string of indices. *)
@ -249,7 +245,9 @@ and pp_cexpr fmt ce = match ce with
| Cstructlit (s, el) ->
fprintf fmt "(%a){@[%a@]}" pp_string s (pp_list1 pp_cexpr ",") el
| Carraylit el ->
fprintf fmt "((int []){@[%a@]})" (pp_list1 pp_cexpr ",") el (* WRONG *)
fprintf fmt "((int []){@[%a@]})" (pp_list1 pp_cexpr ",") el (* TODO master : WRONG *)
| Cmethod_call _ -> assert false (* TODO async *)
and pp_clhs fmt lhs = match lhs with
| Cvar s -> pp_string fmt s
| Cderef lhs' -> fprintf fmt "*%a" pp_clhs lhs'
@ -314,11 +312,10 @@ let pp_cfile_desc fmt filen cfile =
let output_cfile dir (filen, cfile_desc) =
if !Compiler_options.verbose then
Format.printf "C-NG generating %s/%s@." dir filen;
let buf = Buffer.create 20000 in
let oc = open_out (Filename.concat dir filen) in
let fmt = Format.formatter_of_buffer buf in
let fmt = Format.formatter_of_out_channel oc in
pp_cfile_desc fmt filen cfile_desc;
Buffer.output_buffer oc buf;
pp_print_flush fmt ();
close_out oc
let output dir cprog =

5
compiler/obc/c/c.mli
View file

@ -46,9 +46,8 @@ and cexpr =
| Cconst of cconst (** Constants. *)
| Clhs of clhs (** Left-hand-side expressions are obviously expressions! *)
| Caddrof of clhs (** Take the address of a left-hand-side expression. *)
| Cstructlit of string * cexpr list (** Structure literal
" \{f1, f2, ... \}". *)
| Carraylit of cexpr list (** Array literal [e1, e2, ...]. *)
| Cstructlit of string * cexpr list (** Structure literal [{f1, f2, ... }]. *)
| Carraylit of cexpr list (** Array literal [\[e1, e2, ...\]]. *)
| Cmethod_call of cexpr * string * cexpr list (** Object member function call with parameters. *)
and cconst =
| Ccint of int (** Integer constant. *)

599
compiler/obc/java/java.ml
View file

@ -7,540 +7,103 @@
(* *)
(**************************************************************************)
type class_name = Names.qualname (** [qual] is the package name, [Name] is the class name *)
type obj_ident = Idents.var_ident
type constructor_name = Names.qualname (** [Qual] is the enum class name (type), [NAME] is the constructor name *)
type const_name = Names.qualname
type method_name = Names.name
type field_name = Names.name
type field_ident = Idents.var_ident
type op_name = Names.qualname
type var_ident = Idents.var_ident
open Signature
open Modules
open Format
open Obc
open Misc
open Types
open Names
open Idents
open Pp_tools
type ty = Tclass of class_name
| Tgeneric of class_name * ty list
| Tbool
| Tint
| Tfloat
| Tarray of ty * exp
| Tunit
let jname_of_name name =
let b = Buffer.create (String.length name) in
let rec convert c =
match c with
| 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' ->
Buffer.add_char b c
| '\'' -> Buffer.add_string b "_prime"
| _ ->
Buffer.add_string b "lex";
Buffer.add_string b (string_of_int (Char.code c));
Buffer.add_string b "_" in
and classe = { c_protection : protection;
c_static : bool;
c_name : class_name;
c_kind : class_kind }
String.iter convert name;
Buffer.contents b
and class_kind = Cenum of constructor_name list
| Cgeneric of class_desc
let print_name ff name =
fprintf ff "%s" (jname_of_name name)
and class_desc = { cd_fields : field list;
cd_classs : classe list;
cd_constructors : methode list;
cd_methodes : methode list; }
let print_shortname ff longname =
print_name ff (shortname longname)
and var_dec = { vd_type : ty;
vd_ident : var_ident }
let rec java_type_default_value = function
| Tid id when id = Initial.pint -> "int", "0"
| Tid id when id = Initial.pfloat -> "float", "0.0"
| Tid id when id = Initial.pbool -> "boolean", "false"
| Tid t ->
(match find_type t with
| Tabstract -> assert false
| Talias t -> java_type_default_value t
| Tenum _ -> "int", "0" (* TODO java *)
| Tstruct _ -> shortname t, "null" )
| Tasync (a,t) -> assert false (* TODO async *)
| Tarray _ -> assert false (* TODO array *)
| Tprod _ -> assert false (* TODO java *)
| Tunit -> "void", "null"
and protection = Ppublic | Pprotected | Pprivate | Ppackage
let print_type ff ty =
let jty,_ = java_type_default_value ty in
print_name ff jty
and field = { f_protection : protection;
f_static : bool;
f_final : bool;
f_type : ty;
f_name : field_ident;
f_value : exp option }
let print_field ff (name,ty) =
fprintf ff "%a %a;"
print_type ty
print_name name
let print_const_field ff (name,ty) =
fprintf ff "%a@ %a"
print_type ty
print_name name
let print_assgt_field ff (name,_) =
fprintf ff "this.%a = %a;"
print_name name
print_name name
(* assumes tn is already translated with jname_of_name *)
let print_struct_type ff tn fields =
fprintf ff "@[<v>@[<v 2>public class %s {@ " tn;
(* fields *)
print_list print_field "" "" "" ff fields;
(* constructor *)
let sorted_fields =
List.sort
(fun (n1,_) (n2,_) -> String.compare n1 n2)
fields in
fprintf ff "@ @[<v 2>public %s(@[<hov>" tn;
print_list print_const_field "" "," "" ff sorted_fields;
fprintf ff "@]) {@ ";
(* constructor assignments *)
print_list print_assgt_field "" "" "" ff fields;
(* constructor end *)
fprintf ff "@]@ }";
(* class end *)
fprintf ff "@]@ }@]"
and methode = { m_protection : protection;
m_static : bool;
m_name : method_name;
m_args : var_dec list;
m_returns : ty;
m_body : block; }
let rec print_tags ff n = function
| [] -> ()
| tg :: tgs' ->
fprintf ff "@ public static final int %a = %d;"
print_name ( shortname tg ) (* TODO java deal with modules *)
n;
print_tags ff (n+1) tgs'
and block = { b_locals : var_dec list;
b_body : act list; }
(* assumes tn is already translated with jname_of_name *)
let print_enum_type ff tn tgs =
fprintf ff "@[<v>@[<v 2>public class %s {" tn;
print_tags ff 1 tgs;
fprintf ff "@]@ }@]"
and act = Anewvar of var_dec * exp
| Aassgn of pattern * exp
| Amethod_call of pattern * method_name * exp list
| Aswitch of exp * (constructor_name * block) list
| Aif of exp * block
| Aifelse of exp * block * block
| Ablock of block
| Afor of var_ident * exp * exp * block
| Areturn of exp
let rec print_type_to_file java_dir headers { t_name = tn; t_desc = td} =
let tn = jname_of_name (shortname tn) in (* TODO java deal with modules *)
match td with
| Type_abs -> ()
| Type_enum tgs ->
let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in
let ff = formatter_of_out_channel out_ch in
(*Misc.print_header_info ff "/*" "*/"; *)
List.iter (fprintf ff "%s") headers;
(* fprintf ff "@[<v>package %s;@\n@\n" headers; *) (* TODO java deal with modules *)
print_enum_type ff tn tgs;
fprintf ff "@.";
close_out out_ch
| Type_struct fields ->
let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in
let ff = formatter_of_out_channel out_ch in
(* Misc.print_header_info ff "/*" "*/"; *)(* TODO java deal with modules *)
List.iter (fprintf ff "%s") headers;
(* fprintf ff "@[<v>package %s;@\n@\n" headers; *)
print_struct_type ff tn
(List.map (fun {f_name = n;f_type = t} -> (shortname n,t)) fields); (* TODO java deal with modules *)
fprintf ff "@.";
close_out out_ch
| Type_alias t -> assert false (* TODO java *)
and exp = Eval of pattern
| Efun of op_name * exp list
| Emethod_call of pattern * method_name * exp list
| Enew of ty * exp list
| Evoid (*printed as nothing*)
| Earray of exp list
| Svar of const_name
| Sint of int
| Sfloat of float
| Sbool of bool
| Sconstructor of constructor_name
let print_types java_dir headers tps =
List.iter (print_type_to_file java_dir headers) tps
and pattern = Pfield of pattern * field_name
| Pvar of var_ident
| Parray_elem of pattern * exp
| Pthis of field_ident
(******************************)
type program = classe list
type answer =
| Sing of var_ident
| Mult of var_ident list
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; }
let print_const ff c ts =
match c.se_desc with
| Sint i -> fprintf ff "%d" i
| Sfloat f -> fprintf ff "%f" f
| Sbool true -> fprintf ff "true"
| Sbool false -> fprintf ff "false"
| Sconstructor c ->
let tg = shortname c in (* TODO java gérer les modules *)
let s = (fst (List.find (fun (tn, tgs) -> List.exists (fun tg' -> tg = tg') tgs) ts))
^ "." ^ (jname_of_name tg) in
fprintf ff "%s" s
| _ -> assert false (* TODO java *)
let mk_classe ?(protection=Ppublic) ?(static=false) ?(fields=[]) ?(classes=[]) ?(constrs=[]) ?(methodes=[])
class_name =
{ c_protection = protection; c_static = static; c_name = class_name;
c_kind = Cgeneric { cd_fields = fields; cd_classs = classes; cd_constructors = constrs; cd_methodes = methodes; } }
let position a xs =
let rec walk i = function
| [] -> None
| x :: xs' -> if x = a then Some i else walk (i + 1) xs'
in walk 1 xs
let print_ident ff id =
print_name ff (name id)
let print_var ff x avs single =
match (position x avs) with
| None -> print_ident ff x
| Some n ->
if single then print_ident ff (List.hd avs)
else fprintf ff "step_ans.c_%d" n
let javaop_of_op = function
| "=" -> "=="
| "<>" -> "!="
| "or" -> "||"
| "&" -> "&&"
| "*." -> "*"
| "/." -> "/"
| "+." -> "+"
| "-." -> "-"
| op -> op
let priority = function
| "*" | "/" | "*." | "/." -> 5
| "+" | "-" | "+." | "-." -> 4
| "=" | "<>" | "<=" | "=>" -> 3
| "&" -> 2
| "|" -> 1
| _ -> 0
let rec print_lhs ff e avs single =
match e.pat_desc with
| Lvar x ->
print_var ff x avs single
| Lmem x -> print_ident ff x
| Lfield(e, field) ->
print_lhs ff e avs single;
fprintf ff ".%s" (jname_of_name (shortname field))
| Larray _ -> assert false (* TODO java array *)
let rec print_exp ff e p avs ts single =
match e.e_desc with
| Elhs 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) ->
let fields =
List.sort
(fun (ln1,_) (ln2,_) ->
String.compare (shortname ln1) (shortname ln2))
fields in
let exps = List.map (fun (_,e) -> e) fields in
fprintf ff "new %a(@[<hov>"
print_shortname type_name;
print_exps ff exps 0 avs ts single;
fprintf ff "@])"
| Earray _ -> assert false (* TODO array *)
| Ebang _ -> assert false (* TODO async *)
and print_exps ff es p avs ts single =
match es with
| [] -> ()
| [e] -> print_exp ff e p avs ts single
| e :: es' ->
print_exp ff e p avs ts single;
fprintf ff ",@ ";
print_exps ff es' p avs ts single
and print_op ff op es p avs ts single =
match (shortname op), es with
| (("+" | "-" | "*" | "/"
|"+." | "-." | "*." | "/."
| "=" | "<>" | "<" | "<="
| ">" | ">=" | "&" | "or") as op_name, [e1;e2]) ->
let p' = priority op_name in
if p' < p then fprintf ff "(" else ();
print_exp ff e1 p' avs ts single;
fprintf ff " %s " (javaop_of_op op_name);
print_exp ff e2 p' avs ts single;
if p' < p then fprintf ff ")" else ()
| "not", [e] ->
fprintf ff "!";
print_exp ff e 6 avs ts single;
| "~-", [e] ->
fprintf ff "-";
print_exp ff e 6 avs ts single;
| _ ->(*
begin
begin
match op with
| Name(op_name) ->
print_name ff op_name;
| Modname({ qual = mod_name; id = op_name }) ->
fprintf ff "%a.%a"
print_name (String.uncapitalize mod_name)
print_name op_name
end;
fprintf ff "@[(";
print_exps ff es 0 avs ts single;
fprintf ff ")@]"
end *)
assert false (* TODO java *)
let rec print_proj ff xs ao avs single =
let rec walk ind = function
| [] -> ()
| x :: xs' ->
print_lhs ff x avs single;
fprintf ff " = %s.c_%d;@ " ao ind;
walk (ind + 1) xs'
in walk 1 xs
let mk_enum ?(protection=Ppublic) ?(static=false)
constructor_names class_name =
{ c_protection = protection; c_static = static; c_name = class_name; c_kind = Cenum(constructor_names) }
let bool_case = function
| [] -> assert false
| ("true", _) :: _
| ("false", _) :: _ -> true
| _ -> false
let obj_ref_to_string = function
| Oobj o -> o
| Oarray (o,p) -> o (* TODO java array *)
let rec print_act ff a objs avs ts single =
match a with
| Aassgn (x, e) ->
fprintf ff "@[";
print_asgn ff x e avs ts single;
fprintf ff ";@]"
| Acall (xs,oref,Mstep,es) ->
let o = obj_ref_to_string oref in
(match xs with
| [x] ->
print_lhs ff x avs single;
fprintf ff " = %s.step(" o;
fprintf ff "@[";
print_exps ff es 0 avs ts single;
fprintf ff "@]";
fprintf ff ");@ "
| xs ->
let cn = (List.find (fun od -> od.o_name = o) objs).o_class in
let at = (jname_of_name (shortname cn)) ^ "Answer" in
let ao = o ^ "_ans" in
fprintf ff "%s %s = new %s();@ " at ao at;
fprintf ff "%s = %s.step(" ao o;
fprintf ff "@[";
print_exps ff es 0 avs ts single;
fprintf ff "@]";
fprintf ff ");@ ";
print_proj ff xs ao avs single)
| Acase (e, grds) ->
let grds =
List.map
(fun (ln,act) -> (shortname ln),act) grds in
if bool_case grds
then print_if ff e grds objs avs ts single
else (fprintf ff "@[<v>@[<v 2>switch (%a) {@ "
(fun ff e -> print_exp ff e 0 avs ts single) e;
print_grds ff grds objs avs ts single;
fprintf ff "@]@ }@]");
| Acall (_,oref,Mreset,_) ->
let o = obj_ref_to_string oref in
fprintf ff "%s.reset();" o
| Afor _ -> assert false (* TODO java array *)
| Aasync_call _ -> assert false (* TODO java array *)
and print_grds ff grds objs avs ts single =
match grds with
| [] -> ()
| (tg, b) :: grds' ->
(* retrieve class name *)
let cn = (fst
(List.find
(fun (tn, tgs) ->
List.exists (fun tg' -> tg = tg') tgs)
ts)) in
fprintf ff "@[<v 2>case %a.%a:@ "
print_name cn
print_name tg;
print_block ff b objs avs ts single;
fprintf ff "@ break;@ @]@ ";
print_grds ff grds' objs avs ts single
and print_if ff e grds objs avs ts single =
match grds with
| [("true", a)] ->
fprintf ff "@[<v>@[<v 2>if (%a) {@ "
(fun ff e -> print_exp ff e 0 avs ts single) e;
print_block ff a objs avs ts single;
fprintf ff "@]@ }@]"
| [("false", a)] ->
fprintf ff "@[<v>@[<v 2>if (!%a) {@ "
(fun ff e -> print_exp ff e 6 avs ts single) e;
print_block ff a objs avs ts single;
fprintf ff "@]@ }@]"
| [("true", a1); ("false", a2)] ->
fprintf ff "@[<v>@[<v 2>if (%a) {@ "
(fun ff e -> print_exp ff e 0 avs ts single) e;
print_block ff a1 objs avs ts single;
fprintf ff "@]@ @[<v 2>} else {@ ";
print_block ff a2 objs avs ts single;
fprintf ff "@]@ }@]"
| [("false", a2); ("true", a1)] ->
fprintf ff "@[<v>@[<v 2>if (%a) {@ "
(fun ff e -> print_exp ff e 0 avs ts single) e;
print_block ff a1 objs avs ts single;
fprintf ff "@]@ @[<v 2>} else {@ ";
print_block ff a2 objs avs ts single;
fprintf ff "@]@ }@]"
| _ -> assert false
and print_asgn ff x e avs ts single =
fprintf ff "@[";
print_lhs ff x avs single;
fprintf ff " = ";
print_exp ff e 0 avs ts single;
fprintf ff "@]"
and print_block ff b objs avs ts single = () (* TODO urgent java *)
let print_vd ff vd =
let jty,jdv = java_type_default_value vd.v_type in
fprintf ff "@[<v>";
print_name ff jty;
fprintf ff " %s = %s;"
(jname_of_name (name vd.v_ident))
jdv;
fprintf ff "@]"
let print_obj ff od =
fprintf ff "@[<v>";
fprintf ff "%a %a = new %a();"
print_shortname od.o_class
print_name od.o_name
print_shortname od.o_class;
fprintf ff "@]"
let rec print_objs ff ods =
match ods with
| [] -> ()
| od :: ods' ->
print_obj ff od;
fprintf ff "@ ";
print_objs ff ods'
let print_comps ff fds=
let rec walk n = function
| [] -> ()
| fd :: fds' ->
fprintf ff "@ ";
fprintf ff "public ";
print_type ff fd.v_type;
fprintf ff " c_%s;" (string_of_int n);
walk (n + 1) fds'
in walk 1 fds
let print_ans_struct ff name fields =
fprintf ff "@[<v>@[<v 2>public class %s {" name;
print_comps ff fields;
fprintf ff "@]@ }@]@ "
let print_vd' ff vd =
fprintf ff "@[";
print_type ff vd.v_type;
fprintf ff "@ %s" (jname_of_name (name vd.v_ident));
fprintf ff "@]"
let rec print_in ff = function
| [] -> ()
| [vd] -> print_vd' ff vd
| vd :: vds' ->
print_vd' ff vd;
fprintf ff ",@ ";
print_in ff vds'
let rec print_mem ff = function
| [] -> ()
| vd :: m' ->
print_vd ff vd;
fprintf ff "@ ";
print_mem ff m'
let print_loc ff vds = print_mem ff vds
let print_step ff n s objs ts single =
let n = jname_of_name n in
fprintf ff "@[<v>@ @[<v 2>public ";
if single then print_type ff (List.hd s.m_outputs).v_type
else fprintf ff "%s" (n ^ "Answer");
fprintf ff " step(@[";
print_in ff s.m_inputs;
fprintf ff "@]) {@ ";
let loc = if single then (List.hd s.m_outputs) :: s.m_body.b_locals else s.m_body.b_locals in
if loc = [] then () else (print_loc ff loc; fprintf ff "@ ");
if single then fprintf ff "@ "
else fprintf ff "%sAnswer step_ans = new %sAnswer();@ @ " n n;
print_act ff s.bd objs
(List.map (fun vd -> vd.v_ident) s.out) ts single;
fprintf ff "@ @ return ";
if single
then fprintf ff "%s" (jname_of_name (Idents.name (List.hd s.out).v_ident))
else fprintf ff "step_ans";
fprintf ff ";@]@ }@ @]"
let print_reset ff r ts =
fprintf ff "@[<v>@ @[<v 2>public void reset() {@ ";
print_act ff r [] [] ts false;
fprintf ff "@]@ }@ @]"
let print_class ff headers ts single opened_mod cl =
let clid = jname_of_name cl.cl_id in
List.iter (fprintf ff "%s") headers;
(* fprintf ff "@[<v>package %s;@\n@\n" headers; *)
(* import opened modules *)
List.iter
(fun m ->
fprintf ff "import %s.*;@\n" (String.uncapitalize m))
opened_mod;
fprintf ff "@\n@[<v 2>public class %s {@ " clid;
if cl.mem = [] then ()
else fprintf ff "@[<v>@ "; print_mem ff cl.mem; fprintf ff "@]";
if cl.objs = [] then ()
else fprintf ff "@[<v>@ "; print_objs ff cl.objs; fprintf ff "@]";
print_reset ff cl.reset ts;
print_step ff clid cl.step cl.objs ts single;
fprintf ff "@]@ }@]"
let print_class_and_answer_to_file java_dir headers ts opened_mod cl =
let clid = jname_of_name cl.cl_id in
let print_class_to_file single =
let out_ch = open_out (java_dir ^ "/" ^ clid ^ ".java") in
let ff = formatter_of_out_channel out_ch in
Misc.print_header_info ff "/*" "*/";
print_class ff headers ts single opened_mod cl;
fprintf ff "@.";
close_out out_ch
in
match cl.step.out with
| [_] -> print_class_to_file true
| _ ->
let out_ch = open_out (java_dir ^ "/" ^ clid ^ "Answer.java") in
let ff = formatter_of_out_channel out_ch in
Misc.print_header_info ff "/*" "*/";
List.iter (fprintf ff "%s") headers;
(* fprintf ff "@[<v>package %s;@\n@\n" headers; *)
List.iter
(fun m ->
fprintf ff "import %s.*;@\n" (String.uncapitalize m))
opened_mod;
print_ans_struct ff (clid ^ "Answer") cl.step.out;
fprintf ff "@.";
close_out out_ch;
print_class_to_file false
let print_classes java_dir headers ts opened_mod cls =
List.iter
(print_class_and_answer_to_file java_dir headers ts opened_mod)
cls
(******************************)
let print java_dir p =
let headers =
List.map snd
(List.filter
(fun (tag,_) -> tag = "java")
p.o_pragmas) in
print_types java_dir headers p.o_types;
o_types := p.o_types;
print_classes
java_dir headers
(List.flatten
(List.map
(function
| { t_desc = Type_abs } -> []
| { t_name = tn; t_desc = Type_enum tgs } -> [tn, tgs]
| { t_name = tn; t_desc = Type_struct fields } ->
[tn, (List.map fst fields)])
p.o_types))
p.o_opened
p.o_defs
(******************************)
let mk_field ?(protection = Ppublic) ?(static = false) ?(final = false) ?(value = None)
ty name =
{ f_protection = protection; f_static = static; f_final = final; f_type = ty; f_name = name; f_value = value }

5
compiler/obc/java/java_main.ml
View file

@ -1,4 +1,9 @@
open Java
open Java_printer
open Obc2java
let program p =
let filename = filename_of_module p in
let dirname = build_path filename in

150
compiler/obc/java/java_printer.ml Normal file
View file

@ -0,0 +1,150 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* Java printer *)
open Java
open Pp_tools
open Format
let class_name = Global_printer.print_shortname
let obj_ident = Global_printer.print_ident
let constructor_name = Global_printer.print_qualname
let bare_constructor_name = Global_printer.print_shortname
let method_name = pp_print_string
let field_name = pp_print_string
let field_ident = Global_printer.print_ident
let op_name = Global_printer.print_qualname (* TODO java fix this for infix etc... see others is_infix and old_java *)
let var_ident = Global_printer.print_ident
let const_name = Global_printer.print_qualname
let rec ty ff t = match t with
| Tbool -> fprintf ff "boolean"
| Tint -> fprintf ff "int"
| Tfloat -> fprintf ff "float"
| Tclass n -> class_name ff n
| Tgeneric (n, ty_l) -> fprintf ff "%a<@[%a@]>" class_name n (print_list_r ty """,""") ty_l
| Tarray (t,_) -> fprintf ff "%a[]" ty t
| Tunit -> pp_print_string ff "void"
let protection ff = function
| Ppublic -> fprintf ff "public "
| Pprotected -> fprintf ff "protected "
| Pprivate -> fprintf ff "private "
| Ppackage -> ()
let var_dec ff vd = fprintf ff "%a %a" ty vd.vd_type var_ident vd.vd_ident
let vd_list s1 s2 s3 ff vd_l = print_list_r var_dec s1 s2 s3 ff vd_l
let static ff s = if s then fprintf ff "static " else ()
let final ff f = if f then fprintf ff "final " else ()
let rec field ff f =
fprintf ff "@[<2>%a%a%a%a %a%a;@]"
protection f.f_protection
static f.f_static
final f.f_final
ty f.f_type
field_ident f.f_name
(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
| 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 pattern ff = function
| Pfield (p,f) -> fprintf ff "%a.%a" pattern p field_name f
| Pvar v -> var_ident ff v
| Parray_elem (p,e) -> fprintf ff "%a[%a]" pattern p exp e
| Pthis f -> fprintf ff "this.%a" field_ident f
let rec block ff b =
fprintf ff "@[<v>%a@ %a@]"
(vd_list """;"";") b.b_locals
(print_list_r act """;"";") b.b_body
and act ff = function
| Anewvar (vd,e) -> fprintf ff "%a = %a" var_dec vd exp e
| Aassgn (p,e) -> fprintf ff "%a = %a" pattern p exp e
| Amethod_call (o,m,e_l) -> fprintf ff "%a.%a%a" pattern o method_name m args e_l
| Aswitch (e, c_b_l) ->
let pcb ff (c,b) = fprintf ff "@[<hov 2>case %a:@ %a@ break;@]" bare_constructor_name c block b in
fprintf ff "@[<v4>switch (%a) {@ %a@]@\n}"
exp e
(print_list_r pcb """""") c_b_l
| Aif (e,bt) ->
fprintf ff "@[<2>if (%a) {@ %a@ }@]" exp e block bt
| Aifelse (e,bt,bf) ->
fprintf ff "@[<2>if (%a) {@ %a@ }@]@\n@[<2>else {@ %a@ }@]"
exp e
block bt
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
exp i1
exp i2
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}"
protection m.m_protection
static m.m_static
ty m.m_returns
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
and classe ff c = match c.c_kind with
| Cenum c_l ->
fprintf ff "@[<4>%a%aenum %a {@\n%a@]@\n}"
protection c.c_protection
static c.c_static
class_name c.c_name
(print_list_r bare_constructor_name """,""") c_l
| Cgeneric cd ->
fprintf ff "@[<4>%a%aclass %a {@\n%a@]@\n}"
protection c.c_protection
static c.c_static
class_name c.c_name
class_desc cd
let output_classe dir c =
let { Names.name = file_name; Names.qual = package_name } = c.c_name in
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;
classe ff c;
pp_print_flush ff ();
close_out oc

263
compiler/obc/java/obc2java.ml Normal file
View file

@ -0,0 +1,263 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(** An Obc.program is a Java.package,
Obc.type_dec, Obc.class_def are Java.classs
Obc.const_dec is defined in the special class CONSTANTES
Obc.Lvar are Pvar
Obc.Lmem are this.Pvar (Pfield)
Obc.Oobj and Oarray are simply Pvar and Parray_elem
Obc.Types_alias are dereferenced since no simple type alias is possible in Java *)
open Format
open Misc
open Names
open Modules
open Signature
open Obc
open Java
(** a [Module] becomes a [package] *)
let translate_qualname q = match q with
| { qual = "Pervasives" } -> q
| { qual = m } when m = g_env.current_mod -> q (* current module is not translated to keep track,
there is no issue since printed without the qualifier *)
| { qual = m } when m = local_qualname -> q
| _ -> { 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 }
(** a [Module.name] becomes a [module.Name]
used for type_names, class_names, fun_names *)
let qualname_to_class_name q =
let q = translate_qualname q in
{ 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 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 translate_constructor_name q =
match Modules.find_constrs c with
| Tid c_ty -> _translate_constructor_name q q_ty
| _ -> assert false
(** a [name] becomes a [package.Name] *)
let name_to_classe_name n = n |> Modules.current_qual |> qualname_to_class_name
(** translate an ostatic_exp into an jexp *)
let rec static_exp param_env se = match se.Types.se_desc with
| Types.Svar c ->
if shortname c = local_qualname
then let n = NamesEnv.find (shortname c) param_env in Svar (n |> Idents.name |> local_qn)
else Svar (translate_const_name c)
| Types.Sint i -> Sint i
| 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.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
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")
| Types.Tid t when t = Initial.pfloat -> Tclass (Names.local_qn "Float")
| Types.Tid t -> Tclass (qualname_to_class_name t)
| Types.Tarray (t,size) -> Tarray (boxed_ty param_env t, static_exp param_env size)
| Types.Tasync _ -> assert false; (* TODO async *)
| Types.Tunit -> Tunit
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
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
| Types.Tid t when t = Initial.pfloat -> Tfloat
| Types.Tid t -> Tclass (qualname_to_class_name t)
| Types.Tarray (t,size) -> Tarray (ty param_env t, static_exp param_env size)
| Types.Tasync _ -> assert false; (* TODO async *)
| Types.Tunit -> Tunit
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 act_list param_env act_l =
let _act acts act = 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
assgn::acts
| Obc.Acall (p_l, obj, _, 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
assgn::(copies@acts)
| Obc.Acall (_, obj, Mreset, _) ->
let acall = Amethod_call (obj_ref param_env obj, "step", []) in
acall::acts
| Obc.Async_call _ -> assert false (* TODO java async *)
| Obc.Acase (e, c_b_l) ->
let _c_b (c,b) = translate_constructor_name
Aswitch (exp param_env e,
let 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
{ b_locals = locals; b_body = acts }
let class_def_list classes cd_l =
let class_def classes cd =
Idents.enter_node cd.cd_name;
let class_name = qualname_to_class_name cd.cd_name in
(* [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_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
in
let args, param_env = Misc.mapfold param_to_arg NamesEnv.empty cd.cd_params in
let body =
(* TODO java array : also initialize arrays with [ new int[3] ] *)
let final_field_init_act arg = Aassgn (Pthis arg.vd_ident, Eval (Pvar arg.vd_ident)) in
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*)
in
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
{ b_locals = []; b_body = acts }
in
mk_methode ~args:args body (shortname class_name), param_env
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 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)
in
(mk_field ~protection:Pprotected jty od.o_ident) :: fields
in
let params_to_field fields p =
let p_ident = NamesEnv.find p.p_name param_env in
(mk_field ~protection:Pprotected ~final:true (ty param_env p.p_type) p_ident) :: fields
in
let fields = List.fold_left mem_to_field [] cd.cd_mems in
let fields = List.fold_left obj_to_field fields cd.cd_objs in
List.fold_left params_to_field fields cd.cd_params
in
let step =
let ostep = find_step_method cd in
let vd_output = var_dec_list param_env ostep.m_outputs in
let return_ty = ostep.m_outputs |> vd_list_to_type |> (ty param_env) in
let return_act = Areturn (match vd_output with
| [] -> Evoid
| [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"
in
let reset =
let oreset = find_reset_method cd in
let body = block param_env oreset.m_body in
mk_methode body "reset"
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
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
| 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
| Type_struct f_l ->
let mk_field_jfield { f_name = oname; 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
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
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 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 fields = List.map mk_const_field cd_l in
[mk_classe ~fields:fields classe_name]
let program p =
let classes = const_dec_list p.p_consts in
let classes = type_dec_list classes p.p_types in
let p = class_def_list classes p.p_defs in
p

546
compiler/obc/java/old_java.ml Normal file
View file

@ -0,0 +1,546 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
open Signature
open Modules
open Format
open Obc
open Misc
open Types
open Names
open Idents
open Pp_tools
let jname_of_name name =
let b = Buffer.create (String.length name) in
let rec convert c =
match c with
| 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' ->
Buffer.add_char b c
| '\'' -> Buffer.add_string b "_prime"
| _ ->
Buffer.add_string b "lex";
Buffer.add_string b (string_of_int (Char.code c));
Buffer.add_string b "_" in
String.iter convert name;
Buffer.contents b
let print_name ff name =
fprintf ff "%s" (jname_of_name name)
let print_shortname ff longname =
print_name ff (shortname longname)
let rec java_type_default_value = function
| Tid id when id = Initial.pint -> "int", "0"
| Tid id when id = Initial.pfloat -> "float", "0.0"
| Tid id when id = Initial.pbool -> "boolean", "false"
| Tid t ->
(match find_type t with
| Tabstract -> assert false
| Talias t -> java_type_default_value t
| Tenum _ -> "int", "0" (* TODO java *)
| Tstruct _ -> shortname t, "null" )
| Tasync (a,t) -> assert false (* TODO async *)
| Tarray _ -> assert false (* TODO array *)
| Tprod _ -> assert false (* TODO java *)
| Tunit -> "void", "null"
let print_type ff ty =
let jty,_ = java_type_default_value ty in
print_name ff jty
let print_field ff (name,ty) =
fprintf ff "%a %a;"
print_type ty
print_name name
let print_const_field ff (name,ty) =
fprintf ff "%a@ %a"
print_type ty
print_name name
let print_assgt_field ff (name,_) =
fprintf ff "this.%a = %a;"
print_name name
print_name name
(* assumes tn is already translated with jname_of_name *)
let print_struct_type ff tn fields =
fprintf ff "@[<v>@[<v 2>public class %s {@ " tn;
(* fields *)
print_list print_field "" "" "" ff fields;
(* constructor *)
let sorted_fields =
List.sort
(fun (n1,_) (n2,_) -> String.compare n1 n2)
fields in
fprintf ff "@ @[<v 2>public %s(@[<hov>" tn;
print_list print_const_field "" "," "" ff sorted_fields;
fprintf ff "@]) {@ ";
(* constructor assignments *)
print_list print_assgt_field "" "" "" ff fields;
(* constructor end *)
fprintf ff "@]@ }";
(* class end *)
fprintf ff "@]@ }@]"
let rec print_tags ff n = function
| [] -> ()
| tg :: tgs' ->
fprintf ff "@ public static final int %a = %d;"
print_name ( shortname tg ) (* TODO java deal with modules *)
n;
print_tags ff (n+1) tgs'
(* assumes tn is already translated with jname_of_name *)
let print_enum_type ff tn tgs =
fprintf ff "@[<v>@[<v 2>public class %s {" tn;
print_tags ff 1 tgs;
fprintf ff "@]@ }@]"
let rec print_type_to_file java_dir headers { t_name = tn; t_desc = td} =
let tn = jname_of_name (shortname tn) in (* TODO java deal with modules *)
match td with
| Type_abs -> ()
| Type_enum tgs ->
let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in
let ff = formatter_of_out_channel out_ch in
(*Misc.print_header_info ff "/*" "*/"; *)
List.iter (fprintf ff "%s") headers;
(* fprintf ff "@[<v>package %s;@\n@\n" headers; *) (* TODO java deal with modules *)
print_enum_type ff tn tgs;
fprintf ff "@.";
close_out out_ch
| Type_struct fields ->
let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in
let ff = formatter_of_out_channel out_ch in
(* Misc.print_header_info ff "/*" "*/"; *)(* TODO java deal with modules *)
List.iter (fprintf ff "%s") headers;
(* fprintf ff "@[<v>package %s;@\n@\n" headers; *)
print_struct_type ff tn
(List.map (fun {f_name = n;f_type = t} -> (shortname n,t)) fields); (* TODO java deal with modules *)
fprintf ff "@.";
close_out out_ch
| Type_alias t -> assert false (* TODO java *)
let print_types java_dir headers tps =
List.iter (print_type_to_file java_dir headers) tps
(******************************)
type answer =
| Sing of var_ident
| Mult of var_ident list
let print_const ff c ts =
match c.se_desc with
| Sint i -> fprintf ff "%d" i
| Sfloat f -> fprintf ff "%f" f
| Sbool true -> fprintf ff "true"
| Sbool false -> fprintf ff "false"
| Sconstructor c ->
let tg = shortname c in (* TODO java gérer les modules *)
let s = (fst (List.find (fun (tn, tgs) -> List.exists (fun tg' -> tg = tg') tgs) ts))
^ "." ^ (jname_of_name tg) in
fprintf ff "%s" s
| _ -> assert false (* TODO java *)
let position a xs =
let rec walk i = function
| [] -> None
| x :: xs' -> if x = a then Some i else walk (i + 1) xs'
in walk 1 xs
let print_ident ff id =
print_name ff (name id)
let print_var ff x avs single =
match (position x avs) with
| None -> print_ident ff x
| Some n ->
if single then print_ident ff (List.hd avs)
else fprintf ff "step_ans.c_%d" n
let javaop_of_op = function
| "=" -> "=="
| "<>" -> "!="
| "or" -> "||"
| "&" -> "&&"
| "*." -> "*"
| "/." -> "/"
| "+." -> "+"
| "-." -> "-"
| op -> op
let priority = function
| "*" | "/" | "*." | "/." -> 5
| "+" | "-" | "+." | "-." -> 4
| "=" | "<>" | "<=" | "=>" -> 3
| "&" -> 2
| "|" -> 1
| _ -> 0
let rec print_lhs ff e avs single =
match e.pat_desc with
| Lvar x ->
print_var ff x avs single
| Lmem x -> print_ident ff x
| Lfield(e, field) ->
print_lhs ff e avs single;
fprintf ff ".%s" (jname_of_name (shortname field))
| Larray _ -> assert false (* TODO java array *)
let rec print_exp ff e p avs ts single =
match e.e_desc with
| Elhs 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) ->
let fields =
List.sort
(fun (ln1,_) (ln2,_) ->
String.compare (shortname ln1) (shortname ln2))
fields in
let exps = List.map (fun (_,e) -> e) fields in
fprintf ff "new %a(@[<hov>"
print_shortname type_name;
print_exps ff exps 0 avs ts single;
fprintf ff "@])"
| Earray _ -> assert false (* TODO array *)
| Ebang _ -> assert false (* TODO async *)
and print_exps ff es p avs ts single =
match es with
| [] -> ()
| [e] -> print_exp ff e p avs ts single
| e :: es' ->
print_exp ff e p avs ts single;
fprintf ff ",@ ";
print_exps ff es' p avs ts single
and print_op ff op es p avs ts single =
match (shortname op), es with
| (("+" | "-" | "*" | "/"
|"+." | "-." | "*." | "/."
| "=" | "<>" | "<" | "<="
| ">" | ">=" | "&" | "or") as op_name, [e1;e2]) ->
let p' = priority op_name in
if p' < p then fprintf ff "(" else ();
print_exp ff e1 p' avs ts single;
fprintf ff " %s " (javaop_of_op op_name);
print_exp ff e2 p' avs ts single;
if p' < p then fprintf ff ")" else ()
| "not", [e] ->
fprintf ff "!";
print_exp ff e 6 avs ts single;
| "~-", [e] ->
fprintf ff "-";
print_exp ff e 6 avs ts single;
| _ ->(*
begin
begin
match op with
| Name(op_name) ->
print_name ff op_name;
| Modname({ qual = mod_name; id = op_name }) ->
fprintf ff "%a.%a"
print_name (String.uncapitalize mod_name)
print_name op_name
end;
fprintf ff "@[(";
print_exps ff es 0 avs ts single;
fprintf ff ")@]"
end *)
assert false (* TODO java *)
let rec print_proj ff xs ao avs single =
let rec walk ind = function
| [] -> ()
| x :: xs' ->
print_lhs ff x avs single;
fprintf ff " = %s.c_%d;@ " ao ind;
walk (ind + 1) xs'
in walk 1 xs
let bool_case = function
| [] -> assert false
| ("true", _) :: _
| ("false", _) :: _ -> true
| _ -> false
let obj_ref_to_string = function
| Oobj o -> o
| Oarray (o,p) -> o (* TODO java array *)
let rec print_act ff a objs avs ts single =
match a with
| Aassgn (x, e) ->
fprintf ff "@[";
print_asgn ff x e avs ts single;
fprintf ff ";@]"
| Acall (xs,oref,Mstep,es) ->
let o = obj_ref_to_string oref in
(match xs with
| [x] ->
print_lhs ff x avs single;
fprintf ff " = %s.step(" o;
fprintf ff "@[";
print_exps ff es 0 avs ts single;
fprintf ff "@]";
fprintf ff ");@ "
| xs ->
let cn = (List.find (fun od -> od.o_name = o) objs).o_class in
let at = (jname_of_name (shortname cn)) ^ "Answer" in
let ao = o ^ "_ans" in
fprintf ff "%s %s = new %s();@ " at ao at;
fprintf ff "%s = %s.step(" ao o;
fprintf ff "@[";
print_exps ff es 0 avs ts single;
fprintf ff "@]";
fprintf ff ");@ ";
print_proj ff xs ao avs single)
| Acase (e, grds) ->
let grds =
List.map
(fun (ln,act) -> (shortname ln),act) grds in
if bool_case grds
then print_if ff e grds objs avs ts single
else (fprintf ff "@[<v>@[<v 2>switch (%a) {@ "
(fun ff e -> print_exp ff e 0 avs ts single) e;
print_grds ff grds objs avs ts single;
fprintf ff "@]@ }@]");
| Acall (_,oref,Mreset,_) ->
let o = obj_ref_to_string oref in
fprintf ff "%s.reset();" o
| Afor _ -> assert false (* TODO java array *)
| Aasync_call _ -> assert false (* TODO java array *)
and print_grds ff grds objs avs ts single =
match grds with
| [] -> ()
| (tg, b) :: grds' ->
(* retrieve class name *)
let cn = (fst
(List.find
(fun (tn, tgs) ->
List.exists (fun tg' -> tg = tg') tgs)
ts)) in
fprintf ff "@[<v 2>case %a.%a:@ "
print_name cn
print_name tg;
print_block ff b objs avs ts single;
fprintf ff "@ break;@ @]@ ";
print_grds ff grds' objs avs ts single
and print_if ff e grds objs avs ts single =
match grds with
| [("true", a)] ->
fprintf ff "@[<v>@[<v 2>if (%a) {@ "
(fun ff e -> print_exp ff e 0 avs ts single) e;
print_block ff a objs avs ts single;
fprintf ff "@]@ }@]"
| [("false", a)] ->
fprintf ff "@[<v>@[<v 2>if (!%a) {@ "
(fun ff e -> print_exp ff e 6 avs ts single) e;
print_block ff a objs avs ts single;
fprintf ff "@]@ }@]"
| [("true", a1); ("false", a2)] ->
fprintf ff "@[<v>@[<v 2>if (%a) {@ "
(fun ff e -> print_exp ff e 0 avs ts single) e;
print_block ff a1 objs avs ts single;
fprintf ff "@]@ @[<v 2>} else {@ ";
print_block ff a2 objs avs ts single;
fprintf ff "@]@ }@]"
| [("false", a2); ("true", a1)] ->
fprintf ff "@[<v>@[<v 2>if (%a) {@ "
(fun ff e -> print_exp ff e 0 avs ts single) e;
print_block ff a1 objs avs ts single;
fprintf ff "@]@ @[<v 2>} else {@ ";
print_block ff a2 objs avs ts single;
fprintf ff "@]@ }@]"
| _ -> assert false
and print_asgn ff x e avs ts single =
fprintf ff "@[";
print_lhs ff x avs single;
fprintf ff " = ";
print_exp ff e 0 avs ts single;
fprintf ff "@]"
and print_block ff b objs avs ts single = () (* TODO urgent java *)
let print_vd ff vd =
let jty,jdv = java_type_default_value vd.v_type in
fprintf ff "@[<v>";
print_name ff jty;
fprintf ff " %s = %s;"
(jname_of_name (name vd.v_ident))
jdv;
fprintf ff "@]"
let print_obj ff od =
fprintf ff "@[<v>";
fprintf ff "%a %a = new %a();"
print_shortname od.o_class
print_name od.o_name
print_shortname od.o_class;
fprintf ff "@]"
let rec print_objs ff ods =
match ods with
| [] -> ()
| od :: ods' ->
print_obj ff od;
fprintf ff "@ ";
print_objs ff ods'
let print_comps ff fds=
let rec walk n = function
| [] -> ()
| fd :: fds' ->
fprintf ff "@ ";
fprintf ff "public ";
print_type ff fd.v_type;
fprintf ff " c_%s;" (string_of_int n);
walk (n + 1) fds'
in walk 1 fds
let print_ans_struct ff name fields =
fprintf ff "@[<v>@[<v 2>public class %s {" name;
print_comps ff fields;
fprintf ff "@]@ }@]@ "
let print_vd' ff vd =
fprintf ff "@[";
print_type ff vd.v_type;
fprintf ff "@ %s" (jname_of_name (name vd.v_ident));
fprintf ff "@]"
let rec print_in ff = function
| [] -> ()
| [vd] -> print_vd' ff vd
| vd :: vds' ->
print_vd' ff vd;
fprintf ff ",@ ";
print_in ff vds'
let rec print_mem ff = function
| [] -> ()
| vd :: m' ->
print_vd ff vd;
fprintf ff "@ ";
print_mem ff m'
let print_loc ff vds = print_mem ff vds
let print_step ff n s objs ts single =
let n = jname_of_name n in
fprintf ff "@[<v>@ @[<v 2>public ";
if single then print_type ff (List.hd s.m_outputs).v_type
else fprintf ff "%s" (n ^ "Answer");
fprintf ff " step(@[";
print_in ff s.m_inputs;
fprintf ff "@]) {@ ";
let loc = if single then (List.hd s.m_outputs) :: s.m_body.b_locals else s.m_body.b_locals in
if loc = [] then () else (print_loc ff loc; fprintf ff "@ ");
if single then fprintf ff "@ "
else fprintf ff "%sAnswer step_ans = new %sAnswer();@ @ " n n;
print_act ff s.bd objs
(List.map (fun vd -> vd.v_ident) s.out) ts single;
fprintf ff "@ @ return ";
if single
then fprintf ff "%s" (jname_of_name (Idents.name (List.hd s.out).v_ident))
else fprintf ff "step_ans";
fprintf ff ";@]@ }@ @]"
let print_reset ff r ts =
fprintf ff "@[<v>@ @[<v 2>public void reset() {@ ";
print_act ff r [] [] ts false;
fprintf ff "@]@ }@ @]"
let print_class ff headers ts single opened_mod cl =
let clid = jname_of_name cl.cl_id in
List.iter (fprintf ff "%s") headers;
(* fprintf ff "@[<v>package %s;@\n@\n" headers; *)
(* import opened modules *)
List.iter
(fun m ->
fprintf ff "import %s.*;@\n" (String.uncapitalize m))
opened_mod;
fprintf ff "@\n@[<v 2>public class %s {@ " clid;
if cl.mem = [] then ()
else fprintf ff "@[<v>@ "; print_mem ff cl.mem; fprintf ff "@]";
if cl.objs = [] then ()
else fprintf ff "@[<v>@ "; print_objs ff cl.objs; fprintf ff "@]";
print_reset ff cl.reset ts;
print_step ff clid cl.step cl.objs ts single;
fprintf ff "@]@ }@]"
let print_class_and_answer_to_file java_dir headers ts opened_mod cl =
let clid = jname_of_name cl.cl_id in
let print_class_to_file single =
let out_ch = open_out (java_dir ^ "/" ^ clid ^ ".java") in
let ff = formatter_of_out_channel out_ch in
Misc.print_header_info ff "/*" "*/";
print_class ff headers ts single opened_mod cl;
fprintf ff "@.";
close_out out_ch
in
match cl.step.out with
| [_] -> print_class_to_file true
| _ ->
let out_ch = open_out (java_dir ^ "/" ^ clid ^ "Answer.java") in
let ff = formatter_of_out_channel out_ch in
Misc.print_header_info ff "/*" "*/";
List.iter (fprintf ff "%s") headers;
(* fprintf ff "@[<v>package %s;@\n@\n" headers; *)
List.iter
(fun m ->
fprintf ff "import %s.*;@\n" (String.uncapitalize m))
opened_mod;
print_ans_struct ff (clid ^ "Answer") cl.step.out;
fprintf ff "@.";
close_out out_ch;
print_class_to_file false
let print_classes java_dir headers ts opened_mod cls =
List.iter
(print_class_and_answer_to_file java_dir headers ts opened_mod)
cls
(******************************)
let print java_dir p =
let headers =
List.map snd
(List.filter
(fun (tag,_) -> tag = "java")
p.o_pragmas) in
print_types java_dir headers p.o_types;
o_types := p.o_types;
print_classes
java_dir headers
(List.flatten
(List.map
(function
| { t_desc = Type_abs } -> []
| { t_name = tn; t_desc = Type_enum tgs } -> [tn, tgs]
| { t_name = tn; t_desc = Type_struct fields } ->
[tn, (List.map fst fields)])
p.o_types))
p.o_opened
p.o_defs
(******************************)

27
compiler/obc/obc.ml
View file

@ -16,12 +16,12 @@ open Signature
open Location
type class_name = qualname
type instance_name = qualname
type obj_name = name
type op_name = qualname
type obj_ident = var_ident
type type_dec =
{ t_name : qualname;
{ t_name : type_name;
t_desc : tdesc;
t_loc : location }
@ -56,8 +56,8 @@ and exp_desc =
| Ebang of exp
type obj_ref =
| Oobj of obj_name
| Oarray of obj_name * pattern
| Oobj of obj_ident
| Oarray of obj_ident * pattern
type method_name =
| Mreset
@ -80,10 +80,10 @@ and var_dec =
v_loc : location }
type obj_dec =
{ o_name : obj_name;
o_class : instance_name;
{ o_ident : obj_ident;
o_class : class_name;
o_params : static_exp list;
o_size : static_exp option;
o_size : static_exp option; (** size of the array if the declaration is an array of obj *)
o_loc : location }
type method_def =
@ -147,6 +147,17 @@ let rec vd_find n = function
| vd::l ->
if vd.v_ident = n then vd else vd_find n l
(** Returns the type of a [var_dec list] *)
let vd_list_to_type vd_l = match vd_l with
| [] -> Types.Tunit
| [vd] -> vd.v_type
| _ -> Tprod (List.map (fun vd -> vd.v_type) vd_l)
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)
let lhs_of_exp e = match e.e_desc with
| Elhs l -> l
| _ -> assert false

8
compiler/obc/obc_printer.ml
View file

@ -14,7 +14,7 @@ let print_vd ff vd =
fprintf ff "@]"
let print_obj ff o =
fprintf ff "@[<v>"; print_name ff o.o_name;
fprintf ff "@[<v>"; print_ident ff o.o_ident;
fprintf ff " : "; print_qualname ff o.o_class;
fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "<<"","">>") o.o_params;
(match o.o_size with
@ -67,10 +67,10 @@ let print_asgn ff pref x e =
fprintf ff "@]"
let print_obj_call ff = function
| Oobj o -> print_name ff o
| Oobj o -> print_ident ff o
| Oarray (o, i) ->
fprintf ff "%a[%a]"
print_name o
print_ident o
print_lhs i
let print_method_name ff = function
@ -90,7 +90,7 @@ 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 @]@,}@]"
fprintf ff "@[<v>@[<v 2>for %s = %a to %a {@ %a @]@,}@]"
(name x)
print_static_exp i1
print_static_exp i2

2
compiler/utilities/misc.ml
View file

@ -112,7 +112,7 @@ let rec assocd value = function
(** { 3 Compiler iterators } *)
(** Mapfold *)
(** Mapfold *) (* TODO optim : lot's of place we don't need the List.rev *)
let mapfold f acc l =
let l,acc = List.fold_left
(fun (l,acc) e -> let e,acc = f acc e in e::l, acc)

2
todo.txt
View file

@ -1,6 +1,8 @@
Plus ou moins ordonné du plus urgent au moins urgent.
*- 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" ...
*- Optimisation de la traduction des automates : pas besoin de variables de reset pour les états "continue", etc.