New Java backend closing
Léonard Gérard
14 years ago
parent
fc08753bd9
commit
df469db394
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
(******************************)
|
||||
Loading…
Reference in New Issue