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

Recursives Qualnames.

Browse source 
In order to have a correct handling of inner classes in Java, and to prepare for modules inside modules.
This commit is contained in:
Léonard Gérard 2011-02-07 14:24:17 +01:00
parent 09419a77a5
commit 8f4411e145
50 changed files with 866 additions and 365 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
compiler/global/global_printer.ml
View file

@ -7,11 +7,27 @@ open Modules
open Format
open Pp_tools
let print_qualname ff qn = match qn with
| { qual = "Pervasives"; name = n } -> print_name ff n
| { qual = m; name = n } when m = g_env.current_mod -> print_name ff n
| { qual = m; name = n } when m = local_qualname -> print_name ff n
| { qual = m; name = n } -> fprintf ff "%s.%a" m print_name n
let rec _print_modul ff m = match m with
| Pervasives -> ()
| LocalModule -> ()
| _ when m = g_env.current_mod -> ()
| Module m -> fprintf ff "%a." print_name m
| QualModule { qual = m; name = n } -> fprintf ff "%a%a." _print_modul m print_name n
(** Prints a [modul] with a [.] at the end when not empty *)
let print_modul ff m = match m with
| Pervasives -> ()
| LocalModule -> ()
| _ when m = g_env.current_mod -> ()
| Module m -> fprintf ff "%a" print_name m
| QualModule { qual = m; name = n } -> fprintf ff "%a%a" _print_modul m print_name n
let print_qualname ff { qual = q; name = n} = match q with
| Pervasives -> print_name ff n
| LocalModule -> print_name ff n
| _ when q = g_env.current_mod -> print_name ff n
| _ -> fprintf ff "%a%a" _print_modul q print_name n
let print_shortname ff {name = n} = print_name ff n
@ -29,9 +45,8 @@ let rec print_static_exp ff se = match se.se_desc with
| Sop (op, se_list) ->
if is_infix (shortname op)
then
let op_s = opname op ^ " " in
fprintf ff "@[%a@]"
(print_list_l print_static_exp "(" op_s ")") se_list
let e1,e2 = Misc.assert_2 se_list in
fprintf ff "(@[%a@ %a %a@])" print_static_exp e1 print_qualname op print_static_exp e2
else
fprintf ff "@[<2>%a@,%a@]"
print_qualname op print_static_exp_tuple se_list

18
compiler/global/initial.ml
View file

@ -14,18 +14,18 @@ open Types
let tglobal = []
let cglobal = []
let pbool = { qual = "Pervasives"; name = "bool" }
let pbool = { qual = Pervasives; name = "bool" }
let tbool = Types.Tid pbool
let ptrue = { qual = "Pervasives"; name = "true" }
let pfalse = { qual = "Pervasives"; name = "false" }
let por = { qual = "Pervasives"; name = "or" }
let pint = { qual = "Pervasives"; name = "int" }
let ptrue = { qual = Pervasives; name = "true" }
let pfalse = { qual = Pervasives; name = "false" }
let por = { qual = Pervasives; name = "or" }
let pint = { qual = Pervasives; name = "int" }
let tint = Types.Tid pint
let pfloat = { qual = "Pervasives"; name = "float" }
let pfloat = { qual = Pervasives; name = "float" }
let tfloat = Types.Tid pfloat
let mk_pervasives s = { qual = "Pervasives"; name = s }
let mk_pervasives s = { qual = Pervasives; name = s }
let mk_static_int_op op args =
mk_static_exp ~ty:tint (Sop (op,args))
@ -39,7 +39,7 @@ let mk_static_bool b =
(* build the initial environment *)
let initialize modname =
Modules.initialize modname;
let initialize modul =
Modules.initialize modul;
List.iter (fun (f, ty) -> Modules.add_type f ty) tglobal;
List.iter (fun (f, ty) -> Modules.add_constrs f ty) cglobal

57
compiler/global/modules.ml
View file

