You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
280 lines
10 KiB
OCaml
280 lines
10 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* Heptagon *)
|
|
(* *)
|
|
(* Gwenael Delaval, LIG/INRIA, UJF *)
|
|
(* Leonard Gerard, Parkas, ENS *)
|
|
(* Adrien Guatto, Parkas, ENS *)
|
|
(* Cedric Pasteur, 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/> *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* Java printer *)
|
|
|
|
open Java
|
|
open Pp_tools
|
|
open Format
|
|
open Misc
|
|
|
|
let class_name = Global_printer.print_qualname
|
|
let bare_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 var_ident = Global_printer.print_ident
|
|
let const_name = Global_printer.print_qualname
|
|
|
|
let protection ff = function
|
|
| Ppublic -> fprintf ff "public "
|
|
| Pprotected -> fprintf ff "protected "
|
|
| Pprivate -> fprintf ff "private "
|
|
| Ppackage -> ()
|
|
|
|
let static ff s = if s then fprintf ff "static " else ()
|
|
|
|
let final ff f = if f then fprintf ff "final " else ()
|
|
|
|
let rec _ty is_new is_init ff t = match t with
|
|
| Tbool -> fprintf ff "boolean"
|
|
| Tint -> fprintf ff "int"
|
|
| Tlong -> fprintf ff "long"
|
|
| Tfloat -> fprintf ff "float"
|
|
| Tclass n -> class_name ff n
|
|
| Tgeneric (n, ty_l) ->
|
|
if is_new
|
|
then fprintf ff "%a" class_name n
|
|
else fprintf ff "%a<@[%a@]>" class_name n (print_list_r ty """,""") ty_l
|
|
| Tarray (t,s_l) ->
|
|
let me = _ty is_new is_init in
|
|
(* print size expressions only for new without init *)
|
|
let print_size = if is_new && not is_init then exp else (fun ff e -> ()) in
|
|
fprintf ff "%a@[%a@]" me t (print_list print_size "[""][""]") s_l
|
|
| Tunit -> pp_print_string ff "void"
|
|
|
|
(* print types for [new] expressions (without generics) *)
|
|
and new_ty ff t = _ty true false ff t
|
|
|
|
(* print types for [new] expressions without generics nor array size *)
|
|
and new_init_ty ff t = _ty true true ff t
|
|
|
|
(* print types *)
|
|
and ty ff t = _ty false false ff t
|
|
|
|
and var_dec init ff vd =
|
|
if init & not vd.vd_alias then
|
|
fprintf ff "%a %a = %a" ty vd.vd_type var_ident vd.vd_ident exp (Java.default_value vd.vd_type)
|
|
else
|
|
fprintf ff "%a %a" ty vd.vd_type var_ident vd.vd_ident
|
|
|
|
and vd_list s1 s2 s3 ff vd_l = match vd_l with
|
|
| [] -> ()
|
|
| _ -> fprintf ff "@[<v>%a@]@\n" (print_list_r (var_dec true) s1 s2 s3) vd_l
|
|
|
|
and 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_ident
|
|
(print_opt2 exp " = ") f.f_value
|
|
|
|
and exp ff = function
|
|
| Ethis -> fprintf ff "this"
|
|
| Efun (f,e_l) -> op ff (f, e_l)
|
|
| Emethod_call (o,m,e_l) -> fprintf ff "%a.%a%a" exp o method_name m args e_l
|
|
| Enew (c,e_l) -> fprintf ff "new %a%a" new_ty c args e_l
|
|
| Enew_array (t,e_l) ->
|
|
(match e_l with
|
|
| [] -> fprintf ff "new %a" new_ty t
|
|
| _ -> fprintf ff "new %a@[<2>%a@]" new_init_ty t (print_list_r exp "{"",""}") e_l )
|
|
| Evoid -> ()
|
|
| Ecast (t,e) -> fprintf ff "(%a)(%a)" ty t exp e
|
|
| Svar c -> const_name ff c
|
|
| Sint i -> pp_print_int ff i
|
|
| Sfloat f -> fprintf ff "%Ff" f
|
|
| Sbool b -> pp_print_bool ff b
|
|
| Sconstructor c -> constructor_name ff c
|
|
| Sstring s -> fprintf ff "\"%s\"" (String.escaped s)
|
|
| Snull -> fprintf ff "null"
|
|
| Efield (p,f) -> fprintf ff "%a.%a" exp p field_name f
|
|
| Evar v -> var_ident ff v
|
|
| Eclass c -> class_name ff c
|
|
| Earray_elem (p,e_l) -> fprintf ff "%a@[%a@]" exp p (print_list exp "[""][""]") e_l
|
|
|
|
and op ff (f, e_l) =
|
|
let javaop = function
|
|
| "=" -> "=="
|
|
| "<>" -> "!="
|
|
| "or" -> "||"
|
|
| "&" -> "&&"
|
|
| "*." -> "*"
|
|
| "/." -> "/"
|
|
| "+." -> "+"
|
|
| "-." -> "-"
|
|
| "~~" -> "~"
|
|
| "<<<" -> "<<"
|
|
| ">>>" -> ">>"
|
|
| "&&&" -> "&"
|
|
| "|||" -> "|"
|
|
| op -> op
|
|
in
|
|
match Names.modul f with
|
|
| Names.Pervasives ->
|
|
(match Names.shortname f with
|
|
|("+" | "-" | "*" | "/" | "%"
|
|
|"+." | "-." | "*." | "/."
|
|
| "=" | "<>" | "<" | "<="
|
|
| ">" | ">=" | "&" | "or") as n ->
|
|
let e1,e2 = Misc.assert_2 e_l in
|
|
fprintf ff "(@[%a@ %s %a@])" exp e1 (javaop n) exp e2
|
|
| "not" ->
|
|
let e = Misc.assert_1 e_l in
|
|
fprintf ff "!%a" exp e
|
|
| "~-" ->
|
|
let e = Misc.assert_1 e_l in
|
|
fprintf ff "-%a" exp e
|
|
| "assert" ->
|
|
let e = Misc.assert_1 e_l in
|
|
fprintf ff "assert(%a)" exp e
|
|
| s -> fprintf ff "jeptagon.Pervasives.%s%a" s args e_l)
|
|
(* TODO java deal with this correctly
|
|
bug when using Pervasives.ggg in the code but works when using ggg directly *)
|
|
| _ -> fprintf ff "%a%a" Global_printer.print_qualname f args e_l
|
|
|
|
and args ff e_l = fprintf ff "@[(%a)@]" (print_list_r exp """,""") e_l
|
|
|
|
and pattern ff = function
|
|
| Pfield (p, f) -> fprintf ff "%a.%a" pattern p field_name f
|
|
| Pvar v -> var_ident ff v
|
|
| Pclass c -> class_name ff c
|
|
| Parray_elem (p,e_l) -> fprintf ff "%a%a" pattern p (print_list exp "[""][""]") e_l
|
|
| Pthis f -> fprintf ff "this.%a" field_ident f
|
|
|
|
let rec block ff b =
|
|
fprintf ff "%a%a"
|
|
(vd_list """;"";") b.b_locals
|
|
(print_list_r act """""") b.b_body
|
|
|
|
(*
|
|
and switch_hack ff c_b_l =
|
|
fprintf ff "@[<hv 2> default :
|
|
\\Dead code. Hack to prevent \"may not be initialized\" java error.@ %a@ break;@]"
|
|
block (c_b_l |> List.hd |> snd)
|
|
*)
|
|
|
|
and act ff = function
|
|
| Anewvar (vd,e) -> fprintf ff "@[<4>%a =@ %a;@]" (var_dec false) vd exp e
|
|
| Aassgn (p,e) -> fprintf ff "@[<4>%a =@ %a;@]" pattern p exp e
|
|
| 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 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\"
|
|
java error.@ %a@ break;@]" block (c_b_l |> List.hd |> snd)
|
|
in*)
|
|
fprintf ff "@[<v4>switch (%a) {@ %a@]@\n}"
|
|
exp e
|
|
(print_list_r pcb """""") c_b_l
|
|
| Aif (e,bt) ->
|
|
fprintf ff "@[<v 4>if (%a) {@ %a }@]" exp e block bt
|
|
| Aifelse (e,bt,bf) ->
|
|
fprintf ff "@[<v>@[<v4>if (%a) {@ %a@]@ @[<v4>} else {@ %a@]@ }@]"
|
|
exp e
|
|
block bt
|
|
block bf
|
|
| Ablock b -> if (List.length b.b_body > 0) then fprintf ff "@[<v>@[<v4>{@ %a@]@ }@]" block b
|
|
| Afor (x, i1, i2, b) ->
|
|
fprintf ff "@[<hv>@[<hv 4>for (%a = %a; %a<%a; %a++) {@ %a@]@ }@]"
|
|
(var_dec false) x
|
|
exp i1
|
|
var_ident x.vd_ident
|
|
exp i2
|
|
var_ident x.vd_ident
|
|
block b
|
|
| Areturn e -> fprintf ff "return %a;" exp e
|
|
|
|
let methode ff m =
|
|
fprintf ff "@[<v4>%a%a%a %a @[<4>(%a)@] @[%a@]{@ %a@]@\n}"
|
|
protection m.m_protection
|
|
static m.m_static
|
|
ty m.m_returns
|
|
method_name m.m_name
|
|
(print_list_r (var_dec false) """,""") m.m_args
|
|
(print_list_r class_name "throws "","" ") m.m_throws
|
|
block m.m_body
|
|
|
|
let constructor ff m =
|
|
fprintf ff "@[<v4>%a%a @[<4>(%a)@] {@\n%a@]@\n}"
|
|
protection m.m_protection
|
|
method_name m.m_name
|
|
(print_list_r (var_dec false) """,""") m.m_args
|
|
block m.m_body
|
|
|
|
let rec class_desc ff cd =
|
|
fprintf ff "@[<v>%a@ %a@ %a@ %a@]"
|
|
(print_list_r field """;"";") cd.cd_fields
|
|
(print_list_r classe """""") cd.cd_classs
|
|
(print_list constructor """""") cd.cd_constructors
|
|
(print_list methode """""") cd.cd_methodes
|
|
|
|
and classe ff c = match c.c_kind with
|
|
| Cenum c_l ->
|
|
fprintf ff "@\n@[<4>%a%aenum %a {@\n%a@]@\n}"
|
|
protection c.c_protection
|
|
static c.c_static
|
|
bare_class_name c.c_name
|
|
(print_list_r bare_constructor_name """,""") c_l
|
|
| Cgeneric cd ->
|
|
fprintf ff "@\n@[<4>%a%aclass %a @[<h>%a@]{@\n%a@]@\n}"
|
|
protection c.c_protection
|
|
static c.c_static
|
|
bare_class_name c.c_name
|
|
(print_list_r class_name "implements "",""") c.c_implements
|
|
class_desc cd
|
|
|
|
let output_classe base_dir c =
|
|
let { Names.name = file_name; Names.qual = package } = c.c_name in
|
|
let file_name = file_name ^ ".java" in
|
|
let package_dirs = Misc.split_string (Names.modul_to_string package) "." in
|
|
let create_dir base_dir dir =
|
|
let dir = Filename.concat base_dir dir in
|
|
Compiler_utils.ensure_dir dir;
|
|
dir
|
|
in
|
|
let dir = List.fold_left create_dir base_dir package_dirs in
|
|
let oc = open_out (Filename.concat dir file_name) in
|
|
let ff = Format.formatter_of_out_channel oc in
|
|
pp_set_margin ff 120;
|
|
fprintf ff "package %a;@\n@[<v>%a@]@\n%a@."
|
|
Global_printer.print_full_modul package
|
|
(print_list_r (fun ff n -> fprintf ff "import %a" class_name n) """;"";") c.c_imports
|
|
classe c;
|
|
close_out oc
|
|
|
|
let output_program dir (p:Java.program) =
|
|
List.iter (output_classe dir) p
|
|
|