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

Clean up documentation comments

Browse source
This commit is contained in:
Gwenaël Delaval 2017-03-03 11:41:57 +01:00
parent 2e107cd872
commit 2f18926bf4
16 changed files with 165 additions and 145 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
compiler/global/idents.ml
View file

@ -116,8 +116,12 @@ module S = Set.Make (struct type t = string
module UniqueNames =
struct
open Names
let used_names = ref (ref NamesSet.empty) (** Used strings in the current node *)
let env = ref Env.empty (** Map idents to their string *)
(** Used strings in the current node *)
let used_names = ref (ref NamesSet.empty)
(** Map idents to their string *)
let env = ref Env.empty
let (node_env : NamesSet.t ref QualEnv.t ref) = ref QualEnv.empty
let name_counters = Hashtbl.create 500

32
compiler/global/modules.ml
View file

@ -38,8 +38,8 @@ open Names
exception Already_defined
(** Warning: Whenever this type is modified,
interface_format_version in signature.ml should be incremented. *)
(* Warning: Whenever this type is modified,
interface_format_version in signature.ml should be incremented. *)
(** Object serialized in compiled interfaces. *)
type module_object =
{ m_name : Names.modul;
@ -51,24 +51,16 @@ type module_object =
m_format_version : string; }
type env = {
(** Current module name *)
mutable current_mod : modul;
(** Modules opened and loaded into the env *)
mutable opened_mod : modul list;
(** Modules loaded into the env *)
mutable loaded_mod : modul list;
(** Node definitions *)
mutable values : node QualEnv.t;
(** Type definitions *)
mutable types : type_def QualEnv.t;
(** Constants definitions *)
mutable consts : const_def QualEnv.t;
(** Constructors mapped to their corresponding type *)
mutable constrs : qualname QualEnv.t;
(** Fields mapped to their corresponding type *)
mutable fields : qualname QualEnv.t;
(** Accepted compiled interface version *)
format_version : string }
mutable current_mod : modul; (** Current module name *)
mutable opened_mod : modul list; (** Modules opened and loaded into the env *)
mutable loaded_mod : modul list; (** Modules loaded into the env *)
mutable values : node QualEnv.t; (** Node definitions *)
mutable types : type_def QualEnv.t; (** Type definitions *)
mutable consts : const_def QualEnv.t; (** Constants definitions *)
mutable constrs : qualname QualEnv.t; (** Constructors mapped to their corresponding type *)
mutable fields : qualname QualEnv.t; (** Fields mapped to their corresponding type *)
format_version : string (** Accepted compiled interface version *)
}
(** The global environnement *)
let g_env =

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

@ -157,35 +157,42 @@ module Rename =
struct
include
(Map.Make (struct type t = string let compare = String.compare end))
(** Rename a var *)
let var loc env n =
try fst (find n env)
with Not_found -> Error.message loc (Evar_unbound n)
(** Rename a last *)
let last loc env n =
try
let id, last = find n env in
if not last then Error.message loc (Enot_last n) else id
with Not_found -> Error.message loc (Evar_unbound n)
(** Adds a name to the list of used names and idents. *)
let add_used_name env n =
add n (ident_of_name n, false) env
(** Add a var *)
let add_var loc env n =
if mem n env then Error.message loc (Evariable_already_defined n)
else
add n (ident_of_name n, false) env
(** Add a last *)
let add_last loc env n =
if mem n env then Error.message loc (Evariable_already_defined n)
else
add n (ident_of_name n, true) env
(** Add a var dec *)
let add env vd =
let add = match vd.v_last with
| Var -> add_var
| Last _ -> add_last in
add vd.v_loc env vd.v_name
(** Append a list of var dec *)
let append env vd_list = List.fold_left add env vd_list
end

2
compiler/heptagon/transformations/itfusion.ml
View file

