Added Java 1.4 target (experimental)
Experimental : remains some bugs on arrays
This commit is contained in:
Gwenaël Delaval
parent
74a760ee0a
commit
3e8af67e07
7 changed files with 854 additions and 4 deletions
|
|
@ -82,6 +82,7 @@ let java_conf () =
|
|||
let targets =
|
||||
[ mk_target ~interface:(IObc Cmain.interface) "c" (Obc_no_params Cmain.program);
|
||||
mk_target ~load_conf:java_conf "java" (Obc Java_main.program);
|
||||
mk_target ~load_conf:java_conf "java14" (Obc Java14_main.program);
|
||||
mk_target "z3z" (Minils_no_params ignore);
|
||||
mk_target "obc" (Obc write_obc_file);
|
||||
mk_target "obc_np" (Obc_no_params write_obc_file);
|
||||
|
|
|
|||
|
|
@ -90,13 +90,15 @@ and block = { b_locals : var_dec list;
|
|||
and act = Anewvar of var_dec * exp
|
||||
| Aassgn of pattern * exp
|
||||
| Aexp of exp
|
||||
| Aswitch of exp * (constructor_name * block) list
|
||||
| Aswitch of exp * (switch_case * block) list
|
||||
| Aif of exp * block
|
||||
| Aifelse of exp * block * block
|
||||
| Ablock of block
|
||||
| Afor of var_dec * exp * exp * block
|
||||
| Areturn of exp
|
||||
|
||||
and switch_case = Senum of constructor_name | Sexp of exp
|
||||
|
||||
and exp = Ethis
|
||||
| Efun of op_name * exp list
|
||||
| Emethod_call of exp * method_name * exp list
|
||||
|
|
|
|||
136
compiler/obc/java/java14_main.ml
Normal file
136
compiler/obc/java/java14_main.ml
Normal file
|
|
@ -0,0 +1,136 @@
|
|||
open Misc
|
||||
open Names
|
||||
open Modules
|
||||
open Signature
|
||||
open Java
|
||||
open Java_printer
|
||||
|
||||
(** returns the vd and the pat of a fresh ident from [name] *)
|
||||
let mk_var ty name =
|
||||
let id = Idents.gen_var "java_main" name in
|
||||
mk_var_dec id false ty, Pvar id, Evar id
|
||||
|
||||
|
||||
let program p =
|
||||
(*Scalarize*)
|
||||
let p = Compiler_utils.pass "Scalarize" true Scalarize.program p Obc_compiler.pp in
|
||||
let p_java = Obc2java14.program p in
|
||||
let dir = Compiler_utils.build_path "java" in
|
||||
Compiler_utils.ensure_dir dir;
|
||||
|
||||
(* Compile and output the nodes *)
|
||||
output_program dir p_java;
|
||||
|
||||
(* Create a runnable main simulation *)
|
||||
if !Compiler_options.simulation
|
||||
then (
|
||||
let q_main =
|
||||
try !Compiler_options.simulation_node |> qualify_value
|
||||
with Not_found ->
|
||||
Format.eprintf "Unable to find main node: %s@." !Compiler_options.simulation_node;
|
||||
raise Errors.Error
|
||||
in
|
||||
let sig_main = find_value q_main in
|
||||
let ty_main = sig_main.node_outputs |> types_of_arg_list |> Types.prod in
|
||||
let ty_main_args = sig_main.node_params |> types_of_param_list in
|
||||
let class_name = Obc2java14.fresh_classe (!Compiler_options.simulation_node ^ "_sim") in
|
||||
Idents.enter_node class_name;
|
||||
let field_step_dnb, id_step_dnb =
|
||||
let id = Idents.gen_var "java_main" "default_step_nb" in
|
||||
mk_field ~static:true ~final:true ~value:(Some (Sint 30000)) Tint id, id
|
||||
in
|
||||
let main_methode =
|
||||
|
||||
(* step is the current iteration step *)
|
||||
let vd_step, pat_step, exp_step = mk_var Tint "step" in
|
||||
|
||||
let vd_args, _, exp_args =
|
||||
mk_var (Tarray (Tclass (Names.pervasives_qn "String"), [Sint 0])) "args" in
|
||||
|
||||
let get_arg i = Earray_elem(exp_args, [Sint i]) in
|
||||
|
||||
(* (* argnb is the current argument during the parsing *)
|
||||
let vd_argnb, pat_argnb, exp_argnb = mk_var Tint "argNb" in
|
||||
let init_argnb = Aassgn (pat_argnb, Sint 0) in
|
||||
let incr_argnb = Aassgn (pat_argnb, Efun(pervasives_qn "+", [exp_argnb; Sint 1])) in
|
||||
let exp_current_arg = Earray_elem(exp_args, exp_argnb) in
|
||||
*)
|
||||
let body =
|
||||
let vd_main, e_main, q_main, ty_main =
|
||||
let q_main = Obc2java14.qualname_to_package_classe q_main in (*java qual*)
|
||||
let id = Idents.gen_var "java_main" "main" in
|
||||
mk_var_dec id false (Tclass q_main), Evar id, q_main, ty_main
|
||||
in
|
||||
let acts =
|
||||
let out = Eclass(Names.qualname_of_string "java.lang.System.out") in
|
||||
let jarrays = Eclass(Names.qualname_of_string "java.util.Arrays") in
|
||||
let jint = Eclass(Names.qualname_of_string "Integer") in
|
||||
let jfloat = Eclass(Names.qualname_of_string "Float") in
|
||||
let jbool = Eclass(Names.qualname_of_string "Boolean") in
|
||||
let jsys = Eclass(Names.qualname_of_string "java.lang.System") in
|
||||
let jminus = pervasives_qn "-" in
|
||||
let jplus = pervasives_qn "+" in
|
||||
|
||||
(* parse arguments to give to the main *)
|
||||
let rec parse_args t_l i = match t_l with
|
||||
| [] -> []
|
||||
| t::t_l when t = Initial.tint ->
|
||||
(Emethod_call(jint, "parseInt", [get_arg i]))
|
||||
:: parse_args t_l (i+1)
|
||||
| t::t_l when t = Initial.tfloat ->
|
||||
(Emethod_call(jfloat, "parseFloat", [get_arg i]))
|
||||
:: parse_args t_l (i+1)
|
||||
| t::t_l when t = Initial.tint ->
|
||||
(Emethod_call(jbool, "parseBool", [get_arg i]))
|
||||
:: parse_args t_l (i+1)
|
||||
| _ -> Misc.unsupported "java main does not support parsing complexe static args"
|
||||
in
|
||||
let main_args = parse_args ty_main_args 0 in
|
||||
|
||||
let parse_max_iteration =
|
||||
let t_size = List.length ty_main_args in
|
||||
(* no more arg to give to main, the last one if it exists is the iteration nb *)
|
||||
Aifelse(Efun(Names.pervasives_qn ">", [ Efield (exp_args, "length"); Sint t_size ]),
|
||||
(* given max number of iterations *)
|
||||
mk_block [Aassgn(pat_step,
|
||||
Emethod_call(jint, "parseInt", [get_arg t_size]))],
|
||||
(* default max number of iterations *)
|
||||
mk_block [Aassgn(pat_step, Evar id_step_dnb)]);
|
||||
in
|
||||
let ret = Emethod_call(e_main, "step", []) in
|
||||
let print_ret = match ty_main with
|
||||
| Types.Tarray (Types.Tarray _, _) -> Emethod_call(jarrays, "deepToString", [ret])
|
||||
| Types.Tarray _ -> Emethod_call(jarrays, "toString", [ret])
|
||||
| t when t = Initial.tint -> Emethod_call(jint, "toString", [ret])
|
||||
| t when t = Initial.tfloat -> Emethod_call(jfloat, "toString", [ret])
|
||||
| t when t = Initial.tbool -> Emethod_call(jbool, "toString", [ret])
|
||||
| _ -> Emethod_call(ret, "toString", [])
|
||||
in
|
||||
let main_for_loop i =
|
||||
(* [Aexp (Emethod_call(out, "printf", *)
|
||||
(* [Sstring "%d => %s\\n"; Evar i; print_ret]))] *)
|
||||
[Aexp ret]
|
||||
in
|
||||
let vd_t1, e_t1 =
|
||||
let id = Idents.gen_var "java_main" "t" in
|
||||
mk_var_dec id false Tlong, Evar id
|
||||
in
|
||||
[ Anewvar(vd_main, Enew (Tclass q_main, main_args));
|
||||
parse_max_iteration;
|
||||
Anewvar(vd_t1, Emethod_call(jsys, "currentTimeMillis", []));
|
||||
Obc2java14.fresh_for exp_step main_for_loop;
|
||||
Aexp (Emethod_call(out, "print",
|
||||
[ Efun(jplus,
|
||||
[Sstring "time : %d\\n";
|
||||
Efun(jminus,
|
||||
[Emethod_call(jsys, "currentTimeMillis", []);
|
||||
e_t1])])]))
|
||||
]
|
||||
in
|
||||
mk_block ~locals:[vd_step] acts
|
||||
in
|
||||
mk_methode ~static:true ~args:[vd_args] body "main"
|
||||
in
|
||||
let c = mk_classe ~fields:[field_step_dnb] ~methodes:[main_methode] class_name in
|
||||
output_program dir [c]
|
||||
)
|
||||
|
|
@ -204,7 +204,11 @@ and act ff = function
|
|||
| Aexp e -> fprintf ff "@[%a@];" exp e
|
||||
| Aswitch (e, c_b_l) ->
|
||||
let pcb ff (c,b) =
|
||||
fprintf ff "@[<v4>case %a:@ %a@ break;@]" bare_constructor_name c block b in
|
||||
let print_case ff c =
|
||||
match c with
|
||||
| Senum c -> bare_constructor_name ff c
|
||||
| Sexp e -> exp ff e in
|
||||
fprintf ff "@[<v4>case %a:@ %a@ break;@]" print_case c block b in
|
||||
(* let switch_hack ff c_b_l = (* TODO java : better thing to do ? *)
|
||||
fprintf ff "@[<2>default ://Dead code. Hack to prevent \
|
||||
\"may not be initialized\"
|
||||
|
|
|
|||
|
|
@ -320,7 +320,7 @@ let jop_of_op param_env op_name e_l =
|
|||
match op_name with
|
||||
| { qual = Module "Iostream"; name = "printf" } ->
|
||||
Emethod_call (Eclass(Names.qualname_of_string "java.lang.System.out"),
|
||||
"print",
|
||||
"printf",
|
||||
(exp_list param_env e_l))
|
||||
| _ ->
|
||||
Efun (op_name, exp_list param_env e_l)
|
||||
|
|
@ -371,7 +371,9 @@ let rec act_list param_env act_l acts =
|
|||
let _, _else = List.find (fun (c,_) -> c = Initial.pfalse) c_b_l in
|
||||
(Aifelse (exp param_env e, block param_env _then, block param_env _else)) :: acts)
|
||||
| Obc.Acase (e, c_b_l) ->
|
||||
let _c_b (c,b) = translate_constructor_name c, block param_env b in
|
||||
let _c_b (c,b) =
|
||||
Senum (translate_constructor_name c),
|
||||
block param_env b in
|
||||
let acase = Aswitch (exp param_env e, List.map _c_b c_b_l) in
|
||||
acase::acts
|
||||
| Obc.Afor (v, se, se', b) ->
|
||||
|
|
|
|||
623
compiler/obc/java/obc2java14.ml
Normal file
623
compiler/obc/java/obc2java14.ml
Normal file
|
|
@ -0,0 +1,623 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Heptagon *)
|
||||
(* *)
|
||||
(* Gwenael Delaval, LIG/INRIA, UJF *)
|
||||
(* Leonard Gerard, Parkas, ENS *)
|
||||
(* Adrien Guatto, Parkas, ENS *)
|
||||
(* Cedric Pasteur, Parkas, ENS *)
|
||||
(* Marc Pouzet, Parkas, ENS *)
|
||||
(* *)
|
||||
(* Copyright 2012 ENS, INRIA, UJF *)
|
||||
(* *)
|
||||
(* This file is part of the Heptagon compiler. *)
|
||||
(* *)
|
||||
(* Heptagon is free software: you can redistribute it and/or modify it *)
|
||||
(* under the terms of the GNU General Public License as published by *)
|
||||
(* the Free Software Foundation, either version 3 of the License, or *)
|
||||
(* (at your option) any later version. *)
|
||||
(* *)
|
||||
(* Heptagon is distributed in the hope that it will be useful, *)
|
||||
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
|
||||
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
|
||||
(* GNU General Public License for more details. *)
|
||||
(* *)
|
||||
(* You should have received a copy of the GNU General Public License *)
|
||||
(* along with Heptagon. If not, see <http://www.gnu.org/licenses/> *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(** 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 *)
|
||||
|
||||
(** Requires scalarized Obc :
|
||||
[p = e] when [e] is an array is understand as a copy of the reference, not a copy of the array.*)
|
||||
|
||||
open Format
|
||||
open Misc
|
||||
open Names
|
||||
open Modules
|
||||
open Signature
|
||||
open Obc
|
||||
open Obc_utils
|
||||
open Java
|
||||
|
||||
let this_field_ident id = Efield (Ethis, Idents.name id)
|
||||
|
||||
(** Additional classes created during the translation *)
|
||||
let add_classe, get_classes =
|
||||
let extra_classes = ref [] in
|
||||
(fun c -> extra_classes := c :: !extra_classes)
|
||||
,(fun () -> !extra_classes)
|
||||
|
||||
(** fresh Afor from 0 to [size]
|
||||
with [body] a function from [var_ident] (the iterator) to [act] list *)
|
||||
let fresh_for size body =
|
||||
let i = Idents.gen_var "obc2java" "i" in
|
||||
let id = mk_var_dec i false Tint in
|
||||
Afor (id, Sint 0, size, mk_block (body i))
|
||||
|
||||
(** fresh nested Afor from 0 to [size]
|
||||
with [body] a function from [var_ident] list (the iterator list) to [act] list :
|
||||
s_l = [10; 20]
|
||||
then
|
||||
for i in 20
|
||||
for j in 10
|
||||
body [i][j]
|
||||
*)
|
||||
let fresh_nfor s_l body =
|
||||
let rec aux s_l i_l = match s_l with
|
||||
| [s] ->
|
||||
let i = Idents.gen_var "obc2java" "i" in
|
||||
let id = (mk_var_dec i false Tint) in
|
||||
Afor (id, Sint 0, s, mk_block (body (List.rev (i::i_l))))
|
||||
| s::s_l ->
|
||||
let i = Idents.gen_var "obc2java" "i" in
|
||||
let id = mk_var_dec i false Tint in
|
||||
Afor (id, Sint 0, s, mk_block ([aux s_l (i::i_l)]))
|
||||
| [] -> Misc.internal_error "Fresh nfor called with empty size list"
|
||||
in
|
||||
aux s_l []
|
||||
|
||||
(* current module is not translated to keep track,
|
||||
there is no issue since printed without the qualifier *)
|
||||
let rec translate_modul m = m (*match m with
|
||||
| Pervasives
|
||||
| LocalModule -> m
|
||||
| _ when m = g_env.current_mod -> m
|
||||
| Module n -> Module n
|
||||
| QualModule { qual = q; name = n} ->
|
||||
QualModule { qual = translate_modul q; name = String.lowercase n }
|
||||
*)
|
||||
|
||||
(** a [Module.const] becomes a [module.CONSTANTES.CONST] *)
|
||||
let translate_const_name { qual = m; name = n } =
|
||||
{ qual = QualModule { qual = translate_modul m; name = "CONSTANTES"}; name = String.uppercase n }
|
||||
|
||||
(** a [Module.fun] becomes a [module.FUNS.fun] *)
|
||||
let translate_fun_name { qual = m; name = n } =
|
||||
{ qual = QualModule { qual = translate_modul m; name = "FUNS"}; name = n }
|
||||
|
||||
(** a [Module.name] becomes a [module.Name]
|
||||
used for type_names, class_names, fun_names *)
|
||||
let qualname_to_class_name q =
|
||||
{ qual = translate_modul q.qual; name = String.capitalize q.name }
|
||||
|
||||
(** a [Module.name] becomes a [module.Name] even on current_mod *)
|
||||
let qualname_to_package_classe q =
|
||||
{ qual = translate_modul q.qual; name = String.capitalize q.name }
|
||||
|
||||
(** Create a fresh class qual from a name *)
|
||||
let fresh_classe n = Modules.fresh_value "obc2java" n |> qualname_to_package_classe
|
||||
|
||||
(** a [Module.Constr] of an [Module.enum] type
|
||||
becomes a [module.Enum.CONSTR] of the [module.Enum] class *)
|
||||
let translate_constructor_name_2 q q_ty =
|
||||
let classe = qualname_to_class_name q_ty in
|
||||
{ qual = QualModule classe; name = String.uppercase q.name }
|
||||
|
||||
let translate_constructor_name q =
|
||||
match Modules.unalias_type (Types.Tid (Modules.find_constrs q)) with
|
||||
| Types.Tid q_ty when q_ty = Initial.pbool -> q |> shortname |> local_qn
|
||||
| Types.Tid q_ty -> translate_constructor_name_2 q q_ty
|
||||
| _ -> assert false
|
||||
|
||||
let translate_field_name f = f |> Names.shortname |> String.lowercase
|
||||
|
||||
(** a [name] becomes a [package.Name] *)
|
||||
let name_to_classe_name n = n |> Modules.current_qual |> qualname_to_package_classe
|
||||
|
||||
(** translate an ostatic_exp into an jexp *)
|
||||
let rec static_exp param_env se = match se.Types.se_desc with
|
||||
| Types.Svar c ->
|
||||
(match c.qual with
|
||||
| LocalModule ->
|
||||
let n = NamesEnv.find (shortname c) param_env in
|
||||
Svar (n |> Idents.name |> local_qn)
|
||||
| _ -> Svar (translate_const_name c))
|
||||
| Types.Sint i -> Sint i
|
||||
| Types.Sfloat f -> Sfloat f
|
||||
| Types.Sbool b -> Sbool b
|
||||
| Types.Sstring s -> Sstring s
|
||||
| Types.Sconstructor c -> let c = translate_constructor_name c in Sconstructor c
|
||||
| Types.Sfield _ -> eprintf "ojSfield @."; assert false;
|
||||
| Types.Stuple se_l -> tuple param_env se_l
|
||||
| Types.Sarray_power (see,pow_list) ->
|
||||
let pow_list = List.rev pow_list in
|
||||
let rec make_array tyl pow_list = match tyl, pow_list with
|
||||
| Tarray(t, _), pow::pow_list ->
|
||||
let pow = (try Static.int_of_static_exp Names.QualEnv.empty pow
|
||||
with Errors.Error ->
|
||||
eprintf "%aStatic power of array should have integer power. \
|
||||
Please use callgraph or non-static exp in %a.@."
|
||||
Location.print_location se.Types.se_loc
|
||||
Global_printer.print_static_exp se;
|
||||
raise Errors.Error)
|
||||
in
|
||||
Enew_array (tyl, Misc.repeat_list (make_array t pow_list) pow)
|
||||
| _ -> static_exp param_env see
|
||||
in
|
||||
make_array (ty param_env se.Types.se_ty) pow_list
|
||||
(*let t = match x.pat_ty with
|
||||
| Tarray (t,_) -> t
|
||||
| _ -> Misc.internal_error "mls2obc select slice type" 5
|
||||
in
|
||||
let eval_int pow = (try Static.int_of_static_exp Names.QualEnv.empty pow
|
||||
with Errors.Error ->
|
||||
eprintf "%aStatic power of array should have integer power. \
|
||||
Please use callgraph or non-static exp in %a.@."
|
||||
Location.print_location se.Types.se_loc
|
||||
Global_printer.print_static_exp se;
|
||||
raise Errors.Error)
|
||||
in
|
||||
let rec make_matrix acc = match pow_list with
|
||||
| [] -> acc
|
||||
| pow :: pow_list ->
|
||||
let pow = eval_int pow in
|
||||
make_matrix (Misc.repeat_list acc pow) pow_list
|
||||
in
|
||||
let se_l = match pow_list with
|
||||
| [] -> Misc.internal_error "Empty power list" 0
|
||||
| pow :: pow_list -> make_matrix (Misc.repeat_list (static_exp param_env see)) pow_list
|
||||
in
|
||||
Enew_array (ty param_env se.Types.se_ty, se_l)*)
|
||||
| Types.Sarray se_l ->
|
||||
Enew_array (ty param_env se.Types.se_ty, List.map (static_exp param_env) se_l)
|
||||
| Types.Srecord f_e_l ->
|
||||
let ty_name =
|
||||
match se.Types.se_ty with
|
||||
| Types.Tid ty_name -> qualname_to_package_classe ty_name
|
||||
| _ -> Misc.internal_error "Obc2java14"
|
||||
in
|
||||
let f_e_l =
|
||||
List.sort
|
||||
(fun (f1,_) (f2,_) -> compare f1.name f2.name)
|
||||
f_e_l in
|
||||
let e_l = List.map (fun (_f,e) -> e) f_e_l in
|
||||
Enew (Tclass ty_name, List.map (static_exp param_env) e_l)
|
||||
| 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 Modules.unalias_type t with
|
||||
| Types.Tprod [] -> Tunit
|
||||
| Types.Tprod ty_l -> tuple_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 ->
|
||||
begin try
|
||||
let ty = find_type t in
|
||||
begin match ty with
|
||||
| Tenum _ -> Tint
|
||||
| _ -> Tclass (qualname_to_class_name t)
|
||||
end
|
||||
with Not_found -> Tclass (qualname_to_class_name t)
|
||||
end
|
||||
| Types.Tarray _ ->
|
||||
let rec gather_array t = match t with
|
||||
| Types.Tarray (t,size) ->
|
||||
let t, s_l = gather_array t in
|
||||
t, (static_exp param_env size)::s_l
|
||||
| _ -> ty param_env t, []
|
||||
in
|
||||
let t, s_l = gather_array t in
|
||||
Tarray (t, s_l)
|
||||
| Types.Tinvalid -> Misc.internal_error "obc2java invalid type"
|
||||
|
||||
and tuple_ty param_env ty_l =
|
||||
let ln = ty_l |> List.length |> Pervasives.string_of_int in
|
||||
Tclass (java_pervasive_class ("Tuple"^ln))
|
||||
|
||||
and ty param_env t =
|
||||
let t = Modules.unalias_type t in
|
||||
match t with
|
||||
| Types.Tprod [] -> Tunit
|
||||
| Types.Tprod ty_l -> tuple_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 ->
|
||||
begin try
|
||||
let ty = find_type t in
|
||||
begin match ty with
|
||||
| Tenum _ -> Tint
|
||||
| _ -> Tclass (qualname_to_class_name t)
|
||||
end
|
||||
with Not_found -> Tclass (qualname_to_class_name t)
|
||||
end
|
||||
| Types.Tarray _ ->
|
||||
let rec gather_array t = match t with
|
||||
| Types.Tarray (t,size) ->
|
||||
let tin, s_l = gather_array t in
|
||||
tin, (static_exp param_env size)::s_l
|
||||
| _ -> ty param_env t, []
|
||||
in
|
||||
let tin, s_l = gather_array t in
|
||||
Tarray (tin, s_l)
|
||||
| Types.Tinvalid -> Misc.internal_error "obc2java invalid type"
|
||||
|
||||
and var_dec param_env vd = { vd_type = ty param_env vd.v_type;
|
||||
vd_alias = vd.v_alias;
|
||||
vd_ident = vd.v_ident }
|
||||
|
||||
and var_dec_list param_env vd_l = List.map (var_dec param_env) vd_l
|
||||
|
||||
and exp param_env e = match e.e_desc with
|
||||
| Obc.Eextvalue p -> ext_value param_env p
|
||||
| Obc.Eop (op,e_l) -> Efun (op, exp_list param_env e_l)
|
||||
| Obc.Estruct (ty_name,f_e_l) ->
|
||||
let ty_name = qualname_to_package_classe ty_name in
|
||||
let f_e_l =
|
||||
List.sort
|
||||
(fun (f1,_) (f2,_) -> compare f1.name f2.name)
|
||||
f_e_l in
|
||||
let e_l = List.map (fun (_f,e) -> e) f_e_l in
|
||||
Enew (Tclass ty_name, exp_list param_env e_l)
|
||||
| Obc.Earray e_l -> Enew_array (ty param_env e.e_ty, exp_list param_env e_l)
|
||||
|
||||
and exp_list param_env e_l = List.map (exp param_env) e_l
|
||||
|
||||
and tuple param_env se_l =
|
||||
let t = tuple_ty param_env (List.map (fun e -> Modules.unalias_type e.Types.se_ty) se_l) in
|
||||
Enew (t, List.map (static_exp param_env) se_l)
|
||||
|
||||
|
||||
and pattern param_env p = match p.pat_desc with
|
||||
| Obc.Lvar v -> Pvar v
|
||||
| Obc.Lmem v -> Pthis v
|
||||
| Obc.Lfield (p,f) -> Pfield (pattern param_env p, translate_field_name f)
|
||||
| Obc.Larray _ ->
|
||||
let p, idx_l =
|
||||
let rec gather_idx acc p = match p.pat_desc with
|
||||
| Obc.Larray (p,e) -> gather_idx ((exp param_env e)::acc) p
|
||||
| _ -> pattern param_env p, acc
|
||||
in
|
||||
let p, idx_l = gather_idx [] p in
|
||||
p, idx_l
|
||||
in
|
||||
Parray_elem (p, idx_l)
|
||||
|
||||
and pattern_to_exp param_env p = match p.pat_desc with
|
||||
| Obc.Lvar v -> Evar v
|
||||
| Obc.Lmem v -> this_field_ident v
|
||||
| Obc.Lfield (p,f) ->
|
||||
Efield (pattern_to_exp param_env p, translate_field_name f)
|
||||
| Obc.Larray _ ->
|
||||
let p, idx_l =
|
||||
let rec gather_idx acc p = match p.pat_desc with
|
||||
| Obc.Larray (p,e) -> gather_idx ((exp param_env e)::acc) p
|
||||
| _ -> pattern_to_exp param_env p, acc
|
||||
in
|
||||
let p, idx_l = gather_idx [] p in
|
||||
p, idx_l
|
||||
in
|
||||
Earray_elem (p, idx_l)
|
||||
|
||||
and ext_value param_env w = match w.w_desc with
|
||||
| Obc.Wvar v -> Evar v
|
||||
| Obc.Wconst c -> static_exp param_env c
|
||||
| Obc.Wmem v -> this_field_ident v
|
||||
| Obc.Wfield (p,f) -> Efield (ext_value param_env p, translate_field_name f)
|
||||
| Obc.Warray (p,e) -> Earray_elem (ext_value param_env p, [exp param_env e])
|
||||
|
||||
|
||||
let obj_ref param_env o = match o with
|
||||
| Oobj id -> Evar id
|
||||
| Oarray (id, p_l) ->
|
||||
(* the generated list is in java order *)
|
||||
let idx_l = List.map (fun p -> pattern_to_exp param_env p) p_l in
|
||||
Earray_elem (Evar id, idx_l)
|
||||
|
||||
let jop_of_op param_env op_name e_l =
|
||||
match op_name with
|
||||
| { qual = Module "Iostream"; name = "printf" } ->
|
||||
Emethod_call (Eclass(Names.qualname_of_string "java.lang.System.out"),
|
||||
"print",
|
||||
(exp_list param_env e_l))
|
||||
| _ ->
|
||||
Efun (op_name, exp_list param_env e_l)
|
||||
|
||||
|
||||
let rec act_list param_env act_l acts =
|
||||
let _act act acts = match act with
|
||||
| Obc.Aassgn (p,e) -> (Aassgn (pattern param_env p, exp param_env e))::acts
|
||||
| Obc.Aop (op,e_l) -> Aexp (jop_of_op param_env op e_l) :: acts
|
||||
| Obc.Acall (p_l, obj, Mstep, e_l) ->
|
||||
let o_ref = obj_ref param_env obj in
|
||||
let ecall = Emethod_call (o_ref, "step", exp_list param_env e_l) in
|
||||
let assgn = Aexp ecall in
|
||||
let copy_return_to_var i p =
|
||||
let p = pattern param_env p in
|
||||
Aassgn (p, Emethod_call (o_ref, "getOutput" ^ (string_of_int i), []))
|
||||
in
|
||||
let copies = Misc.mapi copy_return_to_var p_l in
|
||||
assgn::(copies@acts)
|
||||
| Obc.Acall (_, obj, Mreset, _) ->
|
||||
let acall = Emethod_call (obj_ref param_env obj, "reset", []) in
|
||||
Aexp acall::acts
|
||||
| Obc.Acase (e, c_b_l) when e.e_ty = Types.Tid Initial.pbool ->
|
||||
(match c_b_l with
|
||||
| [] -> acts
|
||||
| [(c,b)] when c = Initial.ptrue ->
|
||||
(Aif (exp param_env e, block param_env b)):: acts
|
||||
| [(c,b)] when c = Initial.pfalse ->
|
||||
(Aifelse (exp param_env e, {b_locals = []; b_body = []}, block param_env b)) :: acts
|
||||
| _ ->
|
||||
let _, _then = List.find (fun (c,_) -> c = Initial.ptrue) c_b_l in
|
||||
let _, _else = List.find (fun (c,_) -> c = Initial.pfalse) c_b_l in
|
||||
(Aifelse (exp param_env e, block param_env _then, block param_env _else)) :: acts)
|
||||
| Obc.Acase (e, c_b_l) ->
|
||||
let _c_b (c,b) =
|
||||
let type_name =
|
||||
match e.e_ty with
|
||||
Types.Tid n -> qualname_to_package_classe n
|
||||
| _ -> failwith("act_list: translating case") in
|
||||
let c = translate_constructor_name_2 c type_name in
|
||||
Sexp(Sconstructor c),
|
||||
block param_env b in
|
||||
let acase = Aswitch (exp param_env e, List.map _c_b c_b_l) in
|
||||
acase::acts
|
||||
| Obc.Afor (v, se, se', b) ->
|
||||
let afor = Afor (var_dec param_env v,
|
||||
exp param_env se, exp param_env se', block param_env b) in
|
||||
afor::acts
|
||||
| Obc.Ablock b ->
|
||||
let ablock = Ablock (block param_env b) in
|
||||
ablock::acts
|
||||
in
|
||||
List.fold_right _act act_l acts
|
||||
|
||||
and block param_env ?(locals=[]) ?(end_acts=[]) ob =
|
||||
let blocals = var_dec_list param_env ob.Obc.b_locals in
|
||||
let locals = locals @ blocals in
|
||||
let acts = act_list param_env ob.Obc.b_body end_acts in
|
||||
{ b_locals = locals; b_body = acts }
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(** Create the [param_env] and translate [Signature.param]s to [var_dec]s
|
||||
@return [vds, param_env] *)
|
||||
let sig_params_to_vds p_l =
|
||||
let param_to_arg param_env p =
|
||||
let p_ident = Idents.gen_var "obc2java" (String.uppercase p.Signature.p_name) in
|
||||
let p_vd = mk_var_dec p_ident false (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 Misc.mapfold param_to_arg NamesEnv.empty p_l
|
||||
|
||||
(** Translate [Signature.arg]s to [var_dec]s *)
|
||||
let sig_args_to_vds param_env a_l =
|
||||
let arg_to_vd { a_name = n; a_type = t } =
|
||||
let n = match n with None -> "v" | Some s -> s in
|
||||
let id = Idents.gen_var "obc2java" n in
|
||||
mk_var_dec id false (ty param_env t)
|
||||
in List.map arg_to_vd a_l
|
||||
|
||||
(** [copy_to_this vd_l] creates [this.x = x] for all [x] in [vd_l] *)
|
||||
let copy_to_this vd_l =
|
||||
let _vd vd = Aassgn (Pthis vd.vd_ident, Evar vd.vd_ident) in
|
||||
List.map _vd vd_l
|
||||
|
||||
|
||||
let class_def_list classes cd_l =
|
||||
let class_def classes cd =
|
||||
Idents.enter_node cd.cd_name;
|
||||
let class_name = qualname_to_package_classe cd.cd_name in
|
||||
(* [param_env] is an env mapping local param name to ident *)
|
||||
(* [params] : fields to stock the static parameters, arguments of the constructors *)
|
||||
let fields_params, vds_params, exps_params, param_env =
|
||||
let v, env = sig_params_to_vds cd.cd_params in
|
||||
let f = vds_to_fields ~protection:Pprotected v in
|
||||
let e = vds_to_exps v in
|
||||
f, v, e, env
|
||||
in
|
||||
(* [reset] is the reset method of the class,
|
||||
[reset_mems] is the block to reset the members of the class
|
||||
without call to the reset method of inner instances,
|
||||
it retains [this.x = 0] but not [this.I.reset()] *)
|
||||
let reset, reset_mems =
|
||||
try (* When there exist a reset method *)
|
||||
let oreset = find_reset_method cd in
|
||||
let body = block param_env oreset.Obc.m_body in
|
||||
let reset_mems = block param_env (remove_resets oreset.Obc.m_body) in
|
||||
mk_methode body "reset", reset_mems
|
||||
with Not_found -> (* stub reset method *)
|
||||
mk_methode (mk_block []) "reset", mk_block []
|
||||
in
|
||||
(* [obj_env] gives the type of an [obj_ident],
|
||||
needed in async because we change the classe for async obj *)
|
||||
let constructeur, obj_env =
|
||||
let obj_env = (* Mapping between Obc class and Java class, useful at least with asyncs *)
|
||||
let aux obj_env od =
|
||||
let t = Tclass (qualname_to_class_name od.o_class)
|
||||
in Idents.Env.add od.o_ident t obj_env
|
||||
in List.fold_left aux Idents.Env.empty cd.cd_objs
|
||||
in
|
||||
let body =
|
||||
(* Function to initialize the objects *)
|
||||
let obj_init_act acts od =
|
||||
let params = List.map (static_exp param_env) od.o_params in
|
||||
match od.o_size with
|
||||
| None ->
|
||||
let t = Idents.Env.find od.o_ident obj_env in
|
||||
(Aassgn (Pthis od.o_ident, Enew (t, params)))::acts
|
||||
| Some size_l ->
|
||||
let size_l = List.rev (List.map (static_exp param_env) size_l) in
|
||||
let t = Idents.Env.find od.o_ident obj_env in
|
||||
let assgn_elem i_l =
|
||||
[ Aassgn (Parray_elem (Pthis od.o_ident, List.map mk_var i_l), Enew (t, params)) ]
|
||||
in
|
||||
(Aassgn (Pthis od.o_ident, Enew_array (Tarray (t,size_l), [])))
|
||||
:: (fresh_nfor size_l assgn_elem)
|
||||
:: acts
|
||||
in
|
||||
(* function to allocate the arrays *)
|
||||
let allocate acts vd = match Modules.unalias_type vd.v_type with
|
||||
| Types.Tarray _ ->
|
||||
let t = ty param_env vd.v_type in
|
||||
( Aassgn (Pthis vd.v_ident, Enew_array (t,[])) ):: acts
|
||||
| _ -> acts
|
||||
in
|
||||
(* init actions [acts] in reverse order : *)
|
||||
(* init member variables *)
|
||||
let acts = [Ablock reset_mems] in
|
||||
(* allocate member arrays *)
|
||||
let acts = List.fold_left allocate acts cd.cd_mems in
|
||||
(* init member objects *)
|
||||
let acts = List.fold_left obj_init_act acts cd.cd_objs in
|
||||
(* init static params *)
|
||||
let acts = (copy_to_this vds_params)@acts in
|
||||
{ b_locals = []; b_body = acts }
|
||||
in mk_methode ~args:vds_params body (shortname class_name), obj_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 =
|
||||
let jty = match od.o_size with
|
||||
| None -> Idents.Env.find od.o_ident obj_env
|
||||
| Some size_l -> Tarray (Idents.Env.find od.o_ident obj_env,
|
||||
List.map (static_exp param_env) size_l)
|
||||
in
|
||||
(mk_field ~protection:Pprotected jty od.o_ident) :: fields
|
||||
in
|
||||
let fields = fields_params in
|
||||
let fields = List.fold_left mem_to_field fields cd.cd_mems in
|
||||
List.fold_left obj_to_field fields cd.cd_objs
|
||||
in
|
||||
let ostep = find_step_method cd in
|
||||
let vd_output = var_dec_list param_env ostep.m_outputs in
|
||||
let output_fields =
|
||||
List.map (fun vd -> mk_field vd.vd_type vd.vd_ident) vd_output in
|
||||
let fields = fields @ output_fields in
|
||||
let build_output_methods i f =
|
||||
mk_methode ~returns:f.f_type
|
||||
(mk_block [Areturn (Evar f.f_ident)])
|
||||
("getOutput" ^ (string_of_int i))
|
||||
in
|
||||
let output_methods = Misc.mapi build_output_methods output_fields in
|
||||
let step =
|
||||
let body = block param_env ostep.Obc.m_body in
|
||||
mk_methode ~args:(var_dec_list param_env ostep.Obc.m_inputs) ~returns:Tunit body "step"
|
||||
in
|
||||
let classe = mk_classe ~fields:fields
|
||||
~constrs:[constructeur]
|
||||
~methodes:([step;reset]@output_methods)
|
||||
class_name in
|
||||
classe::classes
|
||||
in
|
||||
List.fold_left class_def classes cd_l
|
||||
|
||||
|
||||
let type_dec_list classes td_l =
|
||||
let param_env = NamesEnv.empty in
|
||||
let _td classes td =
|
||||
let classe_name = qualname_to_package_classe td.t_name in
|
||||
Idents.enter_node classe_name;
|
||||
match td.t_desc with
|
||||
| Type_abs -> Misc.unsupported "obc2java, abstract type."
|
||||
| Type_alias t -> (*verify that it is possible to unalias and skip it*)
|
||||
let _ = Modules.unalias_type t in
|
||||
classes
|
||||
| Type_enum c_l ->
|
||||
let mk_constr_field (acc_fields,i) c =
|
||||
let init_value = Sint i in
|
||||
let c = translate_constructor_name_2 c classe_name in
|
||||
let field =
|
||||
mk_field ~static:true ~final:true ~value:(Some init_value)
|
||||
Tint (Idents.ident_of_name c.name) in
|
||||
(field::acc_fields),(i+1) in
|
||||
let fields,_ = List.fold_left mk_constr_field ([],1) c_l in
|
||||
(mk_classe ~fields:(List.rev fields) classe_name) :: classes
|
||||
| Type_struct f_l ->
|
||||
let mk_field_jfield { Signature.f_name = oname; Signature.f_type = oty } =
|
||||
let jty = ty param_env oty in
|
||||
let field = Idents.ident_of_name (translate_field_name oname) in
|
||||
(* [translate_field_name] will give the right result anywhere it is used,
|
||||
since the [ident_of_name] will keep it as it is unique in the class,
|
||||
see [Idents.enter_node classe_name] *)
|
||||
mk_field jty field
|
||||
in
|
||||
let f_l =
|
||||
List.sort
|
||||
(fun f1 f2 ->
|
||||
compare (f1.Signature.f_name.name) (f2.Signature.f_name.name))
|
||||
f_l in
|
||||
let fields = List.map mk_field_jfield f_l in
|
||||
let cons_params = List.map (fun f -> mk_var_dec f.f_ident false f.f_type) fields in
|
||||
let cons_body =
|
||||
List.map
|
||||
(fun f -> Aassgn ((Pthis f.f_ident),(Evar f.f_ident)))
|
||||
fields in
|
||||
let cons =
|
||||
mk_methode
|
||||
~args:cons_params
|
||||
(mk_block cons_body)
|
||||
classe_name.name in
|
||||
(mk_classe ~fields:fields ~constrs:[cons] classe_name) :: classes
|
||||
in
|
||||
List.fold_left _td classes td_l
|
||||
|
||||
|
||||
let const_dec_list cd_l = match cd_l with
|
||||
| [] -> []
|
||||
| _ ->
|
||||
let classe_name = "CONSTANTES" |> name_to_classe_name in
|
||||
Idents.enter_node classe_name;
|
||||
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 |> Idents.ident_of_name in
|
||||
(* name should always keep the shortname unchanged
|
||||
since we enter a special node free of existing variables *)
|
||||
(* thus [translate_const_name] will gives the right result anywhere it is used. *)
|
||||
let value = Some (static_exp param_env ovalue) in
|
||||
let t = ty param_env otype in
|
||||
mk_field ~static: true ~final: true ~value: value t name
|
||||
in
|
||||
let fields = List.map mk_const_field cd_l in
|
||||
[mk_classe ~fields: fields classe_name]
|
||||
|
||||
|
||||
|
||||
let program p =
|
||||
let rec program_descs pds (ns,cs,ts) = match pds with
|
||||
| [] -> ns,cs,ts
|
||||
| Obc.Pclass n :: pds -> program_descs pds (n::ns,cs,ts)
|
||||
| Obc.Pconst c :: pds -> program_descs pds (ns,c::cs,ts)
|
||||
| Obc.Ptype t :: pds -> program_descs pds (ns,cs,t::ts)
|
||||
in
|
||||
let ns,cs,ts = program_descs p.p_desc ([],[],[]) in
|
||||
let classes = const_dec_list cs in
|
||||
let classes = type_dec_list classes ts in
|
||||
let p = class_def_list classes ns in
|
||||
get_classes()@p
|
||||
|
||||
|
||||
|
||||
82
test/scripts/compile_javac_14_run
Executable file
82
test/scripts/compile_javac_14_run
Executable file
|
|
@ -0,0 +1,82 @@
|
|||
#!/bin/bash
|
||||
|
||||
source scripts/config
|
||||
|
||||
progpath=$1
|
||||
shift
|
||||
coption="-target java14 $*"
|
||||
|
||||
# run the program: no by default
|
||||
run=0
|
||||
|
||||
cp $progpath $checkdir
|
||||
|
||||
|
||||
pushd $checkdir > /dev/null
|
||||
|
||||
heptprog=`basename $progpath`
|
||||
heptroot=`basename $heptprog .ept`
|
||||
|
||||
assert_node=$(eval grep CHECK $heptprog | awk '{ print $3 }')
|
||||
|
||||
if [ -n "$assert_node" ]; then
|
||||
coption="$coption -assert $assert_node"
|
||||
run=1
|
||||
fi
|
||||
|
||||
if grep "node main()" $heptprog >/dev/null; then
|
||||
coption="$coption -hepts -s main"
|
||||
run=1
|
||||
fi
|
||||
|
||||
# Special case: t2 and t2open needs t1
|
||||
|
||||
# if [[ ($heptroot == "t2") || ($heptroot == "t2open") ]]; then
|
||||
# # Nothing to do
|
||||
# fi
|
||||
|
||||
# Special case: statics2 needs statics1
|
||||
|
||||
if [[ ($heptroot == "statics1") ]]; then
|
||||
coption="$coption -c"
|
||||
fi
|
||||
|
||||
# if [[ ($heptroot == "statics2") ]]; then
|
||||
|
||||
# fi
|
||||
|
||||
# Capitalized root
|
||||
CapHeptroot=`echo ${heptroot} | sed 's/^\(.\).*$/\1/' | tr "[:lower:]" "[:upper:]"`\
|
||||
`echo ${heptroot} | sed 's/^.//'`
|
||||
|
||||
echo $HEPTC $coption $heptprog
|
||||
if $HEPTC $coption $heptprog; then
|
||||
pushd java > /dev/null
|
||||
echo $JAVAC -source 1.4 ${CapHeptroot}/*.java
|
||||
if $JAVAC -source 1.4 ${CapHeptroot}/*.java; then
|
||||
if [[ $run == 1 ]]; then
|
||||
echo $JAVA ${CapHeptroot}.Main_sim $NBSTEP
|
||||
if $JAVA ${CapHeptroot}.Main_sim $NBSTEP; then
|
||||
echo "Test successful."
|
||||
res=0
|
||||
else
|
||||
echo "Run failed."
|
||||
res=1
|
||||
fi
|
||||
else
|
||||
echo "Test successful (Java compilation only; no run)."
|
||||
res=0
|
||||
fi
|
||||
else
|
||||
echo "Compilation of Java target code failed"
|
||||
res=1
|
||||
fi
|
||||
popd >/dev/null
|
||||
else
|
||||
echo "Compilation of $heptprog failed"
|
||||
res=1
|
||||
fi
|
||||
|
||||
popd > /dev/null
|
||||
|
||||
exit $res
|
||||
Loading…
Reference in a new issue