@ -23,7 +23,7 @@ exception Already_defined
interface_format_version in signature.ml should be incremented. *)
(** Object serialized in compiled interfaces. *)
type module_object =
{ m_name : string;
{ m_name : Names.modul;
m_values : node NamesEnv.t;
m_types : type_def NamesEnv.t;
m_consts : const_def NamesEnv.t;
@ -33,11 +33,11 @@ type module_object =
type env = {
(** Current module name *)
mutable current_mod : module_name;
mutable current_mod : modul;
(** Modules opened and loaded into the env *)
mutable opened_mod : module_name list;
mutable opened_mod : modul list;
(** Modules loaded into the env *)
mutable loaded_mod : module_name list;
mutable loaded_mod : modul list;
(** Node definitions *)
mutable values : node QualEnv.t;
(** Type definitions *)
@ -53,12 +53,12 @@ type env = {
(** The global environnement *)
let g_env =
{ current_mod = "";
{ current_mod = Module "";
opened_mod = [];
loaded_mod = [];
values = QualEnv.empty;
types = QualEnv.empty;
constrs = QualEnv.empty;
constrs = QualEnv.empty;
fields = QualEnv.empty;
consts = QualEnv.empty;
format_version = interface_format_version }
@ -86,23 +86,28 @@ let _append_module mo =
g_env.fields <- QualEnv.append (qualify_all mo.m_fields) g_env.fields;
g_env.consts <- QualEnv.append (qualify mo.m_consts) g_env.consts
(** Load a module into the global environnement unless already loaded *)
let _load_module modname =
if is_loaded modname then ()
(** Load a module into the global environment unless already loaded *)
let _load_module modul =
if is_loaded modul then ()
else
let modname = match modul with
| Names.Pervasives -> "Pervasives"
| Names.Module n -> n
| Names.LocalModule -> Misc.internal_error "modules" 0
| Names.QualModule _ -> Misc.unsupported "modules" 0
in
let name = String.uncapitalize modname in
try
let filename = Compiler_utils.findfile (name ^ ".epci") in
let ic = open_in_bin filename in
let mo:module_object =
try
input_value ic
with
| End_of_file | Failure _ ->
close_in ic;
Format.eprintf "Corrupted compiled interface file %s.@\n\
Please recompile %s.ept first.@." filename name;
raise Errors.Error in
try input_value ic
with End_of_file | Failure _ ->
close_in ic;
Format.eprintf "Corrupted compiled interface file %s.@\n\
Please recompile %s.ept first.@." filename name;
raise Errors.Error
in
if mo.m_format_version <> interface_format_version
then (
Format.eprintf "The file %s was compiled with an older version \
@ -118,20 +123,20 @@ let _load_module modname =
(** Opens a module unless already opened
by loading it into the global environnement and seting it as opened *)
let open_module modname =
if is_opened modname then ()
by loading it into the global environment and setting it as opened *)
let open_module modul =
if is_opened modul then ()
else
_load_module modname;
g_env.opened_mod <- modname::g_env.opened_mod
_load_module modul;
g_env.opened_mod <- modul::g_env.opened_mod
(** Initialize the global environnement :
(** Initialize the global environment :
set current module and open default modules *)
let initialize modname =
g_env.current_mod <- modname;
let initialize modul =
g_env.current_mod <- modul;
g_env.opened_mod <- [];
g_env.loaded_mod <- [modname];
g_env.loaded_mod <- [modul];
List.iter open_module !default_used_modules

62
compiler/global/names.ml
View file

@ -3,25 +3,38 @@
[fullname] longname -> Module.name *)
type name = string
type module_name = name
and qualname = { qual: string; name: string }
type modul =
| Pervasives
| LocalModule
| Module of module_name
| QualModule of qualname
and qualname = { qual: modul; name: name }
type type_name = qualname
type fun_name = qualname
type field_name = qualname
type constructor_name = qualname
type constant_name = qualname
type module_name = name
let local_qualname = "$$%local_current_illegal_module_name%$$"
let local_qn name = { qual = local_qualname; name = name }
let pervasives_qn name = { qual = Pervasives; name = name }
let local_qn name = { qual = LocalModule; name = name }
module NamesEnv = struct
include (Map.Make(struct type t = name let compare = compare end))
let append env0 env = fold (fun key v env -> add key v env) env0 env
end
module ModulEnv = struct
include (Map.Make(struct type t = modul let compare = compare end))
let append env0 env = fold (fun key v env -> add key v env) env0 env
end
module QualEnv = struct
include (Map.Make(struct type t = qualname let compare = compare end))
@ -34,18 +47,32 @@ module S = Set.Make (struct type t = string let compare = compare end)
let shortname { name = n; } = n
let qualname { qual = n; } = n
let fullname { qual = qual; name = n; } = qual ^ "." ^ n
let modul { qual = m; } = m
let rec modul_to_string m = match m with
| Pervasives -> "Pervasives"
| LocalModule -> "\#$%@#_LOCAL_MODULE"
| Module n -> n
| QualModule {qual = q; name = n} -> (modul_to_string q) ^"."^ n
let fullname {qual = q; name = n} = modul_to_string q ^ "." ^ n
let rec modul_of_string_list = function
| [] -> LocalModule
| ["Pervasives"] -> Pervasives
| [q] -> Module q
| q::q_l -> QualModule {qual = modul_of_string_list q_l; name = q}
let qualname_of_string s =
try
let ind = String.index s '.' in
if ind = 0 || ind = String.length s - 1
then invalid_arg "mk_longname: ill-formed identifier";
let n = String.sub s (ind + 1) (String.length s - ind - 1) in
{ qual = String.sub s 0 ind; name = n; }
with Not_found -> { qual = ""; name = s }
let q_l_n = Misc.split_string s "." in
match List.rev q_l_n with
| [] -> Misc.internal_error "Names" 0
| n::q_l -> { qual = modul_of_string_list q_l; name = n }
let modul_of_string s =
let q_l = Misc.split_string s "." in
modul_of_string_list (List.rev q_l)
(** Are infix
[or], [quo], [mod], [land], [lor], [lxor], [lsl], [lsr], [asr]
@ -58,7 +85,7 @@ let is_infix s =
StrSet.empty in
if StrSet.mem s infix_set then true
else (match String.get s 0 with
| 'a' .. 'z' | 'A' .. 'Z' | '_' | '`' -> false
| 'a' .. 'z' | 'A' .. 'Z' | '_' | '`' | '~' -> false
| _ -> true)
open Format
@ -70,13 +97,6 @@ let print_name ff n =
else n
in fprintf ff "%s" n
let print_raw_qualname ff {qual = q; name = n} =
fprintf ff "%s.%a" q print_name n
let opname qn = match qn with
| { qual = "Pervasives"; name = m; } -> m
| { qual = qual; name = n; } -> qual ^ "." ^ n
(** Use a printer to generate a string compatible with a name *)
let print_pp_to_name p x =
Misc.sanitize_string (Misc.print_pp_to_string p x)

12
compiler/global/static.ml
View file

@ -28,22 +28,22 @@ let partial_apply_op op se_list =
match se_list with
| [{ se_desc = Sint n1 }; { se_desc = Sint n2 }] ->
(match op with
| { qual = "Pervasives"; name = "+" } ->
| { qual = Pervasives; name = "+" } ->
Sint (n1 + n2)
| { qual = "Pervasives"; name = "-" } ->
| { qual = Pervasives; name = "-" } ->
Sint (n1 - n2)
| { qual = "Pervasives"; name = "*" } ->
| { qual = Pervasives; name = "*" } ->
Sint (n1 * n2)
| { qual = "Pervasives"; name = "/" } ->
| { qual = Pervasives; name = "/" } ->
let n = if n2 = 0 then raise Instanciation_failed else n1 / n2 in
Sint n
| { qual = "Pervasives"; name = "=" } ->
| { qual = Pervasives; name = "=" } ->
Sbool (n1 = n2)
| _ -> assert false (*TODO: add missing operators*)
)
| [{ se_desc = Sint n }] ->
(match op with
| { qual = "Pervasives"; name = "~-" } -> Sint (-n)
| { qual = Pervasives; name = "~-" } -> Sint (-n)
| _ -> assert false (*TODO: add missing operators*)
)
| _ -> Sop(op, se_list)

2
compiler/heptagon/hept_printer.ml
View file

@ -286,7 +286,7 @@ let print_node ff
(print_local_vars "") nb.b_local
print_eq_list nb.b_equs
let print_open_module ff name = fprintf ff "open %a@." print_name name
let print_open_module ff name = fprintf ff "open %s@." (modul_to_string name)
let print oc { p_opened = po; p_types = pt; p_nodes = pn; p_consts = pc } =
let ff = Format.formatter_of_out_channel oc in

6
compiler/heptagon/heptagon.ml
View file

@ -158,8 +158,8 @@ type const_dec = {
c_loc : location }
type program = {
p_modname : name;
p_opened : name list;
p_modname : modul;
p_opened : modul list;
p_types : type_dec list;
p_nodes : node_dec list;
p_consts : const_dec list }
@ -179,7 +179,7 @@ and interface_decl = {
interf_loc : location }
and interface_desc =
| Iopen of name
| Iopen of modul
| Itypedef of type_dec
| Iconstdef of const_dec
| Isignature of signature

2
compiler/heptagon/main/hept_parser_scoper.ml
View file

@ -32,6 +32,7 @@ let parse_program modname lexbuf =
let p = do_silent_pass "Parsing" (parse Hept_parser.program) lexbuf in
let p = { p with Hept_parsetree.p_modname = modname } in
(* Fuse static exps together *)
let p = do_silent_pass "Static Scoping" Hept_static_scoping.program p in
@ -43,6 +44,7 @@ let parse_program modname lexbuf =
let parse_interface modname lexbuf =
(* Parsing of the file *)
let i = do_silent_pass "Parsing" (parse Hept_parser.interface) lexbuf in
(* TODO ?
let i = { i with Hept_parsetree.=i_modname = modname } in *)

6
compiler/heptagon/main/heptcheck.ml
View file

@ -15,7 +15,7 @@ open Hept_compiler
open Location
let check_implementation modname filename =
let check_implementation modul filename =
(* input and output files *)
let source_name = filename ^ ".ept" in
@ -25,11 +25,11 @@ let check_implementation modname filename =
in
try
Initial.initialize modname;
Initial.initialize modul;
add_include (Filename.dirname filename);
(* Parsing of the file *)
let p = do_silent_pass "Parsing" (parse_implementation modname) lexbuf in
let p = do_silent_pass "Parsing" (parse_implementation modul) lexbuf in
(* Fuse static exps together *)
let p = do_silent_pass "Static Scoping"

21
compiler/heptagon/parsing/hept_parser.mly
View file

@ -127,7 +127,7 @@ pragma_headers:
open_modules:
| /* empty */ { [] }
| open_modules OPEN Constructor { $3 :: $1 }
| open_modules OPEN modul { $3 :: $1 }
;
const_decs:
@ -537,14 +537,21 @@ indexes:
| LBRACKET exp RBRACKET indexes { $2::$4 }
;
qualified(X):
| m=modul DOT x=X { Q { qual = m; name = x } }
modul:
| c=Constructor { Names.Module c }
| m=modul DOT c=Constructor { Names.QualModule { Names.qual = m; Names.name = c} }
constructor:
| Constructor { ToQ $1 } %prec prec_ident
| Constructor DOT Constructor { Q {qual = $1; name = $3} }
| q=qualified(Constructor) { q }
;
qualname:
| ident { ToQ $1 }
| Constructor DOT ident { Q {qual = $1; name = $3} }
| i=ident { ToQ i }
| q=qualified(ident) { q }
;
@ -554,8 +561,8 @@ _const:
| FLOAT { Sfloat $1 }
| BOOL { Sbool $1 }
| constructor { Sconstructor $1 }
| Constructor DOT ident
{ Svar (Q {qual = $1; name = $3}) }
| q=qualified (ident)
{ Svar q }
;
tuple_exp:
@ -612,7 +619,7 @@ interface_decl:
_interface_decl:
| type_dec { Itypedef $1 }
| const_dec { Iconstdef $1 }
| OPEN Constructor { Iopen $2 }
| OPEN modul { Iopen $2 }
| VAL node_or_fun ident node_params LPAREN params_signature RPAREN
RETURNS LPAREN params_signature RPAREN
{ Isignature({ sig_name = $3;

9
compiler/heptagon/parsing/hept_parsetree.ml
View file

@ -17,6 +17,8 @@ type var_name = Names.name
(** dec_names are locally declared qualified names *)
type dec_name = Names.name
type module_name = Names.modul
(** state_names, [automata] translate them in constructors with a fresh type. *)
type state_name = Names.name
@ -182,7 +184,7 @@ type const_dec =
type program =
{ p_modname : dec_name;
p_pragmas : (var_name * string) list;
p_opened : dec_name list;
p_opened : module_name list;
p_types : type_dec list;
p_nodes : node_dec list;
p_consts : const_dec list; }
@ -206,7 +208,7 @@ and interface_decl =
interf_loc : location }
and interface_desc =
| Iopen of dec_name
| Iopen of module_name
| Itypedef of type_dec
| Iconstdef of const_dec
| Isignature of signature
@ -223,8 +225,7 @@ let mk_call ?(params=[]) op exps =
Eapp (mk_app op params, exps)
let mk_op_call ?(params=[]) s exps =
mk_call ~params:params
(Efun (Q { Names.qual = "Pervasives"; Names.name = s })) exps
mk_call ~params:params (Efun (Q (Names.pervasives_qn s))) exps
let mk_iterator_call it ln params n exps =
Eiterator (it, mk_app (Enode ln) params, n, exps)

6
compiler/heptagon/parsing/hept_scoping.ml
View file

@ -172,8 +172,8 @@ let translate_iterator_type = function
op<a1,a2> (a3) == op <a1> (a2,a3) == op (a1,a2,a3) *)
let static_app_from_app app args=
match app.a_op with
| Efun (Q ({ qual = "Pervasives" } as q))
| Enode (Q ({ qual = "Pervasives" } as q)) ->
| Efun (Q ({ qual = Pervasives } as q))
| Enode (Q ({ qual = Pervasives } as q)) ->
q, (app.a_params @ args)
| _ -> raise Not_static
@ -457,7 +457,7 @@ let translate_program p =
let consts = List.map translate_const_dec p.p_consts in
let types = List.map translate_typedec p.p_types in
let nodes = List.map translate_node p.p_nodes in
{ Heptagon.p_modname = p.p_modname;
{ Heptagon.p_modname = Names.modul_of_string p.p_modname;
Heptagon.p_opened = p.p_opened;
Heptagon.p_types = types;
Heptagon.p_nodes = nodes;

4
compiler/heptagon/parsing/hept_static_scoping.ml
View file

@ -17,8 +17,8 @@ let assert_se e = match e.e_desc with
op<a1,a2> (a3) == op <a1> (a2,a3) == op (a1,a2,a3) *)
let static_app_from_app app args =
match app.a_op with
| Efun ((Q { Names.qual = "Pervasives" }) as q)
| Enode ((Q { Names.qual = "Pervasives" }) as q) ->
| Efun ((Q { Names.qual = Names.Pervasives }) as q)
| Enode ((Q { Names.qual = Names.Pervasives }) as q) ->
q, (app.a_params @ args)
| _ -> raise Not_static

4
compiler/main/heptc.ml
View file

@ -72,8 +72,8 @@ let compile_program modname source_f =
let compile source_f =
let modname = source_f |> Filename.basename |> Filename.chop_extension |> String.capitalize in
Initial.initialize modname;
let modul = Names.modul_of_string modname in
Initial.initialize modul;
source_f |> Filename.dirname |> add_include;
match Misc.file_extension source_f with

30
compiler/main/mls2obc.ml
View file

@ -25,7 +25,7 @@ let fresh_it () =
let gen_obj_ident n = Idents.gen_var "mls2obc" ((shortname n) ^ "_inst")
let op_from_string op = { qual = "Pervasives"; name = op; }
let op_from_string op = { qual = Pervasives; name = op; }
let rec pattern_of_idx_list p l =
let rec aux ty l = match ty, l with
@ -335,6 +335,7 @@ and mk_node_call map call_context app loc name_list args ty =
let obj =
{ o_ident = obj_ref_name o; o_class = f;
o_params = app.Minils.a_params;
o_async = app.Minils.a_async;
o_size = size_from_call_context call_context; o_loc = loc } in
let si = (match app.Minils.a_op with
| Minils.Efun _ -> []
@ -352,33 +353,36 @@ and translate_iterator map call_context it name_list app loc n x xd c_list ty =
| _ -> Format.eprintf "%a" Global_printer.print_type ty; internal_error "mls2obc" 6
in
let array_of_output name_list ty_list =
List.map (fun l -> mk_pattern ty (Larray (l, mk_evar_int x))) name_list (* TODO not ty, but Tprod (ti...) -> ti *)
List.map2 (fun l ty -> mk_pattern ty (Larray (l, mk_evar_int x))) name_list ty_list
in
let array_of_input c_list = List.map (array_elt_of_exp (mk_pattern_int (Lvar x))) c_list in
match it with
| Minils.Imap ->
let c_list = array_of_input c_list in
let ty_list = Types.unprod ty in
let ty_list = List.map unarray (Types.unprod ty) in
let name_list = array_of_output name_list ty_list in
let node_out_ty = Types.prod (List.map unarray ty_list) in
let node_out_ty = Types.prod ty_list in
let v, si, j, action = mk_node_call map call_context app loc name_list c_list node_out_ty in
let v = translate_var_dec v in
let b = mk_block ~locals:v action in
si, j, [ Afor (xd, mk_static_int 0, n, b) ]
let bi = mk_block si in
[Afor (xd, mk_static_int 0, n, bi)], j, [Afor (xd, mk_static_int 0, n, b)]
| Minils.Imapfold ->
let (c_list, acc_in) = split_last c_list in
let c_list = array_of_input c_list in
let ty_list = Types.unprod ty in
let (name_list, acc_out) = split_last name_list in
let name_list = array_of_output name_list ty_list in
let node_out_ty = Types.prod (Misc.map_butlast unarray ty_list) in
let ty_list = Misc.map_butlast unarray (Types.unprod ty) in
let ty_name_list, ty_acc_out = Misc.split_last ty_list in
let (name_list, acc_out) = Misc.split_last name_list in
let name_list = array_of_output name_list ty_name_list in
let node_out_ty = Types.prod ty_list in
let v, si, j, action = mk_node_call map call_context app loc (name_list @ [ acc_out ])
(c_list @ [ mk_exp acc_out.pat_ty (Epattern acc_out) ]) node_out_ty
in
let v = translate_var_dec v in
let b = mk_block ~locals:v action in
si, j, [Aassgn (acc_out, acc_in); Afor (xd, mk_static_int 0, n, b)]
let bi = mk_block si in
[Afor (xd, mk_static_int 0, n, bi)], j, [Aassgn (acc_out, acc_in); Afor (xd, mk_static_int 0, n, b)]
| Minils.Ifold ->
let (c_list, acc_in) = split_last c_list in
@ -389,7 +393,8 @@ and translate_iterator map call_context it name_list app loc n x xd c_list ty =
in
let v = translate_var_dec v in
let b = mk_block ~locals:v action in
si, j, [ Aassgn (acc_out, acc_in); Afor (xd, mk_static_int 0, n, b) ]
let bi = mk_block si in
[Afor (xd, mk_static_int 0, n, bi)], j, [ Aassgn (acc_out, acc_in); Afor (xd, mk_static_int 0, n, b) ]
| Minils.Ifoldi ->
let (c_list, acc_in) = split_last c_list in
@ -400,7 +405,8 @@ and translate_iterator map call_context it name_list app loc n x xd c_list ty =
in
let v = translate_var_dec v in
let b = mk_block ~locals:v action in
si, j, [ Aassgn (acc_out, acc_in); Afor (xd, mk_static_int 0, n, b) ]
let bi = mk_block si in
[Afor (xd, mk_static_int 0, n, bi)], j, [ Aassgn (acc_out, acc_in); Afor (xd, mk_static_int 0, n, b) ]
let remove m d_list =
List.filter (fun { Minils.v_ident = n } -> not (List.mem_assoc n m)) d_list

4
compiler/minils/main/mls2seq.ml
View file

@ -24,7 +24,7 @@ type target =
(** Writes a .epo file for program [p]. *)
let write_object_file p =
let filename = (filename_of_name p.Minils.p_modname)^".epo" in
let filename = (Names.modul_to_string p.Minils.p_modname)^".epo" in
let epoc = open_out_bin filename in
output_value epoc p;
close_out epoc;
@ -32,7 +32,7 @@ let write_object_file p =
(** Writes a .obc file for program [p]. *)
let write_obc_file p =
let obc_name = (filename_of_name p.Obc.p_modname)^".obc" in
let obc_name = (Names.modul_to_string p.Obc.p_modname)^".obc" in
let obc = open_out obc_name in
Obc_printer.print obc p;
close_out obc;

6
compiler/minils/minils.ml
View file

@ -125,9 +125,9 @@ type const_dec = {
c_loc : location }
type program = {
p_modname : name;
p_modname : modul;
p_format_version : string;
p_opened : name list;
p_opened : modul list;
p_types : type_dec list;
p_nodes : node_dec list;
p_consts : const_dec list }
@ -171,7 +171,7 @@ let mk_app ?(params=[]) ?(async=None) ?(unsafe=false) op =
(** The modname field has to be set when known, TODO LG : format_version *)
let mk_program o n t c =
{ p_modname = ""; p_format_version = "";
{ p_modname = Module ""; p_format_version = "";
p_opened = o; p_nodes = n; p_types = t; p_consts = c }
let void = mk_exp ~ty:Types.Tunit (Eapp (mk_app Etuple, [], None))

2
compiler/minils/mls_printer.ml
View file

@ -179,7 +179,7 @@ and print_eqs ff = function
| [] -> ()
| l -> fprintf ff "@[<v2>let@ %a@]@\ntel" (print_list_r print_eq """;""") l
let print_open_module ff name = fprintf ff "open %a@." print_name name
let print_open_module ff name = fprintf ff "open %s@." (modul_to_string name)
let rec print_type_dec ff { t_name = name; t_desc = tdesc } =
let print_type_desc ff = function

2
compiler/minils/mls_utils.ml
View file

@ -53,7 +53,7 @@ let is_record_type ty = match ty with
| _ -> false
let is_op = function
| { qual = "Pervasives"; name = _ } -> true | _ -> false
| { qual = Pervasives; name = _ } -> true | _ -> false
let exp_list_of_static_exp_list se_list =
let mk_one_const se =

38
compiler/minils/transformations/callgraph.ml
View file

@ -137,13 +137,11 @@ struct
let se, _ = Global_mapfold.static_exp funs m se in
let se = match se.se_desc with
| Svar q ->
if q.qual = local_qualname
then (* This var is a static parameter, it has to be instanciated *)
(try QualEnv.find q m
with Not_found ->
Format.eprintf "local param not local";
assert false;)
else se
(match q.qual with
| LocalModule -> (* This var is a static parameter, it has to be instanciated *)
(try QualEnv.find q m
with Not_found -> Misc.internal_error "callgraph" 0)
| _ -> se)
| _ -> se in
se, m
@ -201,18 +199,24 @@ end
open Param_instances
type info =
{ mutable opened : program NamesEnv.t;
{ mutable opened : program ModulEnv.t;
mutable called_nodes : ((qualname * static_exp list) list) QualEnv.t; }
let info =
{ (** opened programs*)
opened = NamesEnv.empty;
opened = ModulEnv.empty;
(** Maps a node to the list of (node name, params) it calls *)
called_nodes = QualEnv.empty }
(** Loads the modname.epo file. *)
let load_object_file modname =
Modules.open_module modname;
let load_object_file modul =
Modules.open_module modul;
let modname = match modul with
| Names.Pervasives -> "Pervasives"
| Names.Module n -> n
| Names.LocalModule -> Misc.internal_error "modules" 0
| Names.QualModule _ -> Misc.unsupported "modules" 0
in
let name = String.uncapitalize modname in
try
let filename = Compiler_utils.findfile (name ^ ".epo") in
@ -226,7 +230,7 @@ let load_object_file modname =
raise Errors.Error
);
close_in ic;
info.opened <- NamesEnv.add p.p_modname p info.opened
info.opened <- ModulEnv.add p.p_modname p info.opened
with
| End_of_file | Failure _ ->
close_in ic;
@ -242,10 +246,10 @@ let load_object_file modname =
(** @return the node with name [ln], loading the corresponding
object file if necessary. *)
let node_by_longname node =
if not (NamesEnv.mem node.qual info.opened)
if not (ModulEnv.mem node.qual info.opened)
then load_object_file node.qual;
try
let p = NamesEnv.find node.qual info.opened in
let p = ModulEnv.find node.qual info.opened in
List.find (fun n -> n.n_name = node) p.p_nodes
with
Not_found -> Error.message no_location (Error.Enode_unbound node)
@ -258,7 +262,7 @@ let collect_node_calls ln =
| [] -> acc
| _ ->
(match ln with
| { qual = "Pervasives" } -> acc
| { qual = Pervasives } -> acc
| _ -> (ln, params)::acc)
in
let edesc _ acc ed = match ed with
@ -303,9 +307,9 @@ let program p =
(* Find the nodes without static parameters *)
let main_nodes = List.filter (fun n -> is_empty n.n_params) p.p_nodes in
let main_nodes = List.map (fun n -> n.n_name, []) main_nodes in
info.opened <- NamesEnv.add p.p_modname p NamesEnv.empty;
info.opened <- ModulEnv.add p.p_modname p ModulEnv.empty;
(* Creates the list of instances starting from these nodes *)
List.iter call_node main_nodes;
let p_list = NamesEnv.fold (fun _ p l -> p::l) info.opened [] in
let p_list = ModulEnv.fold (fun _ p l -> p::l) info.opened [] in
(* Generate all the needed instances *)
List.map Param_instances.Instantiate.program p_list

2
compiler/obc/c/c.ml
View file

@ -158,7 +158,7 @@ let pp_string fmt s =
fprintf fmt "%s" (cname_of_name s)
let cname_of_qn q =
if q.qual = "Pervasives" or q.qual = Names.local_qualname then
if q.qual = Pervasives or q.qual = Names.local_qualname then
q.name
else
(q.qual ^ "__" ^ q.name)

4
compiler/obc/c/cgen.ml
View file

@ -296,7 +296,7 @@ and cexprs_of_exps var_env exps =
List.map (cexpr_of_exp var_env) exps
and cop_of_op_aux op_name cexps = match op_name with
| { qual = "Pervasives"; name = op } ->
| { qual = Pervasives; name = op } ->
begin match op,cexps with
| "~-", [e] -> Cuop ("-", e)
| "not", [e] -> Cuop ("!", e)
@ -354,7 +354,7 @@ let assoc_cn instance obj_env =
(assoc_obj (obj_ref_name instance) obj_env).o_class
let is_op = function
| { qual = "Pervasives"; name = _ } -> true
| { qual = Pervasives; name = _ } -> true
| _ -> false
let out_var_name_of_objn o =

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

@ -28,6 +28,8 @@ type ty = Tclass of class_name
and classe = { c_protection : protection;
c_static : bool;
c_name : class_name;
c_imports : class_name list;
c_implements : class_name list;
c_kind : class_kind }
and class_kind = Cenum of constructor_name list
@ -47,7 +49,7 @@ and field = { f_protection : protection;
f_static : bool;
f_final : bool;
f_type : ty;
f_name : field_ident;
f_ident : field_ident;
f_value : exp option }
and methode = { m_protection : protection;
@ -55,6 +57,7 @@ and methode = { m_protection : protection;
m_name : method_name;
m_args : var_dec list;
m_returns : ty;
m_throws : class_name list;
m_body : block; }
@ -63,33 +66,47 @@ and block = { b_locals : var_dec list;
and act = Anewvar of var_dec * exp
| Aassgn of pattern * exp
| Amethod_call of pattern * method_name * exp list
| Amethod_call of exp * method_name * exp list
| Aasync_method_call of exp * method_name * exp list (* could be used for async logging etc *)
| Aswitch of exp * (constructor_name * block) list
| Aif of exp * block
| Aifelse of exp * block * block
| Ablock of block
| Afor of var_dec * exp * exp * block (* TODO var_dec *)
| Afor of var_dec * exp * exp * block
| Areturn of exp
and exp = Eval of pattern
| Efun of op_name * exp list
| Emethod_call of pattern * method_name * exp list
| Emethod_call of exp * method_name * exp list
| Easync_method_call of exp * method_name * exp list
| Enew of ty * exp list
| Enew_array of ty * exp list
| Enew_array of ty * exp list (** [ty] is the array base type *)
| Evoid (*printed as nothing*)
| Svar of const_name
| Sint of int
| Sfloat of float
| Sbool of bool
| Sconstructor of constructor_name
| Snull
and pattern = Pfield of pattern * field_name
| Pclass of class_name
| Pvar of var_ident
| Parray_elem of pattern * exp
| Pthis of field_ident
type program = classe list
let default_value ty = match ty with
| Tclass _ -> Snull
| Tgeneric _ -> Snull
| Tbool -> Sbool true
| Tint -> Sint 0
| Tfloat -> Sfloat 0.0
| Tunit -> Evoid
| Tarray _ -> Enew_array (ty,[])
let mk_var x = Eval (Pvar x)
let mk_var_dec x ty =
@ -98,20 +115,29 @@ let mk_var_dec x ty =
let mk_block ?(locals=[]) b =
{ b_locals = locals; b_body = b; }
let mk_methode ?(protection=Ppublic) ?(static=false) ?(args=[]) ?(returns=Tunit)
body name =
{ m_protection = protection; m_static = static; m_name = name; m_args = args; m_returns = returns; m_body = body; }
let mk_classe ?(protection=Ppublic) ?(static=false) ?(fields=[]) ?(classes=[]) ?(constrs=[]) ?(methodes=[])
let mk_methode ?(protection=Ppublic) ?(static=false) ?(args=[]) ?(returns=Tunit) ?(throws=[])
body name =
{ m_protection = protection; m_static = static; m_name = name; m_args = args;
m_throws = throws; m_returns = returns; m_body = body; }
let mk_classe ?(imports=[]) ?(protection=Ppublic) ?(static=false) ?(fields=[])
?(classes=[]) ?(constrs=[]) ?(methodes=[]) ?(implements=[])
class_name =
{ c_protection = protection; c_static = static; c_name = class_name;
{ 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; } }
let mk_enum ?(protection=Ppublic) ?(static=false)
let mk_enum ?(protection=Ppublic) ?(static=false) ?(imports=[]) ?(implements=[])
constructor_names class_name =
{ c_protection = protection; c_static = static; c_name = class_name; c_kind = Cenum(constructor_names) }
{ c_protection = protection; c_static = static; c_name = class_name; c_imports = imports; c_implements = implements;
c_kind = Cenum(constructor_names) }
let mk_field ?(protection = Ppublic) ?(static = false) ?(final = false) ?(value = None)
ty name =
{ f_protection = protection; f_static = static; f_final = final; f_type = ty; f_name = name; f_value = value }
ty ident =
{ f_protection = protection; f_static = static; f_final = final; f_type = ty; f_ident = ident; f_value = value }
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

7
compiler/obc/java/java_main.ml
View file

@ -1,13 +1,10 @@
open Java
open Java_printer
open Obc2java
open Compiler_utils
let program p =
let filename = filename_of_name p.Obc.p_modname in
let dirname = build_path (filename ^ "_java") in
let dir = clean_dir dirname in
let p_java = Obc2java.program p in
let dir = Compiler_utils.build_path "java" in
Compiler_utils.ensure_dir dir;
output_program dir p_java

165
compiler/obc/java/java_printer.ml
View file

@ -12,119 +12,174 @@
open Java
open Pp_tools
open Format
open Misc
(* TODO java faire des vrais qualname recursifs, bare_constructor doit être vraiment bare *)
let class_name = Global_printer.print_shortname
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 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 =
let rec _ty size 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,s) -> if size then fprintf ff "%a[%a]" ty t exp s else fprintf ff "%a[]" ty t
| Tunit -> pp_print_string ff "void"
and full_ty ff t = _ty true ff t
and ty ff t = _ty false ff t
and var_dec init ff vd =
if init 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_name
field_ident f.f_ident
(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
| Enew_array (t,e_l) -> fprintf ff "new %a@[<2>%a@]" ty t (print_list_r exp "{"",""}") e_l
| 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
| Easync_method_call _ -> Misc.internal_error "java_printer, Easync call not translated" 0
| Enew (c,e_l) -> fprintf ff "new %a%a" full_ty c args e_l
| Enew_array (t,e_l) ->
(match e_l with
| [] -> fprintf ff "new %a" full_ty t
| _ -> fprintf ff "new %a@[<2>%a@]" ty t (print_list_r exp "{"",""}") e_l )
| Evoid -> ()
| 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
| Snull -> fprintf ff "null"
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
| _ -> Misc.unsupported "java_printer" 1)
| _ -> 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) -> 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@]"
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 "%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
| Anewvar (vd,e) -> fprintf ff "@[<2>%a =@ %a@]" (var_dec false) vd exp e
| Aassgn (p,e) -> fprintf ff "@[<2>%a =@ %a@]" pattern p exp e
| Amethod_call (o,m,e_l) -> fprintf ff "@[%a.%a%a@]" exp o method_name m args e_l
| Aasync_method_call _ -> Misc.internal_error "java_printer, Aasync call not translated" 1
| 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
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 "@[<2>if (%a) {@ %a@ }@]" exp e block bt
fprintf ff "@[<hv 2>if (%a) {@ %a@ }@]" exp e block bt
| Aifelse (e,bt,bf) ->
fprintf ff "@[<2>if (%a) {@ %a@ }@]@\n@[<2>else {@ %a@ }@]"
fprintf ff "@[<hv 2>if (%a) {@ %a@ }@]@\n@[<hv 2>else {@ %a@ }@]"
exp e
block bt
block bf
| Ablock b -> fprintf ff "@[<2>{@ %a@ }]" block b
| Ablock b -> fprintf ff "@[<v2>{@ %a@ }]" block b
| Afor (x, i1, i2, b) ->
fprintf ff "@[<2>for (%a = %a; %a<%a; %a++) {@ %a@ }@]"
var_dec x
exp i1
var_ident x.vd_ident
exp i2
var_ident x.vd_ident
block b
fprintf ff "@[<hv 2>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 "@[<4>%a%a%a %a @[<2>(%a)@] {@\n%a@]@\n}"
fprintf ff "@[<v4>%a%a%a %a @[<2>(%a)@] @[%a@]{@ %a@]@\n}"
protection m.m_protection
static m.m_static
ty m.m_returns
method_name m.m_name
(vd_list """,""") m.m_args
(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 "@[<4>%a%a @[<2>(%a)@] {@\n%a@]@\n}"
fprintf ff "@[<v4>%a%a @[<2>(%a)@] {@\n%a@]@\n}"
protection m.m_protection
method_name m.m_name
(vd_list """,""") m.m_args
(print_list_r (var_dec false) """,""") m.m_args
block m.m_body
let rec class_desc ff cd =
@ -139,23 +194,33 @@ and classe ff c = match c.c_kind with
fprintf ff "@[<4>%a%aenum %a {@\n%a@]@\n}"
protection c.c_protection
static c.c_static
class_name c.c_name
bare_class_name c.c_name
(print_list_r bare_constructor_name """,""") c_l
| Cgeneric cd ->
fprintf ff "@[<4>%a%aclass %a {@\n%a@]@\n}"
fprintf ff "@[<4>%a%aclass %a @[<h>%a@]{@\n%a@]@\n}"
protection c.c_protection
static c.c_static
class_name c.c_name
bare_class_name c.c_name
(print_list_r class_name "implements "",""") c.c_implements
class_desc cd
let output_classe dir c =
let { Names.name = file_name; Names.qual = package_name } = c.c_name in
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
fprintf ff "package %s;@\n" (String.lowercase package_name);
classe ff c;
pp_print_flush ff ();
pp_set_margin ff 120;
fprintf ff "package %a;@\n@[<v>%a@]@\n%a@."
Global_printer.print_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) =

366
compiler/obc/java/obc2java.ml
View file

@ -23,109 +23,132 @@ open Signature
open Obc
open Java
let java_pervasives = Names.modul_of_string "jeptagon.Pervasives"
let java_pervasives_class = Names.qualname_of_string "jeptagon.Pervasives"
let fresh_it () =
let id = Idents.gen_var "obc2java" "i" in
id, mk_var_dec id Tint
let java_callable = Names.qualname_of_string "java.util.concurrent.Callable"
let import_async = [Names.qualname_of_string "java.util.concurrent.Future";
Names.qualname_of_string "java.util.concurrent.ExecutionException"]
let throws_async = [Names.qualname_of_string "InterruptedException";
Names.qualname_of_string "ExecutionException"]
(** 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, id = fresh_it () in
let i = Idents.gen_var "obc2java" "i" in
let id = mk_var_dec i Tint in
Afor (id, Sint 0, size, mk_block (body i))
(** 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 }
(* current module is not translated to keep track, there is no issue since printed without the qualifier *)
let rec translate_modul ?(full=false) m = match m with
| Pervasives
| LocalModule -> m
| _ when m = g_env.current_mod && not full -> m
| Module n -> Module (String.lowercase 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 q = match q with
| { qual = m } when m = local_qualname -> { q with name = String.uppercase q.name }
| _ -> { q with qual = (String.lowercase q.qual)^ ".CONSTANTES"; name = String.uppercase q.name }
let translate_const_name { qual = m; name = n } =
{ qual = QualModule { qual = translate_modul m; name = "CONSTANTES"}; name = String.uppercase n }
(** 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 }
{ 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 ~full:true 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 q q_ty = (* TODO java recursive qualname ! *)
let translate_constructor_name_2 q q_ty =
let classe = qualname_to_class_name q_ty in
let q = qualname_to_class_name q in
{ q with name = classe.name ^ "." ^ q.name }
{ qual = QualModule classe; name = String.uppercase q.name }
let translate_constructor_name q =
match 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 q q_ty
| 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_class_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 ->
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)
(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.Sconstructor c -> let c = translate_constructor_name c in Sconstructor c
| Types.Sfield f -> eprintf "ojSfield @."; assert false;
| Types.Stuple t -> eprintf "ojStuple@."; assert false;
(* TODO java ?? not too difficult if needed, return Tuplen<..>() *)
| Types.Stuple se_l -> tuple param_env se_l
| Types.Sarray_power _ -> eprintf "ojSarray_power@."; assert false; (* TODO java array *)
| Types.Sarray se_l -> Enew_array (ty param_env se.Types.se_ty, List.map (static_exp param_env) se_l)
| Types.Srecord _ -> eprintf "ojSrecord@."; 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.string_of_int in
Tgeneric ({ qual = "heptagon"; name = "Tuple"^ln }, List.map (boxed_ty param_env) ty_l)
| 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 -> 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.Tasync (_,t) -> Tgeneric (Names.pervasives_qn "Future", [boxed_ty param_env t])
| Types.Tunit -> Tunit
and tuple_ty param_env ty_l =
let ln = ty_l |> List.length |> Pervasives.string_of_int in
Tgeneric ({ qual = java_pervasives; name = "Tuple"^ln }, List.map (boxed_ty param_env) ty_l)
and ty param_env t :Java.ty = match t with
| Types.Tprod ty_l ->
let ln = ty_l |> List.length |> Pervasives.string_of_int in
Tgeneric ({ qual = "heptagon"; name = "Tuple"^ln }, List.map (boxed_ty param_env) ty_l)
| 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 -> 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.Tasync (_,t) -> Tgeneric (Names.pervasives_qn "Future", [boxed_ty param_env t])
| Types.Tunit -> Tunit
let var_dec param_env vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident }
and var_dec param_env vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident }
let var_dec_list param_env vd_l = List.map (var_dec param_env) vd_l
and var_dec_list param_env vd_l = List.map (var_dec param_env) vd_l
let rec exp param_env e = match e.e_desc with
and exp param_env e = match e.e_desc with
| Obc.Epattern p -> Eval (pattern param_env p)
| Obc.Econst se -> static_exp param_env se
| Obc.Eop (op,e_l) -> Efun (op, exp_list param_env e_l)
| Obc.Estruct _ -> eprintf "ojEstruct@."; assert false (* TODO java *)
| Obc.Earray e_l -> Enew_array (ty param_env e.e_ty, exp_list param_env e_l)
| Obc.Ebang _ -> eprintf "ojEbang@."; assert false (* TODO java async *)
| Obc.Ebang e -> Emethod_call (exp param_env e,"get",[])
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 -> 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
@ -133,20 +156,23 @@ and pattern param_env p = match p.pat_desc with
| Obc.Larray (p,e) -> Parray_elem (pattern param_env p, exp param_env e)
let obj_ref param_env o = match o with
| Oobj id -> Pvar id
| Oarray (id,p) -> Parray_elem (Pvar id, Eval (pattern param_env p))
| Oobj id -> Eval (Pvar id)
| Oarray (id,p) -> Eval (Parray_elem (Pvar id, Eval (pattern param_env p)))
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.Acall ([], obj, Mstep, e_l) ->
| Obc.Acall ([], obj, Mstep, e_l)
| Obc.Aasync_call (_,[], 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) ->
| Obc.Acall ([p], obj, Mstep, e_l)
| Obc.Aasync_call (_,[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, ecall) in
assgn::acts
| Obc.Acall (p_l, obj, Mstep, e_l) ->
| Obc.Acall (p_l, obj, Mstep, e_l)
| Obc.Aasync_call (_,p_l, obj, Mstep, 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
@ -157,10 +183,10 @@ let rec act_list param_env act_l acts =
in
let copies = Misc.mapi copy_return_to_var p_l in
assgn::(copies@acts)
| Obc.Acall (_, obj, Mreset, _) ->
| Obc.Acall (_, obj, Mreset, _)
| Obc.Aasync_call (_,_, obj, Mreset, _) ->
let acall = Amethod_call (obj_ref param_env obj, "reset", []) in
acall::acts
| Obc.Aasync_call _ -> assert false (* TODO java async *)
| Obc.Acase (e, c_b_l) when e.e_ty = Types.Tid Initial.pbool ->
(match c_b_l with
| [] -> acts
@ -169,8 +195,8 @@ let rec act_list param_env act_l 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,b) -> c = Initial.ptrue) c_b_l in
let _, _else = List.find (fun (c,b) -> c = Initial.pfalse) c_b_l in
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) = translate_constructor_name c, block param_env b in
@ -188,58 +214,193 @@ and block param_env ?(locals=[]) ?(end_acts=[]) ob =
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 = { 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 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 (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, Eval (Pvar vd.vd_ident)) in
List.map _vd vd_l
let create_async_classe async base_classe =
let classe_name = base_classe.o_class |> Names.shortname |> (fun n -> "Async_factory_"^n) |> fresh_classe in
let callable_name = base_classe.o_class |> Names.shortname |> (fun n -> "Async_"^n) in
let callable_classe_name = {qual = QualModule classe_name; name = callable_name } in
Idents.enter_node classe_name;
(* Base class signature *)
let { node_inputs = b_in;
node_outputs = b_out;
node_statefull = b_stateful;
node_params = b_params; } = Modules.find_value base_classe.o_class in
(* Fields *)
(* [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 b_params in
let f = vds_to_fields ~protection:Pprotected v in
let e = vds_to_exps v in
f, v, e, env
in
(* [instance] : field used to represent the instance of the base classe *)
let field_inst, ty_inst, id_inst, var_inst, vd_inst =
let t = Tclass (qualname_to_class_name base_classe.o_class) in
let id = base_classe.o_ident in
mk_field ~protection:Pprotected t id, t, id, mk_var id, mk_var_dec id t
in
(* [result] : field used to stock the asynchronous result *)
let field_result, ty_aresult, ty_result, id_result, var_result =
let t = b_out |> Signature.types_of_arg_list |> Types.prod in
let ty_result = boxed_ty param_env t in
let t = Types.Tasync(async, t) in
let aty = ty param_env t in
let result_id = Idents.gen_var "obc2java" "result" in
mk_field ~protection:Pprotected aty result_id, aty, ty_result, result_id, mk_var result_id
in
let fields = field_inst::field_result::fields_params in
(* [step] arguments *)
let fields_step, vds_step, exps_step =
let v = sig_args_to_vds param_env b_in in
let e = vds_to_exps v in
let f = vds_to_fields v in
f, v, e
in
(* Methods *)
let constructor, reset =
let body, body_r =
let acts_params = copy_to_this vds_params in
let act_inst = Aassgn (Pthis id_inst, Enew (ty_inst, exps_params)) in
let act_result = Aassgn (Pthis id_result, Snull) in
mk_block (act_result::act_inst::acts_params)
, mk_block [act_result; act_inst]
in
mk_methode ~args:vds_params body (shortname classe_name)
, mk_methode body_r "reset"
in
let step =
let body =
let act_syncronize =
Aif( Efun(Initial.mk_pervasives "<>", [Snull; var_result])
, mk_block [Amethod_call(var_result, "get", [])])
in
let act_result =
let exp_call =
let args = var_inst::exps_step in
let executor = Eval (Pfield (Pclass java_pervasives_class, "executor_cached")) in
Emethod_call (executor, "submit", [Enew (Tclass callable_classe_name, args)] )
in Aassgn (Pthis id_result, exp_call)
in
let act_return = Areturn var_result in
mk_block [act_syncronize; act_result; act_return]
in mk_methode ~throws:throws_async ~args:vds_step ~returns:ty_aresult body "step"
in
(* Inner class *)
let callable_class =
let fields = field_inst::fields_step in
let constructor =
let body =
let acts_init = copy_to_this (vd_inst::vds_step) in
mk_block acts_init
in mk_methode ~args:(vd_inst::vds_step) body (shortname callable_classe_name)
in
let call =
let body =
let act = Areturn (Emethod_call (Eval (Pthis id_inst), "step", exps_step)) in
mk_block [act]
in mk_methode ~returns:ty_result body "call"
in mk_classe ~protection:Pprotected ~static:true ~fields:fields ~implements:[java_callable]
~constrs:[constructor] ~methodes:[call] callable_classe_name
in
mk_classe ~imports:import_async ~fields:fields ~constrs:[constructor]
~methodes:[step;reset] ~classes:[callable_class] classe_name
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" (String.uppercase 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
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
(* [obj_env] gives the type of an [obj_ident], needed in async because we change the classe for async obj *)
let constructeur, param_env, obj_env =
let obj_env = (* In async we change the type of the async objects *)
let aux obj_env od =
let t = match od.o_async with
| None -> Tclass (qualname_to_class_name od.o_class)
| Some a -> let c = create_async_classe a od in add_classe c; Tclass c.c_name
in Idents.Env.add od.o_ident t obj_env
in List.fold_left aux Idents.Env.empty cd.cd_objs
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
(* Initialize the objects *)
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)) ]
| None ->
let t = Idents.Env.find od.o_ident obj_env in
[ Aassgn (Pthis od.o_ident, Enew (t, params)) ]
| Some size ->
let size = static_exp param_env size in
let assgn_elem i =
[ Aassgn (Parray_elem (Pthis od.o_ident, mk_var i), Enew (Tclass od.o_class, params)) ]
in
[ Aassgn (Pthis od.o_ident, Enew (Tarray (Tclass od.o_class,size), []));
let t = Idents.Env.find od.o_ident obj_env in
let assgn_elem i = [ Aassgn (Parray_elem (Pthis od.o_ident, mk_var i), Enew (t, params)) ] in
[ Aassgn (Pthis od.o_ident, Enew_array (Tarray (t,size), []));
fresh_for size assgn_elem ]
in
act@acts
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
let acts_init_params = copy_to_this vds_params in
let acts = List.fold_left obj_init_act acts_init_params cd.cd_objs in
{ b_locals = []; b_body = acts }
in
mk_methode ~args:args body (shortname class_name), param_env
mk_methode ~args:vds_params body (shortname class_name), param_env, 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 -> Tclass (qualname_to_class_name od.o_class)
| Some size -> Tarray (Tclass (qualname_to_class_name od.o_class), static_exp param_env size)
| None -> Idents.Env.find od.o_ident obj_env
| Some size -> Tarray (Idents.Env.find od.o_ident obj_env, 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
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 step =
let ostep = find_step_method cd in
@ -251,14 +412,15 @@ let class_def_list classes cd_l =
| 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.Obc.m_body in
mk_methode ~args:(var_dec_list param_env ostep.Obc.m_inputs) ~returns:return_ty body "step"
mk_methode ~throws:throws_async ~args:(var_dec_list param_env ostep.Obc.m_inputs) ~returns:return_ty body "step"
in
let reset =
let oreset = find_reset_method cd in
let body = block param_env oreset.Obc.m_body in
mk_methode body "reset"
in
let classe = mk_classe ~fields:fields ~constrs:[constructeur] ~methodes:[step;reset] class_name in
let classe = mk_classe ~imports:import_async ~fields:fields
~constrs:[constructeur] ~methodes:[step;reset] class_name in
classe::classes
in
List.fold_left class_def classes cd_l
@ -267,17 +429,20 @@ let class_def_list 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_class_name td.t_name in
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" 1 (* TODO java *)
| Type_alias ot -> classes (* TODO java alias ?? *)
| Type_abs -> Misc.unsupported "obc2java, abstract type." 1
| Type_alias _ -> Misc.unsupported "obc2java, type alias." 2
| Type_enum c_l ->
let mk_constr_enum c = _translate_constructor_name c td.t_name in
let mk_constr_enum c = translate_constructor_name_2 c td.t_name in
(mk_enum (List.map mk_constr_enum c_l) 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 (* TODO java pretty ugly *)
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
(mk_classe ~fields:(List.map mk_field_jfield f_l) classe_name) :: classes
@ -285,27 +450,30 @@ let type_dec_list classes td_l =
List.fold_left _td classes td_l
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 |> Idents.ident_of_name in (* TODO java pretty ugly*)
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
match cd_l with
| [] -> []
| _ ->
let classe_name = "CONSTANTES" |> name_to_classe_name in
let fields = List.map mk_const_field cd_l in
[mk_classe ~fields:fields classe_name]
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 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
get_classes()@p

2
compiler/obc/ml/misc.ml
View file

@ -15,7 +15,7 @@ let version = "3.0b"
let date = DATE
(* standard module *)
let pervasives_module = "Pervasives"
let pervasives_module = Pervasives
let standard_lib = STDLIB
(* variable creation *)

7
compiler/obc/obc.ml
View file

@ -76,11 +76,12 @@ and block =
and var_dec =
{ v_ident : var_ident;
v_type : ty; (* TODO GD should be here, v_controllable : bool *)
v_type : ty;
v_loc : location }
type obj_dec =
{ o_ident : obj_ident;
o_async : async_t option;
o_class : class_name;
o_params : static_exp list;
o_size : static_exp option; (** size of the array if the declaration is an array of obj *)
@ -101,8 +102,8 @@ type class_def =
cd_loc : location }
type program =
{ p_modname : name;
p_opened : name list;
{ p_modname : modul;
p_opened : modul list;
p_types : type_dec list;
p_consts : const_dec list;
p_defs : class_def list }

4
compiler/obc/obc_printer.ml
View file

@ -179,9 +179,7 @@ let print_type_def ff { t_name = name; t_desc = tdesc } =
fprintf ff "@]@.@]"
let print_open_module ff name =
fprintf ff "@[open ";
print_name ff name;
fprintf ff "@.@]"
fprintf ff "open %s@." (modul_to_string name)
let print_const_dec ff c =
fprintf ff "const %a = %a@." print_qualname c.c_name

2
compiler/obc/obc_utils.ml
View file

@ -67,5 +67,5 @@ struct
obj_dec = deps_obj_dec;
} in
let (_, deps) = Obc_mapfold.program funs S.empty p in
S.remove p.p_modname (S.remove "Pervasives" deps)
S.remove p.p_modname (S.remove Pervasives deps)
end

2
compiler/utilities/global/compiler_options.ml
View file

@ -15,7 +15,7 @@ let version = "0.4"
let date = "DATE"
(* standard module *)
let pervasives_module = "Pervasives"
let pervasives_module = Pervasives
let standard_lib = "STDLIB"
let standard_lib = try Sys.getenv "HEPTLIB" with Not_found -> standard_lib

11
compiler/utilities/global/compiler_utils.ml
View file

@ -58,14 +58,13 @@ let silent_pass d enabled f p =
then do_silent_pass d f p
else p
let build_path suf =
match !target_path with
| None -> suf
| Some path -> Filename.concat path suf
let filename_of_name n =
String.uncapitalize n
let clean_dir dir =
if Sys.file_exists dir && Sys.is_directory dir
then begin
@ -74,6 +73,12 @@ let clean_dir dir =
end else Unix.mkdir dir 0o740;
dir
let ensure_dir dir =
if not (Sys.file_exists dir && Sys.is_directory dir)
then Unix.mkdir dir 0o740
exception Cannot_find_file of string
let findfile filename =

32
compiler/utilities/misc.ml
View file

@ -158,16 +158,26 @@ let fold_righti f l acc =
| h :: l -> f i h (aux (i + 1) l acc) in
aux 0 l acc
exception Assert_false
let internal_error passe code =
Format.eprintf "@.---------\nInternal compiler error\nPasse : %s, Code : %d\n----------@." passe code;
raise Assert_false
exception Unsupported
let unsupported passe code =
Format.eprintf "@.---------\nUnsupported feature, please report it\nPasse : %s, Code : %d\n----------@." passe code;
raise Unsupported
(* Functions to decompose a list into a tuple *)
let _arity_error i l =
Format.eprintf "Internal compiler error: \
wrong list size (found %d, expected %d).@." (List.length l) i;
assert false
Format.eprintf "@.---------\nInternal compiler error: \
wrong list size (found %d, expected %d).\n----------@." (List.length l) i;
raise Assert_false
let _arity_min_error i l =
Format.eprintf "Internal compiler error: \
wrong list size (found %d, expected %d at least).@." (List.length l) i;
assert false
Format.eprintf "@.---------\nInternal compiler error: \
wrong list size (found %d, expected %d at least).\n----------@." (List.length l) i;
raise Assert_false
let assert_empty = function
| [] -> ()
@ -199,14 +209,4 @@ let split_string s separator = Str.split (separator |> Str.quote |> Str.regexp)
let file_extension s = split_string s "." |> last_element
exception Assert_false
let internal_error passe code =
Format.eprintf "@.---------\nInternal compiler error\nPasse : %s, Code : %d\n----------@." passe code;
raise Assert_false
exception Unsupported
let unsupported passe code =
Format.eprintf "@.---------\nUnsupported feature, please report it\nPasse : %s, Code : %d\n----------@." passe code;
raise Unsupported

BIN
lib/java/jeptagon.jar Normal file
View file

Binary file not shown.

98
lib/java/jeptagon/Pervasives.java Normal file
View file

@ -0,0 +1,98 @@
package jeptagon;
public class Pervasives {
public static final java.util.concurrent.ExecutorService executor_cached = java.util.concurrent.Executors.newCachedThreadPool();
public static class Tuple1 <T> {
public final T c0;
public Tuple1(T v) {
c0 = v;
}
}
public static class Tuple2 <T0,T1> {
public final T0 c0;
public final T1 c1;
public Tuple2(T0 v0, T1 v1) {
c0 = v0;
c1 = v1;
}
}
public static class Tuple3 <T0,T1,T2> {
public final T0 c0;
public final T1 c1;
public final T2 c2;
public Tuple3(T0 v0, T1 v1, T2 v2) {
c0 = v0;
c1 = v1;
c2 = v2;
}
}
public static class Tuple4 <T0,T1,T2,T3> {
public final T0 c0;
public final T1 c1;
public final T2 c2;
public final T3 c3;
public Tuple4(T0 v0, T1 v1, T2 v2, T3 v3) {
c0 = v0;
c1 = v1;
c2 = v2;
c3 = v3;
}
}
public static class Tuple5 <T0,T1,T2,T3,T4> {
public final T0 c0;
public final T1 c1;
public final T2 c2;
public final T3 c3;
public final T4 c4;
public Tuple5(T0 v0, T1 v1, T2 v2, T3 v3, T4 v4) {
c0 = v0;
c1 = v1;
c2 = v2;
c3 = v3;
c4 = v4;
}
}
public static class Tuple6 <T0,T1,T2,T3,T4,T5> {
public final T0 c0;
public final T1 c1;
public final T2 c2;
public final T3 c3;
public final T4 c4;
public final T5 c5;
public Tuple6(T0 v0, T1 v1, T2 v2, T3 v3, T4 v4, T5 v5) {
c0 = v0;
c1 = v1;
c2 = v2;
c3 = v3;
c4 = v4;
c5 = v5;
}
}
public static class Tuple7 <T0,T1,T2,T3,T4,T5,T6> {
public final T0 c0;
public final T1 c1;
public final T2 c2;
public final T3 c3;
public final T4 c4;
public final T5 c5;
public final T6 c6;
public Tuple7(T0 v0, T1 v1, T2 v2, T3 v3, T4 v4, T5 v5, T6 v6) {
c0 = v0;
c1 = v1;
c2 = v2;
c3 = v3;
c4 = v4;
c5 = v5;
c6 = v6;
}
}
}

6
test/async/java_m Executable file
View file

@ -0,0 +1,6 @@
#!/bin/bash
cp $@ build/
cd build
../../../heptc -target java $@
cd ..

6
test/async/obc_m Executable file
View file

@ -0,0 +1,6 @@
#!/bin/bash
cp $@ build/
cd build
../../../heptc -target obc $@
cd ..

25
test/async/pipline.ept Normal file
View file

@ -0,0 +1,25 @@
fun sum (x,m: int) returns (s: int)
let
s = x + m
tel
fun substr (x,m: int) returns (d: int; m2:int)
let
d = x - m;
m2 = m;
tel
fun mean<<n: int>> (i: int^n) returns (m: int)
let
m = fold sum <<n>> (i,0)
tel
node normalized_movie<<n: int>> (i: int^n) returns (im: int^n)
var m: int; trash: int;
let
m = mean<<n>>(i);
(im,trash) = mapfold substr <<n>> (i,m)
tel

20
test/async/pipline_a.ept Normal file
View file

@ -0,0 +1,20 @@
fun substr (x,m: int) returns (d: int; m2:int)
let
d = x - m;
m2 = m;
tel
fun mean<<n: int>> (i: int^n) returns (m: int)
let
m = (fold (+) <<n>> (i,0) )/n
tel
node normalized_movie<<n: int>> (i: int^n) returns (im: int^n)
var m: async int; trash: int;
let
m = async mean<<n>>(i);
(im,trash) = mapfold substr <<n>> (i fby i, 0 -> !(pre m))
tel

25
test/async/pipline_b.ept Normal file
View file

@ -0,0 +1,25 @@
fun sum (x,m: int) returns (s: int)
let
s = x + m
tel
fun substr (x,m: int) returns (d: int; m2:int)
let
d = x - m;
m2 = m;
tel
fun mean<<n: int>> (i: int^n) returns (m: int)
let
m = fold sum <<n>> (i,0)
tel
node normalized_movie<<n: int>> (i: int^n) returns (im: int^n)
var m: int; trash: int;
let
m = mean<<n>>(i);
(im,trash) = mapfold substr <<n>> (i fby i, 0 -> (pre m))
tel

4
test/bad/t11-initialization.ept
View file

@ -1,4 +1,4 @@
node mmm(x: int) returns (o': int)
node mmm(x: int) returns (o2: int)
var last m: int; o: int;
let
automaton
@ -7,5 +7,5 @@ node mmm(x: int) returns (o': int)
state J
do m = last m + 1; o = 0
end;
o' = 1 -> pre o
o2 = 1 -> pre o
tel

3
test/check
View file

@ -91,7 +91,7 @@ launch_check () {
score=`expr $score + 1`;
fi
done
echo
echo "Tests goods"
for f in ../good/*.ept; do
echec=0
@ -235,6 +235,7 @@ while [ $# -gt 0 ]; do
"-h" )
echo "usage : $0 <options> <compilo>"
echo "options : "
echo "-clean : clean build dir"
echo "-java : test of code generation (java code)"
echo "-c : test of code generation (c code)"
echo "-all : test all"

8
test/good/bad_updown.ept
View file

@ -1,12 +1,12 @@
node updown(b : bool) returns (o : bool)
var o',on_off:bool;
var o2,on_off:bool;
let
on_off = true;
automaton
state Down
do o' = false until on_off then Up
do o2 = false until on_off then Up
state Up
do o' = true until on_off then Down
do o2 = true until on_off then Down
end;
o = merge b (true-> o') (false -> false)
o = merge b (true-> o2) (false -> false)
tel

6
test/good/flatten.ept
View file

@ -3,12 +3,12 @@ node f(x,y : int; b : bool) returns (z : int)
var t : int;
let
do
var t2,t2' : int; in
t2 = if b then 0 else t2';
var t2,t22 : int; in
t2 = if b then 0 else t22;
do
var t3 : int; in
t3 = y + t;
t2' = t3;
t22 = t3;
done;
t = x + t2;
done;

4
test/good/statics2.ept
View file

@ -24,9 +24,9 @@ let
o = f<<m + k2>>();
tel
fun h() returns (y,y':int)
fun h() returns (y,y2:int)
let
y = c2 + g<<c2>>() + i<<k2>>();
y' = c2 + Statics.g<<k2>>() + Statics.i<<k2>>();
y2 = c2 + Statics.g<<k2>>() + Statics.i<<k2>>();
tel

16
test/good/t1.ept
View file

@ -17,7 +17,7 @@ node mm(x: int) returns (o: int)
end
tel
node mmm(x: int) returns (o': int)
node mmm(x: int) returns (o2: int)
var last m: int = 1; o: int;
let
automaton
@ -26,21 +26,21 @@ node mmm(x: int) returns (o': int)
state J
do m = last m + 1; o = 0
end;
o' = 1 -> pre o
o2 = 1 -> pre o
tel
node m(x: int) returns (o: int)
var last o' : int = 1;
var last o2 : int = 1;
let
automaton
state I
do o' = 1
unless (last o' = 2) then J
do o2 = 1
unless (last o2 = 2) then J
state J
do o' = 3
unless (last o' = 1) then I
do o2 = 3
unless (last o2 = 1) then I
end;
o = o';
o = o2;
tel
node h(z: int; x, y: int) returns (o2: int)

6
test/good/t2.ept
View file

@ -32,13 +32,13 @@ node g(x: bool) returns (o: bool)
tel
node hhh() returns ()
var last o' : int = 0;
var last o2 : int = 0;
let
automaton
state S1
var r: int;
do o' = 1; r = 2
unless last o' = 0 then S1
do o2 = 1; r = 2
unless last o2 = 0 then S1
end
tel

4
test/good/t9.ept
View file

@ -4,8 +4,8 @@
node f(x,z:int) returns (o1,o2:int)
let
switch (x = z)
| true var o'1: int; o'2: int;
do (o'1, o'2) = (1, 2); o1 = o'1; o2 = o'2;
| true var o12: int; o22: int;
do (o12, o22) = (1, 2); o1 = o12; o2 = o22;
| false do (o2, o1) = (3, 3);
end
tel

4
test/good/test.ept
View file

@ -11,12 +11,12 @@ let
tel
node updown'() returns (y:int)
node updown2() returns (y:int)
let
y = (0 fby y) + 1
tel
node main() returns (y:int)
let
y = updown'();
y = updown2();
tel

16
test/good/when_merge1.ept
View file

@ -25,7 +25,7 @@ node mm(x: int) returns (o: int)
end
tel
node mmm(x: int) returns (o': int)
node mmm(x: int) returns (o2: int)
var last m: int = 1; o: int;
let
automaton
@ -34,21 +34,21 @@ node mmm(x: int) returns (o': int)
state J
do m = last m + 1; o = 0
end;
o' = 1 -> pre o
o2 = 1 -> pre o
tel
node m(x: int) returns (o: int)
var last o' : int = 1;
var last o2 : int = 1;
let
automaton
state I
do o' = 1
unless (last o' = 2) then J
do o2 = 1
unless (last o2 = 2) then J
state J
do o' = 3
unless (last o' = 1) then I
do o2 = 3
unless (last o2 = 1) then I
end;
o = o';
o = o2;
tel
node h(z: int; x, y: int) returns (o2: int)