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

tentative 1 de faire marcher java.

Browse source
This commit is contained in:
Léonard Gérard 2011-01-11 14:26:50 +01:00
parent e9e8ca382a
commit 6c763f1eb8
2 changed files with 79 additions and 121 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -13,6 +13,7 @@ open Modules
open Format open Format
open Obc open Obc
open Misc open Misc
open Types
open Names open Names
open Idents open Idents
open Pp_tools open Pp_tools
@ -38,48 +39,20 @@ let print_name ff name =
let print_shortname ff longname = let print_shortname ff longname =
print_name ff (shortname longname) print_name ff (shortname longname)
let o_types : type_dec list ref = ref [] let rec java_type_default_value = function
| Tid id when id = Initial.pint -> "int", "0"
let java_type_default_value = function | Tid id when id = Initial.pfloat -> "float", "0.0"
| Tint -> "int", "0" | Tid id when id = Initial.pbool -> "boolean", "false"
| Tfloat -> "float", "0.0"
| Tid (Name("bool"))
| Tid (Modname({ id = "bool" })) ->
"boolean", "false"
| Tid t when ((shortname t) = "int") -> "int", "0"
| Tid t when ((shortname t) = "float") -> "float", "0.0"
| Tid t -> | Tid t ->
begin try (match find_type t with
let { info = ty_desc } = find_type (t) in | Tabstract -> assert false
begin match ty_desc with | Talias t -> java_type_default_value t
| Tenum _ -> | Tenum _ -> "int", "0" (* TODO java *)
"int", "0" | Tstruct _ -> shortname t, "null" )
| _ -> | Tasync (a,t) -> assert false (* TODO async *)
let t = shortname t in | Tarray _ -> assert false (* TODO array *)
if t = "bool" | Tprod _ -> assert false (* TODO java *)
then ("boolean", "false") | Tunit -> "void", "null"
else (t, "null")
end
with Not_found ->
begin try
let { t_desc = tdesc } =
List.find (fun {t_name = tn} -> tn = (shortname t)) !o_types in
begin match tdesc with
| Type_enum _ ->
"int", "0"
| _ ->
let t = shortname t in
if t = "bool"
then ("boolean", "false")
else (t, "null")
end
with Not_found ->
let t = shortname t in
if t = "bool"
then ("boolean", "false")
else (t, "null")
end
end
let print_type ff ty = let print_type ff ty =
let jty,_ = java_type_default_value ty in let jty,_ = java_type_default_value ty in
@ -125,7 +98,7 @@ let rec print_tags ff n = function
| [] -> () | [] -> ()
| tg :: tgs' -> | tg :: tgs' ->
fprintf ff "@ public static final int %a = %d;" fprintf ff "@ public static final int %a = %d;"
print_name tg print_name ( shortname tg ) (* TODO java deal with modules *)
n; n;
print_tags ff (n+1) tgs' print_tags ff (n+1) tgs'
@ -135,28 +108,30 @@ let print_enum_type ff tn tgs =
print_tags ff 1 tgs; print_tags ff 1 tgs;
fprintf ff "@]@ }@]" fprintf ff "@]@ }@]"
let print_type_to_file java_dir headers { t_name = tn; t_desc = td} = let rec print_type_to_file java_dir headers { t_name = tn; t_desc = td} =
let tn = jname_of_name tn in let tn = jname_of_name (shortname tn) in (* TODO java deal with modules *)
match td with match td with
| Type_abs -> () | Type_abs -> ()
| Type_enum tgs -> | Type_enum tgs ->
let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in
let ff = formatter_of_out_channel out_ch in let ff = formatter_of_out_channel out_ch in
Misc.print_header_info ff "/*" "*/"; (*Misc.print_header_info ff "/*" "*/"; *)
List.iter (fprintf ff "%s") headers; List.iter (fprintf ff "%s") headers;
(* fprintf ff "@[<v>package %s;@\n@\n" headers; *) (* fprintf ff "@[<v>package %s;@\n@\n" headers; *) (* TODO java deal with modules *)
print_enum_type ff tn tgs; print_enum_type ff tn tgs;
fprintf ff "@."; fprintf ff "@.";
close_out out_ch close_out out_ch
| Type_struct fields -> | Type_struct fields ->
let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in
let ff = formatter_of_out_channel out_ch in let ff = formatter_of_out_channel out_ch in
Misc.print_header_info ff "/*" "*/"; (* Misc.print_header_info ff "/*" "*/"; *)(* TODO java deal with modules *)
List.iter (fprintf ff "%s") headers; List.iter (fprintf ff "%s") headers;
(* fprintf ff "@[<v>package %s;@\n@\n" headers; *) (* fprintf ff "@[<v>package %s;@\n@\n" headers; *)
print_struct_type ff tn fields; 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 "@."; fprintf ff "@.";
close_out out_ch close_out out_ch
| Type_alias t -> assert false (* TODO java *)
let print_types java_dir headers tps = let print_types java_dir headers tps =
List.iter (print_type_to_file java_dir headers) tps List.iter (print_type_to_file java_dir headers) tps
@ -168,26 +143,17 @@ type answer =
| Mult of var_ident list | Mult of var_ident list
let print_const ff c ts = let print_const ff c ts =
match c with match c.se_desc with
| Cint i -> fprintf ff "%d" i | Sint i -> fprintf ff "%d" i
| Cfloat f -> fprintf ff "%f" f | Sfloat f -> fprintf ff "%f" f
| Cconstr t -> | Sbool true -> fprintf ff "true"
let s = | Sbool false -> fprintf ff "false"
match t with | Sconstructor c ->
| Name("true") let tg = shortname c in (* TODO java gérer les modules *)
| Modname({id = "true"}) -> "true" let s = (fst (List.find (fun (tn, tgs) -> List.exists (fun tg' -> tg = tg') tgs) ts))
| Name("false") ^ "." ^ (jname_of_name tg) in
| Modname({id = "false"}) -> "false"
| Name(tg)
| Modname({id = tg}) ->
(fst
(List.find
(fun (tn, tgs) ->
List.exists (fun tg' -> tg = tg') tgs)
ts))
^ "." ^ (jname_of_name tg)
in
fprintf ff "%s" s fprintf ff "%s" s
| _ -> assert false (* TODO java *)
let position a xs = let position a xs =
let rec walk i = function let rec walk i = function
@ -225,20 +191,21 @@ let priority = function
| _ -> 0 | _ -> 0
let rec print_lhs ff e avs single = let rec print_lhs ff e avs single =
match e with match e.pat_desc with
| Var x -> | Lvar x ->
print_var ff x avs single print_var ff x avs single
| Mem x -> print_ident ff x | Lmem x -> print_ident ff x
| Field(e, field) -> | Lfield(e, field) ->
print_lhs ff e avs single; print_lhs ff e avs single;
fprintf ff ".%s" (jname_of_name (shortname field)) fprintf ff ".%s" (jname_of_name (shortname field))
| Larray _ -> assert false (* TODO java array *)
let rec print_exp ff e p avs ts single = let rec print_exp ff e p avs ts single =
match e with match e.e_desc with
| Lhs l -> print_lhs ff l avs single | Elhs l -> print_lhs ff l avs single
| Const c -> print_const ff c ts | Econst c -> print_const ff c ts
| Op (op, es) -> print_op ff op es p avs ts single | Eop (op, es) -> print_op ff op es p avs ts single
| Struct_lit(type_name,fields) -> | Estruct (type_name,fields) ->
let fields = let fields =
List.sort List.sort
(fun (ln1,_) (ln2,_) -> (fun (ln1,_) (ln2,_) ->
@ -249,6 +216,8 @@ let rec print_exp ff e p avs ts single =
print_shortname type_name; print_shortname type_name;
print_exps ff exps 0 avs ts single; print_exps ff exps 0 avs ts single;
fprintf ff "@])" fprintf ff "@])"
| Earray _ -> assert false (* TODO array *)
| Ebang _ -> assert false (* TODO async *)
and print_exps ff es p avs ts single = and print_exps ff es p avs ts single =
match es with match es with
@ -277,7 +246,7 @@ and print_op ff op es p avs ts single =
| "~-", [e] -> | "~-", [e] ->
fprintf ff "-"; fprintf ff "-";
print_exp ff e 6 avs ts single; print_exp ff e 6 avs ts single;
| _ -> | _ ->(*
begin begin
begin begin
match op with match op with
@ -291,7 +260,8 @@ and print_op ff op es p avs ts single =
fprintf ff "@[("; fprintf ff "@[(";
print_exps ff es 0 avs ts single; print_exps ff es 0 avs ts single;
fprintf ff ")@]" fprintf ff ")@]"
end end *)
assert false (* TODO java *)
let rec print_proj ff xs ao avs single = let rec print_proj ff xs ao avs single =
let rec walk ind = function let rec walk ind = function
@ -309,18 +279,18 @@ let bool_case = function
| ("false", _) :: _ -> true | ("false", _) :: _ -> true
| _ -> false | _ -> false
let obj_call_to_string = function let obj_ref_to_string = function
| Context o | Oobj o -> o
| Array_context (o,_) -> o | Oarray (o,p) -> o (* TODO java array *)
let rec print_act ff a objs avs ts single = let rec print_act ff a objs avs ts single =
match a with match a with
| Assgn (x, e) -> | Aassgn (x, e) ->
fprintf ff "@["; fprintf ff "@[";
print_asgn ff x e avs ts single; print_asgn ff x e avs ts single;
fprintf ff ";@]" fprintf ff ";@]"
| Step_ap (xs, o, es) -> | Acall (xs,oref,Mstep,es) ->
let o = obj_call_to_string o in let o = obj_ref_to_string oref in
(match xs with (match xs with
| [x] -> | [x] ->
print_lhs ff x avs single; print_lhs ff x avs single;
@ -330,7 +300,7 @@ let rec print_act ff a objs avs ts single =
fprintf ff "@]"; fprintf ff "@]";
fprintf ff ");@ " fprintf ff ");@ "
| xs -> | xs ->
let cn = (List.find (fun od -> od.obj = o) objs).cls in let cn = (List.find (fun od -> od.o_name = o) objs).o_class in
let at = (jname_of_name (shortname cn)) ^ "Answer" in let at = (jname_of_name (shortname cn)) ^ "Answer" in
let ao = o ^ "_ans" in let ao = o ^ "_ans" in
fprintf ff "%s %s = new %s();@ " at ao at; fprintf ff "%s %s = new %s();@ " at ao at;
@ -340,13 +310,7 @@ let rec print_act ff a objs avs ts single =
fprintf ff "@]"; fprintf ff "@]";
fprintf ff ");@ "; fprintf ff ");@ ";
print_proj ff xs ao avs single) print_proj ff xs ao avs single)
| Comp (a1, a2) -> | Acase (e, grds) ->
print_act ff a1 objs avs ts single;
(match a2 with
| Nothing -> ()
| _ -> fprintf ff "@ ");
print_act ff a2 objs avs ts single
| Case (e, grds) ->
let grds = let grds =
List.map List.map
(fun (ln,act) -> (shortname ln),act) grds in (fun (ln,act) -> (shortname ln),act) grds in
@ -356,13 +320,17 @@ let rec print_act ff a objs avs ts single =
(fun ff e -> print_exp ff e 0 avs ts single) e; (fun ff e -> print_exp ff e 0 avs ts single) e;
print_grds ff grds objs avs ts single; print_grds ff grds objs avs ts single;
fprintf ff "@]@ }@]"); fprintf ff "@]@ }@]");
| Reinit o -> fprintf ff "%s.reset();" o | Acall (_,oref,Mreset,_) ->
| Nothing -> () 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 = and print_grds ff grds objs avs ts single =
match grds with match grds with
| [] -> () | [] -> ()
| [(tg, act)] -> | (tg, b) :: grds' ->
(* retrieve class name *) (* retrieve class name *)
let cn = (fst let cn = (fst
(List.find (List.find
@ -372,19 +340,7 @@ and print_grds ff grds objs avs ts single =
fprintf ff "@[<v 2>case %a.%a:@ " fprintf ff "@[<v 2>case %a.%a:@ "
print_name cn print_name cn
print_name tg; print_name tg;
print_act ff act objs avs ts single; print_block ff b objs avs ts single;
fprintf ff "@ break;@]";
| (tg, act) :: 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_act ff act objs avs ts single;
fprintf ff "@ break;@ @]@ "; fprintf ff "@ break;@ @]@ ";
print_grds ff grds' objs avs ts single print_grds ff grds' objs avs ts single
@ -393,26 +349,26 @@ and print_if ff e grds objs avs ts single =
| [("true", a)] -> | [("true", a)] ->
fprintf ff "@[<v>@[<v 2>if (%a) {@ " fprintf ff "@[<v>@[<v 2>if (%a) {@ "
(fun ff e -> print_exp ff e 0 avs ts single) e; (fun ff e -> print_exp ff e 0 avs ts single) e;
print_act ff a objs avs ts single; print_block ff a objs avs ts single;
fprintf ff "@]@ }@]" fprintf ff "@]@ }@]"
| [("false", a)] -> | [("false", a)] ->
fprintf ff "@[<v>@[<v 2>if (!%a) {@ " fprintf ff "@[<v>@[<v 2>if (!%a) {@ "
(fun ff e -> print_exp ff e 6 avs ts single) e; (fun ff e -> print_exp ff e 6 avs ts single) e;
print_act ff a objs avs ts single; print_block ff a objs avs ts single;
fprintf ff "@]@ }@]" fprintf ff "@]@ }@]"
| [("true", a1); ("false", a2)] -> | [("true", a1); ("false", a2)] ->
fprintf ff "@[<v>@[<v 2>if (%a) {@ " fprintf ff "@[<v>@[<v 2>if (%a) {@ "
(fun ff e -> print_exp ff e 0 avs ts single) e; (fun ff e -> print_exp ff e 0 avs ts single) e;
print_act ff a1 objs avs ts single; print_block ff a1 objs avs ts single;
fprintf ff "@]@ @[<v 2>} else {@ "; fprintf ff "@]@ @[<v 2>} else {@ ";
print_act ff a2 objs avs ts single; print_block ff a2 objs avs ts single;
fprintf ff "@]@ }@]" fprintf ff "@]@ }@]"
| [("false", a2); ("true", a1)] -> | [("false", a2); ("true", a1)] ->
fprintf ff "@[<v>@[<v 2>if (%a) {@ " fprintf ff "@[<v>@[<v 2>if (%a) {@ "
(fun ff e -> print_exp ff e 0 avs ts single) e; (fun ff e -> print_exp ff e 0 avs ts single) e;
print_act ff a1 objs avs ts single; print_block ff a1 objs avs ts single;
fprintf ff "@]@ @[<v 2>} else {@ "; fprintf ff "@]@ @[<v 2>} else {@ ";
print_act ff a2 objs avs ts single; print_block ff a2 objs avs ts single;
fprintf ff "@]@ }@]" fprintf ff "@]@ }@]"
| _ -> assert false | _ -> assert false
@ -423,6 +379,8 @@ and print_asgn ff x e avs ts single =
print_exp ff e 0 avs ts single; print_exp ff e 0 avs ts single;
fprintf ff "@]" fprintf ff "@]"
and print_block ff b objs avs ts single = () (* TODO urgent java *)
let print_vd ff vd = let print_vd ff vd =
let jty,jdv = java_type_default_value vd.v_type in let jty,jdv = java_type_default_value vd.v_type in
fprintf ff "@[<v>"; fprintf ff "@[<v>";
@ -435,9 +393,9 @@ let print_vd ff vd =
let print_obj ff od = let print_obj ff od =
fprintf ff "@[<v>"; fprintf ff "@[<v>";
fprintf ff "%a %a = new %a();" fprintf ff "%a %a = new %a();"
print_shortname od.cls print_shortname od.o_class
print_name od.obj print_name od.o_name
print_shortname od.cls; print_shortname od.o_class;
fprintf ff "@]" fprintf ff "@]"
let rec print_objs ff ods = let rec print_objs ff ods =
@ -488,14 +446,14 @@ let rec print_mem ff = function
let print_loc ff vds = print_mem ff vds let print_loc ff vds = print_mem ff vds
let print_step ff n s objs ts single = let print_step ff n s objs ts single =
let name = jname_of_name n in let n = jname_of_name n in
fprintf ff "@[<v>@ @[<v 2>public "; fprintf ff "@[<v>@ @[<v 2>public ";
if single then print_type ff (List.hd s.out).v_type if single then print_type ff (List.hd s.m_outputs).v_type
else fprintf ff "%s" (n ^ "Answer"); else fprintf ff "%s" (n ^ "Answer");
fprintf ff " step(@["; fprintf ff " step(@[";
print_in ff s.inp; print_in ff s.m_inputs;
fprintf ff "@]) {@ "; fprintf ff "@]) {@ ";
let loc = if single then (List.hd s.out) :: s.local else s.local in 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 loc = [] then () else (print_loc ff loc; fprintf ff "@ ");
if single then fprintf ff "@ " if single then fprintf ff "@ "
else fprintf ff "%sAnswer step_ans = new %sAnswer();@ @ " n n; else fprintf ff "%sAnswer step_ans = new %sAnswer();@ @ " n n;

0
compiler/obc/java/javamain.ml → compiler/obc/java/java_main.ml
View file