@ -134,7 +134,7 @@ let edesc funs acc ed =
let ed, acc = Hept_mapfold.edesc funs acc ed in
match ed with
| Eiterator(Imap, f, n, [], e_list, r) ->
(** @return the list of inputs of the anonymous function,
(* @return the list of inputs of the anonymous function,
a list of created equations (the body of the function),
the args for the call of f in the lambda,
the args for the iterator (ie the arrays).

4
compiler/main/heptc.ml
View file

@ -148,7 +148,7 @@ let main () =
"-nbvars", Arg.Set nbvars, doc_nbvars;
"-itfusion", Arg.Set do_iterator_fusion, doc_itfusion;
"-strict_ssa", Arg.Unit set_strict_ssa, doc_strict_ssa;
"-nosink", Arg.Set nosink, doc_nosink;
"-nosink", Arg.Set nosink, doc_nosink;
"-memalloc", Arg.Unit do_mem_alloc_and_typing, doc_memalloc;
"-only-memalloc", Arg.Set do_mem_alloc, doc_memalloc_only;
"-only-linear", Arg.Set do_linear_typing, doc_linear_only;
@ -168,5 +168,5 @@ let main () =
| Errors.Error -> exit 2;;
(** Launch the [main] *)
(* Launch the [main] *)
main ()

15
compiler/main/hepts.ml
View file

@ -32,7 +32,6 @@
(* Graphical simulator *)
open Compiler_utils
open Errors
open Modules
open Signature
open Names
@ -272,12 +271,12 @@ let create_input v_name v_ty n (table:GPack.table) =
let rec input name =
let _ = check_type name in
begin try
let ty = find_type name in
let ty = find_type name in
begin
match ty with
| Tenum(clist) -> new enum_input name.qual clist table n
| Talias(Tid name) -> input name
| _ -> new entry_input "" table n
match ty with
| Tenum(clist) -> new enum_input name.qual clist table n
| Talias(Tid name) -> input name
| _ -> new entry_input "" table n
end
with Not_found ->
new entry_input "" table n
@ -367,7 +366,7 @@ let main () =
if (!mod_name = "") || (!node_name = "") || (!exec_name = "") then
begin
Arg.usage arg_list usage_msg;
raise Error
raise Errors.Error
end;
open_module (Module !mod_name);
@ -827,4 +826,4 @@ let main () =
win#show ();
GtkThread.main () ;;
try main () with Error -> exit 2;;
try main () with Errors.Error -> exit 2;;

33
compiler/minils/analysis/interference.ml
View file

@ -355,7 +355,9 @@ let compute_live_vars eqs =
let alive_vars = List.fold_left VarEnv.add_ivar alive_vars read_ivars in
(* remove vars defined in this equation *)
let alive_vars =
List.fold_left (fun alive_vars id -> VarEnv.remove_except_mem id alive_vars) alive_vars def_ivars
List.fold_left (fun alive_vars id -> VarEnv.remove_except_mem id alive_vars)
alive_vars
def_ivars
in
print_debug "%a@," Mls_printer.print_eq eq;
print_debug_var_env "alive" alive_vars;
@ -419,7 +421,7 @@ let init_interference_graph () =
let ty = Static.simplify_type Names.QualEnv.empty (World.ivar_type iv) in
TyEnv.add_element ty (Interference_graph.mk_node iv) env
in
(** Adds a node for the variable and all fields of a variable. *)
(* Adds a node for the variable and all fields of a variable. *)
let add_ivar env iv ty =
let ivars = all_ivars [] iv None ty in
List.fold_left add_tyenv env ivars
@ -536,7 +538,7 @@ let find_targeting f =
corresponding to live vars sets are already added by build_interf_graph.
*)
let process_eq ({ eq_lhs = pat; eq_rhs = e } as eq) =
(** Other cases*)
(* Other cases*)
match pat, e.e_desc with
| _, Eiterator((Imap|Imapi), { a_op = Enode _ | Efun _ }, _, pw_list, w_list, _) ->
let invars = InterfRead.ivars_of_extvalues w_list in
@ -626,10 +628,15 @@ let add_init_return_eq f =
Eapp(mk_app Earray, decs@mems, None)
in
(** a_1,..,a_p = __init__ *)
let eq_init = mk_equation false (pat_from_dec_list f.n_input)
(mk_extvalue_exp Clocks.Cbase Initial.tint ~linearity:Ltop (Wconst (Initial.mk_static_int 0))) in
(** __return__ = o_1,..,o_q, mem_1, ..., mem_k *)
(* a_1,..,a_p = __init__ *)
let eq_init =
mk_equation false
(pat_from_dec_list f.n_input)
(mk_extvalue_exp Clocks.Cbase
Initial.tint
~linearity:Ltop
(Wconst (Initial.mk_static_int 0))) in
(* __return__ = o_1,..,o_q, mem_1, ..., mem_k *)
let eq_return = mk_equation false (Etuplepat [])
(mk_exp Clocks.Cbase Tinvalid ~linearity:Ltop (tuple_from_dec_and_mem_list f.n_output)) in
(eq_init::f.n_equs)@[eq_return]
@ -643,15 +650,15 @@ let coalesce_mems () =
let build_interf_graph f =
World.init f;
(** Init interference graph *)
(* Init interference graph *)
init_interference_graph ();
let eqs = add_init_return_eq f in
(** Build live vars sets for each equation *)
(* Build live vars sets for each equation *)
let live_vars = compute_live_vars eqs in
(* Coalesce linear variables *)
coalesce_linear_vars ();
(** Other cases*)
(* Other cases *)
List.iter process_eq f.n_equs;
(* Add interferences from live vars set*)
add_interferences live_vars;
@ -713,13 +720,13 @@ let create_subst_lists igs =
List.flatten (List.map create_one_ig igs)
let node _ acc f =
(** Build the interference graphs *)
(* Build the interference graphs *)
let igs = build_interf_graph f in
(** Color the graph *)
(* Color the graph *)
color_interf_graphs igs;
if print_interference_graphs then
print_graphs f igs;
(** Remember the choice we made for code generation *)
(* Remember the choice we made for code generation *)
{ f with n_mem_alloc = create_subst_lists igs }, acc
let program p =

1
compiler/minils/main/mls_compiler.ml
View file

@ -29,7 +29,6 @@
(***********************************************************************)
open Compiler_utils
open Compiler_options
open Names
let pp p = if !verbose then Mls_printer.print stdout p

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

@ -60,7 +60,8 @@ end
module Param_instances :
sig
type key = private static_exp (** Fully instantiated param *)
(** Fully instantiated param *)
type key = private static_exp
type env = key QualEnv.t
val instantiate: env -> static_exp list -> key list
val get_node_instances : QualEnv.key -> key list list
@ -77,19 +78,22 @@ struct
(** An instance is a list of instantiated params *)
type instance = key list
(** two instances are equal if the desc of keys are equal *)
let compare_instances =
let compare se1 se2 = compare se1.se_desc se2.se_desc in
Misc.list_compare compare
module S = (** Instances set *)
(** Instances set *)
module S =
Set.Make(
struct
type t = instance
let compare = compare_instances
end)
module M = (** Map instance to its instantiated node *)
(** Map instance to its instantiated node *)
module M =
Map.Make(
struct
type t = qualname * instance
@ -235,15 +239,17 @@ end
open Param_instances
type info =
{ mutable opened : program ModulEnv.t;
mutable called_nodes : ((qualname * static_exp list) list) QualEnv.t; }
type info = {
mutable opened : program ModulEnv.t; (** Opened programs *)
mutable called_nodes : ((qualname * static_exp list) list) QualEnv.t;
(** Maps a node to the list of (node name, params) it calls *)
}
let info =
{ (** opened programs*)
{
opened = ModulEnv.empty;
(** Maps a node to the list of (node name, params) it calls *)
called_nodes = QualEnv.empty }
called_nodes = QualEnv.empty
}
(** Loads the modname.epo file. *)
let load_object_file modul =
@ -297,7 +303,7 @@ let node_by_longname node =
(** @return the list of nodes called by the node named [ln], with the
corresponding params (static parameters appear as free variables). *)
let collect_node_calls ln =
(** only add nodes when not external and with params *)
(* only add nodes when not external and with params *)
let add_called_node ln params acc =
match params with
| [] -> acc

1
compiler/myocamlbuild_config.ml
View file

@ -51,7 +51,6 @@ let ocamlfind_after_rules () =
(* Use both ml and mli files to build documentation: *)
rule "ocaml: ml & mli -> odoc"
~insert:`top
~tags:["ocaml"; "doc"; "doc_use_interf_n_implem"]
~prod:"%.odoc"
(* "%.cmo" so that cmis of ml dependencies are already built: *)
~deps:["%.ml"; "%.mli"; "%.cmo"]

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

@ -73,11 +73,11 @@ type cty =
variable declarations before a list of semicolon-separated statements, the
whole thing being enclosed in curly braces. *)
type cblock = {
var_decls : (string * cty) list;
(** Variable declarations, where each declaration consists of a variable
name and the associated C type. *)
var_decls : (string * cty) list;
(** The actual statement forming our block. *)
block_body : cstm list;
(** The actual statement forming our block. *)
}
(* TODO: The following types for C expressions would be better using polymorphic
@ -97,17 +97,20 @@ and cexpr =
| Cderef of cexpr (** Pointer dereference, *ptr. *)
| Cfield of cexpr * qualname (** Field access to left-hand-side. *)
| Carray of cexpr * cexpr (** Array access cexpr[cexpr] *)
and cconst =
| Ccint of int (** Integer constant. *)
| Ccfloat of float (** Floating-point number constant. *)
| Ctag of string (** Tag, member of a previously declared enumeration. *)
| Cstrlit of string (** String literal, enclosed in double-quotes. *)
(** C left-hand-side (ie. affectable) expressions. *)
and clhs =
| CLvar of string (** A local variable. *)
| CLderef of clhs (** Pointer dereference, *ptr. *)
| CLfield of clhs * qualname (** Field access to left-hand-side. *)
| CLarray of clhs * cexpr (** Array access clhs[cexpr] *)
(** C statements. *)
and cstm =
| Csexpr of cexpr (** Expression evaluation, may cause side-effects! *)
@ -123,16 +126,16 @@ and cstm =
(** C type declarations ; will {b always} correspond to a typedef in emitted
source code. *)
type cdecl =
(** C typedef declaration (alias, name)*)
| Cdecl_typedef of cty * string
(** C enum declaration, with associated value tags. *)
(** C typedef declaration (alias, name)*)
| Cdecl_enum of string * string list
(** C structure declaration, with each field's name and type. *)
(** C enum declaration, with associated value tags. *)
| Cdecl_struct of string * (string * cty) list
(** C function declaration. *)
(** C structure declaration, with each field's name and type. *)
| Cdecl_function of string * cty * (string * cty) list
(** C constant declaration (alias, name)*)
(** C function declaration. *)
| Cdecl_constant of string * cty * cexpr
(** C constant declaration (alias, name)*)
(** C function definitions *)
type cfundef = {
@ -330,7 +333,7 @@ let pp_cdef fmt cdef = match cdef with
| Cvardef (s, cty) -> fprintf fmt "%a %a;@\n" pp_cty cty pp_string s
let pp_cfile_desc fmt filen cfile =
(** [filen_wo_ext] is the file's name without the extension. *)
(* [filen_wo_ext] is the file's name without the extension. *)
let filen_wo_ext = String.sub filen 0 (String.length filen - 2) in
match cfile with
| Cheader (deps, cdecls) ->
@ -386,7 +389,7 @@ let rec array_base_ctype ty idx_list =
let rec clhs_of_cexpr cexpr =
match cexpr with
| Cvar v -> CLvar v
| Cderef e -> CLderef (clhs_of_cexpr e)
| Cderef e -> CLderef (clhs_of_cexpr e)
| Cfield (e,qn) -> CLfield (clhs_of_cexpr e, qn)
| Carray (e1,e2) -> CLarray (clhs_of_cexpr e1, e2)
| _ -> failwith("C expression not translatable to LHS")

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

@ -278,9 +278,9 @@ let rec cexpr_of_static_exp se =
and cexpr_of_exp out_env var_env exp =
match exp.e_desc with
| Eextvalue w -> cexpr_of_ext_value out_env var_env w
(** Operators *)
(* Operators *)
| Eop(op, exps) -> cop_of_op out_env var_env op exps
(** Structure literals. *)
(* Structure literals. *)
| Estruct (tyn, fl) ->
let cexpr = cexpr_of_exp out_env var_env in
let cexps_assoc = List.rev_map (fun (f, e) -> f, cexpr e) fl in
@ -330,7 +330,7 @@ and cop_of_op out_env var_env op_name exps =
cop_of_op_aux op_name cexps
and clhs_of_pattern out_env var_env l = match l.pat_desc with
(** Each Obc variable corresponds to a real local C variable. *)
(* Each Obc variable corresponds to a real local C variable. *)
| Lvar v ->
let n = name v in
let n_lhs =
@ -347,9 +347,9 @@ and clhs_of_pattern out_env var_env l = match l.pat_desc with
)
else
n_lhs
(** Dereference our [self] struct holding the node's memory. *)
(* Dereference our [self] struct holding the node's memory. *)
| Lmem v -> CLfield (CLderef (CLvar "self"), local_qn (name v))
(** Field access. /!\ Indexed Obj expression should be a valid lhs! *)
(* Field access. /!\ Indexed Obj expression should be a valid lhs! *)
| Lfield (l, fn) -> CLfield(clhs_of_pattern out_env var_env l, fn)
| Larray (l, idx) ->
CLarray(clhs_of_pattern out_env var_env l,
@ -359,7 +359,7 @@ and clhs_list_of_pattern_list out_env var_env lhss =
List.map (clhs_of_pattern out_env var_env) lhss
and cexpr_of_pattern out_env var_env l = match l.pat_desc with
(** Each Obc variable corresponds to a real local C variable. *)
(* Each Obc variable corresponds to a real local C variable. *)
| Lvar v ->
let n = name v in
let n_lhs =
@ -376,9 +376,9 @@ and cexpr_of_pattern out_env var_env l = match l.pat_desc with
)
else
n_lhs
(** Dereference our [self] struct holding the node's memory. *)
(* Dereference our [self] struct holding the node's memory. *)
| Lmem v -> Cfield (Cderef (Cvar "self"), local_qn (name v))
(** Field access. /!\ Indexed Obj expression should be a valid lhs! *)
(* Field access. /!\ Indexed Obj expression should be a valid lhs! *)
| Lfield (l, fn) -> Cfield(cexpr_of_pattern out_env var_env l, fn)
| Larray (l, idx) ->
Carray(cexpr_of_pattern out_env var_env l,
@ -386,7 +386,7 @@ and cexpr_of_pattern out_env var_env l = match l.pat_desc with
and cexpr_of_ext_value out_env var_env w = match w.w_desc with
| Wconst c -> cexpr_of_static_exp c
(** Each Obc variable corresponds to a plain local C variable. *)
(* Each Obc variable corresponds to a plain local C variable. *)
| Wvar v ->
let n = name v in
let n_lhs =
@ -402,9 +402,9 @@ and cexpr_of_ext_value out_env var_env w = match w.w_desc with
| _ -> n_lhs)
else
n_lhs
(** Dereference our [self] struct holding the node's memory. *)
(* Dereference our [self] struct holding the node's memory. *)
| Wmem v -> Cfield (Cderef (Cvar "self"), local_qn (name v))
(** Field access. /!\ Indexed Obj expression should be a valid lhs! *)
(* Field access. /!\ Indexed Obj expression should be a valid lhs! *)
| Wfield (l, fn) -> Cfield(cexpr_of_ext_value out_env var_env l, fn)
| Warray (l, idx) ->
Carray(cexpr_of_ext_value out_env var_env l,
@ -462,7 +462,7 @@ let step_fun_call out_env var_env sig_info objn out args =
[args] is the list of expressions to use as arguments.
[mem] is the lhs where is stored the node's context.*)
let generate_function_call out_env var_env obj_env outvl objn args =
(** Class name for the object to step. *)
(* Class name for the object to step. *)
let classln = assoc_cn objn obj_env in
let classn = cname_of_qn classln in
let sig_info = find_value classln in
@ -472,16 +472,16 @@ let generate_function_call out_env var_env obj_env outvl objn args =
if is_op classln then
cop_of_op_aux classln args
else
(** The step function takes scalar arguments and its own internal memory
(* The step function takes scalar arguments and its own internal memory
holding structure. *)
let args = step_fun_call out_env var_env sig_info objn out args in
(** Our C expression for the function call. *)
(* Our C expression for the function call. *)
Cfun_call (classn ^ "_step", args)
in
(** Act according to the length of our list. Step functions with
multiple return values will return a structure, and we care of
assigning each field to the corresponding local variable. *)
(* Act according to the length of our list. Step functions with
multiple return values will return a structure, and we care of
assigning each field to the corresponding local variable. *)
match outvl with
| [] -> [Csexpr fun_call]
| [outv] when is_op classln ->
@ -534,7 +534,7 @@ let rec create_affect_const var_env (dest : clhs) c =
class names. *)
let rec cstm_of_act out_env var_env obj_env act =
match act with
(** Cosmetic : cases on boolean values are converted to if statements. *)
(* Cosmetic : cases on boolean values are converted to if statements. *)
| Acase (c, [({name = "true"}, te); ({ name = "false" }, fe)])
| Acase (c, [({name = "false"}, fe); ({ name = "true"}, te)]) ->
let cc = cexpr_of_exp out_env var_env c in
@ -553,12 +553,12 @@ let rec cstm_of_act out_env var_env obj_env act =
[Cif (cc, cte, cfe)]
(** Translation of case into a C switch statement is simple enough: we
just recursively translate obj expressions and statements to
corresponding C constructs, and cautiously "shortnamize"
constructor names. *)
(* Translation of case into a C switch statement is simple enough: we
just recursively translate obj expressions and statements to
corresponding C constructs, and cautiously "shortnamize"
constructor names. *)
| Acase (e, cl) ->
(** [ccl_of_obccl] translates an Obc clause to a C clause. *)
(* [ccl_of_obccl] translates an Obc clause to a C clause. *)
let ccl =
List.map
(fun (c,act) -> cname_of_qn c,
@ -568,33 +568,33 @@ let rec cstm_of_act out_env var_env obj_env act =
| Ablock b ->
cstm_of_act_list out_env var_env obj_env b
(** For composition of statements, just recursively apply our
translation function on sub-statements. *)
(* For composition of statements, just recursively apply our
translation function on sub-statements. *)
| Afor ({ v_ident = x }, i1, i2, act) ->
[Cfor(name x, cexpr_of_exp out_env var_env i1,
cexpr_of_exp out_env var_env i2,
cstm_of_act_list out_env var_env obj_env act)]
(** Translate constant assignment *)
(* Translate constant assignment *)
| Aassgn (vn, { e_desc = Eextvalue { w_desc = Wconst c }; }) ->
let vn = clhs_of_pattern out_env var_env vn in
create_affect_const var_env vn c
(** Purely syntactic translation from an Obc local variable to a C
local one, with recursive translation of the rhs expression. *)
(* Purely syntactic translation from an Obc local variable to a C
local one, with recursive translation of the rhs expression. *)
| Aassgn (vn, e) ->
let vn = clhs_of_pattern out_env var_env vn in
let ty = assoc_type_lhs vn var_env in
let ce = cexpr_of_exp out_env var_env e in
create_affect_stm vn ce ty
(** Our Aop marks an operator invocation that will perform side effects. Just
translate to a simple C statement. *)
(* Our Aop marks an operator invocation that will perform side effects. Just
translate to a simple C statement. *)
| Aop (op_name, args) ->
[Csexpr (cop_of_op out_env var_env op_name args)]
(** Reinitialization of an object variable, extracting the reset
function's name from our environment [obj_env]. *)
(* Reinitialization of an object variable, extracting the reset
function's name from our environment [obj_env]. *)
| Acall (name_list, o, Mreset, args) ->
assert_empty name_list;
assert_empty args;
@ -615,9 +615,9 @@ let rec cstm_of_act out_env var_env obj_env act =
mk_loop pl field
)
(** Step functions applications can return multiple values, so we use a
local structure to hold the results, before allocating to our
variables. *)
(* Step functions applications can return multiple values, so we use a
local structure to hold the results, before allocating to our
variables. *)
| Acall (outvl, objn, Mstep, el) ->
let args = cexprs_of_exps out_env var_env el in
let outvl = clhs_list_of_pattern_list out_env var_env outvl in
@ -664,18 +664,18 @@ let step_fun_args n md =
field by return value. *)
let fun_def_of_step_fun n obj_env mem objs md =
let fun_name = (cname_of_qn n) ^ "_step" in
(** Its arguments, translating Obc types to C types and adding our internal
(* Its arguments, translating Obc types to C types and adding our internal
memory structure. *)
let args = step_fun_args n md in
(** Out vars for function calls *)
(* Out vars for function calls *)
let out_vars =
unique
(List.map (fun obj -> out_var_name_of_objn (cname_of_qn obj.o_class),
Cty_id (qn_append obj.o_class "_out"))
(List.filter (fun obj -> not (is_op obj.o_class)) objs)) in
(** The body *)
(* The body *)
let mems = List.map cvar_of_vd (mem@md.m_outputs) in
let var_env = args @ mems @ out_vars in
let out_env =
@ -699,8 +699,8 @@ let fun_def_of_step_fun n obj_env mem objs md =
(** [mem_decl_of_class_def cd] returns a declaration for a C structure holding
internal variables and objects of the Obc class definition [cd]. *)
let mem_decl_of_class_def cd =
(** This one just translates the class name to a struct name following the
convention we described above. *)
(* This one just translates the class name to a struct name following the
convention we described above. *)
let struct_field_of_obj_dec l od =
if is_stateful od.o_class then
let ty = Cty_id (qn_append od.o_class "_mem") in
@ -717,9 +717,9 @@ let mem_decl_of_class_def cd =
l
in
if is_stateful cd.cd_name then (
(** Fields corresponding to normal memory variables. *)
(* Fields corresponding to normal memory variables. *)
let mem_fields = List.map cvar_of_vd cd.cd_mems in
(** Fields corresponding to object variables. *)
(* Fields corresponding to object variables. *)
let obj_fields = List.fold_left struct_field_of_obj_dec [] cd.cd_objs in
[Cdecl_struct ((cname_of_qn cd.cd_name) ^ "_mem",
mem_fields @ obj_fields)]
@ -727,7 +727,7 @@ let mem_decl_of_class_def cd =
[]
let out_decl_of_class_def cd =
(** Fields corresponding to output variables. *)
(* Fields corresponding to output variables. *)
let step_m = find_step_method cd in
let out_fields = List.map cvar_of_vd step_m.m_outputs in
[Cdecl_struct ((cname_of_qn cd.cd_name) ^ "_out", out_fields)]
@ -757,16 +757,16 @@ let reset_fun_def_of_class_def cd =
(** [cdecl_and_cfun_of_class_def cd] translates the class definition [cd] to
a C program. *)
let cdefs_and_cdecls_of_class_def cd =
(** We keep the state of our class in a structure, holding both internal
variables and the state of other nodes. For a class named ["cname"], the
structure will be called ["cname_mem"]. *)
(* We keep the state of our class in a structure, holding both internal
variables and the state of other nodes. For a class named ["cname"], the
structure will be called ["cname_mem"]. *)
Idents.enter_node cd.cd_name;
let step_m = find_step_method cd in
let memory_struct_decl = mem_decl_of_class_def cd in
let out_struct_decl = out_decl_of_class_def cd in
let step_fun_def = fun_def_of_step_fun cd.cd_name
cd.cd_objs cd.cd_mems cd.cd_objs step_m in
(** C function for resetting our memory structure. *)
(* C function for resetting our memory structure. *)
let reset_fun_def = reset_fun_def_of_class_def cd in
let res_fun_decl = cdecl_of_cfundef reset_fun_def in
let step_fun_decl = cdecl_of_cfundef step_fun_def in

22
compiler/obc/c/cmain.ml
View file

@ -98,7 +98,7 @@ let assert_node_res cd =
[Csexpr (Cfun_call ("fprintf",
[Cvar "stderr";
Cconst (Cstrlit ("Node \""
^ (Names.fullname cd.cd_name)
^ (Names.fullname cd.cd_name)
^ "\" failed at step" ^
" %d.\n"));
Cvar step_counter]));
@ -120,8 +120,8 @@ let main_def_of_class_def cd =
| Tid _ -> "%s"
in
(** Does reading type [ty] need a buffer? When it is the case,
[need_buf_for_ty] also returns the type's name. *)
(* Does reading type [ty] need a buffer? When it is the case,
[need_buf_for_ty] also returns the type's name. *)
let need_buf_for_ty ty = match ty with
| Tarray _ | Tprod _ | Tinvalid -> assert false
| Types.Tid id when id = Initial.pfloat -> None
@ -131,7 +131,7 @@ let main_def_of_class_def cd =
in
let cprint_string s = Csexpr (Cfun_call ("printf", [Cconst (Cstrlit s)])) in
(** Generates scanf statements. *)
(* Generates scanf statements. *)
let rec read_lhs_of_ty lhs ty =
match ty with
| Tarray (ty, n) ->
@ -187,18 +187,18 @@ let main_def_of_class_def cd =
| None -> ([scan_exp (Caddrof lhs)], [])
| Some tyn ->
let varn = fresh "buf" in
let lhs = clhs_of_cexpr lhs in
let lhs = clhs_of_cexpr lhs in
([scan_exp (Cvar varn);
Caffect (lhs,
(Cfun_call (tyn ^ "_of_string",
(Cfun_call (tyn ^ "_of_string",
[Cvar varn])))],
[(varn, Cty_arr (20, Cty_char))])
end
| Tprod _ | Tinvalid -> failwith("read_lhs_of_ty: untranslatable type")
in
(** Generates printf statements and buffer declarations needed for printing
resulting values of enum types. *)
(* Generates printf statements and buffer declarations needed for printing
resulting values of enum types. *)
let rec write_lhs_of_ty lhs ty =
match ty with
| Tarray (ty, n) ->
@ -282,8 +282,8 @@ let main_def_of_class_def cd =
@ concat scanf_decls
@ concat printf_decls in
(** The main function loops (while (1) { ... }) reading arguments for our node
and prints the results. *)
(* The main function loops (while (1) { ... }) reading arguments for our node
and prints the results. *)
let step_l =
let funcall =
let args =
@ -300,7 +300,7 @@ let main_def_of_class_def cd =
else [Csexpr (Cfun_call ("puts", [Cconst (Cstrlit "")]))])
@ [Csexpr (Cfun_call ("fflush", [Cvar "stdout"]))] in
(** Do not forget to initialize memory via reset if needed. *)
(* Do not forget to initialize memory via reset if needed. *)
let rst_i =
if cd.cd_stateful
then [Csexpr (Cfun_call ((cname_of_qn cd.cd_name) ^ "_reset",

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

@ -27,8 +27,11 @@
(* *)
(***********************************************************************)
type class_name = Names.qualname (** [qual] is the package name, [Name] is the class name *)
(** [qual] is the package name, [Name] is the class name *)
type class_name = Names.qualname
type obj_ident = Idents.var_ident
(** [Qual] is the enum class name (type), [NAME] is the constructor name *)
type constructor_name = Names.qualname
type const_name = Names.qualname

38
compiler/obc/transformations/deadcode.ml
View file

@ -37,38 +37,38 @@ let act funs act_list a =
| Aassgn (lhs, e) -> (* remove x=x equations *)
(match e.e_desc with
| Eextvalue w when (Obc_compare.compare_lhs_extvalue lhs w = 0)
-> a, act_list (* removal of action *)
-> a, act_list (* removal of action *)
| _ -> a, a :: act_list
)
| Acase (_, []) -> a, act_list (* removal *)
| Acase ({e_desc =
Eextvalue(
{w_desc = Wconst ({se_desc = Sbool b})}
)
},
c_b_l) ->
Eextvalue(
{w_desc = Wconst ({se_desc = Sbool b})}
)
},
c_b_l) ->
let pb = if b then ptrue else pfalse in
let c_b_l = List.filter (fun (c,b) -> c = pb) c_b_l in
let c_b_l = List.filter (fun (c,_b) -> c = pb) c_b_l in
begin
match c_b_l with
[c,b] ->
let a = Ablock b in
a, a :: act_list
[_c,b] ->
let a = Ablock b in
a, a :: act_list
| [] -> a, act_list
| _ -> assert false (* More than one case after filter *)
end
| Acase ({e_desc =
Eextvalue(
{w_desc = Wconst ({se_desc = Sconstructor ce})}
)
},
c_b_l) ->
let c_b_l = List.filter (fun (c,b) -> c = ce) c_b_l in
Eextvalue(
{w_desc = Wconst ({se_desc = Sconstructor ce})}
)
},
c_b_l) ->
let c_b_l = List.filter (fun (c,_b) -> c = ce) c_b_l in
begin
match c_b_l with
[c,b] ->
let a = Ablock b in
a, a :: act_list
[_c,b] ->
let a = Ablock b in
a, a :: act_list
| [] -> a, act_list
| _ -> assert false (* More than one case after filter *)
end

1
compiler/utilities/misc.ml
View file

@ -115,6 +115,7 @@ let split_nlast n l =
else l1, l2
exception List_too_short
(** [split_at n l] splits [l] in two after the [n]th value.
Raises List_too_short exception if the list is too short. *)
let rec split_at n l = match n, l with