2012-06-27 18:09:30 +02:00
|
|
|
(***********************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* Heptagon *)
|
|
|
|
(* *)
|
|
|
|
(* Gwenael Delaval, LIG/INRIA, UJF *)
|
|
|
|
(* Leonard Gerard, Parkas, ENS *)
|
|
|
|
(* Adrien Guatto, Parkas, ENS *)
|
|
|
|
(* Cedric Pasteur, Parkas, ENS *)
|
2012-06-29 01:43:15 +02:00
|
|
|
(* Marc Pouzet, Parkas, ENS *)
|
2012-06-27 18:09:30 +02:00
|
|
|
(* *)
|
|
|
|
(* 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/> *)
|
|
|
|
(* *)
|
|
|
|
(***********************************************************************)
|
2011-01-05 15:47:53 +01:00
|
|
|
|
2011-01-20 23:05:18 +01:00
|
|
|
type class_name = Names.qualname (** [qual] is the package name, [Name] is the class name *)
|
|
|
|
type obj_ident = Idents.var_ident
|
2011-11-20 23:09:12 +01:00
|
|
|
(** [Qual] is the enum class name (type), [NAME] is the constructor name *)
|
|
|
|
type constructor_name = Names.qualname
|
2011-01-20 23:05:18 +01:00
|
|
|
type const_name = Names.qualname
|
|
|
|
type method_name = Names.name
|
|
|
|
type field_name = Names.name
|
|
|
|
type field_ident = Idents.var_ident
|
|
|
|
type op_name = Names.qualname
|
|
|
|
type var_ident = Idents.var_ident
|
|
|
|
|
|
|
|
type ty = Tclass of class_name
|
|
|
|
| Tgeneric of class_name * ty list
|
|
|
|
| Tbool
|
|
|
|
| Tint
|
2011-07-08 15:25:00 +02:00
|
|
|
| Tlong
|
2011-01-20 23:05:18 +01:00
|
|
|
| Tfloat
|
2011-06-27 16:08:56 +02:00
|
|
|
| Tarray of ty * exp list
|
2011-01-20 23:05:18 +01:00
|
|
|
| Tunit
|
|
|
|
|
|
|
|
and classe = { c_protection : protection;
|
|
|
|
c_static : bool;
|
|
|
|
c_name : class_name;
|
2011-02-07 14:24:17 +01:00
|
|
|
c_imports : class_name list;
|
|
|
|
c_implements : class_name list;
|
2011-01-20 23:05:18 +01:00
|
|
|
c_kind : class_kind }
|
|
|
|
|
|
|
|
and class_kind = Cenum of constructor_name list
|
|
|
|
| Cgeneric of class_desc
|
|
|
|
|
|
|
|
and class_desc = { cd_fields : field list;
|
|
|
|
cd_classs : classe list;
|
|
|
|
cd_constructors : methode list;
|
|
|
|
cd_methodes : methode list; }
|
|
|
|
|
|
|
|
and var_dec = { vd_type : ty;
|
2011-11-21 11:36:04 +01:00
|
|
|
vd_alias : bool;
|
2011-01-20 23:05:18 +01:00
|
|
|
vd_ident : var_ident }
|
|
|
|
|
|
|
|
and protection = Ppublic | Pprotected | Pprivate | Ppackage
|
|
|
|
|
|
|
|
and field = { f_protection : protection;
|
|
|
|
f_static : bool;
|
|
|
|
f_final : bool;
|
|
|
|
f_type : ty;
|
2011-02-07 14:24:17 +01:00
|
|
|
f_ident : field_ident;
|
2011-01-20 23:05:18 +01:00
|
|
|
f_value : exp option }
|
|
|
|
|
|
|
|
and methode = { m_protection : protection;
|
|
|
|
m_static : bool;
|
|
|
|
m_name : method_name;
|
|
|
|
m_args : var_dec list;
|
|
|
|
m_returns : ty;
|
2011-02-07 14:24:17 +01:00
|
|
|
m_throws : class_name list;
|
2011-01-20 23:05:18 +01:00
|
|
|
m_body : block; }
|
|
|
|
|
|
|
|
|
|
|
|
and block = { b_locals : var_dec list;
|
|
|
|
b_body : act list; }
|
|
|
|
|
|
|
|
and act = Anewvar of var_dec * exp
|
|
|
|
| Aassgn of pattern * exp
|
2011-04-28 15:20:21 +02:00
|
|
|
| Aexp of exp
|
2012-11-17 23:03:54 +01:00
|
|
|
| Aswitch of exp * (switch_case * block) list
|
2011-01-20 23:05:18 +01:00
|
|
|
| Aif of exp * block
|
|
|
|
| Aifelse of exp * block * block
|
|
|
|
| Ablock of block
|
2011-02-07 14:24:17 +01:00
|
|
|
| Afor of var_dec * exp * exp * block
|
2011-01-20 23:05:18 +01:00
|
|
|
| Areturn of exp
|
|
|
|
|
2012-11-17 23:03:54 +01:00
|
|
|
and switch_case = Senum of constructor_name | Sexp of exp
|
|
|
|
|
2011-05-30 10:06:16 +02:00
|
|
|
and exp = Ethis
|
2011-01-20 23:05:18 +01:00
|
|
|
| Efun of op_name * exp list
|
2011-02-07 14:24:17 +01:00
|
|
|
| Emethod_call of exp * method_name * exp list
|
2011-01-20 23:05:18 +01:00
|
|
|
| Enew of ty * exp list
|
2011-02-07 14:24:17 +01:00
|
|
|
| Enew_array of ty * exp list (** [ty] is the array base type *)
|
2011-01-20 23:05:18 +01:00
|
|
|
| Evoid (*printed as nothing*)
|
2011-03-21 14:30:19 +01:00
|
|
|
| Ecast of ty * exp
|
2011-01-20 23:05:18 +01:00
|
|
|
| Svar of const_name
|
|
|
|
| Sint of int
|
|
|
|
| Sfloat of float
|
|
|
|
| Sbool of bool
|
|
|
|
| Sconstructor of constructor_name
|
2011-02-14 15:21:57 +01:00
|
|
|
| Sstring of string
|
2011-02-07 14:24:17 +01:00
|
|
|
| Snull
|
2011-05-30 10:06:16 +02:00
|
|
|
| Efield of exp * field_name
|
|
|
|
| Eclass of class_name
|
|
|
|
| Evar of var_ident
|
2011-06-27 16:08:56 +02:00
|
|
|
| Earray_elem of exp * exp list
|
2011-02-14 15:21:57 +01:00
|
|
|
|
2011-01-20 23:05:18 +01:00
|
|
|
and pattern = Pfield of pattern * field_name
|
2011-02-07 14:24:17 +01:00
|
|
|
| Pclass of class_name
|
2011-01-20 23:05:18 +01:00
|
|
|
| Pvar of var_ident
|
2011-06-27 16:08:56 +02:00
|
|
|
| Parray_elem of pattern * exp list
|
2011-01-20 23:05:18 +01:00
|
|
|
| Pthis of field_ident
|
|
|
|
|
|
|
|
type program = classe list
|
|
|
|
|
2012-09-28 13:04:08 +02:00
|
|
|
|
|
|
|
(** [jname_of_name name] translates the string [name] to a valid Java identifier. *)
|
|
|
|
let jname_of_name name =
|
|
|
|
let buf = Buffer.create (String.length name) in
|
2013-11-08 18:51:06 +01:00
|
|
|
let convert c =
|
2012-09-28 13:04:08 +02:00
|
|
|
match c with
|
|
|
|
| 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' ->
|
|
|
|
Buffer.add_char buf c
|
|
|
|
| '\'' -> Buffer.add_string buf "_prime"
|
|
|
|
| _ ->
|
|
|
|
Buffer.add_string buf "lex";
|
|
|
|
Buffer.add_string buf (string_of_int (Char.code c)) in
|
|
|
|
String.iter convert name;
|
|
|
|
Buffer.contents buf
|
|
|
|
|
2011-02-07 14:24:17 +01:00
|
|
|
|
2013-11-08 18:51:06 +01:00
|
|
|
let default_value ty = match ty with
|
2011-02-07 14:24:17 +01:00
|
|
|
| Tclass _ -> Snull
|
|
|
|
| Tgeneric _ -> Snull
|
|
|
|
| Tbool -> Sbool true
|
|
|
|
| Tint -> Sint 0
|
2011-07-08 15:25:00 +02:00
|
|
|
| Tlong -> Sint 0
|
2011-02-07 14:24:17 +01:00
|
|
|
| Tfloat -> Sfloat 0.0
|
|
|
|
| Tunit -> Evoid
|
|
|
|
| Tarray _ -> Enew_array (ty,[])
|
|
|
|
|
2011-02-14 15:21:57 +01:00
|
|
|
|
2011-03-08 13:41:28 +01:00
|
|
|
let java_pervasive_class c = Names.qualname_of_string ("jeptagon.Pervasives."^c)
|
2011-11-20 23:09:12 +01:00
|
|
|
let java_pervasives_name = Names.qualname_of_string "jeptagon.Pervasives"
|
|
|
|
let java_pervasives = Eclass java_pervasives_name
|
2011-02-14 15:21:57 +01:00
|
|
|
|
|
|
|
|
2011-05-30 10:06:16 +02:00
|
|
|
let mk_var x = Evar x
|
2011-01-24 16:07:26 +01:00
|
|
|
|
2011-11-21 11:36:04 +01:00
|
|
|
let mk_var_dec x is_alias ty =
|
|
|
|
{ vd_type = ty; vd_alias = is_alias; vd_ident = x }
|
2011-01-24 16:07:26 +01:00
|
|
|
|
|
|
|
let mk_block ?(locals=[]) b =
|
|
|
|
{ b_locals = locals; b_body = b; }
|
|
|
|
|
2011-02-07 14:24:17 +01:00
|
|
|
|
|
|
|
let mk_methode ?(protection=Ppublic) ?(static=false) ?(args=[]) ?(returns=Tunit) ?(throws=[])
|
2011-01-20 23:05:18 +01:00
|
|
|
body name =
|
2011-02-07 14:24:17 +01:00
|
|
|
{ m_protection = protection; m_static = static; m_name = name; m_args = args;
|
|
|
|
m_throws = throws; m_returns = returns; m_body = body; }
|
2011-01-20 23:05:18 +01:00
|
|
|
|
2011-02-07 14:24:17 +01:00
|
|
|
let mk_classe ?(imports=[]) ?(protection=Ppublic) ?(static=false) ?(fields=[])
|
|
|
|
?(classes=[]) ?(constrs=[]) ?(methodes=[]) ?(implements=[])
|
2011-01-20 23:05:18 +01:00
|
|
|
class_name =
|
2011-11-20 23:09:12 +01:00
|
|
|
{ c_protection = protection; c_static = static; c_name = class_name;
|
|
|
|
c_imports = imports; c_implements = implements;
|
|
|
|
c_kind = Cgeneric { cd_fields = fields; cd_classs = classes;
|
|
|
|
cd_constructors = constrs; cd_methodes = methodes; } }
|
2011-01-20 23:05:18 +01:00
|
|
|
|
2011-02-07 14:24:17 +01:00
|
|
|
let mk_enum ?(protection=Ppublic) ?(static=false) ?(imports=[]) ?(implements=[])
|
2011-01-20 23:05:18 +01:00
|
|
|
constructor_names class_name =
|
2011-11-20 23:09:12 +01:00
|
|
|
{ c_protection = protection; c_static = static; c_name = class_name;
|
|
|
|
c_imports = imports; c_implements = implements;
|
2011-02-07 14:24:17 +01:00
|
|
|
c_kind = Cenum(constructor_names) }
|
2011-01-20 23:05:18 +01:00
|
|
|
|
|
|
|
|
2011-11-20 23:09:12 +01:00
|
|
|
let mk_field ?(protection = Ppublic) ?(static = false) ?(final = false) ?(value = None) ty ident =
|
|
|
|
{ f_protection = protection; f_static = static; f_final = final;
|
|
|
|
f_type = ty; f_ident = ident; f_value = value }
|
2011-02-07 14:24:17 +01:00
|
|
|
|
|
|
|
let vds_to_exps vd_l = List.map (fun { vd_ident = x } -> mk_var x) vd_l
|
|
|
|
|
|
|
|
let vds_to_fields ?(protection=Ppublic) vd_l =
|
|
|
|
List.map (fun { vd_ident = x; vd_type = t } -> mk_field ~protection:protection t x) vd_l
|