Merge branch 'java'

Conflicts:
	.gitignore
	compiler/global/global_printer.ml
	compiler/main/mls2obc.ml

.gitignore

@@ -27,3 +27,4 @@ _build
 *.dot
 test/*.ml
 test/_check_builds
+lib/java/.classpath

compiler/TODO.txt

@@ -0,0 +1,6 @@
+- Ne plus forcer l'ordre constantes puis types puis definitions de noeud. Il
+faudra mettre à jour les phases du compilateur et modifier l'ast.
+- Ajouter des constantes locales
+
+- supprimer pinst dans minils
+- heptcheck

compiler/global/clocks.ml

@@ -94,7 +94,9 @@ let rec skeleton ck = function
             Format.eprintf "Internal error, an exp with invalid type@.";
             assert false;
         | _ -> Cprod (List.map (skeleton ck) ty_list))
-  | Tarray _ | Tid _ | Tunit -> Ck ck
+  | Tarray (t, _) -> skeleton ck t
+  | Tmutable t -> skeleton ck t
+  | Tid _ | Tunit -> Ck ck
 
 (* TODO here it implicitely says that the base clock is Cbase
     and that all tuple is on Cbase *)

compiler/global/global_compare.ml

@@ -35,6 +35,7 @@ and link_compare li1 li2 = match li1, li2 with
   | Cindex _, _ -> 1
   | Clink _, _ -> -1
 
+
 let rec static_exp_compare se1 se2 =
   let cr = type_compare se1.se_ty se2.se_ty in
 
@@ -80,7 +81,7 @@ let rec static_exp_compare se1 se2 =
       | Sfield _, (Svar _ | Sint _ | Sfloat _ | Sbool _ | Sconstructor _) -> -1
       | Sfield _, _ -> 1
 
-      | Stuple _, (Srecord _ | Sop _ | Sarray _ | Sarray_power _) -> 1
+      | Stuple _, (Srecord _ | Sop _ | Sarray _ | Sarray_power _ ) -> 1
       | Stuple _, _ -> -1
 
       | Sarray_power _, (Srecord _ | Sop _ | Sarray _) -> -1
@@ -100,7 +101,12 @@ and type_compare ty1 ty2 = match ty1, ty2 with
   | Tarray (ty1, se1), Tarray (ty2, se2) ->
       let cr = type_compare ty1 ty2 in
       if cr <> 0 then cr else static_exp_compare se1 se2
-  | (Tprod _ | Tid _), _ -> 1
-  | (Tarray _), _ -> -1
   | Tunit, Tunit -> 0
+  | Tprod _, _ -> 1
+  | Tid _, Tprod _ -> -1
+  | Tid _, _ -> 1
+  | Tarray _, (Tprod _ | Tid _) -> -1
+  | Tarray _, _ -> 1
+  | Tmutable _, (Tprod _ | Tid _ | Tarray _) -> -1
+  | Tmutable _, _ -> 1
   | Tunit, _ -> -1

compiler/global/global_mapfold.ml

@@ -5,19 +5,17 @@ open Types
 open Signature
 
 type 'a global_it_funs = {
-  static_exp :
-    'a global_it_funs -> 'a -> static_exp -> static_exp * 'a;
-  static_exp_desc :
-    'a global_it_funs -> 'a -> static_exp_desc -> static_exp_desc * 'a;
-  ty : 'a global_it_funs -> 'a -> ty -> ty * 'a;
-(*  ct : 'a global_it_funs -> 'a -> ct -> ct * 'a;
-  ck : 'a global_it_funs -> 'a -> ck -> ck * 'a;
-  link : 'a global_it_funs -> 'a -> link -> link * 'a; *)
-  param: 'a global_it_funs -> 'a -> param -> param * 'a;
-  arg: 'a global_it_funs -> 'a -> arg -> arg * 'a;
-  node : 'a global_it_funs -> 'a -> node -> node * 'a;
-  structure: 'a global_it_funs -> 'a -> structure -> structure * 'a;
-  field: 'a global_it_funs -> 'a -> field -> field * 'a; }
+  static_exp         : 'a global_it_funs -> 'a -> static_exp -> static_exp * 'a;
+  static_exp_desc    : 'a global_it_funs -> 'a -> static_exp_desc -> static_exp_desc * 'a;
+  ty                 : 'a global_it_funs -> 'a -> ty -> ty * 'a;
+(*  ct               : 'a global_it_funs -> 'a -> ct -> ct * 'a;
+  ck                 : 'a global_it_funs -> 'a -> ck -> ck * 'a;
+  link               : 'a global_it_funs -> 'a -> link -> link * 'a; *)
+  param              : 'a global_it_funs -> 'a -> param -> param * 'a;
+  arg                : 'a global_it_funs -> 'a -> arg -> arg * 'a;
+  node               : 'a global_it_funs -> 'a -> node -> node * 'a;
+  structure          : 'a global_it_funs -> 'a -> structure -> structure * 'a;
+  field              : 'a global_it_funs -> 'a -> field -> field * 'a; }
 
 let rec static_exp_it funs acc se = funs.static_exp funs acc se
 and static_exp funs acc se =
@@ -59,6 +57,9 @@ and ty funs acc t = match t with
       let t, acc = ty_it funs acc t in
       let se, acc = static_exp_it funs acc se in
       Tarray (t, se), acc
+  | Tmutable t ->
+      let t, acc = ty_it funs acc t in
+      Tmutable t, acc
   | Tunit -> t, acc
 (*
 and ct_it funs acc c = try funs.ct funs acc c with Fallback -> ct funs acc t

compiler/global/global_printer.ml

@@ -7,11 +7,33 @@ 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 _aux_print_modul ?(full=false) ff m = match m with
+  | Pervasives -> ()
+  | LocalModule -> ()
+  | _ when m = g_env.current_mod && not full -> ()
+  | Module m -> fprintf ff "%a." print_name m
+  | QualModule { qual = m; name = n } -> fprintf ff "%a%a." (_aux_print_modul ~full:full) m print_name n
+
+(** Prints a [modul] with a [.] at the end when not empty *)
+let _print_modul ?(full=false) ff m = match m with
+  | Pervasives -> ()
+  | LocalModule -> ()
+  | _ when m = g_env.current_mod && not full -> ()
+  | Module m -> fprintf ff "%a" print_name m
+  | QualModule { qual = m; name = n } -> fprintf ff "%a%a" (_aux_print_modul ~full:full) m print_name n
+let print_full_modul ff m = _print_modul ~full:true ff m
+let print_modul ff m = _print_modul ~full:false ff m
+
+let _print_qualname ?(full=false) ff { qual = q; name = n} = match q with
+  | Pervasives -> print_name ff n
+  | LocalModule -> print_name ff n
+  | _ when q = g_env.current_mod && not full -> print_name ff n
+  | _ -> fprintf ff "%a%a" (_aux_print_modul ~full:full) q print_name n
+let print_qualname ff qn = _print_qualname ~full:false ff qn
+let print_full_qualname ff qn = _print_qualname ~full:true ff qn
+
+let print_shortname ff {name = n} = print_name ff n
 
 
 let rec print_static_exp ff se = match se.se_desc with
@@ -24,9 +46,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
@@ -43,14 +64,16 @@ and print_static_exp_tuple ff l =
   fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "("","")") l
 
 and print_type ff = function
+  | Tprod [] -> fprintf ff "INVALID TYPE"
   | Tprod ty_list ->
       fprintf ff "@[<hov2>%a@]" (print_list_r print_type "(" " *" ")") ty_list
   | Tid id -> print_qualname ff id
   | Tarray (ty, n) ->
       fprintf ff "@[<hov2>%a^%a@]" print_type ty print_static_exp n
+  | Tmutable ty ->
+      fprintf ff "@[<hov2>mutable %a@]" print_type ty
   | Tunit -> fprintf ff "unit"
 
-
 let print_field ff field =
   fprintf ff "@[%a: %a@]" print_qualname field.f_name  print_type field.f_type
 

compiler/global/idents.mli

@@ -2,6 +2,7 @@
 open Names
 
 (** This modules manages unique identifiers,
+  /!\ To be effective, [enter_node] has to be called when entering a node
   [gen_fresh] generates an identifier
   [name] returns a unique name (inside its node) from an identifier. *)
 
@@ -11,7 +12,7 @@ type ident
 (** Type to be used for local variables *)
 type var_ident = ident
 
-(** Comparision on idents with the same properties as [Pervasives.compare] *)
+(** Comparison on idents with the same properties as [Pervasives.compare] *)
 val ident_compare : ident -> ident -> int
 
 (** Get the full name of an identifier (it is guaranteed to be unique) *)
@@ -21,6 +22,9 @@ val name : ident -> string
     generate a fresh ident with a sweet [name].
     It should be used to define a [fresh] function specific to a pass. *)
 val gen_fresh : string -> ('a -> string) -> 'a -> ident
+
+(** [gen_var pass_name name]
+    generates a fresh ident with a sweet [name] *)
 val gen_var : string -> string -> ident
 
 (** [ident_of_name n] returns an identifier corresponding

compiler/global/initial.ml

@@ -14,28 +14,32 @@ open Types
 let tglobal = []
 let cglobal = []
 
-let pbool = { qual = "Pervasives"; name = "bool" }
-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 pfloat = { qual = "Pervasives"; name = "float" }
+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 tint = Types.Tid pint
+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:(Tid pint) (Sop (op,args))
+  mk_static_exp ~ty:tint (Sop (op,args))
 
 let mk_static_int i =
-  mk_static_exp ~ty:(Tid pint) (Sint i)
+  mk_static_exp ~ty:tint (Sint i)
 
 let mk_static_bool b =
-  mk_static_exp ~ty:(Tid pbool) (Sbool b)
+  mk_static_exp ~ty:tbool (Sbool 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

compiler/global/modules.ml

@@ -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
 
 
@@ -160,7 +165,7 @@ let add_const f v =
 let replace_value f v =
   g_env.values <- QualEnv.add f v g_env.values
 
-(** { 3 Find functions look in the global environnement, nothing more } *)
+(** { 3 Find functions look in the global environement, nothing more } *)
 
 let find_value x = QualEnv.find x g_env.values
 let find_type x = QualEnv.find x g_env.types
@@ -286,6 +291,7 @@ let rec unalias_type t = match t with
       with Not_found -> raise (Undefined_type ty_name))
   | Tarray (ty, n) -> Tarray(unalias_type ty, n)
   | Tprod ty_list -> Tprod (List.map unalias_type ty_list)
+  | Tmutable t -> Tmutable (unalias_type t)
   | Tunit -> Tunit
 
 

compiler/global/names.ml

@@ -3,25 +3,38 @@
     [fullname] longname -> Module.name *)
 
 type name = string
+type module_name = name
+
+type modul =
+  | Pervasives
+  | LocalModule
+  | Module of module_name
+  | QualModule of qualname
 
-and qualname = { qual: string; name: string }
+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))
 
@@ -30,21 +43,37 @@ module QualEnv = struct
 end
 
 module QualSet = Set.Make (struct type t = qualname let compare = compare end)
+module ModulSet = Set.Make (struct type t = modul let compare = compare end)
 module S = Set.Make (struct type t = string let compare = compare end)
 
 
 let shortname { name = 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]
@@ -57,7 +86,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
@@ -69,13 +98,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)

compiler/global/signature.ml

@@ -30,7 +30,7 @@ type size_constraint =
 type node = {
   node_inputs : arg list;
   node_outputs : arg list;
-  node_statefull : bool;
+  node_stateful : bool;
   node_params : param list;
   node_params_constraints : size_constraint list }
 
@@ -58,10 +58,10 @@ let mk_field n ty = { f_name = n; f_type = ty }
 let mk_const_def ty value =
   { c_type = ty; c_value = value }
 
-let mk_node ?(constraints = []) ins outs statefull params =
+let mk_node ?(constraints = []) ins outs stateful params =
   { node_inputs = ins;
     node_outputs  = outs;
-    node_statefull = statefull;
+    node_stateful = stateful;
     node_params = params;
     node_params_constraints = constraints }
 

compiler/global/static.ml

@@ -17,90 +17,133 @@ open Format
 open Types
 open Signature
 open Modules
+open Location
 
-(* unsatisfiable constraint *)
-exception Instanciation_failed
-exception Partial_instanciation of static_exp
 
 exception Not_static
 
-let partial_apply_op op se_list =
+
+
+(** Some evaluations are not possible *)
+type eval_error = Division_by_zero
+exception Evaluation_failed of eval_error * location
+
+(** Some unknown operators could be used preventing the evaluation *)
+type partial_eval_cause = Unknown_op of fun_name | Unknown_param of qualname
+exception Partial_evaluation of partial_eval_cause * location
+
+let message exn =
+  begin match exn with
+    | Evaluation_failed (e,loc) ->
+        (match e with
+          | Division_by_zero ->
+              eprintf "%aForbidden division by 0.@."
+              print_location loc
+        )
+    | Partial_evaluation (e,loc) ->
+        (match e with
+          | Unknown_op op ->
+              eprintf "%aUnknown operator %a.@."
+              Location.print_location loc
+              Global_printer.print_qualname op
+          | Unknown_param q ->
+              eprintf "%aUninstanciated param %a.@."
+              Location.print_location loc
+              Global_printer.print_qualname q
+        )
+    | _ -> raise exn
+  end;
+  raise Errors.Error
+
+
+
+(** When not [partial],
+      @raise Partial_evaluation when the application of the operator can't be evaluated (only Unknown_op).
+    Otherwise keep as it is unknown operators. *)
+let apply_op partial loc 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 = "/" } ->
-               let n = if n2 = 0 then raise Instanciation_failed else n1 / n2 in
-               Sint n
-           | { qual = "Pervasives"; name = "=" } ->
+           | { qual = Pervasives; name = "/" } ->
+               if n2 = 0 then raise (Evaluation_failed (Division_by_zero, loc));
+               Sint (n1 / n2)
+           | { 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)
+    | _ -> if partial then Sop(op, se_list) (* partial evaluation *)
+           else raise (Partial_evaluation (Unknown_op op, loc))
 
-let apply_op op se_list =
-  let se = partial_apply_op op se_list in
-  match se with
-    | Sop _ -> raise Not_found
-    | _ -> se
 
-let eval_core eval apply_op env se = match se.se_desc with
+(** When not [partial],
+      @raise Partial_evaluation when a static var cannot be evaluated, a local static parameter for example.
+    Otherwise evaluate in a best effort manner. *)
+let rec eval_core partial env se = match se.se_desc with
   | Sint _ | Sfloat _ | Sbool _ | Sconstructor _ | Sfield _ -> se
-  | Svar ln -> (
-      try (* first try to find in global const env *)
-        let cd = find_const ln in
-        eval env cd.c_value
-      with Not_found -> (* then try to find in local env *)
-        eval env (QualEnv.find ln env))
+  | Svar ln ->
+      (try (* first try to find in global const env *)
+         let cd = find_const ln in
+         eval_core partial env cd.c_value
+       with Not_found -> (* then try to find in local env *)
+         (try
+            let se = QualEnv.find ln env in
+            (match se.se_desc with
+               | Svar ln' when ln'=ln -> (* prevent basic infinite loop *)
+                  if partial then se else raise Not_found
+               | _ -> eval_core partial env se
+            )
+          with Not_found -> (* Could not evaluate the var *)
+            if partial then se
+            else raise (Partial_evaluation (Unknown_param ln, se.se_loc))
+         )
+      )
   | Sop (op, se_list) ->
-      let se_list = List.map (eval env) se_list in
-        { se with se_desc = apply_op op se_list }
+      let se_list = List.map (eval_core partial env) se_list in
+      let se_desc = apply_op partial se.se_loc op se_list in
+      { se with se_desc = se_desc }
   | Sarray se_list ->
-      { se with se_desc = Sarray (List.map (eval env) se_list) }
+      { se with se_desc = Sarray (List.map (eval_core partial env) se_list) }
   | Sarray_power (se, n) ->
-       { se with se_desc = Sarray_power (eval env se, eval env n) }
+       { se with se_desc = Sarray_power (eval_core partial env se, eval_core partial env n) }
   | Stuple se_list ->
-       { se with se_desc = Stuple (List.map (eval env) se_list) }
+       { se with se_desc = Stuple (List.map (eval_core partial env) se_list) }
   | Srecord f_se_list ->
       { se with se_desc = Srecord
-          (List.map (fun (f,se) -> f, eval env se) f_se_list) }
+          (List.map (fun (f,se) -> f, eval_core partial env se) f_se_list) }
+
 
 (** [simplify env e] returns e simplified with the
     variables values taken from [env] or from the global env with [find_const].
     Every operator that can be computed is.
     It can return static_exp with uninstanciated variables.*)
-let rec simplify env se =
-  try eval_core simplify partial_apply_op env se
-  with _ -> se
+let simplify env se =
+  try eval_core true env se
+  with exn -> message exn
 
 (** [eval env e] does the same as [simplify]
     but if it returns, there are no variables nor op left.
-    @raise [Partial_instanciation] when it cannot fully evaluate *)
-let rec eval env se =
-  try eval_core eval apply_op env se
-  with Not_found -> raise (Partial_instanciation se)
+    @raise [Errors.Error] when it cannot fully evaluate. *)
+let eval env se =
+  try eval_core false env se
+  with exn -> message exn
 
 (** [int_of_static_exp env e] returns the value of the expression
-    [e] in the environment [env], mapping vars to integers. Raises
-    Instanciation_failed if it cannot be computed (if a var has no value).*)
-let int_of_static_exp env se =
-  match (simplify env se).se_desc with
-    | Sint i -> i
-    | _ ->
-      (Format.eprintf "Internal compiler error, \
-        [eval_int] received the static_exp %a.@."
-        Global_printer.print_static_exp se;
-      assert false)
+    [e] in the environment [env], mapping vars to integers.
+    @raise [Errors.Error] if it cannot be computed.*)
+let int_of_static_exp env se = match (eval env se).se_desc with
+  | Sint i -> i
+  | _ -> Misc.internal_error "static int_of_static_exp" 1
 
 (** [is_true env constr] returns whether the constraint is satisfied
     in the environment (or None if this can be decided)

compiler/global/types.ml

@@ -11,6 +11,7 @@ open Names
 open Misc
 open Location
 
+
 type static_exp = { se_desc: static_exp_desc; se_ty: ty; se_loc: location }
 
 and static_exp_desc =
@@ -27,18 +28,23 @@ and static_exp_desc =
   | Sop of fun_name * static_exp list (** defined ops for now in pervasives *)
 
 and ty =
-  | Tprod of ty list
-  | Tid of type_name
-  | Tarray of ty * static_exp
+  | Tprod of ty list (** Product type used for tuples *)
+  | Tid of type_name (** Usable type_name are alias or pervasives {bool,int,float} (see [Initial]) *)
+  | Tarray of ty * static_exp (** [base_type] * [size] *) (* TODO obc : array of prod ?? nonono *)
+  | Tmutable of ty (* TODO obc : do not hack it here *)
   | Tunit
 
-let invalid_type = Tprod []
+let invalid_type = Tprod [] (** Invalid type given to untyped expression etc. *)
 
 let prod = function
   | []      -> Tunit
   | [ty]    -> ty
   | ty_list -> Tprod ty_list
 
+let unprod = function
+  | Tprod l -> l
+  | t -> [t]
+
 
 (** DO NOT use this after the typing, since it could give invalid_type *)
 let mk_static_exp ?(loc = no_location) ?(ty = invalid_type) desc =

compiler/heptagon/analysis/causality.ml

@@ -106,8 +106,8 @@ let rec typing e =
     | Estruct(l) ->
         let l = List.map (fun (_, e) -> typing e) l in
         candlist l
-    | Eiterator (_, _, _, e_list, _) ->
-        ctuplelist (List.map typing e_list)
+    | Eiterator (_, _, _, pe_list, e_list, _) ->
+        ctuplelist (List.map typing (pe_list@e_list))
     | Ewhen (e, c, ce) ->
         let t = typing e in
         let tc = typing ce in

compiler/heptagon/analysis/initialization.ml

@@ -246,7 +246,8 @@ let rec typing h e =
           List.fold_left
             (fun acc (_, e) -> imax acc (itype (typing h e))) izero l in
         skeleton i e.e_ty
-    | Eiterator (_, _, _, e_list, _) ->
+    | Eiterator (_, _, _, pe_list, e_list, _) ->
+        List.iter (fun e -> initialized_exp h e) pe_list;
         List.iter (fun e -> initialized_exp h e) e_list;
         skeleton izero e.e_ty
     | Ewhen (e, _, ce) ->

compiler/heptagon/analysis/statefull.ml

@@ -6,7 +6,7 @@
 (*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
 (*                                                                        *)
 (**************************************************************************)
-(* Checks that a node declared stateless is stateless *)
+(* Checks that a node declared stateless is stateless, and set possible nodes as stateless. *)
 open Names
 open Location
 open Signature
@@ -21,7 +21,7 @@ type error =
 let message loc kind =
   begin match kind with
     | Eshould_be_a_node ->
-        Format.eprintf "%aThis node is statefull \
+        Format.eprintf "%aThis node is stateful \
                        but was declared stateless.@."
           print_location loc
     | Eexp_should_be_stateless ->
@@ -30,54 +30,73 @@ let message loc kind =
   end;
   raise Errors.Error
 
-(** @returns whether the exp is statefull. Replaces node calls with
+let last _ stateful l = match l with
+  | Var -> l, stateful
+  | Last _ -> l, true
+
+(** @returns whether the exp is stateful. Replaces node calls with
     the correct Efun or Enode depending on the node signature. *)
-let edesc funs statefull ed =
-  (* do the recursion on function args *)
-  let ed, statefull = Hept_mapfold.edesc funs statefull ed in
+let edesc funs stateful ed =
+  let ed, stateful = Hept_mapfold.edesc funs stateful ed in
     match ed with
       | Efby _ | Epre _ -> ed, true
       | Eapp({ a_op = Earrow }, _, _) -> ed, true
       | Eapp({ a_op = (Enode f | Efun f) } as app, e_list, r) ->
           let ty_desc = find_value f in
-          let op = if ty_desc.node_statefull then Enode f else Efun f in
-            Eapp({ app with a_op = op }, e_list, r),
-          ty_desc.node_statefull or statefull
-      | _ -> ed, statefull
+          let op = if ty_desc.node_stateful then Enode f else Efun f in
+          Eapp({ app with a_op = op }, e_list, r), ty_desc.node_stateful or stateful
+      | _ -> ed, stateful
+
+let eqdesc funs acc eqd =
+  let eqd, _ = Hept_mapfold.eqdesc funs acc eqd in
+  match eqd with
+    | Eautomaton st_h_l ->
+      let st_h_l, _ = Misc.mapfold (state_handler_it funs) acc st_h_l in
+      Eautomaton st_h_l, true
+    | _ -> raise Errors.Fallback
 
 let eq funs acc eq =
-  let eq, statefull = Hept_mapfold.eq funs acc eq in
-    { eq with eq_statefull = statefull }, statefull
+  let eq, stateful = Hept_mapfold.eq funs acc eq in
+    { eq with eq_stateful = stateful }, stateful
 
 let block funs acc b =
-  let b, statefull = Hept_mapfold.block funs false b in
-    { b with b_statefull = statefull }, acc or statefull
+  let b, stateful = Hept_mapfold.block funs false b in
+    { b with b_stateful = stateful }, acc or stateful
 
+(** Strong preemption should be decided with stateless expressions *)
 let escape_unless funs acc esc =
-  let esc, statefull = Hept_mapfold.escape funs false esc in
-    if statefull then
+  let esc, stateful = Hept_mapfold.escape funs false esc in
+    if stateful then
       message esc.e_cond.e_loc Eexp_should_be_stateless;
-    esc, acc or statefull
+    esc, acc or stateful
 
+(** Present conditions should be stateless *)
 let present_handler funs acc ph =
-  let p_cond, statefull = Hept_mapfold.exp_it funs false ph.p_cond in
-    if statefull then
+  let p_cond, stateful = Hept_mapfold.exp_it funs false ph.p_cond in
+    if stateful then
       message ph.p_cond.e_loc Eexp_should_be_stateless;
   let p_block, acc = Hept_mapfold.block_it funs acc ph.p_block in
     { ph with p_cond = p_cond; p_block = p_block }, acc
 
+
+(** Funs with states are rejected, nodes without state are set as funs *)
 let node_dec funs _ n =
   Idents.enter_node n.n_name;
-  let n, statefull = Hept_mapfold.node_dec funs false n in
-    if statefull & not (n.n_statefull) then
-      message n.n_loc Eshould_be_a_node;
-    n, false
+  let n, stateful = Hept_mapfold.node_dec funs false n in
+  if stateful & (not n.n_stateful) then message n.n_loc Eshould_be_a_node;
+  if not stateful & n.n_stateful (* update the global env if stateful is not necessary *)
+  then Modules.replace_value n.n_name { (Modules.find_value n.n_name) with Signature.node_stateful = false };
+  { n with n_stateful = stateful }, false (* set stateful only if needed *)
+
 
 let program p =
   let funs =
-    { Hept_mapfold.defaults with edesc = edesc;
+    { Hept_mapfold.defaults with
+        edesc = edesc;
         escape_unless = escape_unless;
         present_handler = present_handler;
+        eqdesc = eqdesc;
+        last = last;
         eq = eq; block = block; node_dec = node_dec } in
   let p, _ = Hept_mapfold.program_it funs false p in
     p

compiler/heptagon/analysis/typing.ml

@@ -223,7 +223,7 @@ let unify t1 t2 =
 
 let kind f ty_desc =
   let ty_of_arg v = v.a_type in
-  let op = if ty_desc.node_statefull then Enode f else Efun f in
+  let op = if ty_desc.node_stateful then Enode f else Efun f in
     op, List.map ty_of_arg ty_desc.node_inputs,
   List.map ty_of_arg ty_desc.node_outputs
 
@@ -250,6 +250,7 @@ let build_subst names values =
 let rec subst_type_vars m = function
   | Tarray(ty, e) -> Tarray(subst_type_vars m ty, simplify m e)
   | Tprod l -> Tprod (List.map (subst_type_vars m) l)
+  | Tmutable t -> Tmutable (subst_type_vars m t)
   | t -> t
 
 let add_distinct_env id ty env =
@@ -384,6 +385,8 @@ let rec check_type const_env = function
   | Tid ty_name -> Tid ty_name (* TODO bug ? should check that ty_name exists ? *)
   | Tprod l ->
       Tprod (List.map (check_type const_env) l)
+  | Tmutable t ->
+      Tmutable (check_type const_env t)
   | Tunit -> Tunit
 
 and typing_static_exp const_env se =
@@ -519,7 +522,7 @@ let rec typing const_env h e =
 
       | Eiterator (it, ({ a_op = (Enode f | Efun f);
                           a_params = params } as app),
-                   n, e_list, reset) ->
+                   n, pe_list, e_list, reset) ->
           let ty_desc = find_value f in
           let op, expected_ty_list, result_ty_list = kind f ty_desc in
           let node_params =
@@ -529,6 +532,11 @@ let rec typing const_env h e =
             List.map (subst_type_vars m) expected_ty_list in
           let result_ty_list = List.map (subst_type_vars m) result_ty_list in
           let typed_n = expect_static_exp const_env (Tid Initial.pint) n in
+          (*typing of partial application*)
+          let p_ty_list, expected_ty_list =
+            Misc.split_at (List.length pe_list) expected_ty_list in
+          let typed_pe_list = typing_args const_env h p_ty_list pe_list in
+          (*typing of other arguments*)
           let ty, typed_e_list = typing_iterator const_env h it n
             expected_ty_list result_ty_list e_list in
           let typed_params = typing_node_params const_env
@@ -540,7 +548,7 @@ let rec typing const_env h e =
             List.iter add_size_constraint size_constrs;
             (* return the type *)
             Eiterator(it, { app with a_op = op; a_params = typed_params }
-                        , typed_n, typed_e_list, reset), ty
+                        , typed_n, typed_pe_list, typed_e_list, reset), ty
       | Eiterator _ -> assert false
 
       | Ewhen (e, c, ce) ->
@@ -628,18 +636,14 @@ and typing_app const_env h app e_list =
     | (Efun f | Enode f) ->
         let ty_desc = find_value f in
         let op, expected_ty_list, result_ty_list = kind f ty_desc in
-        let node_params =
-          List.map (fun { p_name = n } -> local_qn n) ty_desc.node_params in
+        let node_params = List.map (fun { p_name = n } -> local_qn n) ty_desc.node_params in
         let m = build_subst node_params app.a_params in
         let expected_ty_list = List.map (subst_type_vars m) expected_ty_list in
-        let typed_e_list = typing_args const_env h
-          expected_ty_list e_list in
+        let typed_e_list = typing_args const_env h expected_ty_list e_list in
         let result_ty_list = List.map (subst_type_vars m) result_ty_list in
         (* Type static parameters and generate constraints *)
-        let typed_params = typing_node_params const_env
-          ty_desc.node_params app.a_params in
-        let size_constrs =
-          instanciate_constr m ty_desc.node_params_constraints in
+        let typed_params = typing_node_params const_env ty_desc.node_params app.a_params in
+        let size_constrs = instanciate_constr m ty_desc.node_params_constraints in
         List.iter add_size_constraint size_constrs;
         prod result_ty_list,
         { app with a_op = op; a_params = typed_params },
@@ -741,6 +745,8 @@ and typing_app const_env h app e_list =
           mk_static_int_op (mk_pervasives "+") [array_size t1; array_size t2] in
         Tarray (element_type t1, n), app, [typed_e1; typed_e2]
 
+
+
 and typing_iterator const_env h
     it n args_ty_list result_ty_list e_list = match it with
   | Imap ->
@@ -831,6 +837,7 @@ and typing_node_params const_env params_sig params =
   List.map2 (fun p_sig p -> expect_static_exp const_env
                p_sig.p_type p) params_sig params
 
+
 let rec typing_pat h acc = function
   | Evarpat(x) ->
       let ty = typ_of_name h x in

compiler/heptagon/hept_mapfold.ml

@@ -54,46 +54,25 @@ open Global_mapfold
 open Heptagon
 
 type 'a hept_it_funs = {
-  app:
-    'a hept_it_funs -> 'a -> Heptagon.app -> Heptagon.app * 'a;
-  block:
-    'a hept_it_funs -> 'a -> Heptagon.block -> Heptagon.block * 'a;
-  edesc:
-    'a hept_it_funs -> 'a -> Heptagon.desc -> Heptagon.desc * 'a;
-  eq:
-    'a hept_it_funs -> 'a -> Heptagon.eq -> Heptagon.eq * 'a;
-  eqdesc:
-    'a hept_it_funs -> 'a -> Heptagon.eqdesc -> Heptagon.eqdesc * 'a;
-  escape_unless :
-    'a hept_it_funs -> 'a -> Heptagon.escape -> Heptagon.escape * 'a;
-  escape_until:
-    'a hept_it_funs -> 'a -> Heptagon.escape -> Heptagon.escape * 'a;
-  exp:
-    'a hept_it_funs -> 'a -> Heptagon.exp -> Heptagon.exp * 'a;
-  pat:
-    'a hept_it_funs -> 'a -> pat -> Heptagon.pat * 'a;
-  present_handler:
-    'a hept_it_funs -> 'a -> Heptagon.present_handler
-                          -> Heptagon.present_handler * 'a;
-  state_handler:
-    'a hept_it_funs -> 'a -> Heptagon.state_handler
-                          -> Heptagon.state_handler * 'a;
-  switch_handler:
-    'a hept_it_funs -> 'a -> Heptagon.switch_handler
-                          -> Heptagon.switch_handler * 'a;
-  var_dec:
-    'a hept_it_funs -> 'a -> Heptagon.var_dec -> Heptagon.var_dec * 'a;
-  last:
-    'a hept_it_funs -> 'a -> Heptagon.last -> Heptagon.last * 'a;
-  contract:
-    'a hept_it_funs -> 'a -> Heptagon.contract -> Heptagon.contract * 'a;
-  node_dec:
-    'a hept_it_funs -> 'a -> Heptagon.node_dec -> Heptagon.node_dec * 'a;
-  const_dec:
-    'a hept_it_funs -> 'a -> Heptagon.const_dec -> Heptagon.const_dec * 'a;
-  program:
-    'a hept_it_funs -> 'a -> Heptagon.program -> Heptagon.program * 'a;
-  global_funs: 'a Global_mapfold.global_it_funs }
+  app            : 'a hept_it_funs -> 'a -> app -> app * 'a;
+  block          : 'a hept_it_funs -> 'a -> block -> block * 'a;
+  edesc          : 'a hept_it_funs -> 'a -> desc -> desc * 'a;
+  eq             : 'a hept_it_funs -> 'a -> eq -> eq * 'a;
+  eqdesc         : 'a hept_it_funs -> 'a -> eqdesc -> eqdesc * 'a;
+  escape_unless  : 'a hept_it_funs -> 'a -> escape -> escape * 'a;
+  escape_until   : 'a hept_it_funs -> 'a -> escape -> escape * 'a;
+  exp            : 'a hept_it_funs -> 'a -> exp -> exp * 'a;
+  pat            : 'a hept_it_funs -> 'a -> pat -> pat * 'a;
+  present_handler: 'a hept_it_funs -> 'a -> present_handler -> present_handler * 'a;
+  state_handler  : 'a hept_it_funs -> 'a -> state_handler -> state_handler * 'a;
+  switch_handler : 'a hept_it_funs -> 'a -> switch_handler -> switch_handler * 'a;
+  var_dec        : 'a hept_it_funs -> 'a -> var_dec -> var_dec * 'a;
+  last           : 'a hept_it_funs -> 'a -> last -> last * 'a;
+  contract       : 'a hept_it_funs -> 'a -> contract -> contract * 'a;
+  node_dec       : 'a hept_it_funs -> 'a -> node_dec -> node_dec * 'a;
+  const_dec      : 'a hept_it_funs -> 'a -> const_dec -> const_dec * 'a;
+  program        : 'a hept_it_funs -> 'a -> program -> program * 'a;
+  global_funs    : 'a Global_mapfold.global_it_funs }
 
 
 let rec exp_it funs acc e = funs.exp funs acc e
@@ -129,12 +108,13 @@ and edesc funs acc ed = match ed with
       let args, acc = mapfold (exp_it funs) acc args in
       let reset, acc = optional_wacc (exp_it funs) acc reset in
       Eapp (app, args, reset), acc
-  | Eiterator (i, app, param, args, reset) ->
+  | Eiterator (i, app, param, pargs, args, reset) ->
       let app, acc = app_it funs acc app in
       let param, acc = static_exp_it funs.global_funs acc param in
+      let pargs, acc = mapfold (exp_it funs) acc pargs in
       let args, acc = mapfold (exp_it funs) acc args in
       let reset, acc = optional_wacc (exp_it funs) acc reset in
-      Eiterator (i, app, param, args, reset), acc
+      Eiterator (i, app, param, pargs, args, reset), acc
   | Ewhen (e, c, n) ->
       let e, acc = exp_it funs acc e in
       Ewhen (e, c, n), acc
@@ -199,7 +179,7 @@ and eqdesc funs acc eqd = match eqd with
 
 and block_it funs acc b = funs.block funs acc b
 and block funs acc b =
-  (* defnames ty ?? *)
+  (* TODO defnames ty ?? *)
   let b_local, acc = mapfold (var_dec_it funs) acc b.b_local in
   let b_equs, acc = mapfold (eq_it funs) acc b.b_equs in
   { b with b_local = b_local; b_equs = b_equs }, acc
@@ -237,7 +217,7 @@ and present_handler funs acc ph =
 
 and var_dec_it funs acc vd = funs.var_dec funs acc vd
 and var_dec funs acc vd =
-  (* v_type ??? *)
+  (* TODO v_type ??? *)
   let v_last, acc = last_it funs acc vd.v_last in
   { vd with v_last = v_last }, acc
 

compiler/heptagon/hept_printer.ml

@@ -105,11 +105,12 @@ and print_exp_desc ff = function
         print_app (app, args) print_every reset
   | Estruct(f_e_list) ->
       print_record (print_couple print_qualname print_exp """ = """) ff f_e_list
-  | Eiterator (it, f, param, args, reset) ->
-      fprintf ff "@[<2>(%s (%a)<<%a>>)@,%a@]%a"
+  | Eiterator (it, f, param, pargs, args, reset) ->
+      fprintf ff "@[<2>(%s (%a)<<%a>>)@,(%a)%a@]%a"
         (iterator_to_string it)
         print_app (f, [])
         print_static_exp param
+        print_exp_tuple pargs
         print_exp_tuple args
         print_every reset
   | Ewhen (e, c, ec) ->
@@ -128,54 +129,55 @@ and print_tag_e_list ff tag_e_list =
 and print_every ff reset =
   print_opt (fun ff id -> fprintf ff " every %a" print_exp id) ff reset
 
-and print_app ff (app, args) = match app.a_op with
- | Eequal ->
-    let e1, e2 = assert_2 args in
-      fprintf ff "@[<2>%a@ = %a@]" print_exp e1  print_exp e2
-  | Etuple -> print_exp_tuple ff args
-  | Efun f | Enode f ->
-      fprintf ff "@[%a@,%a@,%a@]"
-        print_qualname f print_params app.a_params  print_exp_tuple args
-  | Eifthenelse ->
-    let e1, e2, e3 = assert_3 args in
-      fprintf ff "@[<hv>if %a@ then %a@ else %a@]"
-        print_exp e1 print_exp e2 print_exp e3
-  | Efield ->
-    let r = assert_1 args in
-    let f = assert_1 app.a_params in
-    fprintf ff "%a.%a" print_exp r print_static_exp f
-  | Efield_update ->
-    let r,e = assert_2 args in
-    let f = assert_1 app.a_params in
-      fprintf ff "@[<2>{%a with .%a =@ %a}@]"
-        print_exp r print_static_exp f print_exp e
-  | Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") args
-  | Earray_fill ->
-    let e = assert_1 args in
-    let n = assert_1 app.a_params in
-      fprintf ff "%a^%a" print_exp e print_static_exp n
-  | Eselect ->
-    let e = assert_1 args in
-      fprintf ff "%a%a" print_exp e print_index app.a_params
-  | Eselect_slice ->
-    let e = assert_1 args in
-    let idx1, idx2 = assert_2 app.a_params in
-      fprintf ff "%a[%a..%a]"
-        print_exp e  print_static_exp idx1  print_static_exp idx2
-  | Eselect_dyn ->
-    let r, d, e = assert_2min args in
-      fprintf ff "%a%a default %a"
-        print_exp r  print_dyn_index e  print_exp d
-  | Eupdate ->
-    let e1, e2, idx = assert_2min args in
-        fprintf ff "@[<2>(%a with %a =@ %a)@]"
-          print_exp e1 print_dyn_index idx print_exp e2
-  | Econcat ->
-    let e1, e2 = assert_2 args in
-      fprintf ff "@[<2>%a@ @@ %a@]" print_exp e1  print_exp e2
-  | Earrow ->
-    let e1, e2 = assert_2 args in
-      fprintf ff "@[<2>%a ->@ %a@]" print_exp e1  print_exp e2
+and print_app ff (app, args) =
+  match app.a_op with
+    | Eequal ->
+      let e1, e2 = assert_2 args in
+        fprintf ff "@[<2>%a@ = %a@]" print_exp e1  print_exp e2
+    | Etuple -> print_exp_tuple ff args
+    | Efun f | Enode f ->
+        fprintf ff "@[%a@,%a@,%a@]"
+          print_qualname f print_params app.a_params  print_exp_tuple args
+    | Eifthenelse ->
+      let e1, e2, e3 = assert_3 args in
+        fprintf ff "@[<hv>if %a@ then %a@ else %a@]"
+          print_exp e1 print_exp e2 print_exp e3
+    | Efield ->
+      let r = assert_1 args in
+      let f = assert_1 app.a_params in
+      fprintf ff "%a.%a" print_exp r print_static_exp f
+    | Efield_update ->
+      let r,e = assert_2 args in
+      let f = assert_1 app.a_params in
+        fprintf ff "@[<2>{%a with .%a =@ %a}@]"
+          print_exp r print_static_exp f print_exp e
+    | Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") args
+    | Earray_fill ->
+      let e = assert_1 args in
+      let n = assert_1 app.a_params in
+        fprintf ff "%a^%a" print_exp e print_static_exp n
+    | Eselect ->
+      let e = assert_1 args in
+        fprintf ff "%a%a" print_exp e print_index app.a_params
+    | Eselect_slice ->
+      let e = assert_1 args in
+      let idx1, idx2 = assert_2 app.a_params in
+        fprintf ff "%a[%a..%a]"
+          print_exp e  print_static_exp idx1  print_static_exp idx2
+    | Eselect_dyn ->
+      let r, d, e = assert_2min args in
+        fprintf ff "%a%a default %a"
+          print_exp r  print_dyn_index e  print_exp d
+    | Eupdate ->
+      let e1, e2, idx = assert_2min args in
+          fprintf ff "@[<2>(%a with %a =@ %a)@]"
+            print_exp e1 print_dyn_index idx print_exp e2
+    | Econcat ->
+      let e1, e2 = assert_2 args in
+        fprintf ff "@[<2>%a@ @@ %a@]" print_exp e1  print_exp e2
+    | Earrow ->
+      let e1, e2 = assert_2 args in
+        fprintf ff "@[<2>%a ->@ %a@]" print_exp e1  print_exp e2
 
 let rec print_eq ff eq =
   match eq.eq_desc with
@@ -281,7 +283,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

compiler/heptagon/heptagon.ml

@@ -36,7 +36,8 @@ and desc =
   | Econst of static_exp
   | Evar of var_ident
   | Elast of var_ident
-  | Epre of static_exp option * exp (* the static_exp purpose is the initialization of the mem_var *)
+  (* the static_exp purpose is the initialization of the mem_var *)
+  | Epre of static_exp option * exp
   | Efby of exp * exp
   | Estruct of (field_name * exp) list
   | Ewhen of exp * constructor_name * exp
@@ -44,7 +45,8 @@ and desc =
   | Emerge of exp * (constructor_name * exp) list
     (** merge ident (Constructor -> exp)+ *)
   | Eapp of app * exp list * exp option
-  | Eiterator of iterator_type * app * static_exp * exp list * exp option
+  | Eiterator of iterator_type * app * static_exp
+                  * exp list * exp list * exp option
 
 and app = {
   a_op     : op;
@@ -74,8 +76,8 @@ and pat =
 
 type eq = {
   eq_desc      : eqdesc;
-  eq_statefull : bool;
-  eq_loc       : location }
+  eq_stateful : bool;
+  eq_loc       : location; }
 
 and eqdesc =
   | Eautomaton of state_handler list
@@ -89,8 +91,8 @@ and block = {
   b_local     : var_dec list;
   b_equs      : eq list;
   b_defnames  : ty Env.t;
-  b_statefull : bool;
-  b_loc       : location }
+  b_stateful : bool;
+  b_loc       : location; }
 
 and state_handler = {
   s_state  : state_name;
@@ -139,7 +141,7 @@ type contract = {
 
 type node_dec = {
   n_name      : qualname;
-  n_statefull : bool;
+  n_stateful : bool;
   n_input     : var_dec list;
   n_output    : var_dec list;
   n_contract  : contract option;
@@ -155,8 +157,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 }
@@ -164,7 +166,7 @@ type program = {
 type signature = {
   sig_name      : qualname;
   sig_inputs    : arg list;
-  sig_statefull : bool;
+  sig_stateful : bool;
   sig_outputs   : arg list;
   sig_params    : param list;
   sig_loc       : location }
@@ -176,7 +178,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
@@ -186,25 +188,25 @@ let mk_exp desc ?(ct_annot = Clocks.invalid_clock) ?(loc = no_location) ty  =
   { e_desc = desc; e_ty = ty; e_ct_annot = ct_annot;
     e_base_ck = Cbase; e_loc = loc; }
 
-let mk_op ?(params=[]) ?(unsafe=false) op =
+let mk_app ?(params=[]) ?(unsafe=false) op =
   { a_op = op; a_params = params; a_unsafe = unsafe }
 
 let mk_op_app ?(params=[]) ?(unsafe=false) ?(reset=None) op args =
-  Eapp(mk_op ~params:params ~unsafe:unsafe op, args, reset)
+  Eapp(mk_app ~params:params ~unsafe:unsafe op, args, reset)
 
 let mk_type_dec name desc =
   { t_name = name; t_desc = desc; t_loc = no_location; }
 
-let mk_equation ?(statefull = true) desc =
-  { eq_desc = desc; eq_statefull = statefull; eq_loc = no_location; }
+let mk_equation ?(stateful = true) desc =
+  { eq_desc = desc; eq_stateful = stateful; eq_loc = no_location; }
 
 let mk_var_dec ?(last = Var) ?(ck = fresh_clock()) name ty =
   { v_ident = name; v_type = ty; v_clock = ck;
     v_last = last; v_loc = no_location }
 
-let mk_block ?(statefull = true) ?(defnames = Env.empty) ?(locals = []) eqs =
+let mk_block ?(stateful = true) ?(defnames = Env.empty) ?(locals = []) eqs =
   { b_local = locals; b_equs = eqs; b_defnames = defnames;
-    b_statefull = statefull; b_loc = no_location }
+    b_stateful = stateful; b_loc = no_location; }
 
 let dfalse =
   mk_exp (Econst (mk_static_bool false)) (Tid Initial.pbool)
@@ -215,15 +217,15 @@ let mk_ifthenelse e1 e2 e3 =
   { e3 with e_desc = mk_op_app Eifthenelse [e1; e2; e3] }
 
 let mk_simple_equation pat e =
-  mk_equation ~statefull:false (Eeq(pat, e))
+  mk_equation ~stateful:false (Eeq(pat, e))
 
-let mk_switch_equation ?(statefull = true) e l =
-  mk_equation ~statefull:statefull (Eswitch (e, l))
+let mk_switch_equation ?(stateful = true) e l =
+  mk_equation ~stateful:stateful (Eswitch (e, l))
 
-let mk_signature name ins outs statefull params loc =
+let mk_signature name ins outs stateful params loc =
   { sig_name = name;
     sig_inputs = ins;
-    sig_statefull = statefull;
+    sig_stateful = stateful;
     sig_outputs = outs;
     sig_params = params;
     sig_loc = loc }

compiler/heptagon/main/hept_parser_scoper.ml

@@ -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 *)
 

compiler/heptagon/main/heptcheck.ml

@@ -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"

compiler/heptagon/parsing/hept_lexer.mll

@@ -121,7 +121,9 @@ rule token = parse
   | [' ' '\t'] +    { token lexbuf }
   | "."             {DOT}
   | "("             {LPAREN}
+  | "(("             {LPARENLPAREN}
   | ")"             {RPAREN}
+  | "))"             {RPARENRPAREN}
   | "*"             { STAR }
   | "{"             {LBRACE}
   | "}"             {RBRACE}

compiler/heptagon/parsing/hept_parser.mly

@@ -9,7 +9,7 @@ open Hept_parsetree
 
 %}
 
-%token DOT LPAREN RPAREN LBRACE RBRACE COLON SEMICOL
+%token DOT LPAREN LPARENLPAREN RPAREN RPARENRPAREN LBRACE RBRACE COLON SEMICOL
 %token EQUAL EQUALEQUAL LESS_GREATER BARBAR COMMA BAR ARROW LET TEL
 %token <string> Constructor
 %token <string> IDENT
@@ -58,7 +58,6 @@ open Hept_parsetree
 
 
 %right AROBASE
-%nonassoc prec_ident
 %nonassoc DEFAULT
 %left ELSE
 %right ARROW
@@ -76,7 +75,7 @@ open Hept_parsetree
 %right PRE
 %left POWER
 %right PREFIX
-%left DOT
+
 
 
 %start program
@@ -94,6 +93,10 @@ slist(S, x) :
   |                        {[]}
   | x=x                    {[x]}
   | x=x S r=slist(S,x)     {x::r}
+/* Separated list with delimiter*/
+delim_slist(S, L, R, x) :
+  |                        {[]}
+  | L l=slist(S, x) R      {l}
 /*Separated Nonempty list */
 snlist(S, x) :
   | x=x                    {[x]}
@@ -125,7 +128,7 @@ pragma_headers:
 
 open_modules:
   | /* empty */ { [] }
-  | open_modules OPEN Constructor { $3 :: $1 }
+  | open_modules OPEN modul { $3 :: $1 }
 ;
 
 const_decs:
@@ -184,7 +187,7 @@ node_dec:
     RETURNS LPAREN out_params RPAREN
     contract b=block(LET) TEL
       {{ n_name = $2;
-         n_statefull = $1;
+         n_stateful = $1;
          n_input  = $5;
          n_output = $9;
          n_contract = $11;
@@ -309,7 +312,8 @@ sblock(S) :
   | VAR l=loc_params S eq=equs { mk_block l eq (Loc($startpos,$endpos)) }
   | eq=equs                  { mk_block [] eq (Loc($startpos,$endpos)) }
 
-equ: eq=_equ { mk_equation eq (Loc($startpos,$endpos)) }
+equ:
+  | eq=_equ { mk_equation eq (Loc($startpos,$endpos)) }
 _equ:
   | pat EQUAL exp { Eeq($1, $3) }
   | AUTOMATON automaton_handlers END
@@ -430,8 +434,6 @@ _simple_exp:
                 Efield [$1] }
 ;
 
-node_name:
-  | qualname call_params { mk_app (Enode $1) $2 }
 
 merge_handlers:
   | hs=nonempty_list(merge_handler) { hs }
@@ -446,8 +448,9 @@ _exp:
       { Efby ($1, $3) }
   | PRE exp
       { Epre (None, $2) }
-  | node_name LPAREN exps RPAREN
-      { Eapp($1, $3) }
+  /* node call*/
+  | n=qualname p=call_params LPAREN args=exps RPAREN
+      { Eapp(mk_app (Enode n) p , args) }
   | NOT exp
       { mk_op_call "not" [$2] }
   | exp INFIX4 exp
@@ -501,11 +504,15 @@ _exp:
   | exp AROBASE exp
       { mk_call Econcat [$1; $3] }
 /*Iterators*/
-  | iterator qualname DOUBLE_LESS simple_exp DOUBLE_GREATER LPAREN exps RPAREN
-      { mk_iterator_call $1 $2 [] $4 $7 }
-  | iterator LPAREN qualname DOUBLE_LESS array_exp_list DOUBLE_GREATER
-      RPAREN DOUBLE_LESS simple_exp DOUBLE_GREATER LPAREN exps RPAREN
-      { mk_iterator_call $1 $3 $5 $9 $12 }
+  | it=iterator DOUBLE_LESS n=simple_exp DOUBLE_GREATER q=qualname
+      pargs=delim_slist(COMMA, LPARENLPAREN, RPARENRPAREN, exp)
+      LPAREN args=exps RPAREN
+      { mk_iterator_call it q [] n pargs args }
+  | it=iterator DOUBLE_LESS n=simple_exp DOUBLE_GREATER
+      LPAREN q=qualname DOUBLE_LESS sa=array_exp_list DOUBLE_GREATER RPAREN
+      pargs=delim_slist(COMMA, LPARENLPAREN, RPARENRPAREN, exp)
+      LPAREN args=exps RPAREN
+      { mk_iterator_call it q sa n pargs args }
 /*Records operators */
   | LBRACE simple_exp WITH DOT c=qualname EQUAL exp RBRACE
       { mk_call ~params:[mk_field_exp c (Loc($startpos(c),$endpos(c)))]
@@ -529,25 +536,32 @@ 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} }
+  | Constructor { ToQ $1 }
+  | q=qualified(Constructor) { q }
 ;
 
 qualname:
-  | ident { ToQ $1 }
-  | Constructor DOT ident { Q {qual = $1; name = $3} }
+  | i=ident { ToQ i }
+  | q=qualified(ident) { q }
 ;
 
 
-const: c=_const { mk_static_exp c (Loc($startpos,$endpos)) }
+const:
+  | c=_const { mk_static_exp c (Loc($startpos,$endpos)) }
 _const:
-  | INT         { Sint $1 }
-  | FLOAT       { Sfloat $1 }
-  | BOOL        { Sbool $1 }
-  | constructor { Sconstructor $1 }
-  | Constructor DOT ident
-      { Svar (Q {qual = $1; name = $3}) }
+  | INT                { Sint $1 }
+  | FLOAT              { Sfloat $1 }
+  | BOOL               { Sbool $1 }
+  | constructor        { Sconstructor $1 }
+  | q=qualified(ident) { Svar q }
 ;
 
 tuple_exp:
@@ -604,12 +618,12 @@ 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;
                    sig_inputs = $6;
-                   sig_statefull = $2;
+                   sig_stateful = $2;
                    sig_outputs = $10;
                    sig_params = $4;
                    sig_loc = (Loc($startpos,$endpos)) }) }

compiler/heptagon/parsing/hept_parsetree.ml

@@ -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
 
@@ -70,7 +72,7 @@ and edesc =
   | Efby of exp * exp
   | Estruct of (qualname * exp) list
   | Eapp of app * exp list
-  | Eiterator of iterator_type * app * exp * exp list
+  | Eiterator of iterator_type * app * exp * exp list * exp list
   | Ewhen of exp * constructor_name * var_name
   | Emerge of var_name * (constructor_name * exp) list
 
@@ -160,7 +162,7 @@ type contract =
 
 type node_dec =
   { n_name      : dec_name;
-    n_statefull : bool;
+    n_stateful : bool;
     n_input     : var_dec list;
     n_output    : var_dec list;
     n_contract  : contract option;
@@ -177,7 +179,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; }
@@ -189,7 +191,7 @@ type arg =
 type signature =
   { sig_name      : dec_name;
     sig_inputs    : arg list;
-    sig_statefull : bool;
+    sig_stateful : bool;
     sig_outputs   : arg list;
     sig_params    : var_dec list;
     sig_loc       : location }
@@ -201,7 +203,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
@@ -212,17 +214,16 @@ let mk_exp desc ?(ct_annot = Clocks.invalid_clock) loc =
   { e_desc = desc; e_ct_annot = ct_annot; e_loc = loc }
 
 let mk_app op params =
-  { a_op = op; a_params = params }
+  { a_op = op; a_params = params; }
 
 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)
+let mk_iterator_call it ln params n pexps exps =
+  Eiterator (it, mk_app (Enode ln) params, n, pexps, exps)
 
 let mk_static_exp desc loc =
   { se_desc = desc; se_loc = loc }
@@ -248,7 +249,7 @@ let mk_var_dec name ty last loc =
 
 let mk_block locals eqs loc =
   { b_local = locals; b_equs = eqs;
-    b_loc = loc }
+    b_loc = loc; }
 
 let mk_const_dec id ty e loc =
   { c_name = id; c_type = ty; c_value = e; c_loc = loc }

compiler/heptagon/parsing/hept_parsetree_mapfold.ml

@@ -146,11 +146,12 @@ and edesc funs acc ed = match ed with
       let app, acc = app_it funs acc app in
       let args, acc = mapfold (exp_it funs) acc args in
       Eapp (app, args), acc
-  | Eiterator (i, app, param, args) ->
+  | Eiterator (i, app, param, pargs, args) ->
       let app, acc = app_it funs acc app in
       let param, acc = exp_it funs acc param in
+      let pargs, acc = mapfold (exp_it funs) acc pargs in
       let args, acc = mapfold (exp_it funs) acc args in
-      Eiterator (i, app, param, args), acc
+      Eiterator (i, app, param, pargs, args), acc
 
 
 and app_it funs acc a = funs.app funs acc a

compiler/heptagon/parsing/hept_scoping.ml

@@ -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
 
@@ -214,7 +214,8 @@ let rec translate_type loc ty =
       | Tid ln -> Types.Tid (qualify_type ln)
       | Tarray (ty, e) ->
           let ty = translate_type loc ty in
-          Types.Tarray (ty, expect_static_exp e))
+          Types.Tarray (ty, expect_static_exp e)
+    )
   with
     | ScopingError err -> message loc err
 
@@ -242,18 +243,20 @@ and translate_desc loc env = function
         List.map (fun (f,e) -> qualify_field f, translate_exp env e)
           f_e_list in
       Heptagon.Estruct f_e_list
-  | Eapp ({ a_op = op; a_params = params }, e_list) ->
+  | Eapp ({ a_op = op; a_params = params; }, e_list) ->
       let e_list = List.map (translate_exp env) e_list in
       let params = List.map (expect_static_exp) params in
-      let app = Heptagon.mk_op ~params:params (translate_op op) in
+      let app = Heptagon.mk_app ~params:params (translate_op op) in
       Heptagon.Eapp (app, e_list, None)
-  | Eiterator (it, { a_op = op; a_params = params }, n, e_list) ->
+
+  | Eiterator (it, { a_op = op; a_params = params }, n, pe_list, e_list) ->
       let e_list = List.map (translate_exp env) e_list in
+      let pe_list = List.map (translate_exp env) pe_list in
       let n = expect_static_exp n in
       let params = List.map (expect_static_exp) params in
-      let app = Heptagon.mk_op ~params:params (translate_op op) in
+      let app = Heptagon.mk_app ~params:params (translate_op op) in
       Heptagon.Eiterator (translate_iterator_type it,
-                          app, n, e_list, None)
+                          app, n, pe_list, e_list, None)
   | Ewhen (e, c, ce) ->
       let e = translate_exp env e in
       let c = qualify_constrs c in
@@ -269,6 +272,7 @@ and translate_desc loc env = function
         List.map fun_c_e c_e_list in
       Heptagon.Emerge (e, c_e_list)
 
+
 and translate_op = function
   | Eequal -> Heptagon.Eequal
   | Earrow -> Heptagon.Earrow
@@ -292,8 +296,8 @@ and translate_pat loc env = function
 
 let rec translate_eq env eq =
   { Heptagon.eq_desc = translate_eq_desc eq.eq_loc env eq.eq_desc ;
-    Heptagon.eq_statefull = false;
-    Heptagon.eq_loc = eq.eq_loc }
+    Heptagon.eq_stateful = false;
+    Heptagon.eq_loc = eq.eq_loc; }
 
 and translate_eq_desc loc env = function
   | Eswitch(e, switch_handlers) ->
@@ -322,8 +326,8 @@ and translate_block env b =
   { Heptagon.b_local = translate_vd_list env b.b_local;
     Heptagon.b_equs = List.map (translate_eq env) b.b_equs;
     Heptagon.b_defnames = Env.empty;
-    Heptagon.b_statefull = false;
-    Heptagon.b_loc = b.b_loc }, env
+    Heptagon.b_stateful = false;
+    Heptagon.b_loc = b.b_loc; }, env
 
 and translate_state_handler env sh =
   let b, env = translate_block env sh.s_block in
@@ -398,9 +402,9 @@ let translate_node node =
   let i = args_of_var_decs node.n_input in
   let o = args_of_var_decs node.n_output in
   let p = params_of_var_decs node.n_params in
-  add_value n (Signature.mk_node i o node.n_statefull p);
+  add_value n (Signature.mk_node i o node.n_stateful p);
   { Heptagon.n_name = n;
-    Heptagon.n_statefull = node.n_statefull;
+    Heptagon.n_stateful = node.n_stateful;
     Heptagon.n_input = inputs;
     Heptagon.n_output = outputs;
     Heptagon.n_contract = contract;
@@ -452,7 +456,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;
@@ -465,8 +469,8 @@ let translate_signature s =
   let i = List.map translate_arg s.sig_inputs in
   let o = List.map translate_arg s.sig_outputs in
   let p = params_of_var_decs s.sig_params in
-  add_value n (Signature.mk_node i o s.sig_statefull p);
-  Heptagon.mk_signature n i o s.sig_statefull p s.sig_loc
+  add_value n (Signature.mk_node i o s.sig_stateful p);
+  Heptagon.mk_signature n i o s.sig_stateful p s.sig_loc
 
 
 let translate_interface_desc = function

compiler/heptagon/parsing/hept_static_scoping.ml

@@ -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
 

compiler/heptagon/transformations/every.ml

@@ -16,11 +16,12 @@ let edesc funs (v,acc_eq_list) ed =
   let ed, (v, acc_eq_list) = Hept_mapfold.edesc funs (v,acc_eq_list) ed in
   match ed with
     | Eapp (op, e_list, Some re) when not (is_var re) ->
-        let re, vre, eqre = Reset.equation_from_exp re in
+        let re, vre, eqre = Reset.bool_var_from_exp re in
         Eapp(op, e_list, Some re), (vre::v, eqre::acc_eq_list)
-    | Eiterator(it, op, n, e_list, Some re) when not (is_var re) ->
-        let re, vre, eqre = Reset.equation_from_exp re in
-          Eiterator(it, op, n, e_list, Some re), (vre::v, eqre::acc_eq_list)
+    | Eiterator(it, op, n, pe_list, e_list, Some re) when not (is_var re) ->
+        let re, vre, eqre = Reset.bool_var_from_exp re in
+          Eiterator(it, op, n, pe_list, e_list, Some re),
+             (vre::v, eqre::acc_eq_list)
     | _ -> ed, (v, acc_eq_list)
 
 let program p =

compiler/heptagon/transformations/inline.ml

@@ -56,7 +56,7 @@ let exp funs (env, newvars, newequs) exp = match exp.e_desc with
   | Eapp ({ a_op = Enode nn; } as op, argl, rso) when to_be_inlined nn ->
       let add_reset eq = match rso with
         | None -> eq
-        | Some x -> mk_equation ~statefull:false
+        | Some x -> mk_equation ~stateful:false
             (Ereset (mk_block [eq], x)) in
 
       let ni = mk_unique_node (env nn) in
@@ -80,7 +80,7 @@ let exp funs (env, newvars, newequs) exp = match exp.e_desc with
         fst (Hept_mapfold.node_dec funs () ni) in
 
       let mk_input_equ vd e =
-        mk_equation ~statefull:false (Eeq (Evarpat vd.v_ident, e)) in
+        mk_equation ~stateful:false (Eeq (Evarpat vd.v_ident, e)) in
       let mk_output_exp vd = mk_exp (Evar vd.v_ident) vd.v_type in
 
       let newvars = ni.n_input @ ni.n_block.b_local @ ni.n_output @ newvars

compiler/heptagon/transformations/present.ml

@@ -7,15 +7,16 @@
 (*                                                                        *)
 (**************************************************************************)
 (* removing present statements *)
+
 open Heptagon
 open Hept_mapfold
 
 let translate_present_handlers handlers cont =
   let translate_present_handler { p_cond = e; p_block = b } cont =
-    let statefull = b.b_statefull or cont.b_statefull in
-      mk_block ~statefull:statefull ~defnames:b.b_defnames
+    let stateful = b.b_stateful or cont.b_stateful in
+      mk_block ~stateful:stateful ~defnames:b.b_defnames
         [mk_switch_equation
-           ~statefull:statefull e
+           ~stateful:stateful e
            [{ w_name = Initial.ptrue; w_block = b };
             { w_name = Initial.pfalse; w_block = cont }]] in
   let b = List.fold_right translate_present_handler handlers cont in

compiler/heptagon/transformations/reset.ml

@@ -8,7 +8,7 @@
 (**************************************************************************)
 (* removing reset statements *)
 
-(* REQUIRES automaton switch statefull present *)
+(* REQUIRES automaton switch stateful present *)
 
 open Misc
 open Idents
@@ -23,12 +23,12 @@ open Initial
 
 let fresh = Idents.gen_fresh "reset" (fun () -> "r")
 
-(* get e and return x, var_dec_x, x = e *)
-let equation_from_exp e =
-  let n = fresh() in
-  { e with e_desc = Evar n }, mk_var_dec n (Tid Initial.pbool), mk_equation (Eeq(Evarpat n, e))
-
+(* get e and return r, var_dec_r, r = e *)
+let bool_var_from_exp e =
+  let r = fresh() in
+  { e with e_desc = Evar r }, mk_var_dec r (Tid Initial.pbool), mk_equation (Eeq(Evarpat r, e))
 
+(** Merge two reset conditions *)
 let merge_resets res1 res2 =
   let mk_or e1 e2 = mk_op_app (Efun Initial.por) [e1;e2] in
   match res1, res2 with
@@ -66,15 +66,15 @@ let edesc funs (res,s) ed =
         ifres res e1 e2
     | Eapp({ a_op = Enode _ } as op, e_list, re) ->
         Eapp(op, e_list, merge_resets res re)
-    | Eiterator(it, ({ a_op = Enode _ } as op), n, e_list, re) ->
-        Eiterator(it, op, n, e_list, merge_resets res re)
+    | Eiterator(it, ({ a_op = Enode _ } as op), n, pe_list, e_list, re) ->
+        Eiterator(it, op, n, pe_list, e_list, merge_resets res re)
     | _ -> ed
   in
     ed, (res,s)
 
 
 
-let eq funs (res,_) eq = Hept_mapfold.eq funs (res,eq.eq_statefull) eq
+let eq funs (res,_) eq = Hept_mapfold.eq funs (res,eq.eq_stateful) eq
 
 (* Transform reset blocks in blocks with reseted exps, create a var to store the reset condition evaluation. *)
 let eqdesc funs (res,stateful) = function
@@ -82,10 +82,10 @@ let eqdesc funs (res,stateful) = function
       if stateful
       then (
         let e, _ = Hept_mapfold.exp_it funs (res,true) e in
-        let e, vd, eq = equation_from_exp e in
+        let e, vd, eq = bool_var_from_exp e in
         let r = merge_resets res (Some e) in
         let b, _ = Hept_mapfold.block_it funs (r,true) b in
-        let b = { b with b_equs = eq::b.b_equs; b_local = vd::b.b_local; b_statefull = true } in
+        let b = { b with b_equs = eq::b.b_equs; b_local = vd::b.b_local; b_stateful = true } in
         Eblock(b), (res,true))
       else (
         let b, _ = Hept_mapfold.block_it funs (res,false) b in

compiler/heptagon/transformations/switch.ml

@@ -155,11 +155,11 @@ let exp funs (env,h) e =
   | Evar _ -> Env.sample_var e env, (env,h)
   | _ -> Hept_mapfold.exp funs (env,h) e
 
-(* update statefull and loc *)
+(* update stateful and loc *)
 let eq funs (env,h) eq =
   let eqd = match eq.eq_desc with
-    | Eblock b -> (* probably created by eqdesc, so update statefull and loc *)
-        Eblock { b with b_statefull = eq.eq_statefull; b_loc = eq.eq_loc }
+    | Eblock b -> (* probably created by eqdesc, so update stateful and loc *)
+        Eblock { b with b_stateful = eq.eq_stateful; b_loc = eq.eq_loc }
     | _ -> eq.eq_desc in
   Hept_mapfold.eq funs (env,h) {eq with eq_desc = eqd}
 

compiler/main/hept2mls.ml

@@ -209,8 +209,7 @@ let rec translate_op = function
   | Heptagon.Econcat -> Econcat
   | Heptagon.Earray -> Earray
   | Heptagon.Etuple -> Etuple
-  | Heptagon.Earrow ->
-      Error.message no_location Error.Eunsupported_language_construct
+  | Heptagon.Earrow -> Error.message no_location Error.Eunsupported_language_construct
 
 let translate_app app =
   mk_app ~params:app.Heptagon.a_params
@@ -238,10 +237,11 @@ let rec translate env
         mk_exp ~loc:loc ~ty:ty (Eapp (translate_app app,
                                           List.map (translate env) e_list,
                                           translate_reset reset))
-    | Heptagon.Eiterator(it, app, n, e_list, reset) ->
+    | Heptagon.Eiterator(it, app, n, pe_list, e_list, reset) ->
         mk_exp ~loc:loc ~ty:ty
           (Eiterator (translate_iterator_type it,
                     translate_app app, n,
+                    List.map (translate env) pe_list,
                     List.map (translate env) e_list,
                     translate_reset reset))
     | Heptagon.Efby _
@@ -377,7 +377,7 @@ let translate_contract env contract =
 
 let node
     { Heptagon.n_name = n; Heptagon.n_input = i; Heptagon.n_output = o;
-      Heptagon.n_contract = contract;
+      Heptagon.n_contract = contract; Heptagon.n_stateful = stateful;
       Heptagon.n_block = { Heptagon.b_local = v; Heptagon.b_equs = eq_list };
       Heptagon.n_loc = loc;
       Heptagon.n_params =  params;
@@ -390,10 +390,11 @@ let node
     translate_eqs env IdentSet.empty (locals, [], []) eq_list in
   let l_eqs, _ = add_locals IdentSet.empty l_eqs [] s_eqs in
   { n_name = n;
+    n_stateful = stateful;
     n_input = List.map translate_var i;
     n_output = List.map translate_var o;
     n_contract = contract;
-    n_controller_call = ([],[]);
+   (* n_controller_call = ([],[]); *)
     n_local = locals;
     n_equs = l_eqs;
     n_loc = loc ;

compiler/main/heptc.ml

@@ -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

compiler/main/mls2obc.ml

@@ -13,28 +13,36 @@ open Names
 open Idents
 open Signature
 open Obc
+open Obc_utils
+open Obc_mapfold
 open Types
-open Control
 open Static
-open Obc_mapfold
 open Initial
 
-let fresh_it () = Idents.gen_var "mls2obc" "i"
 
-let gen_obj_name n =
-  (shortname n) ^ "_mem" ^ (gen_symbol ())
+let fresh_it () =
+  let id = Idents.gen_var "mls2obc" "i" in
+  id, mk_var_dec id Initial.tint
 
-let op_from_string op = { qual = "Pervasives"; name = op; }
+let gen_obj_ident n = Idents.gen_var "mls2obc" ((shortname n) ^ "_inst")
 
-let rec lhs_of_idx_list e = function
-  | [] -> e | idx :: l -> mk_lhs (Larray (lhs_of_idx_list e l, idx))
+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
+    | _, [] -> p
+    | Tarray (ty',_), idx :: l -> mk_pattern ty' (Larray (aux ty' l, idx))
+    | _ -> internal_error "mls2obc" 1
+  in
+  aux p.pat_ty l
 
 let array_elt_of_exp idx e =
-  match e.e_desc with
-    | Econst ({ se_desc = Sarray_power (c, _) }) ->
-        mk_exp (Econst c)
-    | _ ->
-        mk_lhs_exp (Larray(lhs_of_exp e, mk_exp (Elhs idx)))
+  match e.e_desc, Modules.unalias_type e.e_ty with
+    | Econst ({ se_desc = Sarray_power (c, _) }), Tarray (ty,_) ->
+        mk_exp ty (Econst c)
+    | _, Tarray (ty,_) ->
+        mk_pattern_exp ty (Larray(pattern_of_exp e, mk_exp Initial.tint (Epattern idx)))
+    | _ -> internal_error "mls2obc" 2
 
 (** Creates the expression that checks that the indices
     in idx_list are in the bounds. If idx_list=[e1;..;ep]
@@ -43,21 +51,17 @@ let array_elt_of_exp idx e =
 (** TODO: Add check for idx >= 0  *)
 let rec bound_check_expr idx_list bounds =
   match (idx_list, bounds) with
-    | [idx], [n] ->
-        mk_exp (Eop (op_from_string "<",
-                     [idx; mk_exp (Econst n)]))
+    | [idx], [n] -> mk_exp_bool (Eop (op_from_string "<", [idx; mk_exp_int (Econst n)]))
     | (idx :: idx_list, n :: bounds) ->
-        let e = mk_exp (Eop (op_from_string "<",
-                             [idx; mk_exp (Econst n)])) in
-          mk_exp (Eop (op_from_string "&",
-                       [e; bound_check_expr idx_list bounds]))
-    | (_, _) -> assert false
+        let e = mk_exp_bool (Eop (op_from_string "<", [idx; mk_exp_int (Econst n)])) in
+        mk_exp_bool (Eop (op_from_string "&", [e; bound_check_expr idx_list bounds]))
+    | (_, _) -> internal_error "mls2obc" 3
 
 let reinit o =
   Acall ([], o, Mreset, [])
 
 let rec translate_pat map = function
-  | Minils.Evarpat x -> [ var_from_name map x ]
+  | Minils.Evarpat x -> [ Control.var_from_name map x ]
   | Minils.Etuplepat pat_list ->
       List.fold_right (fun pat acc -> (translate_pat map pat) @ acc)
         pat_list []
@@ -72,11 +76,10 @@ let translate_var_dec l =
 let rec translate map e =
   let desc = match e.Minils.e_desc with
     | Minils.Econst v -> Econst v
-    | Minils.Evar n -> Elhs (var_from_name map n)
+    | Minils.Evar n -> Epattern (Control.var_from_name map n)
     | Minils.Eapp ({ Minils.a_op = Minils.Eequal }, e_list, _) ->
         Eop (op_from_string "=", List.map (translate map ) e_list)
-    | Minils.Eapp ({ Minils.a_op = Minils.Efun n },
-                   e_list, _) when Mls_utils.is_op n ->
+    | Minils.Eapp ({ Minils.a_op = Minils.Efun n }, e_list, _) when Mls_utils.is_op n ->
         Eop (n, List.map (translate map ) e_list)
     | Minils.Ewhen (e, _, _) ->
         let e = translate map e in
@@ -88,100 +91,97 @@ let rec translate map e =
         let f_e_list = List.map (fun (f, e) -> (f, (translate map e))) f_e_list in
           Estruct (type_name, f_e_list)
     | Minils.Eapp ({ Minils.a_op = Minils.Efield; Minils.a_params = params }, e_list, _) ->
-        let f = match (assert_1 params).se_desc with Sfield f -> f | _ -> assert false in
+        let f = match (assert_1 params).se_desc with Sfield f -> f | _ -> internal_error "mls2obc" 4 in
         let e = translate map (assert_1 e_list) in
-          Elhs (mk_lhs (Lfield (lhs_of_exp e, f)))
+        Epattern (mk_pattern e.e_ty (Lfield (pattern_of_exp e, f)))
   (*Remaining array operators*)
     | Minils.Eapp ({ Minils.a_op = Minils.Earray }, e_list, _) ->
         Earray (List.map (translate map ) e_list)
     | Minils.Eapp ({ Minils.a_op = Minils.Eselect;
                      Minils.a_params = idx }, e_list, _) ->
         let e = translate map (assert_1 e_list) in
-        let idx_list = List.map (fun idx -> mk_exp (Econst idx)) idx in
-          Elhs (lhs_of_idx_list (lhs_of_exp e) idx_list)
-    | _ ->
-      Format.eprintf "%a@." Mls_printer.print_exp e;
-      assert false
+        let idx_list = List.map (fun idx -> mk_exp tint (Econst idx)) idx in
+          Epattern (pattern_of_idx_list (pattern_of_exp e) idx_list)
+  (* Already treated cases when translating the [eq] *)
+    | Minils.Eiterator _ | Minils.Emerge _ | Minils.Efby _
+    | Minils.Eapp ({Minils.a_op=(Minils.Enode _|Minils.Efun _|Minils.Econcat|Minils.Eupdate|Minils.Eselect_dyn
+                                 |Minils.Eselect_slice|Minils.Earray_fill|Minils.Efield_update|Minils.Eifthenelse
+                                 |Minils.Etuple)}, _, _) ->
+        (*Format.eprintf "%aThis should not be treated as an exp in mls2obc : %a@."
+          Location.print_location e.Minils.e_loc Mls_printer.print_exp e;
+        assert false*)
+        internal_error "mls2obc" 5
   in
-    mk_exp ~ty:e.Minils.e_ty desc
+  mk_exp e.Minils.e_ty desc
 
 (* [translate pat act = si, d] *)
 and translate_act map pat
     ({ Minils.e_desc = desc } as act) =
     match pat, desc with
-    | Minils.Etuplepat p_list,
-      Minils.Eapp ({ Minils.a_op = Minils.Etuple }, act_list, _) ->
+    | Minils.Etuplepat p_list, Minils.Eapp ({ Minils.a_op = Minils.Etuple }, act_list, _) ->
         List.flatten (List.map2 (translate_act map) p_list act_list)
-    | Minils.Etuplepat p_list,
-        Minils.Econst { se_desc = Stuple se_list } ->
+    | Minils.Etuplepat p_list, Minils.Econst { se_desc = Stuple se_list } ->
         let const_list = Mls_utils.exp_list_of_static_exp_list se_list in
-          List.flatten (List.map2 (translate_act map) p_list const_list)
+        List.flatten (List.map2 (translate_act map) p_list const_list)
+   (* When Merge *)
     | pat, Minils.Ewhen (e, _, _) ->
         translate_act map pat e
     | pat, Minils.Emerge (x, c_act_list) ->
-        let lhs = var_from_name map x in
-        [Acase (mk_exp (Elhs lhs),
-                translate_c_act_list map pat c_act_list)]
-
-    | Minils.Evarpat x,
-                Minils.Eapp ({ Minils.a_op = Minils.Econcat }, [e1; e2], _) ->
-        let cpt1 = fresh_it () in
-        let cpt2 = fresh_it () in
-        let x = var_from_name map x in
+        let pattern = Control.var_from_name map x in
+        [Acase (mk_exp pattern.pat_ty (Epattern pattern), translate_c_act_list map pat c_act_list)]
+   (* Array ops *)
+    | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Econcat }, [e1; e2], _) ->
+        let cpt1, cpt1d = fresh_it () in
+        let cpt2, cpt2d = fresh_it () in
+        let x = Control.var_from_name map x in
+        let t = x.pat_ty in
         (match e1.Minils.e_ty, e2.Minils.e_ty with
-           | Tarray (_, n1), Tarray (_, n2) ->
+           | Tarray (t1, n1), Tarray (t2, n2) ->
                let e1 = translate map e1 in
                let e2 = translate map e2 in
                let a1 =
-                 Afor (cpt1, mk_static_int 0, n1,
-                       mk_block [Aassgn (mk_lhs (Larray (x, mk_evar cpt1)),
-                                         mk_lhs_exp (Larray (lhs_of_exp e1,
-                                                        mk_evar cpt1)))] ) in
-               let idx = mk_exp (Eop (op_from_string "+",
-                                      [ mk_exp (Econst n1); mk_evar cpt2])) in
+                 Afor (cpt1d, mk_static_int 0, n1,
+                       mk_block [Aassgn (mk_pattern t1 (Larray (x, mk_evar_int cpt1)),
+                                         mk_pattern_exp t1 (Larray (pattern_of_exp e1, mk_evar_int cpt1)))] ) in
+               let idx = mk_exp_int (Eop (op_from_string "+", [ mk_exp_int (Econst n1); mk_evar_int cpt2])) in
                let a2 =
-                 Afor (cpt2, mk_static_int 0, n2,
-                       mk_block [Aassgn (mk_lhs (Larray (x, idx)),
-                                         mk_lhs_exp (Larray (lhs_of_exp e2,
-                                                             mk_evar cpt2)))] )
+                 Afor (cpt2d, mk_static_int 0, n2,
+                       mk_block [Aassgn (mk_pattern t2 (Larray (x, idx)),
+                                         mk_pattern_exp t2 (Larray (pattern_of_exp e2, mk_evar_int cpt2)))] )
                in
                [a1; a2]
            | _ -> assert false )
-
-    | Minils.Evarpat x,
-              Minils.Eapp ({ Minils.a_op = Minils.Earray_fill;
-                             Minils.a_params = [n] }, [e], _) ->
-        let cpt = fresh_it () in
+    | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Earray_fill; Minils.a_params = [n] }, [e], _) ->
+        let cpt, cptd = fresh_it () in
         let e = translate map e in
-          [ Afor (cpt, mk_static_int 0, n,
-                  mk_block [Aassgn (mk_lhs (Larray (var_from_name map x,
-                                                  mk_evar cpt)), e) ]) ]
-
-    | Minils.Evarpat x,
-        Minils.Eapp ({ Minils.a_op = Minils.Eselect_slice;
-                       Minils.a_params = [idx1; idx2] }, [e], _) ->
-        let cpt = fresh_it () in
+        let x = Control.var_from_name map x in
+        let t = match x.pat_ty with
+          | Tarray (t,_) -> t
+          | _ -> Misc.internal_error "mls2obc select slice type" 5
+        in
+        [ Afor (cptd, mk_static_int 0, n, mk_block [Aassgn (mk_pattern t (Larray (x, mk_evar_int cpt)), e) ]) ]
+    | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eselect_slice; Minils.a_params = [idx1; idx2] }, [e], _) ->
+        let cpt, cptd = fresh_it () in
         let e = translate map e in
-        let idx = mk_exp (Eop (op_from_string "+",
-                               [mk_evar cpt;
-                                mk_exp (Econst idx1) ])) in
+        let x = Control.var_from_name map x in
+        let t = match x.pat_ty with
+          | Tarray (t,_) -> t
+          | _ -> Misc.internal_error "mls2obc select slice type" 5
+        in
+        let idx = mk_exp_int (Eop (op_from_string "+", [mk_evar_int cpt; mk_exp_int (Econst idx1) ])) in
         (* bound = (idx2 - idx1) + 1*)
         let bound = mk_static_int_op (op_from_string "+")
-                      [ mk_static_int 1;
-                        mk_static_int_op (op_from_string "-") [idx2;idx1] ] in
-         [ Afor (cpt, mk_static_int 0, bound,
-                mk_block [Aassgn (mk_lhs (Larray (var_from_name map x,
-                                                  mk_evar cpt)),
-                      mk_lhs_exp (Larray (lhs_of_exp e, idx)))] ) ]
-
-   | Minils.Evarpat x,
-          Minils.Eapp ({ Minils.a_op = Minils.Eselect_dyn }, e1::e2::idx, _) ->
-        let x = var_from_name map x in
+                                     [ mk_static_int 1; mk_static_int_op (op_from_string "-") [idx2;idx1] ] in
+         [ Afor (cptd, mk_static_int 0, bound,
+                mk_block [Aassgn (mk_pattern t (Larray (x, mk_evar_int cpt)),
+                                  mk_pattern_exp t (Larray (pattern_of_exp e, idx)))] ) ]
+    | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eselect_dyn }, e1::e2::idx, _) ->
+        let x = Control.var_from_name map x in
         let bounds = Mls_utils.bounds_list e1.Minils.e_ty in
         let e1 = translate map e1 in
         let idx = List.map (translate map) idx in
-        let true_act =
-          Aassgn (x, mk_exp (Elhs (lhs_of_idx_list (lhs_of_exp e1) idx))) in
+        let p = pattern_of_idx_list (pattern_of_exp e1) idx in
+        let true_act = Aassgn (x, mk_exp p.pat_ty (Epattern p)) in
         let false_act = Aassgn (x, translate map e2) in
         let cond = bound_check_expr idx bounds in
           [ Acase (cond, [ ptrue, mk_block [true_act];
@@ -194,7 +194,7 @@ and translate_act map pat
         let x = var_from_name map x in
         let bounds = Mls_utils.bounds_list e1.Minils.e_ty in
         let idx = List.map (translate map) idx in
-        let action = Aassgn (lhs_of_idx_list x idx,
+        let action = Aassgn (pattern_of_idx_list x idx,
                             translate map e2) in
         let cond = bound_check_expr idx bounds in
         let action = Acase (cond, [ ptrue, mk_block [action] ]) in
@@ -203,17 +203,14 @@ and translate_act map pat
 
     (** TODO: remplacer par o = { f = v; g = a.g; h = a.h; ... } *)
     | Minils.Evarpat x,
-          Minils.Eapp ({ Minils.a_op = Minils.Efield_update;
-                   Minils.a_params = [{ se_desc = Sfield f }] },
-                  [e1; e2], _) ->
-        let x = var_from_name map x in
+      Minils.Eapp ({ Minils.a_op = Minils.Efield_update; Minils.a_params = [{ se_desc = Sfield f }] }, [e1; e2], _) ->
+        let x = Control.var_from_name map x in
         let copy = Aassgn (x, translate map e1) in
-        let action = Aassgn (mk_lhs (Lfield (x, f)),
-                             translate map e2) in
-          [copy; action]
+        let action = Aassgn (mk_pattern x.pat_ty (Lfield (x, f)), translate map e2) in (* TODO wrong type *)
+        [copy; action]
 
     | Minils.Evarpat n, _ ->
-        [Aassgn (var_from_name map n, translate map act)]
+        [Aassgn (Control.var_from_name map n, translate map act)]
     | _ ->
       Format.eprintf "%a The pattern %a should be a simple var to be translated to obc.@."
         Location.print_location act.Minils.e_loc Mls_printer.print_pat pat;
@@ -224,30 +221,37 @@ and translate_c_act_list map pat c_act_list =
     (fun (c, act) -> (c, mk_block (translate_act map pat act)))
     c_act_list
 
-let mk_obj_call_from_context (o, _) n =
-  match o with
-    | Oobj _ -> Oobj n
-    | Oarray (_, lhs) -> Oarray(n, lhs)
+(** In an iteration, objects used are element of object arrays *)
+type obj_array = { oa_index : Obc.pattern; oa_size : static_exp }
+
+(** A [None] context is normal, otherwise, we are in an iteration *)
+type call_context = obj_array option
+
+let mk_obj_call_from_context c n = match c with
+  | None -> Oobj n
+  | Some oa -> Oarray (n, oa.oa_index)
 
-let size_from_call_context (_, n) = n
+let size_from_call_context c = match c with
+  | None -> None
+  | Some oa -> Some (oa.oa_size)
 
-let empty_call_context = Oobj "n", None
+let empty_call_context = None
 
-(** [si] is the initialization actions used in the reset method.
+(** [si] the initialization actions used in the reset method,
     [j] obj decs
-    [s] is the list of actions used in the step method.
+    [s] the actions used in the step method.
     [v] var decs *)
 let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e }
     (v, si, j, s) =
   let { Minils.e_desc = desc; Minils.e_ck = ck; Minils.e_loc = loc } = e in
   match (pat, desc) with
     | Minils.Evarpat n, Minils.Efby (opt_c, e) ->
-        let x = var_from_name map n in
+        let x = Control.var_from_name map n in
         let si = (match opt_c with
                     | None -> si
-                    | Some c -> (Aassgn (x, mk_exp (Econst c))) :: si) in
-        let action = Aassgn (var_from_name map n, translate map e) in
-        v, si, j, (control map ck action) :: s
+                    | Some c -> (Aassgn (x, mk_exp x.pat_ty (Econst c))) :: si) in
+        let action = Aassgn (Control.var_from_name map n, translate map e) in
+        v, si, j, (Control.control map ck action) :: s
 
     | Minils.Etuplepat p_list,
         Minils.Eapp({ Minils.a_op = Minils.Etuple }, act_list, _) ->
@@ -268,63 +272,61 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e }
         let action =
           Acase (cond, [ptrue, mk_block ~locals:vt true_act;
                         pfalse, mk_block ~locals:vf false_act]) in
-          v, si, j, (control map ck action) :: s
+          v, si, j, (Control.control map ck action) :: s
 
-    | pat, Minils.Eapp ({ Minils.a_op = Minils.Efun _ | Minils.Enode _ } as app,
-                        e_list, r) ->
+    | pat, Minils.Eapp ({ Minils.a_op = Minils.Efun _ | Minils.Enode _ } as app, e_list, r) ->
         let name_list = translate_pat map pat in
         let c_list = List.map (translate map) e_list in
-        let v', si', j', action = mk_node_call map call_context
-          app loc name_list c_list in
-        let action = List.map (control map ck) action in
+        let v', si', j', action = mk_node_call map call_context app loc name_list c_list e.Minils.e_ty in
+        let action = List.map (Control.control map ck) action in
         let s = (match r, app.Minils.a_op with
                    | Some r, Minils.Enode _ ->
                        let ck = Clocks.Con (ck, Initial.ptrue, r) in
-                       let ra = List.map (control map ck) si' in
+                       let ra = List.map (Control.control map ck) si' in
                        ra @ action @ s
                    | _, _ -> action @ s) in
         v' @ v, si'@si, j'@j, s
 
-    | pat, Minils.Eiterator (it, app, n, e_list, reset) ->
+    | pat, Minils.Eiterator (it, app, n, pe_list, e_list, reset) ->
         let name_list = translate_pat map pat in
-        let c_list =
-          List.map (translate map) e_list in
-        let x = fresh_it () in
-        let call_context = Oarray ("n", mk_lhs (Lvar x)), Some n in
+        let p_list = List.map (translate map) pe_list in
+        let c_list = List.map (translate map) e_list in
+        let x, xd = fresh_it () in
+        let call_context =
+          Some { oa_index = mk_pattern_int (Lvar x); oa_size = n} in
         let si', j', action = translate_iterator map call_context it
-          name_list app loc n x c_list in
-        let action = List.map (control map ck) action in
+          name_list app loc n x xd p_list c_list e.Minils.e_ty in
+        let action = List.map (Control.control map ck) action in
         let s =
           (match reset, app.Minils.a_op with
              | Some r, Minils.Enode _ ->
                  let ck = Clocks.Con (ck, Initial.ptrue, r) in
-                 let ra = List.map (control map ck) si' in
+                 let ra = List.map (Control.control map ck) si' in
                    ra @ action @ s
              | _, _ -> action @ s)
         in (v, si' @ si, j' @ j, s)
 
     | (pat, _) ->
         let action = translate_act map pat e in
-        let action = List.map (control map ck) action in
+        let action = List.map (Control.control map ck) action in
           v, si, j, action @ s
 
 and translate_eq_list map call_context act_list =
   List.fold_right (translate_eq map call_context) act_list ([], [], [], [])
 
-and mk_node_call map call_context app loc name_list args =
+and mk_node_call map call_context app loc name_list args ty =
   match app.Minils.a_op with
     | Minils.Efun f when Mls_utils.is_op f ->
-        let e = mk_exp (Eop(f, args)) in
-        [], [], [], [Aassgn(List.hd name_list, e) ]
+        let e = mk_exp ty (Eop(f, args)) in
+        [], [], [], [Aassgn(List.hd name_list, e)]
 
     | Minils.Enode f when Itfusion.is_anon_node f ->
-        let add_input env vd =
-          Env.add vd.Minils.v_ident (mk_lhs (Lvar vd.Minils.v_ident)) env in
-        let build env vd a =
-          Env.add vd.Minils.v_ident a env in
+        let add_input env vd = Env.add vd.Minils.v_ident
+          (mk_pattern vd.Minils.v_type (Lvar vd.Minils.v_ident)) env in
+        let build env vd a = Env.add vd.Minils.v_ident a env in
         let subst_act_list env act_list =
           let exp funs env e = match e.e_desc with
-            | Elhs { pat_desc = Lvar x } ->
+            | Epattern { pat_desc = Lvar x } ->
                 let e =
                   (try Env.find x env
                   with Not_found -> e) in
@@ -345,74 +347,98 @@ and mk_node_call map call_context app loc name_list args =
           v @ nd.Minils.n_local, si, j, subst_act_list env s
 
     | Minils.Enode f | Minils.Efun f ->
-        let o = mk_obj_call_from_context call_context (gen_obj_name f) in
+        let o = mk_obj_call_from_context call_context (gen_obj_ident f) in
         let obj =
-          { o_name = obj_ref_name o; o_class = f;
+          { o_ident = obj_ref_name o; o_class = f;
             o_params = app.Minils.a_params;
             o_size = size_from_call_context call_context; o_loc = loc } in
-        let si =
-          (match app.Minils.a_op with
-             | Minils.Efun _ -> []
-             | Minils.Enode _ -> [reinit o]
-             | _ -> assert false) in
-          [], si, [obj], [Acall (name_list, o, Mstep, args)]
+        let si = (match app.Minils.a_op with
+                   | Minils.Efun _ -> []
+                   | Minils.Enode _ -> [reinit o]
+                   | _ -> assert false) in
+        let s = [Acall (name_list, o, Mstep, args)] in
+        [], si, [obj], s
     | _ -> assert false
 
-and translate_iterator map call_context it name_list app loc n x c_list =
-  let array_of_output name_list =
-    List.map (fun l -> mk_lhs (Larray (l, mk_evar x))) name_list in
+and translate_iterator map call_context it name_list
+    app loc n x xd p_list c_list ty =
+  let unarray ty = match ty with
+    | Tarray (t,_) -> t
+    | _ ->
+        Format.eprintf "%a" Global_printer.print_type ty;
+        internal_error "mls2obc" 6
+  in
+  let array_of_output name_list ty_list =
+    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_lhs (Lvar x))) c_list in
-
+    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 name_list = array_of_output name_list 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 ty_list in
         let v, si, j, action = mk_node_call map call_context
-          app loc name_list c_list in
+          app loc name_list (p_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 (x, 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 (name_list, acc_out) = split_last name_list in
-        let name_list = array_of_output name_list in
-        let v, si, j, action = mk_node_call map call_context
-          app loc (name_list @ [ acc_out ])
-          (c_list @ [ mk_exp (Elhs acc_out) ]) 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 ])
+          (p_list @ 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 (x, 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
         let c_list = array_of_input c_list in
         let acc_out = last_element name_list in
-        let v, si, j, action = mk_node_call map call_context
-          app loc name_list (c_list @ [ mk_exp (Elhs acc_out) ]) in
+        let v, si, j, action =
+          mk_node_call map call_context app loc name_list
+            (p_list @ c_list @ [ mk_exp acc_out.pat_ty (Epattern acc_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 (x, 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
         let c_list = array_of_input c_list in
         let acc_out = last_element name_list in
-        let v, si, j, action = mk_node_call map call_context
-          app loc name_list (c_list @ [ mk_evar x; mk_exp (Elhs acc_out) ]) in
+        let v, si, j, action = mk_node_call map call_context app loc name_list
+          (p_list @ c_list @ [ mk_evar_int x;
+                               mk_exp acc_out.pat_ty (Epattern acc_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 (x, 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
 
-let translate_contract map mem_vars =
+let translate_contract map mem_var_tys =
   function
     | None -> ([], [], [], [])
     | Some
@@ -420,58 +446,51 @@ let translate_contract map mem_vars =
           Minils.c_eq = eq_list;
           Minils.c_local = d_list;
         } ->
-        let (v, si, j, s_list) = translate_eq_list map
-          empty_call_context eq_list in
+        let (v, si, j, s_list) = translate_eq_list map empty_call_context eq_list in
         let d_list = translate_var_dec (v @ d_list) in
         let d_list = List.filter
-          (fun vd -> not (List.mem vd.v_ident mem_vars)) d_list in
+          (fun vd -> not (List.exists (fun (i,_) -> i = vd.v_ident) mem_var_tys)) d_list in
          (si, j, s_list, d_list)
 
 (** Returns a map, mapping variables names to the variables
     where they will be stored. *)
-let subst_map inputs outputs locals mems =
+let subst_map inputs outputs locals mem_tys =
   (* Create a map that simply maps each var to itself *)
-  let m =
+  let map =
     List.fold_left
-      (fun m { Minils.v_ident = x } -> Env.add x (mk_lhs (Lvar x)) m)
+      (fun m { Minils.v_ident = x; Minils.v_type = ty } -> Env.add x (mk_pattern ty (Lvar x)) m)
       Env.empty (inputs @ outputs @ locals)
   in
-  List.fold_left (fun m x -> Env.add x (mk_lhs (Lmem x)) m) m mems
+  List.fold_left (fun map (x, x_ty) -> Env.add x (mk_pattern x_ty (Lmem x)) map) map mem_tys
 
 let translate_node
-    ({
-      Minils.n_name = f;
-      Minils.n_input = i_list;
-      Minils.n_output = o_list;
-      Minils.n_local = d_list;
-      Minils.n_equs = eq_list;
-      Minils.n_contract = contract;
-      Minils.n_params = params;
-      Minils.n_loc = loc;
+    ({ Minils.n_name = f; Minils.n_input = i_list; Minils.n_output = o_list;
+      Minils.n_local = d_list; Minils.n_equs = eq_list; Minils.n_stateful = stateful;
+      Minils.n_contract = contract; Minils.n_params = params; Minils.n_loc = loc;
     } as n) =
-  let mem_vars = Mls_utils.node_memory_vars n in
-  let subst_map = subst_map i_list o_list d_list mem_vars in
-  let (v, si, j, s_list) = translate_eq_list subst_map
-    empty_call_context eq_list in
-  let (si', j', s_list', d_list') =
-    translate_contract subst_map mem_vars contract in
+  Idents.enter_node f;
+  let mem_var_tys = Mls_utils.node_memory_vars n in
+  let subst_map = subst_map i_list o_list d_list mem_var_tys in
+  let (v, si, j, s_list) = translate_eq_list subst_map empty_call_context eq_list in
+  let (si', j', s_list', d_list') = translate_contract subst_map mem_var_tys contract in
   let i_list = translate_var_dec i_list in
   let o_list = translate_var_dec o_list in
   let d_list = translate_var_dec (v @ d_list) in
-  let m, d_list = List.partition
-    (fun vd -> List.mem vd.v_ident mem_vars) d_list in
-  let s = joinlist (s_list @ s_list') in
+  let m, d_list = List.partition (fun vd -> List.exists (fun (i,_) -> i = vd.v_ident) mem_var_tys) d_list in
+  let s = Control.joinlist (s_list @ s_list') in
   let j = j' @ j in
-  let si = joinlist (si @ si') in
-  let stepm = {
-    m_name = Mstep; m_inputs = i_list; m_outputs = o_list;
-    m_body = mk_block ~locals:(d_list' @ d_list) s } in
-  let resetm = {
-    m_name = Mreset; m_inputs = []; m_outputs = [];
-    m_body = mk_block si } in
-    { cd_name = f; cd_mems = m; cd_params = params;
-      cd_objs = j; cd_methods = [stepm; resetm];
-      cd_loc = loc }
+  let si = Control.joinlist (si @ si') in
+  let stepm = { m_name = Mstep; m_inputs = i_list; m_outputs = o_list;
+                m_body = mk_block ~locals:(d_list' @ d_list) s }
+  in
+  let resetm = { m_name = Mreset; m_inputs = []; m_outputs = []; m_body = mk_block si } in
+  if stateful
+  then { cd_name = f; cd_stateful = true; cd_mems = m; cd_params = params;
+         cd_objs = j; cd_methods = [stepm; resetm]; cd_loc = loc; }
+  else ( (* Functions won't have [Mreset] or memories, they still have [params] and instances (of functions) *)
+    { cd_name = f; cd_stateful = false; cd_mems = []; cd_params = params;
+      cd_objs = j; cd_methods = [stepm]; cd_loc = loc; }
+  )
 
 let translate_ty_def { Minils.t_name = name; Minils.t_desc = tdesc;
                        Minils.t_loc = loc } =
@@ -479,8 +498,8 @@ let translate_ty_def { Minils.t_name = name; Minils.t_desc = tdesc;
     | Minils.Type_abs -> Type_abs
     | Minils.Type_alias ln -> Type_alias ln
     | Minils.Type_enum tag_name_list -> Type_enum tag_name_list
-    | Minils.Type_struct field_ty_list ->
-        Type_struct field_ty_list in
+    | Minils.Type_struct field_ty_list -> Type_struct field_ty_list
+  in
   { t_name = name; t_desc = tdesc; t_loc = loc }
 
 let translate_const_def { Minils.c_name = name; Minils.c_value = se;
@@ -490,19 +509,12 @@ let translate_const_def { Minils.c_name = name; Minils.c_value = se;
     c_type = ty;
     c_loc = loc }
 
-let program {
-  Minils.p_modname = p_modname;
-  Minils.p_opened = p_module_list;
-  Minils.p_types = p_type_list;
-  Minils.p_nodes = p_node_list;
-  Minils.p_consts = p_const_list
-} =
-    {
-      p_modname = p_modname;
-      p_opened = p_module_list;
-      p_types = List.map translate_ty_def p_type_list;
-      p_consts = List.map translate_const_def p_const_list;
-      p_defs = List.map translate_node p_node_list;
-    }
+let program { Minils.p_modname = p_modname; Minils.p_opened = p_module_list; Minils.p_types = p_type_list;
+              Minils.p_nodes = p_node_list; Minils.p_consts = p_const_list } =
+  { p_modname = p_modname;
+    p_opened = p_module_list;
+    p_types = List.map translate_ty_def p_type_list;
+    p_consts = List.map translate_const_def p_const_list;
+    p_classes = List.map translate_node p_node_list; }
 
 

compiler/minils/analysis/clocking.ml

@@ -43,11 +43,15 @@ let rec typing h e =
           | None -> fresh_clock ()
           | Some(reset) -> typ_of_name h reset in
         typing_op op args h e ck
-    | Eiterator (_, _, _, args, r) -> (* Typed exactly as a fun or a node... *)
+    (* Typed exactly as a fun or a node... *)
+    | Eiterator (_, _, _, pargs, args, r) ->
         let ck = match r with
           | None -> fresh_clock()
           | Some(reset) -> typ_of_name h reset
-        in (List.iter (expect h (Ck ck)) args; skeleton ck e.e_ty)
+        in
+          List.iter (expect h (Ck ck)) pargs;
+          List.iter (expect h (Ck ck)) args;
+          skeleton ck e.e_ty
     | Ewhen (e, c, n) ->
         let ck_n = typ_of_name h n in
         (expect h (skeleton ck_n e.e_ty) e; skeleton (Con (ck_n, c, n)) e.e_ty)

compiler/minils/main/mls2seq.ml

@@ -15,16 +15,17 @@ open Misc
 
 (** Definition of a target. A target starts either from
     dataflow code (ie Minils) or sequential code (ie Obc),
-    with or without static parameters*)
+    with or without static parameters *)
 type target =
   | Obc of (Obc.program -> unit)
   | Obc_no_params of (Obc.program -> unit)
+  | Obc_scalar of (Obc.program ->unit)
   | Minils of (Minils.program -> unit)
   | Minils_no_params of (Minils.program -> unit)
 
 (** 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,13 +33,15 @@ 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;
     comment "Generation of Obc code"
 
+
 let targets = [ "c", Obc_no_params Cmain.program;
+                "java", Obc_scalar Java_main.program;
                 "obc", Obc write_obc_file;
                 "obc_np", Obc_no_params write_obc_file;
                 "epo", Minils write_object_file ]
@@ -64,10 +67,14 @@ let generate_target p s =
         let p_list = Callgraph.program p in
         let o_list = List.map Mls2obc.program p_list in
         print_unfolded p_list;
-        comment "Translation to Obc";
+        comment "Obc Callgraph";
         if !verbose then
           List.iter (Obc_printer.print stdout) o_list;
         List.iter convert_fun o_list
+    | Obc_scalar convert_fun ->
+        let p = p |> Mls2obc.program |> Scalarize.program in
+        convert_fun p
+
 
 (** Translation into dataflow and sequential languages, defaults to obc. *)
 let program p =

compiler/minils/minils.ml

@@ -58,7 +58,7 @@ and edesc =
                        (** merge ident (Constructor -> exp)+ *)
   | Estruct of (field_name * exp) list
                        (** { field=exp; ... } *)
-  | Eiterator of iterator_type * app * static_exp * exp list * var_ident option
+  | Eiterator of iterator_type * app * static_exp * exp list * exp list * var_ident option
                        (** map f <<n>> (exp, exp...) reset ident *)
 
 and app = { a_op: op; a_params: static_exp list; a_unsafe: bool }
@@ -106,11 +106,12 @@ type contract = {
 
 type node_dec = {
   n_name   : qualname;
+  n_stateful : bool;
   n_input  : var_dec list;
   n_output : var_dec list;
   n_contract : contract option;
-  (* GD: inglorious hack for controller call *)
-  mutable n_controller_call : var_ident list * var_ident list;
+  (* GD: inglorious hack for controller call
+  mutable n_controller_call : var_ident list * var_ident list; *)
   n_local  : var_dec list;
   n_equs   : eq list;
   n_loc    : location;
@@ -124,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 }
@@ -146,13 +147,14 @@ let mk_equation ?(loc = no_location) pat exp =
 
 let mk_node
     ?(input = []) ?(output = []) ?(contract = None) ?(local = []) ?(eq = [])
-    ?(loc = no_location) ?(param = []) ?(constraints = [])
+    ?(stateful = true) ?(loc = no_location) ?(param = []) ?(constraints = [])
     ?(pinst = ([],[])) name =
   { n_name = name;
+    n_stateful = stateful;
     n_input = input;
     n_output = output;
     n_contract = contract;
-    n_controller_call = pinst;
+ (*   n_controller_call = pinst;*)
     n_local = local;
     n_equs = eq;
     n_loc = loc;
@@ -170,8 +172,7 @@ let mk_app ?(params=[]) ?(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))
-

compiler/minils/mls_compare.ml

@@ -48,8 +48,8 @@ let rec exp_compare e1 e2 =
               let cr = compare fn1 fn2 in
               if cr <> 0 then cr else exp_compare e1 e2 in
             list_compare compare_fne fnel1 fnel2
-        | Eiterator (it1, app1, se1, el1, vio1),
-          Eiterator (it2, app2, se2, el2, vio2) ->
+        | Eiterator (it1, app1, se1, pel1, el1, vio1),
+          Eiterator (it2, app2, se2, pel2, el2, vio2) ->
             let cr = compare it1 it2 in
             if cr <> 0 then cr else
               let cr = static_exp_compare se1 se2 in
@@ -57,7 +57,9 @@ let rec exp_compare e1 e2 =
                 let cr = app_compare app1 app2 in
                 if cr <> 0 then cr else
                   let cr = option_compare ident_compare vio1 vio2 in
-                  if cr <> 0 then cr else list_compare exp_compare el1 el2
+                    if cr <> 0 then cr else
+                      let cr = list_compare exp_compare pel1 pel2 in
+                        if cr <> 0 then cr else list_compare exp_compare el1 el2
 
         | Econst _, _ -> 1
 
@@ -90,7 +92,7 @@ and app_compare app1 app2 =
     | (Eequal | Etuple | Efun _ | Enode _ | Eifthenelse | Efield
       | Efield_update), _ -> -1
     | (Earray | Earray_fill | Eselect | Eselect_slice | Eselect_dyn | Eupdate
-      | Econcat), _ -> 1 in
+      | Econcat ), _ -> 1 in
 
   if cr <> 0 then cr
   else list_compare static_exp_compare app1.a_params app2.a_params

compiler/minils/mls_mapfold.ml

@@ -73,11 +73,12 @@ and edesc funs acc ed = match ed with
           (n,e), acc in
       let n_e_list, acc = mapfold aux acc n_e_list in
         Estruct n_e_list, acc
-  | Eiterator (i, app, param, args, reset) ->
+  | Eiterator (i, app, param, pargs, args, reset) ->
       let app, acc = app_it funs acc app in
       let param, acc = static_exp_it funs.global_funs acc param in
+      let pargs, acc = mapfold (exp_it funs) acc pargs in
       let args, acc = mapfold (exp_it funs) acc args in
-        Eiterator (i, app, param, args, reset), acc
+        Eiterator (i, app, param, pargs, args, reset), acc
 
 
 and app_it funs acc a = funs.app funs acc a

compiler/minils/mls_printer.ml

@@ -102,59 +102,61 @@ and print_exp_desc ff = function
         print_ident x print_tag_e_list tag_e_list
   | Estruct f_e_list ->
       print_record (print_couple print_qualname print_exp """ = """) ff f_e_list
-  | Eiterator (it, f, param, args, reset) ->
-      fprintf ff "@[<2>(%s (%a)<<%a>>)@,%a@]%a"
+  | Eiterator (it, f, param, pargs, args, reset) ->
+      fprintf ff "@[<2>(%s (%a)<<%a>>)@,(%a)%a@]%a"
         (iterator_to_string it)
         print_app (f, [])
         print_static_exp param
+        print_exp_tuple pargs
         print_exp_tuple args
         print_every reset
 
-and print_app ff (app, args) = match app.a_op with
-  | Eequal ->
-    let e1, e2 = assert_2 args in
-      fprintf ff "@[<2>%a@ = %a@]" print_exp e1  print_exp e2
-  | Etuple -> print_exp_tuple ff args
-  | Efun f | Enode f ->
-      fprintf ff "@[%a@,%a@,%a@]"
-        print_qualname f print_params app.a_params  print_exp_tuple args
-  | Eifthenelse ->
-    let e1, e2, e3 = assert_3 args in
-      fprintf ff "@[<hv>if %a@ then %a@ else %a@]"
-        print_exp e1 print_exp e2 print_exp e3
-  | Efield ->
-    let r = assert_1 args in
-    let f = assert_1 app.a_params in
-    fprintf ff "%a.%a" print_exp r print_static_exp f
-  | Efield_update ->
-    let r,e = assert_2 args in
-    let f = assert_1 app.a_params in
-      fprintf ff "@[<2>{%a with .%a =@ %a}@]"
-        print_exp r print_static_exp f print_exp e
-  | Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") args
-  | Earray_fill ->
-    let e = assert_1 args in
-    let n = assert_1 app.a_params in
-      fprintf ff "%a^%a" print_exp e print_static_exp n
-  | Eselect ->
-    let e = assert_1 args in
-      fprintf ff "%a%a" print_exp e print_index app.a_params
-  | Eselect_slice ->
-    let e = assert_1 args in
-    let idx1, idx2 = assert_2 app.a_params in
-      fprintf ff "%a[%a..%a]"
-        print_exp e  print_static_exp idx1  print_static_exp idx2
-  | Eselect_dyn ->
-    let r, d, e = assert_2min args in
-      fprintf ff "%a%a default %a"
-        print_exp r  print_dyn_index e  print_exp d
-  | Eupdate ->
-    let e1, e2, idx = assert_2min args in
-        fprintf ff "@[<2>(%a with %a =@ %a)@]"
-          print_exp e1 print_dyn_index idx print_exp e2
-  | Econcat ->
-    let e1, e2 = assert_2 args in
-      fprintf ff "@[<2>%a@ @@ %a@]" print_exp e1  print_exp e2
+and print_app ff (app, args) =
+  match app.a_op with
+    | Eequal ->
+      let e1, e2 = assert_2 args in
+        fprintf ff "@[<2>%a@ = %a@]" print_exp e1  print_exp e2
+    | Etuple -> print_exp_tuple ff args
+    | Efun f | Enode f ->
+        fprintf ff "@[%a@,%a@,%a@]"
+          print_qualname f print_params app.a_params  print_exp_tuple args
+    | Eifthenelse ->
+      let e1, e2, e3 = assert_3 args in
+        fprintf ff "@[<hv>if %a@ then %a@ else %a@]"
+          print_exp e1 print_exp e2 print_exp e3
+    | Efield ->
+      let r = assert_1 args in
+      let f = assert_1 app.a_params in
+      fprintf ff "%a.%a" print_exp r print_static_exp f
+    | Efield_update ->
+      let r,e = assert_2 args in
+      let f = assert_1 app.a_params in
+        fprintf ff "@[<2>{%a with .%a =@ %a}@]"
+          print_exp r print_static_exp f print_exp e
+    | Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") args
+    | Earray_fill ->
+      let e = assert_1 args in
+      let n = assert_1 app.a_params in
+        fprintf ff "%a^%a" print_exp e print_static_exp n
+    | Eselect ->
+      let e = assert_1 args in
+        fprintf ff "%a%a" print_exp e print_index app.a_params
+    | Eselect_slice ->
+      let e = assert_1 args in
+      let idx1, idx2 = assert_2 app.a_params in
+        fprintf ff "%a[%a..%a]"
+          print_exp e  print_static_exp idx1  print_static_exp idx2
+    | Eselect_dyn ->
+      let r, d, e = assert_2min args in
+        fprintf ff "%a%a default %a"
+          print_exp r  print_dyn_index e  print_exp d
+    | Eupdate ->
+      let e1, e2, idx = assert_2min args in
+          fprintf ff "@[<2>(%a with %a =@ %a)@]"
+            print_exp e1 print_dyn_index idx print_exp e2
+    | Econcat ->
+      let e1, e2 = assert_2 args in
+        fprintf ff "@[<2>%a@ @@ %a@]" print_exp e1  print_exp e2
 
 and print_handler ff c =
   fprintf ff "@[<2>%a@]" (print_couple print_qualname print_exp "("" -> "")") c
@@ -174,7 +176,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

compiler/minils/mls_utils.ml

@@ -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 =
@@ -80,7 +80,7 @@ struct
     (* special cases *)
     let acc = match e.e_desc with
       | Evar x | Emerge(x,_) | Ewhen(_, _, x)
-      | Eapp(_, _, Some x) | Eiterator (_, _, _, _, Some x) ->
+      | Eapp(_, _, Some x) | Eiterator (_, _, _, _, _, Some x) ->
           add x acc
       | Efby(_, e) ->
           if is_left then
@@ -135,10 +135,15 @@ struct
     | _ -> []
 end
 
+(* Assumes normal form, all fby are solo rhs *)
 let node_memory_vars n =
   let eq _ acc ({ eq_lhs = pat; eq_rhs = e } as eq) =
     match e.e_desc with
-    | Efby(_, _) -> eq, Vars.vars_pat acc pat
+    | Efby(_, _) ->
+        let v_l = Vars.vars_pat [] pat in
+        let t_l = Types.unprod e.e_ty in
+        let acc = (List.combine v_l t_l) @ acc in
+        eq, acc
     | _ -> eq, acc
   in
   let funs = { Mls_mapfold.defaults with eq = eq } in

compiler/minils/transformations/callgraph.ml

@@ -14,7 +14,7 @@ module Error =
 struct
   type error =
     | Enode_unbound of qualname
-    | Epartial_instanciation of static_exp
+    | Epartial_evaluation of static_exp list
 
   let message loc kind =
     begin match kind with
@@ -22,10 +22,10 @@ struct
           Format.eprintf "%aUnknown node '%s'@."
             print_location loc
             (fullname ln)
-      | Epartial_instanciation se ->
-          Format.eprintf "%aUnable to fully instanciate the static exp '%a'@."
-            print_location se.se_loc
-            print_static_exp se
+      | Epartial_evaluation se_l ->
+          Format.eprintf "%aUnable to fully instanciate the static exps '%a'@."
+            print_location loc
+            print_static_exp_tuple se_l
     end;
     raise Errors.Error
 end
@@ -77,10 +77,10 @@ struct
   let nodes_instances = ref QualEnv.empty
 
   (** create a params instance *)
-  let instantiate m se =
-    try List.map (eval m) se
-    with Partial_instanciation se ->
-      Error.message no_location (Error.Epartial_instanciation se)
+  let instantiate m se_l =
+    try List.map (eval m) se_l
+    with Errors.Error ->
+      Error.message no_location (Error.Epartial_evaluation se_l)
 
   (** @return the name of the node corresponding to the instance of
       [ln] with the static parameters [params]. *)
@@ -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
 
@@ -158,13 +156,15 @@ struct
             let op = Enode (node_for_params_call ln (instantiate m params)) in
             Eapp ({ app with a_op = op; a_params = [] }, e_list, r)
         | Eiterator(it, ({ a_op = Efun ln; a_params = params } as app),
-                      n, e_list, r) ->
+                      n, pe_list, e_list, r) ->
             let op = Efun (node_for_params_call ln (instantiate m params)) in
-            Eiterator(it, {app with a_op = op; a_params = [] }, n, e_list, r)
+            Eiterator(it, {app with a_op = op; a_params = [] },
+                     n, pe_list, e_list, r)
         | Eiterator(it, ({ a_op = Enode ln; a_params = params } as app),
-                     n, e_list, r) ->
+                     n, pe_list, e_list, r) ->
             let op = Enode (node_for_params_call ln (instantiate m params)) in
-            Eiterator(it,{app with a_op = op; a_params = [] }, n, e_list, r)
+            Eiterator(it,{app with a_op = op; a_params = [] },
+                     n, pe_list, e_list, r)
         | _ -> ed
       in ed, m
 
@@ -201,18 +201,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 +232,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 +248,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,14 +264,14 @@ 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
     | Eapp ({ a_op = (Enode ln | Efun ln); a_params = params }, _, _) ->
         ed, add_called_node ln params acc
     | Eiterator(_, { a_op = (Enode ln | Efun ln); a_params = params },
-                _, _, _) ->
+                _, _, _, _) ->
         ed, add_called_node ln params acc
     | _ -> raise Errors.Fallback
   in
@@ -303,9 +309,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

compiler/minils/transformations/checkpass.ml

@@ -46,7 +46,7 @@ let add_check prefix pass nd nd_list =
     Modules.add_value nd_check.n_name
       { node_inputs = [];
         node_outputs = [{ a_name = None; a_type = Tid Initial.pbool; }];
-        node_statefull = true;
+        node_stateful = true;
         node_params = [];
         node_params_constraints = [] };
 

compiler/minils/transformations/introvars.ml

@@ -76,10 +76,12 @@ let rec exp e (eq_list, var_list) = match e.e_desc with
               intro_vars e_list (eq_list, var_list) in
             let fnel = List.combine (List.map fst fnel) e_list in
             Estruct fnel, eq_list, var_list
-        | Eiterator (it, app, se, e_list, vio) ->
+        | Eiterator (it, app, se, pe_list, e_list, vio) ->
             let (e_list, eq_list, var_list) =
               intro_vars e_list (eq_list, var_list) in
-            Eiterator (it, app, se, e_list, vio), eq_list, var_list in
+            let (pe_list, eq_list, var_list) =
+              intro_vars pe_list (eq_list, var_list) in
+            Eiterator (it, app, se, pe_list, e_list, vio), eq_list, var_list in
       ({ e with e_desc = e_desc; }, eq_list, var_list)
 
 and intro_vars e_list (eq_list, var_list) =

compiler/minils/transformations/itfusion.ml

@@ -9,13 +9,13 @@ open Minils
 (* Functions to temporarily store anonymous nodes*)
 let mk_fresh_node_name () = Modules.fresh_value "itfusion" "temp"
 
-let fresh_vd_of_arg =
+let fresh_vd_of_arg a =
   Idents.gen_fresh "itfusion"
                    (fun a -> match a.a_name with
                              | None -> "v"
-                             | Some n -> n)
+                             | Some n -> n) a
 
-let fresh_var = Idents.gen_fresh "itfusion" (fun () -> "x")
+let fresh_var () = Idents.gen_var "itfusion" "x"
 
 let anon_nodes = ref QualEnv.empty
 
@@ -89,7 +89,7 @@ let mk_call app acc_eq_list =
 let edesc funs acc ed =
   let ed, acc = Mls_mapfold.edesc funs acc ed in
   match ed with
-    | Eiterator(Imap, f, n, e_list, r) ->
+    | Eiterator(Imap, f, n, [], e_list, r) ->
         (** @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,
@@ -102,7 +102,7 @@ let edesc funs acc ed =
                         o1, o2 = f (_v1, _v2, z')
         *)
         let mk_arg e (inp, acc_eq_list, largs, args, b) = match e.e_desc with
-          | Eiterator(Imap, g, m, local_args, _) when are_equal n m ->
+          | Eiterator(Imap, g, m, [], local_args, _) when are_equal n m ->
               let new_inp, e, acc_eq_list = mk_call g acc_eq_list in
               new_inp @ inp, acc_eq_list, e::largs, local_args @ args, true
           | _ ->
@@ -122,7 +122,7 @@ let edesc funs acc ed =
           let eq = mk_equation (pat_of_vd_list outp) call in
           (* create the lambda *)
           let anon = mk_app (Enode (add_anon_node inp outp [] (eq::acc_eq_list))) in
-          Eiterator(Imap, anon, n, args, r), acc)
+          Eiterator(Imap, anon, n, [], args, r), acc)
         else
           ed, acc
 

compiler/minils/transformations/normalize.ml

@@ -132,7 +132,7 @@ let const e c =
 (* normal form for expressions and equations:                              *)
 (* - e ::= op(e,...,e) | x | C | e when C(x)                               *)
 (* - act ::= e | merge x (C1 -> act) ... (Cn -> act) | (act,...,act)       *)
-(* - eq ::= [x = v fby e] | [pat = act ] | [pat = f(e1,...,en) every n     *)
+(* - eq ::= [x = v fby e] | [pat = act] | [pat = f(e1,...,en) every n     *)
 (* - A-normal form: (e1,...,en) when c(x) = (e1 when c(x),...,en when c(x) *)
 type kind = VRef | Exp | Act | Any
 
@@ -199,7 +199,7 @@ let rec translate kind context e =
     | Eapp(app, e_list, r) ->
         let context, e_list = translate_app kind context app.a_op e_list in
           context, { e with e_desc = Eapp(app, e_list, r) }
-    | Eiterator (it, app, n, e_list, reset) ->
+    | Eiterator (it, app, n, pe_list, e_list, reset) ->
       (* normalize anonymous nodes *)
       (match app.a_op with
         | Enode f when Itfusion.is_anon_node f ->
@@ -218,9 +218,11 @@ let rec translate kind context e =
             translate kind context e in
           Misc.mapfold_right add e_list context in
 
+        let context, pe_list =
+          translate_list function_args_kind context pe_list in
         let context, e_list =
           translate_iterator_arg_list context e_list in
-        context, { e with e_desc = Eiterator(it, app, n,
+        context, { e with e_desc = Eiterator(it, app, n, flatten_e_list pe_list,
                                              flatten_e_list e_list, reset) }
   in add context kind e
 

compiler/minils/transformations/schedule.ml

@@ -79,11 +79,11 @@ let eqs funs () eq_list =
 
 let edesc _ () = function
   | Eiterator(it, ({ a_op = Enode f } as app),
-              n, e_list, r) when Itfusion.is_anon_node f ->
+              n, [], e_list, r) when Itfusion.is_anon_node f ->
     let nd = Itfusion.find_anon_node f in
     let nd = { nd with n_equs = schedule nd.n_equs } in
       Itfusion.replace_anon_node f nd;
-      Eiterator(it, app, n, e_list, r), ()
+      Eiterator(it, app, n, [], e_list, r), ()
   | _ -> raise Errors.Fallback
 
 let program p =

compiler/minils/transformations/singletonvars.ml

@@ -52,7 +52,7 @@ struct
       | Evar vi -> add_var_use vi use_counts
       | Emerge (vi, _) -> add_clock_use vi use_counts
       | Ewhen (_, _, vi) -> add_clock_use vi use_counts
-      | Eapp (_, _, Some vi) | Eiterator (_, _, _, _, Some vi) ->
+      | Eapp (_, _, Some vi) | Eiterator (_, _, _, _, _, Some vi) ->
           add_reset_use vi use_counts
       | _ -> use_counts in
     (edesc, use_counts)

compiler/minils/transformations/tomato.ml

@@ -67,6 +67,10 @@ module PatEnv =
 
     type penv_t = (int * exp * ident list) P.t
 
+
+    (* An environment used for automata minimization: holds both a pattern environment mapping patterns to equivalence
+       classes, and a [(pat * int list) Env.t] that maps variable [x] to a [(pat, pth)] tuple where [pat] is the pattern
+       holding [x] at path [pth] *)
     type t = penv_t * (pat * int list) Env.t
 
     let empty = (P.empty, Env.empty)
@@ -202,9 +206,12 @@ let behead e =
           List.split
             (List.map (fun (ln, e) -> ((ln, dummy_exp), e)) lne_list) in
         (Estruct lne_list, e_list)
-    | Eiterator (it, op, s, e_list, rst) ->
+    | Eiterator (it, op, s, pe_list, e_list, rst) ->
         let (rst, l) = encode_reset rst in
-        (Eiterator (it, op, s, [], rst), l @ e_list) in
+        (* count is the number of partial arguments *)
+        let count = mk_exp ~ty:Initial.tint
+          (Econst (Initial.mk_static_int (List.length pe_list))) in
+        (Eiterator (it, op, s, [], [], rst), count :: (pe_list @ l @ e_list)) in
   ({ e with e_desc = e_desc; }, children)
 
 let pat_name pat =
@@ -398,7 +405,7 @@ let rec reconstruct input_type (env : PatEnv.t) =
     | Etuplepat pat_list, Tprod ty_list ->
         List.fold_right2 mk_var_decs pat_list ty_list var_list
     | Etuplepat [], Tunit -> var_list
-    | Etuplepat _, (Tarray _ | Tid _ | Tunit) -> assert false (* ill-typed *) in
+    | Etuplepat _, (Tarray _ | Tid _ | Tunit | Tmutable _) -> assert false (* ill-typed *) in
 
   let add_to_lists pat (_, head, children) (eq_list, var_list) =
     (* Remember the encoding of resets given above. *)
@@ -421,11 +428,19 @@ let rec reconstruct input_type (env : PatEnv.t) =
                   List.combine (List.map fst cnel) (List.tl e_list))
       | Estruct fnel, e_list ->
           Estruct (List.combine (List.map fst fnel) e_list)
-      | Eiterator (it, app, se, [], rst), e_list ->
+      | Eiterator (it, app, se, [], [], rst), e_list ->
+          (* the first element is the number of partial arguments *)
+          let count, e_list = assert_1min e_list in
+          let c = (match count.e_desc with
+            | Econst { se_desc = Sint c } -> c
+            | _ -> assert false)
+          in
+          let pe_list, e_list = Misc.split_at c e_list in
           let rst, e_list = rst_of_e_list rst e_list in
-          Eiterator (it, app, se, e_list, rst)
+          Eiterator (it, app, se, pe_list, e_list, rst)
 
-      | (Eiterator (_, _, _, _ :: _, _) | Ewhen _ | Efby _ | Evar _ | Econst _)
+      | (Eiterator (_, _, _, _, _, _) | Ewhen _
+        | Efby _ | Evar _ | Econst _)
           , _ -> assert false (* invariant *) in
     (mk_equation pat { head with e_desc = e_desc; } :: eq_list,
      mk_var_decs pat head.e_ty var_list) in

compiler/obc/_tags

@@ -1 +1 @@
-<c> or <java>:include
+<transformations> or <c> or <java>:include

compiler/obc/c/c.ml

@@ -12,14 +12,7 @@ open List
 open Modules
 open Names
 
-let rec print_list ff print sep l =
-  match l with
-    | [] -> ()
-    | [x] -> print ff x
-    | x :: l ->
-        print ff x;
-        fprintf ff "%s@ " sep;
-        print_list ff print sep l
+let print_list ff print sep l = Pp_tools.print_list_r print "" sep "" ff l
 
 (** [cname_of_name name] translates the string [name] to a valid C identifier.
     Copied verbatim from the old C backend. *)
@@ -81,19 +74,19 @@ and cexpr =
   | Clhs of clhs (** Left-hand-side expressions are obviously expressions! *)
   | Caddrof of clhs (** Take the address of a left-hand-side expression. *)
   | Cstructlit of string * cexpr list (** Structure literal "{ f1, f2, ... }".*)
-  | Carraylit of cexpr list (** Array literal [e1, e2, ...]. *)
+  | Carraylit of cexpr list (** Array literal [\[e1, e2, ...\]]. *)
 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. *)
+(** C left-hand-side (ie. affectable) expressions. *)
 and clhs =
   | Cvar of string (** A local variable. *)
   | Cderef of clhs (** Pointer dereference, *ptr. *)
   | Cfield of clhs * qualname (** Field access to left-hand-side. *)
   | Carray of clhs * cexpr (** Array access clhs[cexpr] *)
-      (** C statements. *)
+(** C statements. *)
 and cstm =
   | Csexpr of cexpr (** Expression evaluation, may cause side-effects! *)
   | Csblock of cblock (** A local sub-block, can have its own private decls. **)
@@ -162,11 +155,14 @@ let rec pp_list f sep fmt l = match l with
 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
-    q.name
-  else
-    (q.qual ^ "__" ^ q.name)
+let rec modul_to_cname q = match q with
+  | Pervasives | LocalModule -> ""
+  | Module m -> m ^ "__"
+  | QualModule { qual = q; name = n } ->
+      (modul_to_cname q)^n^"__"
+
+let cname_of_qn qn =
+  (modul_to_cname qn.qual) ^ qn.name
 
 let pp_qualname fmt q =
   pp_string fmt (cname_of_qn q)
@@ -248,8 +244,9 @@ and pp_cexpr fmt ce = match ce with
   | Caddrof lhs -> fprintf fmt "&%a" pp_clhs lhs
   | Cstructlit (s, el) ->
       fprintf fmt "(%a){@[%a@]}" pp_string s (pp_list1 pp_cexpr ",") el
-  | Carraylit el ->
-      fprintf fmt "((int []){@[%a@]})" (pp_list1 pp_cexpr ",") el (* WRONG *)
+  | Carraylit el -> (* TODO master : WRONG *)
+      fprintf fmt "((int []){@[%a@]})" (pp_list1 pp_cexpr ",") el
+
 and pp_clhs fmt lhs = match lhs with
   | Cvar s -> pp_string fmt s
   | Cderef lhs' -> fprintf fmt "*%a" pp_clhs lhs'
@@ -314,11 +311,10 @@ let pp_cfile_desc fmt filen cfile =
 let output_cfile dir (filen, cfile_desc) =
   if !Compiler_options.verbose then
     Format.printf "C-NG generating %s/%s@." dir filen;
-  let buf = Buffer.create 20000 in
   let oc = open_out (Filename.concat dir filen) in
-  let fmt = Format.formatter_of_buffer buf in
+  let fmt = Format.formatter_of_out_channel oc in
   pp_cfile_desc fmt filen cfile_desc;
-  Buffer.output_buffer oc buf;
+  pp_print_flush fmt ();
   close_out oc
 
 let output dir cprog =

compiler/obc/c/c.mli

@@ -45,9 +45,8 @@ and cexpr =
   | Cconst of cconst (** Constants. *)
   | Clhs of clhs (** Left-hand-side expressions are obviously expressions! *)
   | Caddrof of clhs (** Take the address of a left-hand-side expression. *)
-  | Cstructlit of string * cexpr list (** Structure literal
-                                          " \{f1, f2, ... \}". *)
-  | Carraylit of cexpr list (** Array literal [e1, e2, ...]. *)
+  | Cstructlit of string * cexpr list (** Structure literal [{f1, f2, ... }]. *)
+  | Carraylit of cexpr list (** Array literal [\[e1, e2, ...\]]. *)
 and cconst =
   | Ccint of int (** Integer constant. *)
   | Ccfloat of float (** Floating-point number constant. *)

compiler/obc/c/cgen.ml

@@ -13,6 +13,7 @@ open Misc
 open Names
 open Idents
 open Obc
+open Obc_utils
 open Types
 
 open Modules
@@ -72,10 +73,10 @@ let output_names_list sig_info =
   in
   List.map remove_option sig_info.node_outputs
 
-let is_statefull n =
+let is_stateful n =
   try
     let sig_info = find_value n in
-      sig_info.node_statefull
+      sig_info.node_stateful
   with
       Not_found -> Error.message no_location (Error.Enode (fullname n))
 
@@ -99,8 +100,8 @@ let rec ctype_of_otype oty =
     | Types.Tid id when id = Initial.pfloat -> Cty_float
     | Types.Tid id when id = Initial.pbool -> Cty_int
     | Tid id -> Cty_id id
-    | Tarray(ty, n) -> Cty_arr(int_of_static_exp n,
-                               ctype_of_otype ty)
+    | Tarray(ty, n) -> Cty_arr(int_of_static_exp n, ctype_of_otype ty)
+    | Tmutable t -> ctype_of_otype t
     | Tprod _ -> assert false
     | Tunit -> assert false
 
@@ -254,7 +255,7 @@ let rec cexpr_of_static_exp se =
                      List.map (fun (_, se) -> cexpr_of_static_exp se) fl)
     | Sarray_power(n,c) ->
         let cc = cexpr_of_static_exp c in
-          Carraylit (repeat_list cc (int_of_static_exp n))
+          Carraylit (repeat_list cc (int_of_static_exp n)) (* TODO should be recursive *)
     | Svar ln ->
         (try
           let cd = find_const ln in
@@ -273,7 +274,7 @@ let rec cexpr_of_static_exp se =
 let rec cexpr_of_exp var_env exp =
   match exp.e_desc with
     (** Obj expressions that form valid C lhs are translated via clhs_of_exp. *)
-    | Elhs _  ->
+    | Epattern _  ->
         Clhs (clhs_of_exp var_env exp)
           (** Constants, the easiest translation. *)
     | Econst lit ->
@@ -293,7 +294,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)
@@ -306,7 +307,7 @@ and cop_of_op_aux op_name cexps = match op_name with
               Cbop (copname op, el, er)
           | _ -> Cfun_call(op, cexps)
         end
-    | {qual = m; name = op} -> Cfun_call(op,cexps) (*TODO m should be used?*)
+    | {qual = m; name = op} -> Cfun_call(op,cexps)
 
 and cop_of_op var_env op_name exps =
   let cexps = cexprs_of_exps var_env exps in
@@ -335,7 +336,7 @@ and clhss_of_lhss var_env lhss =
   List.map (clhs_of_lhs var_env) lhss
 
 and clhs_of_exp var_env exp = match exp.e_desc with
-  | Elhs l -> clhs_of_lhs var_env l
+  | Epattern l -> clhs_of_lhs var_env l
   (** We were passed an expression that is not translatable to a valid C lhs?!*)
   | _ -> invalid_arg "clhs_of_exp: argument not a Var, Mem or Field"
 
@@ -343,7 +344,7 @@ let rec assoc_obj instance obj_env =
   match obj_env with
     | [] -> raise Not_found
     | od :: t ->
-        if od.o_name = instance
+        if od.o_ident = instance
         then od
         else assoc_obj instance t
 
@@ -351,7 +352,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 =
@@ -361,13 +362,13 @@ let out_var_name_of_objn o =
     of the called node, [mem] represents the node context and [args] the
     argument list.*)
 let step_fun_call var_env sig_info objn out args =
-  if sig_info.node_statefull then (
+  if sig_info.node_stateful then (
     let mem =
       (match objn with
-         | Oobj o -> Cfield (Cderef (Cvar "self"), local_qn o)
+         | Oobj o -> Cfield (Cderef (Cvar "self"), local_qn (name o))
          | Oarray (o, l) ->
              let l = clhs_of_lhs var_env l in
-               Carray (Cfield (Cderef (Cvar "self"), local_qn o), Clhs l)
+               Carray (Cfield (Cderef (Cvar "self"), local_qn (name o)), Clhs l)
       ) in
       args@[Caddrof out; Caddrof mem]
   ) else
@@ -427,7 +428,7 @@ let rec create_affect_const var_env dest c =
           let dest = Carray (dest, Cconst (Ccint i)) in
           (i - 1, create_affect_const var_env dest c @ affl) in
         snd (List.fold_right create_affect_idx cl (List.length cl - 1, []))
-    | _ -> [Caffect (dest, cexpr_of_exp var_env (mk_exp (Econst c)))]
+    | _ -> [Caffect (dest, cexpr_of_static_exp c)]
 
 (** [cstm_of_act obj_env mods act] translates the Obj action [act] to a list of
     C statements, using the association list [obj_env] to map object names to
@@ -465,12 +466,28 @@ let rec cstm_of_act var_env obj_env act =
                cstm_of_act_list var_env obj_env act) cl in
         [Cswitch (cexpr_of_exp var_env e, ccl)]
 
+    | Ablock b ->
+        cstm_of_act_list var_env obj_env b
+
     (** For composition of statements, just recursively apply our
         translation function on sub-statements. *)
-    | Afor (x, i1, i2, act) ->
+    | Afor ({ v_ident = x }, i1, i2, act) ->
         [Cfor(name x, int_of_static_exp i1,
               int_of_static_exp i2, cstm_of_act_list var_env obj_env act)]
 
+    (** Special case for x = 0^n^n...*)
+    | Aassgn (vn, { e_desc = Econst c }) ->
+        let vn = clhs_of_lhs 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. *)
+    | Aassgn (vn, e) ->
+        let vn = clhs_of_lhs var_env vn in
+        let ty = assoc_type_lhs vn var_env in
+        let ce = cexpr_of_exp var_env e in
+        create_affect_stm vn ce ty
+
     (** Reinitialization of an object variable, extracting the reset
         function's name from our environment [obj_env]. *)
     | Acall (name_list, o, Mreset, args) ->
@@ -482,28 +499,15 @@ let rec cstm_of_act var_env obj_env act =
         (match obj.o_size with
            | None ->
              [Csexpr (Cfun_call (classn ^ "_reset",
-                [Caddrof (Cfield (Cderef (Cvar "self"), local_qn on))]))]
+                [Caddrof (Cfield (Cderef (Cvar "self"), local_qn (name on)))]))]
            | Some size ->
                let x = gen_symbol () in
-               let field = Cfield (Cderef (Cvar "self"), local_qn on) in
+               let field = Cfield (Cderef (Cvar "self"), local_qn (name on)) in
                let elt = [Caddrof( Carray(field, Clhs (Cvar x)) )] in
                  [Cfor(x, 0, int_of_static_exp size,
                        [Csexpr (Cfun_call (classn ^ "_reset", elt ))] )]
         )
 
-    (** Special case for x = 0^n^n...*)
-    | Aassgn (vn, { e_desc = Econst c }) ->
-        let vn = clhs_of_lhs 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. *)
-    | Aassgn (vn, e) ->
-        let vn = clhs_of_lhs var_env vn in
-        let ty = assoc_type_lhs vn var_env in
-        let ce = cexpr_of_exp var_env e in
-        create_affect_stm vn ce ty
-
     (** Step functions applications can return multiple values, so we use a
         local structure to hold the results, before allocating to our
         variables. *)
@@ -537,7 +541,7 @@ let step_fun_args n md =
   let args = cvarlist_of_ovarlist md.m_inputs in
   let out_arg = [("out", Cty_ptr (Cty_id (qn_append n "_out")))] in
   let context_arg =
-    if is_statefull n then
+    if is_stateful n then
       [("self", Cty_ptr (Cty_id (qn_append n "_mem")))]
     else
       []
@@ -590,16 +594,16 @@ let mem_decl_of_class_def cd =
   (** 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_statefull od.o_class then
+    if is_stateful od.o_class then
       let ty = Cty_id (qn_append od.o_class "_mem") in
       let ty = match od.o_size with
         | Some se -> Cty_arr (int_of_static_exp se, ty)
         | None -> ty in
-        (od.o_name, ty)::l
+        (name od.o_ident, ty)::l
     else
       l
   in
-    if is_statefull cd.cd_name then (
+    if is_stateful cd.cd_name then (
       (** Fields corresponding to normal memory variables. *)
       let mem_fields = List.map cvar_of_vd cd.cd_mems in
       (** Fields corresponding to object variables. *)
@@ -618,9 +622,13 @@ let out_decl_of_class_def cd =
 (** [reset_fun_def_of_class_def cd] returns the defintion of the C function
     tasked to reset the class [cd]. *)
 let reset_fun_def_of_class_def cd =
-  let var_env = List.map cvar_of_vd cd.cd_mems in
-  let reset = find_reset_method cd in
-  let body = cstm_of_act_list var_env cd.cd_objs reset.m_body in
+  let body =
+    try
+      let var_env = List.map cvar_of_vd cd.cd_mems in
+      let reset = find_reset_method cd in
+      cstm_of_act_list var_env cd.cd_objs reset.m_body
+    with Not_found -> [] (* TODO C : nicely deal with stateless objects *)
+  in
   Cfundef {
     f_name = (cname_of_qn cd.cd_name) ^ "_reset";
     f_retty = Cty_void;
@@ -631,6 +639,7 @@ 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 =
@@ -647,7 +656,7 @@ let cdefs_and_cdecls_of_class_def cd =
   let res_fun_decl = cdecl_of_cfundef reset_fun_def in
   let step_fun_decl = cdecl_of_cfundef step_fun_def in
   let (decls, defs) =
-    if is_statefull cd.cd_name then
+    if is_stateful cd.cd_name then
       ([res_fun_decl; step_fun_decl], [reset_fun_def; step_fun_def])
     else
       ([step_fun_decl], [step_fun_def]) in
@@ -740,11 +749,11 @@ let cfile_list_of_oprog_ty_decls name oprog =
   filename_types, [types_h; types_c]
 
 let global_file_header name prog =
-  let dependencies = S.elements (Obc_utils.Deps.deps_program prog) in
-  let dependencies = List.map String.uncapitalize dependencies in
+  let dependencies = ModulSet.elements (Obc_utils.Deps.deps_program prog) in
+  let dependencies = List.map modul_to_string dependencies in
 
   let (decls, defs) =
-    List.split (List.map cdefs_and_cdecls_of_class_def prog.p_defs) in
+    List.split (List.map cdefs_and_cdecls_of_class_def prog.p_classes) in
   let decls = List.concat decls
   and defs = List.concat defs in
 

compiler/obc/c/cmain.ml

@@ -13,6 +13,7 @@ open Misc
 open Names
 open Idents
 open Obc
+open Obc_utils
 open Types
 open Modules
 open Signature
@@ -85,24 +86,24 @@ let assert_node_res cd =
 (** [main_def_of_class_def cd] returns a [(var_list, rst_i, step_i)] where
     [var_list] (resp. [rst_i] and [step_i]) is a list of variables (resp. of
     statements) needed for a main() function calling [cd]. *)
-(* TODO: refactor into something more readable. *)
 let main_def_of_class_def cd =
   let format_for_type ty = match ty with
-    | Tarray _ | Tprod _ | Tunit -> assert false
+    | Tarray _ | Tprod _ | Tmutable _ | Tunit -> assert false
     | Types.Tid id when id = Initial.pfloat -> "%f"
     | Types.Tid id when id = Initial.pint -> "%d"
     | Types.Tid id when id = Initial.pbool -> "%d"
-    | Tid _ -> "%s" in
+    | 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. *)
   let need_buf_for_ty ty = match ty with
-    | Tarray _ | Tprod _ | Tunit -> assert false
+    | Tarray _ | Tprod _ | Tmutable _ | Tunit -> assert false
     | Types.Tid id when id = Initial.pfloat -> None
     | Types.Tid id when id = Initial.pint -> None
     | Types.Tid id when id = Initial.pbool -> None
-    | Tid { name = n } -> Some n in
-
+    | Tid { name = n } -> Some n
+  in
   let cprint_string s = Csexpr (Cfun_call ("printf", [Cconst (Cstrlit s)])) in
 
   (** Generates scanf statements. *)
@@ -258,11 +259,10 @@ let main_skel var_list prologue body =
   }
 
 let mk_main name p =
-  match (!Compiler_options.simulation_node, !Compiler_options.assert_nodes) with
-    | (None, []) -> []
-    | (_, n_names) ->
+  if !Compiler_options.simulation then (
+      let n_names = !Compiler_options.assert_nodes in
       let find_class n =
-        try List.find (fun cd -> cd.cd_name.name = n) p.p_defs
+        try List.find (fun cd -> cd.cd_name.name = n) p.p_classes
         with Not_found ->
           Format.eprintf "Unknown node %s.@." n;
           exit 1 in
@@ -275,18 +275,16 @@ let mk_main name p =
           (var @ var_l, res :: res_l, step :: step_l) in
         List.fold_right add a_classes ([], [], []) in
 
-      let (_, var_l, res_l, step_l) =
-        (match !Compiler_options.simulation_node with
-           | None -> (n_names, var_l, res_l, step_l)
-           | Some n ->
-               let (nvar_l, res, nstep_l) =
-                 main_def_of_class_def (find_class n) in
-               (n :: n_names, nvar_l @ var_l,
-                res :: res_l, nstep_l @ step_l)) in
+      let n = !Compiler_options.simulation_node in
+      let (nvar_l, res, nstep_l) = main_def_of_class_def (find_class n) in
+      let (var_l, res_l, step_l) =
+        (nvar_l @ var_l, res :: res_l, nstep_l @ step_l) in
 
       [("_main.c", Csource [main_skel var_l res_l step_l]);
        ("_main.h", Cheader ([name], []))];
-;;
+  ) else
+    []
+
 
 
 (******************************)
@@ -297,7 +295,8 @@ let translate name prog =
   (global_file_header modname prog) @ (mk_main name prog)
 
 let program p =
-  let filename = filename_of_name (cname_of_name p.p_modname) in
+  let filename =
+    filename_of_name (cname_of_name (modul_to_string p.p_modname)) in
   let dirname = build_path (filename ^ "_c") in
   let dir = clean_dir dirname in
   let c_ast = translate filename p in

compiler/obc/control.ml

@@ -14,6 +14,7 @@ open Minils
 open Idents
 open Misc
 open Obc
+open Obc_utils
 open Clocks
 
 let var_from_name map x =
@@ -38,12 +39,12 @@ let rec control map ck s =
     | Cvar { contents = Clink ck } -> control map ck s
     | Con(ck, c, n)  ->
         let x = var_from_name map n in
-          control map ck (Acase(mk_exp (Elhs x), [(c, mk_block [s])]))
+        control map ck (Acase(mk_exp x.pat_ty (Epattern x), [(c, mk_block [s])]))
 
 let is_deadcode = function
     | Aassgn (lhs, e) ->
         (match e.e_desc with
-           | Elhs l -> l = lhs
+           | Epattern l -> l = lhs
            | _ -> false
         )
     | Acase (_, []) -> true

compiler/obc/java/java.ml

@@ -7,582 +7,146 @@
 (*                                                                        *)
 (**************************************************************************)
 
+type class_name = Names.qualname (** [qual] is the package name, [Name] is the class name *)
+type obj_ident = Idents.var_ident
+type constructor_name = Names.qualname (** [Qual] is the enum class name (type), [NAME] is the constructor name *)
+type const_name = Names.qualname
+type method_name = Names.name
+type field_name = Names.name
+type field_ident = Idents.var_ident
+type op_name = Names.qualname
+type var_ident = Idents.var_ident
+
+type ty = Tclass of class_name
+        | Tgeneric of class_name * ty list
+        | Tbool
+        | Tint
+        | Tfloat
+        | Tarray of ty * exp
+        | Tref of ty
+        | Tunit
+
+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
+               | Cgeneric of class_desc
+
+and class_desc = { cd_fields       : field list;
+                   cd_classs       : classe list;
+                   cd_constructors : methode list;
+                   cd_methodes     : methode list; }
+
+and var_dec = { vd_type  : ty;
+                vd_ident : var_ident }
+
+and protection = Ppublic | Pprotected | Pprivate | Ppackage
+
+and field = { f_protection : protection;
+              f_static     : bool;
+              f_final      : bool;
+              f_type       : ty;
+              f_ident      : field_ident;
+              f_value      : exp option }
+
+and methode = { m_protection : protection;
+                m_static     : bool;
+                m_name       : method_name;
+                m_args       : var_dec list;
+                m_returns    : ty;
+                m_throws     : class_name list;
+                m_body       : block; }
+
+
+and block = { b_locals : var_dec list;
+              b_body   : act list; }
+
+and act = Anewvar of var_dec * exp
+        | Aassgn of pattern * exp
+        | Amethod_call of exp * method_name * exp list
+        | 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
+        | Areturn of exp
+
+and exp = Eval of pattern
+        | Ethis
+        | Efun of op_name * exp list
+        | Emethod_call of exp * method_name * exp list
+        | Enew of ty * exp list
+        | Enew_array of ty * exp list (** [ty] is the array base type *)
+        | Evoid (*printed as nothing*)
+        | Ecast of ty * exp
+        | Svar of const_name
+        | Sint of int
+        | Sfloat of float
+        | Sbool of bool
+        | Sconstructor of constructor_name
+        | Sstring of string
+        | 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 rec default_value ty = match ty with
+  | Tclass _ -> Snull
+  | Tgeneric _ -> Snull
+  | Tbool -> Sbool true
+  | Tint -> Sint 0
+  | Tfloat -> Sfloat 0.0
+  | Tunit -> Evoid
+  | Tref t ->  default_value t
+  | Tarray _ -> Enew_array (ty,[])
+
+
+let java_pervasive_class c = Names.qualname_of_string ("jeptagon.Pervasives."^c)
+let the_java_pervasives = Names.qualname_of_string "jeptagon.Pervasives"
+
+
+let mk_var x = Eval (Pvar x)
+
+let mk_var_dec x ty =
+  { vd_type = ty; vd_ident = x }
+
+let mk_block ?(locals=[]) b =
+  { b_locals = locals; b_body = b; }
+
+
+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_imports = imports; c_implements = implements;
+    c_kind = Cgeneric { cd_fields = fields; cd_classs = classes; cd_constructors = constrs; cd_methodes = methodes; } }
 
-open Signature
-open Modules
-open Format
-open Obc
-open Misc
-open Names
-open Idents
-open Pp_tools
-
-let jname_of_name name =
-  let b = Buffer.create (String.length name) in
-  let rec convert c =
-    match c with
-      | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' ->
-          Buffer.add_char b c
-      | '\'' -> Buffer.add_string b "_prime"
-      | _ ->
-          Buffer.add_string b "lex";
-          Buffer.add_string b (string_of_int (Char.code c));
-          Buffer.add_string b "_" in
-
-  String.iter convert name;
-  Buffer.contents b
-
-let print_name ff name =
-  fprintf ff "%s" (jname_of_name name)
-
-let print_shortname ff longname =
-  print_name ff (shortname longname)
-
-let o_types : type_dec list ref = ref []
-
-let java_type_default_value = function
-  | Tint -> "int", "0"
-  | Tfloat -> "float", "0.0"
-  | Tid (Name("bool"))
-  | Tid (Modname({ id = "bool" })) ->
-      "boolean", "false"
-  | Tid t when ((shortname t) = "int") -> "int", "0"
-  | Tid t when ((shortname t) = "float") -> "float", "0.0"
-  | Tid t ->
-      begin try
-        let { info = ty_desc } = find_type (t) in
-        begin match ty_desc with
-          | Tenum _ ->
-              "int", "0"
-          | _ ->
-              let t = shortname t in
-              if t = "bool"
-              then ("boolean", "false")
-              else (t, "null")
-        end
-      with Not_found ->
-        begin try
-          let { t_desc = tdesc } =
-            List.find (fun {t_name = tn} -> tn = (shortname t)) !o_types in
-          begin match tdesc with
-            | Type_enum _ ->
-                "int", "0"
-            | _ ->
-                let t = shortname t in
-                if t = "bool"
-                then ("boolean", "false")
-                else (t, "null")
-          end
-        with Not_found ->
-          let t = shortname t in
-          if t = "bool"
-          then ("boolean", "false")
-          else (t, "null")
-        end
-      end
-
-let print_type ff ty =
-  let jty,_ = java_type_default_value ty in
-  print_name ff jty
-
-let print_field ff (name,ty) =
-  fprintf ff "%a %a;"
-    print_type ty
-    print_name name
-
-let print_const_field ff (name,ty) =
-  fprintf ff "%a@ %a"
-    print_type ty
-    print_name name
-
-let print_assgt_field ff (name,_) =
-  fprintf ff "this.%a = %a;"
-    print_name name
-    print_name name
-
-(* assumes tn is already translated with jname_of_name *)
-let print_struct_type ff tn fields =
-  fprintf ff "@[<v>@[<v 2>public class %s {@ " tn;
-  (* fields *)
-  print_list print_field "" "" "" ff fields;
-  (* constructor *)
-  let sorted_fields =
-    List.sort
-      (fun (n1,_) (n2,_) -> String.compare n1 n2)
-      fields in
-  fprintf ff "@ @[<v 2>public %s(@[<hov>" tn;
-  print_list print_const_field "" "," "" ff sorted_fields;
-  fprintf ff "@]) {@ ";
-  (* constructor assignments *)
-  print_list print_assgt_field "" "" "" ff fields;
-  (* constructor end *)
-  fprintf ff "@]@ }";
-  (* class end *)
-  fprintf ff "@]@ }@]"
-
-
-let rec print_tags ff n = function
-  | []   -> ()
-  | tg :: tgs' ->
-      fprintf ff "@ public static final int %a = %d;"
-        print_name tg
-        n;
-      print_tags ff (n+1) tgs'
-
-(* assumes tn is already translated with jname_of_name *)
-let print_enum_type ff tn tgs =
-  fprintf ff "@[<v>@[<v 2>public class %s {" tn;
-  print_tags ff 1 tgs;
-  fprintf ff "@]@ }@]"
-
-let print_type_to_file java_dir headers { t_name = tn; t_desc = td} =
-  let tn = jname_of_name tn in
-  match td with
-    | Type_abs -> ()
-    | Type_enum tgs ->
-        let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in
-        let ff = formatter_of_out_channel out_ch in
-        Misc.print_header_info ff "/*" "*/";
-        List.iter (fprintf ff "%s") headers;
-        (* fprintf ff "@[<v>package %s;@\n@\n" headers; *)
-        print_enum_type ff tn tgs;
-        fprintf ff "@.";
-        close_out out_ch
-    | Type_struct fields ->
-        let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in
-        let ff = formatter_of_out_channel out_ch in
-        Misc.print_header_info ff "/*" "*/";
-        List.iter (fprintf ff "%s") headers;
-        (* fprintf ff "@[<v>package %s;@\n@\n" headers; *)
-        print_struct_type ff tn fields;
-        fprintf ff "@.";
-        close_out out_ch
-
-let print_types java_dir headers tps =
-  List.iter (print_type_to_file java_dir headers) tps
-
-(******************************)
-
-type answer =
-  | Sing of var_ident
-  | Mult of var_ident list
-
-let print_const ff c ts =
-  match c with
-    | Cint i -> fprintf ff "%d" i
-    | Cfloat f -> fprintf ff "%f" f
-    | Cconstr t ->
-        let s =
-          match t with
-            | Name("true")
-            | Modname({id = "true"}) -> "true"
-            | Name("false")
-            | Modname({id = "false"}) -> "false"
-            | Name(tg)
-            | Modname({id = tg}) ->
-                (fst
-                   (List.find
-                      (fun (tn, tgs) ->
-                         List.exists (fun tg' -> tg = tg') tgs)
-                      ts))
-                ^ "." ^ (jname_of_name tg)
-        in
-        fprintf ff "%s" s
-
-let position a xs =
-  let rec walk i = function
-    | []       -> None
-    | x :: xs' -> if x = a then Some i else walk (i + 1) xs'
-  in walk 1 xs
-
-let print_ident ff id =
-  print_name ff (name id)
-
-let print_var ff x avs single =
-  match (position x avs) with
-    | None -> print_ident ff x
-    | Some n ->
-        if single then print_ident ff (List.hd avs)
-        else fprintf ff "step_ans.c_%d" n
-
-let javaop_of_op = function
-  | "="  -> "=="
-  | "<>" -> "!="
-  | "or" -> "||"
-  | "&"  -> "&&"
-  | "*." -> "*"
-  | "/." -> "/"
-  | "+." -> "+"
-  | "-." -> "-"
-  | op   -> op
-
-let priority = function
-  | "*" | "/" | "*." | "/."  -> 5
-  | "+" | "-" | "+." | "-."  -> 4
-  | "=" | "<>" | "<=" | "=>" -> 3
-  | "&"                      -> 2
-  | "|"                      -> 1
-  | _                        -> 0
-
-let rec print_lhs ff e avs single =
-  match e with
-    | Var x ->
-        print_var ff x avs single
-    | Mem x -> print_ident ff x
-    | Field(e, field) ->
-        print_lhs ff e avs single;
-        fprintf ff ".%s" (jname_of_name (shortname field))
-
-let rec print_exp ff e p avs ts single =
-  match e with
-    | Lhs l -> print_lhs ff l avs single
-    | Const c -> print_const ff c ts
-    | Op (op, es) -> print_op ff op es p avs ts single
-    | Struct_lit(type_name,fields) ->
-        let fields =
-          List.sort
-            (fun (ln1,_) (ln2,_) ->
-               String.compare (shortname ln1) (shortname ln2))
-            fields in
-        let exps = List.map (fun (_,e) -> e) fields in
-        fprintf ff "new %a(@[<hov>"
-          print_shortname type_name;
-        print_exps ff exps 0 avs ts single;
-        fprintf ff "@])"
-
-and print_exps ff es p avs ts single =
-  match es with
-    | [] -> ()
-    | [e] -> print_exp ff e p avs ts single
-    | e :: es' ->
-        print_exp ff e p avs ts single;
-        fprintf ff ",@ ";
-        print_exps ff es' p avs ts single
-
-and print_op ff op es p avs ts single =
-  match (shortname op), es with
-    | (("+" | "-" | "*" | "/"
-       |"+." | "-." | "*." | "/."
-       | "=" | "<>" | "<" | "<="
-       | ">" | ">=" | "&" | "or") as op_name, [e1;e2]) ->
-        let p' = priority op_name in
-        if p' < p then fprintf ff "(" else ();
-        print_exp ff e1 p' avs ts single;
-        fprintf ff " %s " (javaop_of_op op_name);
-        print_exp ff e2 p' avs ts single;
-        if p' < p then fprintf ff ")" else ()
-    | "not", [e] ->
-        fprintf ff "!";
-        print_exp ff e 6 avs ts single;
-    | "~-", [e] ->
-        fprintf ff "-";
-        print_exp ff e 6 avs ts single;
-    | _ ->
-        begin
-          begin
-            match op with
-              | Name(op_name) ->
-                  print_name ff op_name;
-              | Modname({ qual = mod_name; id = op_name }) ->
-                  fprintf ff "%a.%a"
-                    print_name (String.uncapitalize mod_name)
-                    print_name op_name
-          end;
-          fprintf ff "@[(";
-          print_exps ff es 0 avs ts single;
-          fprintf ff ")@]"
-        end
-
-let rec print_proj ff xs ao avs single =
-  let rec walk ind = function
-    | [] -> ()
-    | x :: xs' ->
-        print_lhs ff x avs single;
-        fprintf ff " = %s.c_%d;@ " ao ind;
-        walk (ind + 1) xs'
-  in walk 1 xs
-
-
-let bool_case = function
-  | []                -> assert false
-  | ("true", _) :: _
-  | ("false", _) :: _ -> true
-  | _                 -> false
-
-let obj_call_to_string = function
-  | Context o
-  | Array_context (o,_) -> o
-
-let rec print_act ff a objs avs ts single =
-  match a with
-    | Assgn (x, e) ->
-        fprintf ff "@[";
-        print_asgn ff x e avs ts single;
-        fprintf ff ";@]"
-    | Step_ap (xs, o, es) ->
-        let o = obj_call_to_string o in
-        (match xs with
-           | [x] ->
-               print_lhs ff x avs single;
-               fprintf ff " = %s.step(" o;
-               fprintf ff "@[";
-               print_exps ff es 0 avs ts single;
-               fprintf ff "@]";
-               fprintf ff ");@ "
-           | xs ->
-               let cn = (List.find (fun od -> od.obj = o) objs).cls in
-               let at = (jname_of_name (shortname cn)) ^ "Answer" in
-               let ao = o ^ "_ans" in
-               fprintf ff "%s %s = new %s();@ " at ao at;
-               fprintf ff "%s = %s.step(" ao o;
-               fprintf ff "@[";
-               print_exps ff es 0 avs ts single;
-               fprintf ff "@]";
-               fprintf ff ");@ ";
-               print_proj ff xs ao avs single)
-    | Comp (a1, a2) ->
-        print_act ff a1 objs avs ts single;
-        (match a2 with
-           | Nothing -> ()
-           | _ -> fprintf ff "@ ");
-        print_act ff a2 objs avs ts single
-    | Case (e, grds) ->
-        let grds =
-          List.map
-            (fun (ln,act) -> (shortname ln),act) grds in
-        if bool_case grds
-        then print_if ff e grds objs avs ts single
-        else (fprintf ff "@[<v>@[<v 2>switch (%a) {@ "
-                (fun ff e -> print_exp ff e 0 avs ts single) e;
-              print_grds ff grds objs avs ts single;
-              fprintf ff "@]@ }@]");
-    | Reinit o -> fprintf ff "%s.reset();" o
-    | Nothing -> ()
-
-and print_grds ff grds objs avs ts single =
-  match grds with
-    | [] -> ()
-    | [(tg, act)] ->
-        (* retrieve class name *)
-        let cn = (fst
-                    (List.find
-                       (fun (tn, tgs) ->
-                          List.exists (fun tg' -> tg = tg') tgs)
-                       ts)) in
-        fprintf ff "@[<v 2>case %a.%a:@ "
-          print_name cn
-          print_name tg;
-        print_act ff act objs avs ts single;
-        fprintf ff "@ break;@]";
-    | (tg, act) :: grds' ->
-        (* retrieve class name *)
-        let cn = (fst
-                    (List.find
-                       (fun (tn, tgs) ->
-                          List.exists (fun tg' -> tg = tg') tgs)
-                       ts)) in
-        fprintf ff "@[<v 2>case %a.%a:@ "
-          print_name cn
-          print_name tg;
-        print_act ff act objs avs ts single;
-        fprintf ff "@ break;@ @]@ ";
-        print_grds ff grds' objs avs ts single
-
-and print_if ff e grds objs avs ts single =
-  match grds with
-    | [("true", a)] ->
-        fprintf ff "@[<v>@[<v 2>if (%a) {@ "
-          (fun ff e -> print_exp ff e 0 avs ts single) e;
-        print_act ff a objs avs ts single;
-        fprintf ff "@]@ }@]"
-    | [("false", a)] ->
-        fprintf ff "@[<v>@[<v 2>if (!%a) {@ "
-          (fun ff e -> print_exp ff e 6 avs ts single) e;
-        print_act ff a objs avs ts single;
-        fprintf ff "@]@ }@]"
-    | [("true", a1); ("false", a2)] ->
-        fprintf ff "@[<v>@[<v 2>if (%a) {@ "
-          (fun ff e -> print_exp ff e 0 avs ts single) e;
-        print_act ff a1 objs avs ts single;
-        fprintf ff "@]@ @[<v 2>} else {@ ";
-        print_act ff a2 objs avs ts single;
-        fprintf ff "@]@ }@]"
-    | [("false", a2); ("true", a1)] ->
-        fprintf ff "@[<v>@[<v 2>if (%a) {@ "
-          (fun ff e -> print_exp ff e 0 avs ts single) e;
-        print_act ff a1 objs avs ts single;
-        fprintf ff "@]@ @[<v 2>} else {@ ";
-        print_act ff a2 objs avs ts single;
-        fprintf ff "@]@ }@]"
-    | _ -> assert false
-
-and print_asgn ff x e avs ts single =
-  fprintf ff "@[";
-  print_lhs ff x avs single;
-  fprintf ff " = ";
-  print_exp ff e 0 avs ts single;
-  fprintf ff "@]"
-
-let print_vd ff vd =
-  let jty,jdv = java_type_default_value vd.v_type in
-  fprintf ff "@[<v>";
-  print_name ff jty;
-  fprintf ff " %s = %s;"
-    (jname_of_name (name vd.v_ident))
-    jdv;
-  fprintf ff "@]"
-
-let print_obj ff od =
-  fprintf ff "@[<v>";
-  fprintf ff "%a %a = new %a();"
-    print_shortname od.cls
-    print_name od.obj
-    print_shortname od.cls;
-  fprintf ff "@]"
-
-let rec print_objs ff ods =
-  match ods with
-    | [] -> ()
-    | od :: ods' ->
-        print_obj ff od;
-        fprintf ff "@ ";
-        print_objs ff ods'
-
-let print_comps ff fds=
-  let rec walk n = function
-    | [] -> ()
-    | fd :: fds' ->
-        fprintf ff "@ ";
-        fprintf ff "public ";
-        print_type ff fd.v_type;
-        fprintf ff " c_%s;" (string_of_int n);
-        walk (n + 1) fds'
-  in walk 1 fds
-
-let print_ans_struct ff name fields =
-  fprintf ff "@[<v>@[<v 2>public class %s {" name;
-  print_comps ff fields;
-  fprintf ff "@]@ }@]@ "
-
-let print_vd' ff vd =
-  fprintf ff "@[";
-  print_type ff vd.v_type;
-  fprintf ff "@ %s" (jname_of_name (name vd.v_ident));
-  fprintf ff "@]"
-
-let rec print_in ff = function
-  | [] -> ()
-  | [vd] -> print_vd' ff vd
-  | vd :: vds' ->
-      print_vd' ff vd;
-      fprintf ff ",@ ";
-      print_in ff vds'
-
-let rec print_mem ff = function
-  | [] -> ()
-  | vd :: m' ->
-      print_vd ff vd;
-      fprintf ff "@ ";
-      print_mem ff m'
-
-let print_loc ff vds = print_mem ff vds
-
-let print_step ff n s objs ts single =
-  let name = jname_of_name n in
-  fprintf ff "@[<v>@ @[<v 2>public ";
-  if single then print_type ff (List.hd s.out).v_type
-  else fprintf ff "%s" (n ^ "Answer");
-  fprintf ff " step(@[";
-  print_in ff s.inp;
-  fprintf ff "@]) {@ ";
-  let loc = if single then (List.hd s.out) :: s.local else s.local in
-  if loc = [] then () else (print_loc ff loc; fprintf ff "@ ");
-  if single then fprintf ff "@ "
-  else fprintf ff "%sAnswer step_ans = new %sAnswer();@ @ " n n;
-  print_act ff s.bd objs
-    (List.map (fun vd -> vd.v_ident) s.out) ts single;
-  fprintf ff "@ @ return ";
-  if single
-  then fprintf ff "%s" (jname_of_name (Idents.name (List.hd s.out).v_ident))
-  else fprintf ff "step_ans";
-  fprintf ff ";@]@ }@ @]"
-
-let print_reset ff r ts =
-  fprintf ff "@[<v>@ @[<v 2>public void reset() {@ ";
-  print_act ff r [] [] ts false;
-  fprintf ff "@]@ }@ @]"
-
-let print_class ff headers ts single opened_mod cl =
-  let clid = jname_of_name cl.cl_id in
-  List.iter (fprintf ff "%s") headers;
-  (*   fprintf ff "@[<v>package %s;@\n@\n" headers; *)
-  (* import opened modules *)
-  List.iter
-    (fun m ->
-       fprintf ff "import %s.*;@\n" (String.uncapitalize m))
-    opened_mod;
-
-  fprintf ff "@\n@[<v 2>public class %s {@ " clid;
-  if cl.mem = [] then ()
-  else fprintf ff "@[<v>@ "; print_mem ff cl.mem; fprintf ff "@]";
-  if cl.objs = [] then ()
-  else fprintf ff "@[<v>@ "; print_objs ff cl.objs; fprintf ff "@]";
-  print_reset ff cl.reset ts;
-  print_step ff clid cl.step cl.objs ts single;
-  fprintf ff "@]@ }@]"
-
-let print_class_and_answer_to_file java_dir headers ts opened_mod cl =
-  let clid = jname_of_name cl.cl_id in
-  let print_class_to_file single =
-    let out_ch = open_out (java_dir ^ "/" ^ clid ^ ".java") in
-    let ff = formatter_of_out_channel out_ch in
-    Misc.print_header_info ff "/*" "*/";
-    print_class ff headers ts single opened_mod cl;
-    fprintf ff "@.";
-    close_out out_ch
-  in
-  match cl.step.out with
-    | [_] -> print_class_to_file true
-    | _ ->
-        let out_ch = open_out (java_dir ^ "/" ^ clid ^ "Answer.java") in
-        let ff = formatter_of_out_channel out_ch in
-        Misc.print_header_info ff "/*" "*/";
-        List.iter (fprintf ff "%s") headers;
-        (*         fprintf ff "@[<v>package %s;@\n@\n" headers; *)
-        List.iter
-          (fun m ->
-             fprintf ff "import %s.*;@\n" (String.uncapitalize m))
-          opened_mod;
-        print_ans_struct ff (clid ^ "Answer") cl.step.out;
-        fprintf ff "@.";
-        close_out out_ch;
-        print_class_to_file false
-
-let print_classes java_dir headers ts opened_mod cls =
-  List.iter
-    (print_class_and_answer_to_file java_dir headers ts opened_mod)
-    cls
-
-(******************************)
-let print java_dir p =
-  let headers =
-    List.map snd
-      (List.filter
-         (fun (tag,_) -> tag = "java")
-         p.o_pragmas) in
-  print_types java_dir headers p.o_types;
-  o_types := p.o_types;
-  print_classes
-    java_dir headers
-    (List.flatten
-       (List.map
-          (function
-             | { t_desc = Type_abs }                   -> []
-             | { t_name = tn; t_desc = Type_enum tgs } -> [tn, tgs]
-             | { t_name = tn; t_desc = Type_struct fields } ->
-                 [tn, (List.map fst fields)])
-          p.o_types))
-    p.o_opened
-    p.o_defs
-
-(******************************)
+let mk_enum ?(protection=Ppublic) ?(static=false) ?(imports=[]) ?(implements=[])
+            constructor_names class_name =
+  { 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 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

compiler/obc/java/java_main.ml

@@ -0,0 +1,69 @@
+open Misc
+open Java
+open Java_printer
+
+(** returns the vd and the pat of a fresh ident from [name] *)
+let mk_var ty name =
+  let id = Idents.gen_var "java_main" name in
+  mk_var_dec id ty, Pvar id
+
+let program p =
+  let p_java = Obc2java.program p in
+  let dir = Compiler_utils.build_path "java" in
+  Compiler_utils.ensure_dir dir;
+
+  (* Compile and output the nodes *)
+  output_program dir p_java;
+
+  (* Create a runnable main simulation *)
+  if !Compiler_options.simulation
+  then (
+    let class_name = Obc2java.fresh_classe (!Compiler_options.simulation_node ^ "_sim") in
+    Idents.enter_node class_name;
+    let field_step_dnb, id_step_dnb =
+      let id = Idents.gen_var "java_main" "default_step_nb" in
+      mk_field ~static:true ~final:true ~value:(Some (Sint 30000)) Tint id, id
+    in
+    let main_methode =
+      let vd_step, pat_step = mk_var Tint "step" in
+      let vd_args, pat_args = mk_var (Tarray (Tclass (Names.pervasives_qn "String"), (Sint 0))) "args" in
+      let body =
+        let vd_main, e_main, q_main =
+          let q_main = !Compiler_options.simulation_node |> Modules.qualify_value |> Obc2java.qualname_to_package_classe
+          in let id = Idents.gen_var "java_main" "main" in
+          mk_var_dec id (Tclass q_main), Eval (Pvar id), q_main
+        in
+        let acts =
+          let integer = Eval(Pclass(Names.pervasives_qn "Integer")) in
+          let args1 = Eval(Parray_elem(pat_args, Sint 1)) in
+          let out = Eval(Pclass(Names.qualname_of_string "java.lang.System.out")) in
+          let vd_r, pat_r = mk_var Tint "r" in
+          let step_call = Anewvar(vd_r, Emethod_call(e_main, "step", [])) in
+          [ Anewvar(vd_main, Enew (Tclass q_main, []));
+            Aifelse( Efun(Names.pervasives_qn ">", [Eval (Pfield (pat_args, "length")); Sint 1])
+                   , mk_block [Aassgn(pat_step, Emethod_call(integer, "parseInt", [args1]))]
+                   , mk_block [Aassgn(pat_step, Eval (Pvar id_step_dnb))]);
+            Obc2java.fresh_for (Eval pat_step)
+              (fun i ->
+                let printing =
+                  if !Compiler_options.verbose
+                  then [Amethod_call(out, "printf", [Sstring "%d => %d\\n"; Eval (Pvar i); Eval pat_r])]
+                  else []
+                in step_call::printing )
+          ]
+        in
+        mk_block ~locals:[vd_step] acts
+      in
+      mk_methode ~static:true ~args:[vd_args] body "main"
+    in
+    let c = mk_classe ~fields:[field_step_dnb] ~methodes:[main_methode] class_name in
+    output_program dir [c]
+  )
+
+
+
+
+
+
+
+

compiler/obc/java/java_printer.ml

@@ -0,0 +1,233 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Java printer *)
+
+open Java
+open Pp_tools
+open Format
+open Misc
+
+let class_name = Global_printer.print_qualname
+let bare_class_name = Global_printer.print_shortname
+let obj_ident = Global_printer.print_ident
+let constructor_name = Global_printer.print_qualname
+let bare_constructor_name = Global_printer.print_shortname
+let method_name = pp_print_string
+let field_name = pp_print_string
+let field_ident = Global_printer.print_ident
+let var_ident = Global_printer.print_ident
+let const_name = Global_printer.print_qualname
+
+let protection ff = function
+  | Ppublic -> fprintf ff "public "
+  | Pprotected -> fprintf ff "protected "
+  | Pprivate -> fprintf ff "private "
+  | Ppackage -> ()
+
+let static ff s = if s then fprintf ff "static " else ()
+
+let final ff f = if f then fprintf ff "final " else ()
+
+let rec _ty 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]" full_ty t exp s else fprintf ff "%a[]" ty t
+  | Tref t -> ty ff 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_ident
+    (print_opt2 exp " = ") f.f_value
+
+and exp ff = function
+  | Ethis -> fprintf ff "this"
+  | Eval p -> pattern ff p
+  | Efun (f,e_l) -> op ff (f, e_l)
+  | Emethod_call (o,m,e_l) -> fprintf ff "%a.%a%a" exp o method_name m args e_l
+  | Enew (c,e_l) -> fprintf ff "new %a%a" 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 -> ()
+  | Ecast (t,e) -> fprintf ff "(%a)(%a)" ty t exp e
+  | Svar c -> const_name ff c
+  | Sint i -> pp_print_int ff i
+  | Sfloat f -> pp_print_float ff f
+  | Sbool b -> pp_print_bool ff b
+  | Sconstructor c -> constructor_name ff c
+  | Sstring s -> fprintf ff "\"%s\"" s
+  | 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
+        | s -> fprintf ff "jeptagon.Pervasives.%s%a" s args e_l) (* TODO java deal with this correctly
+            bug when using Pervasives.ggg in the code but works when using ggg directly *)
+  | _ -> fprintf ff "%a%a" Global_printer.print_qualname f args e_l
+
+and args ff e_l = fprintf ff "@[(%a)@]" (print_list_r exp """,""") e_l
+
+and pattern ff = function
+  | Pfield (p,f) -> fprintf ff "%a.%a" pattern p field_name f
+  | Pvar v -> var_ident ff v
+  | Pclass c -> class_name ff c
+  | Parray_elem (p,e) -> fprintf ff "%a[%a]" pattern p exp e
+  | Pthis f -> fprintf ff "this.%a" field_ident f
+
+let rec block ff b =
+  fprintf ff "%a%a"
+    (vd_list """;"";") b.b_locals
+    (print_list_r act """""") b.b_body
+
+(*
+and switch_hack ff c_b_l =
+  fprintf ff "@[<hv 2> default :\\Dead code. Hack to prevent \"may not be initialized\" java error.@ %a@ break;@]"
+    block (c_b_l |> List.hd |> snd)
+*)
+
+and act ff = function
+  | Anewvar (vd,e) -> fprintf ff "@[<4>%a =@ %a;@]" (var_dec false) vd exp e
+  | Aassgn (p,e) -> fprintf ff "@[<4>%a =@ %a;@]" pattern p exp e
+  | Amethod_call (o,m,e_l) -> fprintf ff "@[%a.%a%a;@]" exp o method_name m args e_l
+  | Aswitch (e, c_b_l) ->
+      let pcb ff (c,b) = fprintf ff "@[<v4>case %a:@ %a@ break;@]" bare_constructor_name c block b in
+    (*  let switch_hack ff c_b_l = (* TODO java : better thing to do ? *)
+        fprintf ff "@[<2>default ://Dead code. Hack to prevent \
+                    \"may not be initialized\" java error.@ %a@ break;@]" block (c_b_l |> List.hd |> snd)
+      in*)
+      fprintf ff "@[<v4>switch (%a) {@ %a@]@\n}"
+        exp e
+        (print_list_r pcb """""") c_b_l
+  | Aif (e,bt) ->
+      fprintf ff "@[<v 4>if (%a) {@ %a }@]" exp e block bt
+  | Aifelse (e,bt,bf) ->
+      fprintf ff "@[<v>@[<v4>if (%a) {@ %a@]@ @[<v4>} else {@ %a@]@ }@]"
+        exp e
+        block bt
+        block bf
+  | Ablock b -> if (List.length b.b_body > 0) then fprintf ff "@[<v>@[<v4>{@ %a@]@ }@]" block b
+  | Afor (x, i1, i2, b) ->
+      fprintf ff "@[<hv>@[<hv 4>for (%a = %a; %a<%a; %a++) {@ %a@]@ }@]"
+        (var_dec false) x
+        exp i1
+        var_ident x.vd_ident
+        exp i2
+        var_ident x.vd_ident
+        block b
+  | Areturn e -> fprintf ff "return %a;" exp e
+
+let methode ff m =
+  fprintf ff "@[<v4>%a%a%a %a @[<4>(%a)@] @[%a@]{@ %a@]@\n}"
+    protection m.m_protection
+    static m.m_static
+    ty m.m_returns
+    method_name m.m_name
+    (print_list_r (var_dec false) """,""") m.m_args
+    (print_list_r class_name "throws "","" ") m.m_throws
+    block m.m_body
+
+let constructor ff m =
+  fprintf ff "@[<v4>%a%a @[<4>(%a)@] {@\n%a@]@\n}"
+    protection m.m_protection
+    method_name m.m_name
+    (print_list_r (var_dec false) """,""") m.m_args
+    block m.m_body
+
+let rec class_desc ff cd =
+  fprintf ff "@[<v>%a@ %a@ %a@ %a@]"
+    (print_list_r field """;"";") cd.cd_fields
+    (print_list_r classe """""") cd.cd_classs
+    (print_list constructor """""") cd.cd_constructors
+    (print_list methode """""") cd.cd_methodes
+
+and classe ff c = match c.c_kind with
+  | Cenum c_l ->
+      fprintf ff "@\n@[<4>%a%aenum %a {@\n%a@]@\n}"
+        protection c.c_protection
+        static c.c_static
+        bare_class_name c.c_name
+        (print_list_r bare_constructor_name """,""") c_l
+  | Cgeneric cd ->
+      fprintf ff "@\n@[<4>%a%aclass %a @[<h>%a@]{@\n%a@]@\n}"
+        protection c.c_protection
+        static c.c_static
+        bare_class_name c.c_name
+        (print_list_r class_name "implements "",""") c.c_implements
+        class_desc cd
+
+let output_classe base_dir c =
+  let { Names.name = file_name; Names.qual = package } = c.c_name in
+  let file_name = file_name ^ ".java" in
+  let package_dirs = Misc.split_string (Names.modul_to_string package) "." in
+  let create_dir base_dir dir =
+    let dir = Filename.concat base_dir dir in
+    Compiler_utils.ensure_dir dir;
+    dir
+  in
+  let dir = List.fold_left create_dir base_dir package_dirs in
+  let oc = open_out (Filename.concat dir file_name) in
+  let ff = Format.formatter_of_out_channel oc in
+  pp_set_margin ff 120;
+  fprintf ff "package %a;@\n@[<v>%a@]@\n%a@."
+    Global_printer.print_full_modul package
+    (print_list_r (fun ff n -> fprintf ff "import %a" class_name n) """;"";") c.c_imports
+    classe c;
+  close_out oc
+
+let output_program dir (p:Java.program) =
+  List.iter (output_classe dir) p
+

compiler/obc/java/javamain.ml

@@ -1,6 +0,0 @@
-
-let program p =
-  let filename = filename_of_module p in
-  let dirname = build_path filename in
-  let dir = clean_dir dirname in
-    Java.print dir o

compiler/obc/java/obc2java.ml

@@ -0,0 +1,407 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** An Obc.program is a Java.package,
+       Obc.type_dec, Obc.class_def are Java.classs
+       Obc.const_dec is defined in the special class CONSTANTES
+       Obc.Lvar are Pvar
+       Obc.Lmem are this.Pvar (Pfield)
+       Obc.Oobj and Oarray are simply Pvar and Parray_elem
+       Obc.Types_alias are dereferenced since no simple type alias is possible in Java *)
+
+(** Requires scalar Obc : [p = e] when [e] is an array is understand as a copy of the reference,
+  not a copy of the array. *)
+
+open Format
+open Misc
+open Names
+open Modules
+open Signature
+open Obc
+open Obc_utils
+open Java
+
+
+(** 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 = Idents.gen_var "obc2java" "i" in
+  let id = mk_var_dec i Tint in
+  Afor (id, Sint 0, size, mk_block (body i))
+
+ (* current module is not translated to keep track, there is no issue since printed without the qualifier *)
+let rec translate_modul m = match m with
+  | Pervasives
+  | LocalModule -> m
+  | _ when m = g_env.current_mod -> 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 { qual = m; name = n } =
+  { qual = QualModule { qual = translate_modul m; name = "CONSTANTES"}; name = String.uppercase n }
+
+(** a [Module.fun] becomes a [module.FUNS.fun] *)
+let translate_fun_name { qual = m; name = n } =
+  { qual = QualModule { qual = translate_modul m; name = "FUNS"}; name = n }
+
+(** a [Module.name] becomes a [module.Name]
+    used for type_names, class_names, fun_names *)
+let qualname_to_class_name q =
+  { 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 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_2 q q_ty =
+  let classe = qualname_to_class_name q_ty in
+  { 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_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_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 ->
+      (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 se_l ->  tuple param_env se_l
+  | Types.Sarray_power (see,pow) ->
+      let pow = (try Static.int_of_static_exp Names.QualEnv.empty pow
+                 with Errors.Error ->
+                   eprintf "%aStatic power of array should have integer power. \
+                            Please use callgraph or non-static exp in %a.@."
+                           Location.print_location se.Types.se_loc
+                           Global_printer.print_static_exp se;
+                   raise Errors.Error)
+      in
+      let se_l = Misc.repeat_list (static_exp param_env see) pow in
+      Enew_array (ty param_env se.Types.se_ty, se_l)
+  | 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 -> 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.Tmutable t -> Tref (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
+  Tclass (java_pervasive_class ("Tuple"^ln))
+
+and ty param_env t :Java.ty = match t with
+  | 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.Tmutable t -> Tref (ty param_env t)
+  | Types.Tunit -> Tunit
+
+and var_dec param_env vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident }
+
+and var_dec_list param_env vd_l = List.map (var_dec param_env) vd_l
+
+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)
+
+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
+  | Obc.Lfield (p,f) -> Pfield (pattern param_env p, translate_field_name f)
+  | 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 -> 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) ->
+        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) ->
+        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) ->
+        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
+        let ecall = Emethod_call (obj_ref param_env obj, "step", exp_list param_env e_l) in
+        let assgn = Anewvar (return_vd, ecall) in
+        let copy_return_to_var i p =
+          let t = ty param_env p.pat_ty in
+          let cast t e = match t with
+            | Tbool -> Ecast(Tbool, Ecast(boxed_ty param_env p.pat_ty, e))
+            | Tint -> Ecast(Tint, Ecast(boxed_ty param_env p.pat_ty, e))
+            | Tfloat -> Ecast(Tfloat, Ecast(boxed_ty param_env p.pat_ty, e))
+            | _ -> Ecast(t, e)
+          in
+          let p = pattern param_env p in
+          Aassgn (p, cast t (Eval (Pfield (Pvar return_id, "c"^(string_of_int i)))))
+        in
+        let copies = Misc.mapi copy_return_to_var p_l in
+        assgn::(copies@acts)
+    | Obc.Acall (_, obj, Mreset, _) ->
+        let acall = Amethod_call (obj_ref param_env obj, "reset", []) in
+        acall::acts
+    | Obc.Acase (e, c_b_l) when e.e_ty = Types.Tid Initial.pbool ->
+        (match c_b_l with
+          | [] -> acts
+          | [(c,b)] when c = Initial.ptrue ->
+              (Aif (exp param_env e, block param_env b)):: 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,_) -> 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
+        let acase = Aswitch (exp param_env e, List.map _c_b c_b_l) in
+        acase::acts
+    | Obc.Afor (v, se, se', b) ->
+        let afor = Afor (var_dec param_env v, static_exp param_env se, static_exp param_env se', block param_env b) in
+        afor::acts
+    | Obc.Ablock b ->
+        let ablock = Ablock (block param_env b) in
+        ablock::acts
+  in
+  List.fold_right _act act_l acts
+
+and block param_env ?(locals=[]) ?(end_acts=[]) ob =
+  let blocals = var_dec_list param_env ob.Obc.b_locals in
+  let locals = locals @ blocals in
+  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 class_def_list classes cd_l =
+  let class_def classes cd =
+    Idents.enter_node cd.cd_name;
+    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
+    (* [reset] is the reset method of the class,
+       [reset_mems] is the block to reset the members of the class
+         without call to the reset method of inner instances, it retains [this.x = 0] but not [this.I.reset()] *)
+    let reset, reset_mems =
+      try (* When there exist a reset method *)
+        let oreset = find_reset_method cd in
+        let body = block param_env oreset.Obc.m_body in
+        let reset_mems = block param_env (remove_resets oreset.Obc.m_body) in
+        mk_methode body "reset", reset_mems
+      with Not_found -> (* stub reset method *)
+        mk_methode (mk_block []) "reset", mk_block []
+    in
+     (* [obj_env] gives the type of an [obj_ident], needed in async because we change the classe for async obj *)
+    let constructeur, obj_env =
+      let obj_env = (* Mapping between Obc class and Java class, useful at least with asyncs *)
+        let aux obj_env od =
+          let t = Tclass (qualname_to_class_name od.o_class)
+          in Idents.Env.add od.o_ident t obj_env
+        in List.fold_left aux Idents.Env.empty cd.cd_objs
+      in
+      let body =
+        (* Function to initialize the objects *)
+        let obj_init_act acts od =
+          let params = List.map (static_exp param_env) od.o_params in
+          match od.o_size with
+            | None ->
+                let t = Idents.Env.find od.o_ident obj_env in
+                (Aassgn (Pthis od.o_ident, Enew (t, params)))::acts
+            | Some size ->
+                let size = static_exp param_env size in
+                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)
+                 :: acts
+        in
+        (* function to allocate the arrays *)
+        let allocate acts vd = match vd.v_type with
+          | Types.Tarray (t, size) ->
+              let t = ty param_env vd.v_type in
+              ( Aassgn (Pthis vd.v_ident, Enew_array (t,[])) ):: acts
+          | _ -> acts
+        in
+        (* init actions [acts] in reverse order : *)
+        (* init member variables *)
+        let acts = [Ablock reset_mems] in
+        (* init member objects *)
+        let acts = List.fold_left obj_init_act acts cd.cd_objs in
+        (* allocate member arrays *)
+        let acts = List.fold_left allocate acts cd.cd_mems in
+        (* init static params *)
+        let acts = (copy_to_this vds_params)@acts in
+        { b_locals = []; b_body = List.rev acts }
+      in mk_methode ~args:vds_params body (shortname class_name), 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 -> 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 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
+      let vd_output = var_dec_list param_env ostep.m_outputs in
+      let return_ty = ostep.m_outputs |> vd_list_to_type |> (ty param_env) in
+      let return_act = Areturn (match vd_output with
+                                 | [] -> Evoid
+                                 | [vd] -> Eval (Pvar vd.vd_ident)
+                                 | 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"
+    in
+    let classe = mk_classe ~fields:fields
+                           ~constrs:[constructeur] ~methodes:[step;reset] class_name in
+    classe::classes
+  in
+  List.fold_left class_def 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_package_classe td.t_name in
+    Idents.enter_node classe_name;
+    match td.t_desc with
+      | 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_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
+            (* [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
+  in
+  List.fold_left _td classes td_l
+
+
+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_classes in
+  get_classes()@p
+
+
+

compiler/obc/java/old_java.ml

@@ -0,0 +1,543 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+open Signature
+open Modules
+open Format
+open Obc
+open Misc
+open Types
+open Names
+open Idents
+open Pp_tools
+
+let jname_of_name name =
+  let b = Buffer.create (String.length name) in
+  let rec convert c =
+    match c with
+      | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' ->
+          Buffer.add_char b c
+      | '\'' -> Buffer.add_string b "_prime"
+      | _ ->
+          Buffer.add_string b "lex";
+          Buffer.add_string b (string_of_int (Char.code c));
+          Buffer.add_string b "_" in
+
+  String.iter convert name;
+  Buffer.contents b
+
+let print_name ff name =
+  fprintf ff "%s" (jname_of_name name)
+
+let print_shortname ff longname =
+  print_name ff (shortname longname)
+
+let rec java_type_default_value = function
+  | Tid id when id = Initial.pint -> "int", "0"
+  | Tid id when id = Initial.pfloat -> "float", "0.0"
+  | Tid id when id = Initial.pbool -> "boolean", "false"
+  | Tid t ->
+      (match find_type t with
+        | Tabstract -> assert false
+        | Talias t -> java_type_default_value t
+        | Tenum _ -> "int", "0" (* TODO java *)
+        | Tstruct _ -> shortname t, "null" )
+  | Tarray _ -> assert false (* TODO array *)
+  | Tprod _ -> assert false (* TODO java *)
+  | Tunit -> "void", "null"
+
+let print_type ff ty =
+  let jty,_ = java_type_default_value ty in
+  print_name ff jty
+
+let print_field ff (name,ty) =
+  fprintf ff "%a %a;"
+    print_type ty
+    print_name name
+
+let print_const_field ff (name,ty) =
+  fprintf ff "%a@ %a"
+    print_type ty
+    print_name name
+
+let print_assgt_field ff (name,_) =
+  fprintf ff "this.%a = %a;"
+    print_name name
+    print_name name
+
+(* assumes tn is already translated with jname_of_name *)
+let print_struct_type ff tn fields =
+  fprintf ff "@[<v>@[<v 2>public class %s {@ " tn;
+  (* fields *)
+  print_list print_field "" "" "" ff fields;
+  (* constructor *)
+  let sorted_fields =
+    List.sort
+      (fun (n1,_) (n2,_) -> String.compare n1 n2)
+      fields in
+  fprintf ff "@ @[<v 2>public %s(@[<hov>" tn;
+  print_list print_const_field "" "," "" ff sorted_fields;
+  fprintf ff "@]) {@ ";
+  (* constructor assignments *)
+  print_list print_assgt_field "" "" "" ff fields;
+  (* constructor end *)
+  fprintf ff "@]@ }";
+  (* class end *)
+  fprintf ff "@]@ }@]"
+
+
+let rec print_tags ff n = function
+  | []   -> ()
+  | tg :: tgs' ->
+      fprintf ff "@ public static final int %a = %d;"
+        print_name ( shortname tg ) (* TODO java deal with modules *)
+        n;
+      print_tags ff (n+1) tgs'
+
+(* assumes tn is already translated with jname_of_name *)
+let print_enum_type ff tn tgs =
+  fprintf ff "@[<v>@[<v 2>public class %s {" tn;
+  print_tags ff 1 tgs;
+  fprintf ff "@]@ }@]"
+
+let rec print_type_to_file java_dir headers { t_name = tn; t_desc = td} =
+  let tn = jname_of_name (shortname tn) in (* TODO java deal with modules *)
+  match td with
+    | Type_abs -> ()
+    | Type_enum tgs ->
+        let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in
+        let ff = formatter_of_out_channel out_ch in
+        (*Misc.print_header_info ff "/*" "*/"; *)
+        List.iter (fprintf ff "%s") headers;
+        (* fprintf ff "@[<v>package %s;@\n@\n" headers; *) (* TODO java deal with modules *)
+        print_enum_type ff tn tgs;
+        fprintf ff "@.";
+        close_out out_ch
+    | Type_struct fields ->
+        let out_ch = open_out (java_dir ^ "/" ^ tn ^ ".java") in
+        let ff = formatter_of_out_channel out_ch in
+       (* Misc.print_header_info ff "/*" "*/"; *)(* TODO java deal with modules *)
+        List.iter (fprintf ff "%s") headers;
+        (* fprintf ff "@[<v>package %s;@\n@\n" headers; *)
+        print_struct_type ff tn
+          (List.map (fun {f_name = n;f_type = t} -> (shortname n,t)) fields); (* TODO java deal with modules *)
+        fprintf ff "@.";
+        close_out out_ch
+    | Type_alias t -> assert false (* TODO java *)
+
+let print_types java_dir headers tps =
+  List.iter (print_type_to_file java_dir headers) tps
+
+(******************************)
+
+type answer =
+  | Sing of var_ident
+  | Mult of var_ident list
+
+let print_const ff c ts =
+  match c.se_desc with
+    | Sint i -> fprintf ff "%d" i
+    | Sfloat f -> fprintf ff "%f" f
+    | Sbool true -> fprintf ff "true"
+    | Sbool false -> fprintf ff "false"
+    | Sconstructor c ->
+        let tg = shortname c in (* TODO java gérer les modules *)
+        let s = (fst (List.find (fun (tn, tgs) -> List.exists (fun tg' -> tg = tg') tgs) ts))
+                ^ "." ^ (jname_of_name tg) in
+        fprintf ff "%s" s
+    | _ -> assert false (* TODO java *)
+
+let position a xs =
+  let rec walk i = function
+    | []       -> None
+    | x :: xs' -> if x = a then Some i else walk (i + 1) xs'
+  in walk 1 xs
+
+let print_ident ff id =
+  print_name ff (name id)
+
+let print_var ff x avs single =
+  match (position x avs) with
+    | None -> print_ident ff x
+    | Some n ->
+        if single then print_ident ff (List.hd avs)
+        else fprintf ff "step_ans.c_%d" n
+
+let javaop_of_op = function
+  | "="  -> "=="
+  | "<>" -> "!="
+  | "or" -> "||"
+  | "&"  -> "&&"
+  | "*." -> "*"
+  | "/." -> "/"
+  | "+." -> "+"
+  | "-." -> "-"
+  | op   -> op
+
+let priority = function
+  | "*" | "/" | "*." | "/."  -> 5
+  | "+" | "-" | "+." | "-."  -> 4
+  | "=" | "<>" | "<=" | "=>" -> 3
+  | "&"                      -> 2
+  | "|"                      -> 1
+  | _                        -> 0
+
+let rec print_lhs ff e avs single =
+  match e.pat_desc with
+    | Lvar x ->
+        print_var ff x avs single
+    | Lmem x -> print_ident ff x
+    | Lfield(e, field) ->
+        print_lhs ff e avs single;
+        fprintf ff ".%s" (jname_of_name (shortname field))
+    | Larray _ -> assert false (* TODO java array *)
+
+let rec print_exp ff e p avs ts single =
+  match e.e_desc with
+    | Epattern l -> print_lhs ff l avs single
+    | Econst c -> print_const ff c ts
+    | Eop (op, es) -> print_op ff op es p avs ts single
+    | Estruct (type_name,fields) ->
+        let fields =
+          List.sort
+            (fun (ln1,_) (ln2,_) ->
+               String.compare (shortname ln1) (shortname ln2))
+            fields in
+        let exps = List.map (fun (_,e) -> e) fields in
+        fprintf ff "new %a(@[<hov>"
+          print_shortname type_name;
+        print_exps ff exps 0 avs ts single;
+        fprintf ff "@])"
+    | Earray _ -> assert false (* TODO array *)
+
+and print_exps ff es p avs ts single =
+  match es with
+    | [] -> ()
+    | [e] -> print_exp ff e p avs ts single
+    | e :: es' ->
+        print_exp ff e p avs ts single;
+        fprintf ff ",@ ";
+        print_exps ff es' p avs ts single
+
+and print_op ff op es p avs ts single =
+  match (shortname op), es with
+    | (("+" | "-" | "*" | "/"
+       |"+." | "-." | "*." | "/."
+       | "=" | "<>" | "<" | "<="
+       | ">" | ">=" | "&" | "or") as op_name, [e1;e2]) ->
+        let p' = priority op_name in
+        if p' < p then fprintf ff "(" else ();
+        print_exp ff e1 p' avs ts single;
+        fprintf ff " %s " (javaop_of_op op_name);
+        print_exp ff e2 p' avs ts single;
+        if p' < p then fprintf ff ")" else ()
+    | "not", [e] ->
+        fprintf ff "!";
+        print_exp ff e 6 avs ts single;
+    | "~-", [e] ->
+        fprintf ff "-";
+        print_exp ff e 6 avs ts single;
+    | _ ->(*
+        begin
+          begin
+            match op with
+              | Name(op_name) ->
+                  print_name ff op_name;
+              | Modname({ qual = mod_name; id = op_name }) ->
+                  fprintf ff "%a.%a"
+                    print_name (String.uncapitalize mod_name)
+                    print_name op_name
+          end;
+          fprintf ff "@[(";
+          print_exps ff es 0 avs ts single;
+          fprintf ff ")@]"
+        end *)
+        assert false (* TODO java *)
+
+let rec print_proj ff xs ao avs single =
+  let rec walk ind = function
+    | [] -> ()
+    | x :: xs' ->
+        print_lhs ff x avs single;
+        fprintf ff " = %s.c_%d;@ " ao ind;
+        walk (ind + 1) xs'
+  in walk 1 xs
+
+
+let bool_case = function
+  | []                -> assert false
+  | ("true", _) :: _
+  | ("false", _) :: _ -> true
+  | _                 -> false
+
+let obj_ref_to_string = function
+  | Oobj o -> o
+  | Oarray (o,p) -> o (* TODO java array *)
+
+let rec print_act ff a objs avs ts single =
+  match a with
+    | Aassgn (x, e) ->
+        fprintf ff "@[";
+        print_asgn ff x e avs ts single;
+        fprintf ff ";@]"
+    | Acall (xs,oref,Mstep,es) ->
+        let o = obj_ref_to_string oref in
+        (match xs with
+           | [x] ->
+               print_lhs ff x avs single;
+               fprintf ff " = %s.step(" o;
+               fprintf ff "@[";
+               print_exps ff es 0 avs ts single;
+               fprintf ff "@]";
+               fprintf ff ");@ "
+           | xs ->
+               let cn = (List.find (fun od -> od.o_name = o) objs).o_class in
+               let at = (jname_of_name (shortname cn)) ^ "Answer" in
+               let ao = o ^ "_ans" in
+               fprintf ff "%s %s = new %s();@ " at ao at;
+               fprintf ff "%s = %s.step(" ao o;
+               fprintf ff "@[";
+               print_exps ff es 0 avs ts single;
+               fprintf ff "@]";
+               fprintf ff ");@ ";
+               print_proj ff xs ao avs single)
+    | Acase (e, grds) ->
+        let grds =
+          List.map
+            (fun (ln,act) -> (shortname ln),act) grds in
+        if bool_case grds
+        then print_if ff e grds objs avs ts single
+        else (fprintf ff "@[<v>@[<v 2>switch (%a) {@ "
+                (fun ff e -> print_exp ff e 0 avs ts single) e;
+              print_grds ff grds objs avs ts single;
+              fprintf ff "@]@ }@]");
+    | Acall (_,oref,Mreset,_) ->
+        let o = obj_ref_to_string oref in
+        fprintf ff "%s.reset();" o
+    | Afor _ -> assert false (* TODO java array *)
+
+
+and print_grds ff grds objs avs ts single =
+  match grds with
+    | [] -> ()
+    | (tg, b) :: grds' ->
+        (* retrieve class name *)
+        let cn = (fst
+                    (List.find
+                       (fun (tn, tgs) ->
+                          List.exists (fun tg' -> tg = tg') tgs)
+                       ts)) in
+        fprintf ff "@[<v 2>case %a.%a:@ "
+          print_name cn
+          print_name tg;
+        print_block ff b objs avs ts single;
+        fprintf ff "@ break;@ @]@ ";
+        print_grds ff grds' objs avs ts single
+
+and print_if ff e grds objs avs ts single =
+  match grds with
+    | [("true", a)] ->
+        fprintf ff "@[<v>@[<v 2>if (%a) {@ "
+          (fun ff e -> print_exp ff e 0 avs ts single) e;
+        print_block ff a objs avs ts single;
+        fprintf ff "@]@ }@]"
+    | [("false", a)] ->
+        fprintf ff "@[<v>@[<v 2>if (!%a) {@ "
+          (fun ff e -> print_exp ff e 6 avs ts single) e;
+        print_block ff a objs avs ts single;
+        fprintf ff "@]@ }@]"
+    | [("true", a1); ("false", a2)] ->
+        fprintf ff "@[<v>@[<v 2>if (%a) {@ "
+          (fun ff e -> print_exp ff e 0 avs ts single) e;
+        print_block ff a1 objs avs ts single;
+        fprintf ff "@]@ @[<v 2>} else {@ ";
+        print_block ff a2 objs avs ts single;
+        fprintf ff "@]@ }@]"
+    | [("false", a2); ("true", a1)] ->
+        fprintf ff "@[<v>@[<v 2>if (%a) {@ "
+          (fun ff e -> print_exp ff e 0 avs ts single) e;
+        print_block ff a1 objs avs ts single;
+        fprintf ff "@]@ @[<v 2>} else {@ ";
+        print_block ff a2 objs avs ts single;
+        fprintf ff "@]@ }@]"
+    | _ -> assert false
+
+and print_asgn ff x e avs ts single =
+  fprintf ff "@[";
+  print_lhs ff x avs single;
+  fprintf ff " = ";
+  print_exp ff e 0 avs ts single;
+  fprintf ff "@]"
+
+and print_block ff b objs avs ts single  = () (* TODO urgent java *)
+
+let print_vd ff vd =
+  let jty,jdv = java_type_default_value vd.v_type in
+  fprintf ff "@[<v>";
+  print_name ff jty;
+  fprintf ff " %s = %s;"
+    (jname_of_name (name vd.v_ident))
+    jdv;
+  fprintf ff "@]"
+
+let print_obj ff od =
+  fprintf ff "@[<v>";
+  fprintf ff "%a %a = new %a();"
+    print_shortname od.o_class
+    print_name od.o_name
+    print_shortname od.o_class;
+  fprintf ff "@]"
+
+let rec print_objs ff ods =
+  match ods with
+    | [] -> ()
+    | od :: ods' ->
+        print_obj ff od;
+        fprintf ff "@ ";
+        print_objs ff ods'
+
+let print_comps ff fds=
+  let rec walk n = function
+    | [] -> ()
+    | fd :: fds' ->
+        fprintf ff "@ ";
+        fprintf ff "public ";
+        print_type ff fd.v_type;
+        fprintf ff " c_%s;" (string_of_int n);
+        walk (n + 1) fds'
+  in walk 1 fds
+
+let print_ans_struct ff name fields =
+  fprintf ff "@[<v>@[<v 2>public class %s {" name;
+  print_comps ff fields;
+  fprintf ff "@]@ }@]@ "
+
+let print_vd' ff vd =
+  fprintf ff "@[";
+  print_type ff vd.v_type;
+  fprintf ff "@ %s" (jname_of_name (name vd.v_ident));
+  fprintf ff "@]"
+
+let rec print_in ff = function
+  | [] -> ()
+  | [vd] -> print_vd' ff vd
+  | vd :: vds' ->
+      print_vd' ff vd;
+      fprintf ff ",@ ";
+      print_in ff vds'
+
+let rec print_mem ff = function
+  | [] -> ()
+  | vd :: m' ->
+      print_vd ff vd;
+      fprintf ff "@ ";
+      print_mem ff m'
+
+let print_loc ff vds = print_mem ff vds
+
+let print_step ff n s objs ts single =
+  let n = jname_of_name n in
+  fprintf ff "@[<v>@ @[<v 2>public ";
+  if single then print_type ff (List.hd s.m_outputs).v_type
+  else fprintf ff "%s" (n ^ "Answer");
+  fprintf ff " step(@[";
+  print_in ff s.m_inputs;
+  fprintf ff "@]) {@ ";
+  let loc = if single then (List.hd s.m_outputs) :: s.m_body.b_locals else s.m_body.b_locals in
+  if loc = [] then () else (print_loc ff loc; fprintf ff "@ ");
+  if single then fprintf ff "@ "
+  else fprintf ff "%sAnswer step_ans = new %sAnswer();@ @ " n n;
+  print_act ff s.bd objs
+    (List.map (fun vd -> vd.v_ident) s.out) ts single;
+  fprintf ff "@ @ return ";
+  if single
+  then fprintf ff "%s" (jname_of_name (Idents.name (List.hd s.out).v_ident))
+  else fprintf ff "step_ans";
+  fprintf ff ";@]@ }@ @]"
+
+let print_reset ff r ts =
+  fprintf ff "@[<v>@ @[<v 2>public void reset() {@ ";
+  print_act ff r [] [] ts false;
+  fprintf ff "@]@ }@ @]"
+
+let print_class ff headers ts single opened_mod cl =
+  let clid = jname_of_name cl.cl_id in
+  List.iter (fprintf ff "%s") headers;
+  (*   fprintf ff "@[<v>package %s;@\n@\n" headers; *)
+  (* import opened modules *)
+  List.iter
+    (fun m ->
+       fprintf ff "import %s.*;@\n" (String.uncapitalize m))
+    opened_mod;
+
+  fprintf ff "@\n@[<v 2>public class %s {@ " clid;
+  if cl.mem = [] then ()
+  else fprintf ff "@[<v>@ "; print_mem ff cl.mem; fprintf ff "@]";
+  if cl.objs = [] then ()
+  else fprintf ff "@[<v>@ "; print_objs ff cl.objs; fprintf ff "@]";
+  print_reset ff cl.reset ts;
+  print_step ff clid cl.step cl.objs ts single;
+  fprintf ff "@]@ }@]"
+
+let print_class_and_answer_to_file java_dir headers ts opened_mod cl =
+  let clid = jname_of_name cl.cl_id in
+  let print_class_to_file single =
+    let out_ch = open_out (java_dir ^ "/" ^ clid ^ ".java") in
+    let ff = formatter_of_out_channel out_ch in
+    Misc.print_header_info ff "/*" "*/";
+    print_class ff headers ts single opened_mod cl;
+    fprintf ff "@.";
+    close_out out_ch
+  in
+  match cl.step.out with
+    | [_] -> print_class_to_file true
+    | _ ->
+        let out_ch = open_out (java_dir ^ "/" ^ clid ^ "Answer.java") in
+        let ff = formatter_of_out_channel out_ch in
+        Misc.print_header_info ff "/*" "*/";
+        List.iter (fprintf ff "%s") headers;
+        (*         fprintf ff "@[<v>package %s;@\n@\n" headers; *)
+        List.iter
+          (fun m ->
+             fprintf ff "import %s.*;@\n" (String.uncapitalize m))
+          opened_mod;
+        print_ans_struct ff (clid ^ "Answer") cl.step.out;
+        fprintf ff "@.";
+        close_out out_ch;
+        print_class_to_file false
+
+let print_classes java_dir headers ts opened_mod cls =
+  List.iter
+    (print_class_and_answer_to_file java_dir headers ts opened_mod)
+    cls
+
+(******************************)
+let print java_dir p =
+  let headers =
+    List.map snd
+      (List.filter
+         (fun (tag,_) -> tag = "java")
+         p.o_pragmas) in
+  print_types java_dir headers p.o_types;
+  o_types := p.o_types;
+  print_classes
+    java_dir headers
+    (List.flatten
+       (List.map
+          (function
+             | { t_desc = Type_abs }                   -> []
+             | { t_name = tn; t_desc = Type_enum tgs } -> [tn, tgs]
+             | { t_name = tn; t_desc = Type_struct fields } ->
+                 [tn, (List.map fst fields)])
+          p.o_types))
+    p.o_opened
+    p.o_defs
+
+(******************************)

compiler/obc/ml/caml.ml

@@ -0,0 +1,98 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+(** Sequential caml code. *)
+
+open Misc
+open Names
+open Idents
+open Location
+
+type caml_code =
+    { c_types: (string, type_definition) Hashtbl.t;
+      c_defs: (string * cexp) list;
+    }
+
+and immediate =
+    Cbool of bool
+  | Cint of int
+  | Cfloat of float
+  | Cchar of char
+  | Cstring of string
+  | Cvoid
+
+and cexp =
+    Cconstant of immediate
+  | Cglobal of qualified_ident
+  | Cvar of string
+  | Cconstruct of qualified_ident * cexp list
+  | Capply of cexp * cexp list
+  | Cfun of pattern list * cexp
+  | Cletin of is_rec * (pattern * cexp) list * cexp
+  | Cifthenelse of cexp * cexp * cexp
+  | Cifthen of cexp * cexp
+  | Cmatch of cexp * (pattern * cexp) list
+  | Ctuple of cexp list
+  | Crecord of (qualified_ident * cexp) list
+  | Crecord_access of cexp * qualified_ident
+  | Cseq of cexp list
+  | Cderef of cexp
+  | Cref of cexp
+  | Cset of string * cexp
+  | Clabelset of string * string * cexp
+  | Cmagic of cexp
+
+and is_rec = bool
+
+and pattern =
+    Cconstantpat of immediate
+  | Cvarpat of string
+  | Cconstructpat of qualified_ident * pattern list
+  | Ctuplepat of pattern list
+  | Crecordpat of (qualified_ident * pattern) list
+  | Corpat of pattern * pattern
+  | Caliaspat of pattern * string
+  | Cwildpat
+
+let cvoidpat = Cconstantpat(Cvoid)
+let cvoid = Cconstant(Cvoid)
+let crefvoid = Cref(cvoid)
+let cfalse = Cconstant(Cbool(false))
+let ctrue = Cconstant(Cbool(true))
+let creftrue = Cref(ctrue)
+let cdummy = Cmagic (Cconstant (Cvoid))
+let cand_op = {qual = pervasives_module;id = "&&"}
+let cor_op = {qual = pervasives_module;id = "or"}
+let cnot_op = {qual = pervasives_module;id = "not"}
+let cand c1 c2 = Capply (Cglobal (cand_op), [c1;c2])
+let cor c1 c2 = Capply (Cglobal (cor_op), [c1;c2])
+let cnot c = Capply(Cglobal (cnot_op),[c])
+let cvoidfun e = Cfun([cvoidpat], e)
+let cvoidapply e = Capply(e, [cvoid])
+let cfun params e =
+  match params, e with
+  | params, Cfun(others, e) -> Cfun(params @ others, e)
+  | [], _ -> cvoidfun e
+  | _ ->  Cfun(params, e)
+let capply e l = match l with [] -> cvoidapply e | _ -> Capply(e, l)
+let cifthen c e = match c with Cconstant(Cbool(true)) -> e | _ -> Cifthen(c, e)
+let cifthenelse c e1 e2 =
+  match c with
+  | Cconstant(Cbool(true)) -> e1
+  | Cconstant(Cbool(false)) -> e2
+  | _ -> Cifthenelse(c, e1, e2)
+let cseq e1 e2 =
+  match e1, e2 with
+  | Cconstant(Cvoid), _ -> e2
+  | _, Cconstant(Cvoid) -> e1
+  | e1, Cseq l2 -> Cseq(e1 :: l2)
+  | Cseq(l1), e2 -> Cseq (l1 @ [e2])
+  | _ -> Cseq[e1;e2]
+

compiler/obc/ml/caml_aux.ml

@@ -0,0 +1,131 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Lucid Synchrone                                                       *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* $Id: caml_aux.ml,v 1.1.1.1 2005-11-03 15:45:23 pouzet Exp $ *)
+
+(* file caml-aux.ml *)
+(* auxiliary functions for caml expressions *)
+(* free variables *)
+
+open Misc;;
+open Caml;;
+open Declarative;;
+
+(* convertions from declarative structures to caml ones *)
+(* immediates *)
+let caml_of_declarative_immediate = function
+  | Dbool b -> if b then Ftrue else Ffalse
+  | Dint i -> Fint i
+  | Dfloat f -> Ffloat f
+  | Dchar c -> Fchar c
+  | Dstring s -> Fstring s
+
+(* globals *)
+let string_of_global g =
+  let pref = g.dqualid.dqual in
+  (if (pref <> "") && (pref <> "Lucy_pervasives") then
+    g.dqualid.dqual^"."
+  else "") ^ g.dqualid.did
+
+(* pat_desc *)
+let rec caml_pattern_of_pat_desc = function
+  | Dvarpat i -> Fvarpat ("x__"^(string_of_int i))
+  | Dconstantpat i -> Fimpat (caml_of_declarative_immediate i)
+  | Dtuplepat pl -> Ftuplepat (List.map caml_of_declarative_pattern pl)
+  | Dconstruct0pat g -> Fconstruct0pat (string_of_global g)
+  | Dconstruct1pat (g,p) -> Fconstruct1pat (string_of_global g,
+              caml_of_declarative_pattern p)
+  | Drecordpat gpl -> Frecordpat (List.map
+            (fun (x,y) ->
+              (string_of_global x,
+               caml_of_declarative_pattern y))
+            gpl)
+(* patterns *)
+and caml_of_declarative_pattern p = caml_pattern_of_pat_desc p.dp_desc
+(* ---- end of convertions *)
+
+let rec flat_exp_of_pattern = function
+  | Fpunit -> Fim Funit
+  | Fimpat i -> Fim i
+  | Fvarpat v -> Fvar { cvar_name=v; cvar_imported=false }
+  | Fconstruct0pat c -> Fconstruct0 c
+  | Fconstruct1pat (c,p) -> Fconstruct1 (c, flat_exp_of_pattern p)
+  | Ftuplepat pl -> Ftuple (List.map flat_exp_of_pattern pl)
+  | Frecordpat cpl ->
+      Frecord (List.map (fun (x,y) -> (x,flat_exp_of_pattern y)) cpl)
+
+(* small functions manipulating lists *)
+let union x1 x2 =
+  let rec rec_union l = function
+      [] -> l
+    | h::t -> if List.mem h l then (rec_union l t) else (rec_union (h::l) t)
+  in
+  rec_union x1 x2
+
+let subtract x1 x2 =
+  let rec sub l = function
+      [] -> l
+    | h::t -> if List.mem h x2 then (sub l t) else (sub (h::l) t)
+  in
+  sub [] x1
+
+let flat l =
+  let rec f ac = function
+      [] -> ac
+    | t::q -> f (ac@t) q
+  in
+  f [] l
+
+let intersect x1 x2 =
+  let rec inter l = function
+      [] -> l
+    | h::t -> if List.mem h x1 then (inter (h::l) t) else (inter l t)
+  in
+  inter [] x2
+
+(* make a variable *)
+let make_var n = Fvar {cvar_name = n;cvar_imported = false}
+and make_imported_var n b = Fvar {cvar_name = n;cvar_imported = b}
+
+let nil_ident = "Lucy__nil"
+let state_ident = "Lucy__state"
+
+(* makes a conditional *)
+let ifthenelse(c,e1,e2) =
+  match c with
+    Fim(Ftrue) -> e1
+  | Fim(Ffalse) -> e2
+  | _ -> Fifthenelse(c,e1,e2)
+
+(* makes a list of conditionnals *)
+let ifseq l =
+  let rec ifs l =
+      let (c,e)::t = l in
+      if t = [] then
+  e
+      else
+  ifthenelse (c, e, ifs t)
+  in
+  ifs l
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

compiler/obc/ml/caml_printer.ml

@@ -0,0 +1,404 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Lucid Synchrone                                                       *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* $Id: caml_printer.ml,v 1.20 2008-06-17 13:21:12 pouzet Exp $ *)
+
+(** Printing [Caml] code *)
+
+open Misc
+open Names
+open Format
+open Declarative
+open Declarative_printer
+open Caml
+
+(** Generic printing of a list.
+    This function seems to appear in several places... *)
+let print_list print print_sep l =
+  let rec printrec l =
+    match l with
+      [] -> ()
+    | [x] ->
+  print x
+    | x::l ->
+  open_box 0;
+  print x;
+  print_sep ();
+  print_space ();
+  printrec l;
+  close_box () in
+  printrec l
+
+(** Prints an immediate. A patch is needed on float number for
+    [ocaml] < 3.05. *)
+let print_immediate i =
+  match i with
+    Cbool(b) -> print_string (if b then "true" else "false")
+  | Cint(i) -> print_int i
+  | Cfloat(f) ->  print_float f
+  | Cchar(c) -> print_char '\''; print_char c; print_char '\''
+  | Cstring(s) -> print_string "\"";
+                  print_string (String.escaped s);
+      print_string "\""
+  | Cvoid -> print_string "()"
+
+(** Prints a name. Infix chars are surrounded by parenthesis *)
+let is_infix =
+  let module StrSet = Set.Make(String) in
+  let set_infix =
+    List.fold_right
+      StrSet.add
+      ["or"; "quo"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]
+      StrSet.empty in
+  fun s -> StrSet.mem s set_infix
+
+let print_name s =
+  let c = String.get s 0 in
+  let s = if is_infix s then "(" ^ s ^ ")"
+          else match c with
+    | 'a' .. 'z' | 'A' .. 'Z' | '_' | '`' -> s
+          | '*' -> "( " ^ s ^ " )"
+          | _ -> if s = "()" then s else "(" ^ s ^ ")" in
+  print_string s
+
+(** Prints a global name *)
+let print_qualified_ident {qual=q;id=n} =
+  (* special case for values imported from the standard library *)
+  if (q = pervasives_module) or (q = Modules.compiled_module_name ())
+     or (q = "")
+  then print_name n
+  else
+    begin
+      print_string q;
+      print_string ".";
+      print_name n
+    end
+
+let priority exp =
+  match exp with
+    Crecord _ | Crecord_access _ | Cvar _ | Ctuple _
+  | Cglobal _ | Cconstant _ | Cconstruct(_, []) | Cderef _ -> 3
+  | Clet _ | Cfun _ | Cseq _ -> 1
+  | Cset _ | Clabelset _
+  | Cref _ | Capply _ | Cmagic _ | Cconstruct _ -> 2
+  | Cifthen _ | Cifthenelse _ | Cmatch _ -> 0
+
+let priority_pattern p =
+  match p with
+    Cconstructpat _ | Cconstantpat _ | Cvarpat _
+  | Ctuplepat _ | Crecordpat _ -> 2
+  | _ -> 1
+
+(** Emission of code *)
+let rec print pri e =
+  open_box 2;
+  (* if the priority of the context is higher than the *)
+  (* priority of e, we ass a parenthesis *)
+  let pri_e = priority e in
+  if pri > pri_e then print_string "(";
+  begin match e with
+    Cconstant(e) -> print_immediate e
+  | Cglobal(gl) -> print_qualified_ident gl
+  | Cvar(s) -> print_name s
+  | Cconstruct(gl, e_list) ->
+      print_qualified_ident gl;
+      if e_list <> [] then print_tuple e_list
+  | Capply(f,l) ->
+      print pri_e f;
+      print_space ();
+      print_list (print (pri_e + 1)) (fun () -> ()) l
+  | Cfun(pat_list,e) ->
+      print_string "fun";
+      print_space ();
+      print_list (print_pattern 0) (fun () -> ()) pat_list;
+      print_space ();
+      print_string "->";
+      print_space ();
+      print 0 e
+  (* local definition *)
+  | Clet(is_rec, l, e) -> print_let is_rec l e
+  | Cifthenelse(e1,e2,e3) ->
+      print_string "if";
+      print_space ();
+      print (pri_e - 1) e1;
+      print_space ();
+      print_string "then";
+      print_space ();
+      print 2 e2;
+      print_space ();
+      print_string "else";
+      print_space ();
+      print 2 e3
+  | Cifthen(e1,e2) ->
+      print_string "if";
+      print_space ();
+      print (pri_e - 1) e1;
+      print_space ();
+      print_string "then";
+      print_space ();
+      print 2 e2
+  | Ctuple(l) -> print_tuple l
+  | Crecord(l) ->
+      print_string "{";
+      print_list
+  (fun (gl, e) -> print_qualified_ident gl;
+          print_string " = ";
+    print 1 e)
+        (fun () -> print_string ";") l;
+      print_string "}"
+  | Crecord_access(e, gl) ->
+      print pri_e e;
+      print_string ".";
+      print_qualified_ident gl
+  | Cmatch(e,l) ->
+      print_string "match ";
+      print 0 e;
+      print_string " with";
+      print_space ();
+      List.iter
+  (fun pat_expr ->
+    print_string "| ";
+    print_match_pat_expr 2 pat_expr) l
+  | Cseq l -> print_list (print 2) (fun () -> print_string ";") l
+  | Cderef(e) ->
+      print_string "!";
+      print pri_e e
+  | Cref(e) ->
+      print_string "ref";
+      print_space ();
+      print (pri_e + 1) e
+  | Cset(s, e) ->
+      print_string s;
+      print_string " :=";
+      print_space ();
+      print pri_e e
+  | Clabelset(s, l, e) ->
+      print_string s;
+      print_string ".";
+      print_string l;
+      print_space ();
+      print_string "<-";
+      print_space ();
+      print pri_e e
+  | Cmagic(e) ->
+      print_string "Obj.magic";
+      print_space ();
+      print (pri_e+1) e
+  end;
+  if pri > pri_e then print_string ")";
+  close_box()
+
+and print_tuple e_list =
+  print_string "(";
+  print_list (print 2) (fun () -> print_string ",") e_list;
+  print_string ")"
+
+and print_let_pat_expr (pat, expr) =
+  match pat, expr with
+      pat, Cfun(pat_list, expr) ->
+  open_box 2;
+  print_list (print_pattern 0) (fun () -> ()) (pat :: pat_list);
+  print_string " =";
+  print_space ();
+  print 0 expr;
+  close_box ()
+    | _ ->
+  print_pattern 0 pat;
+  print_string " = ";
+  print 0 expr
+
+and print_let is_rec l e =
+  open_box 0;
+  if is_rec then print_string "let rec " else print_string "let ";
+  print_list print_let_pat_expr
+    (fun () -> print_string "\n"; print_string "and ") l;
+  print_string " in";
+  print_break 1 0;
+  print 0 e;
+  close_box ()
+
+and print_pattern pri pat =
+  open_box 2;
+  let pri_e = priority_pattern pat in
+  if pri > pri_e then print_string "(";
+  begin match pat with
+    Cconstantpat(i) -> print_immediate i
+  | Cvarpat(v) -> print_string v
+  | Cconstructpat(gl, pat_list) ->
+      print_qualified_ident gl;
+      if pat_list <> [] then print_tuple_pat pat_list
+  | Ctuplepat(pat_list) ->
+      print_tuple_pat pat_list
+  | Crecordpat(l) ->
+      print_string "{";
+      print_list (fun (gl, pat) -> print_qualified_ident gl;
+                                 print_string "=";
+                           print_pattern (pri_e - 1) pat)
+                 (fun () -> print_string ";") l;
+      print_string "}"
+  | Corpat(pat1, pat2) ->
+      print_pattern pri_e pat1;
+      print_string "|";
+      print_pattern pri_e pat2
+  | Caliaspat(pat, s) ->
+      print_pattern pri_e pat;
+      print_space ();
+      print_string "as";
+      print_space ();
+      print_string s
+  | Cwildpat -> print_string "_"
+  end;
+  if pri > pri_e then print_string ")";
+  close_box ()
+
+and print_tuple_pat pat_list =
+  print_string "(";
+  print_list (print_pattern 0) (fun () -> print_string ",") pat_list;
+  print_string ")"
+
+and print_match_pat_expr prio (pat, expr) =
+  open_box 2;
+  print_pattern 0 pat;
+  print_space (); print_string "->"; print_space ();
+  print prio expr;
+  close_box ();
+  print_space ();;
+
+(* print a definition *)
+let print_definition (name, e) =
+  print_string "let ";
+  print_let_pat_expr (Cvarpat(name), e)
+
+(* print code *)
+let print_code e = print 0 e
+
+(* print types *)
+let rec print_type typ =
+  open_box 1;
+  begin match typ with
+    Darrow(is_node, typ1, typ2) ->
+      print_type typ1;
+      if is_node then print_string " => " else print_string " -> ";
+      print_type typ2
+  | Dproduct(ty_list) ->
+      print_list print_type (fun _ -> print_string " *") ty_list
+  | Dconstr(qual_ident, ty_list) ->
+      if ty_list <> [] then
+  begin
+    print_string "(";
+    print_list print_type (fun _ -> print_string ",") ty_list;
+    print_string ")";
+    print_space ()
+  end;
+      print_qualified_ident qual_ident
+  | Dtypvar(i) -> print_type_name i
+  | Dbase(b) -> print_base_type b
+  | Dsignal(ty) -> print_type ty; print_space (); print_string "sig"
+  end;
+  close_box ()
+
+and print_type_name n =
+  print_string "'a";
+  print_int n
+
+and print_base_type b =
+  match b with
+    Dtyp_bool -> print_string "bool"
+  | Dtyp_int -> print_string "int"
+  | Dtyp_float -> print_string "float"
+  | Dtyp_unit -> print_string "unit"
+  | Dtyp_string -> print_string "string"
+  | Dtyp_char -> print_string "char"
+
+(* print variant *)
+let print_variant (qualid, { arg = typ_list; res = typ }) =
+  print_string " | ";
+  print_qualified_ident qualid;
+  match typ_list with
+    [] -> (* arity = 0 *)
+          ()
+  | _ -> print_string " of ";
+         print_list print_type (fun () -> print_string "*") typ_list
+
+let print_record (qualid, is_mutable, { res = typ1 }) =
+  if is_mutable then print_string "mutable ";
+  print_qualified_ident qualid;
+  print_string ":";
+  print_type typ1;
+  print_string ";"
+
+let print_type_declaration s { d_type_desc = td; d_type_arity = l } =
+  open_box 2;
+  if l <> [] then
+    begin
+      print_string "(";
+      print_list print_type_name (fun _ -> print_string ",") l;
+      print_string ")";
+      print_space ()
+    end;
+  print_string s;
+  print_string " = ";
+  begin match td with
+    Dabstract_type -> ()
+  | Dabbrev(ty) ->
+      print_type ty
+  | Dvariant_type variant_list ->
+      List.iter print_variant variant_list
+  | Drecord_type record_list ->
+      print_string "{";
+      print_list print_record (fun _ -> ()) record_list;
+      print_string "}"
+  end;
+  print_newline ();
+  close_box ()
+
+let print_type_declarations l =
+  let rec printrec l =
+    match l with
+      [] -> ()
+    | [s, d] -> print_type_declaration s d
+    | (s, d) :: l ->
+  print_type_declaration s d;
+  print_string "and ";
+  printrec l in
+  open_box 0;
+  print_string "type ";
+  printrec l;
+  print_newline ();
+  close_box ();;
+
+(* the main function *)
+set_max_boxes max_int ;;
+
+let output_expr oc e =
+  (* emit on channel oc *)
+  set_formatter_out_channel oc;
+  print 0 e;
+  print_flush ()
+
+let output_code oc c =
+  (* emit on channel oc *)
+  set_formatter_out_channel oc;
+  print_code c
+
+let output_definitions oc d_list =
+  (* emit on channel oc *)
+  set_formatter_out_channel oc;
+  print_list print_definition print_newline d_list;
+  print_flush ()
+
+let output oc caml_code =
+  set_formatter_out_channel oc;
+  (* print type declarations *)
+  let l = Misc.listoftable caml_code.c_types in
+  if l <> [] then print_type_declarations l;
+  (* print value definitions *)
+  print_list print_definition print_newline caml_code.c_code;
+  print_flush ()
+

compiler/obc/ml/cenvironment.ml

@@ -0,0 +1,46 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Lucid Synchrone                                                       *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* $Id: cenvironment.ml,v 1.1 2006-03-18 08:04:25 pouzet Exp $ *)
+
+open Misc
+open Declarative
+
+(** Environment with static link **)
+type cblock =
+    { c_block: block;  (* table of free names *)
+      c_state: name;   (* the name of the internal state *)
+      c_write: name;   (* temporary values *)
+    }
+type env = cblock list
+let empty_env = []
+let current env = List.hd env
+let cblock env = (current env).c_block
+let statename env = (current env).c_state
+
+let push_block block env =
+  { c_block = block;
+    c_state = symbol#name;
+    c_write = symbol#name } :: env
+let push block env =
+  if env = empty_env
+  then push_block block env
+  else let cblock = current env in
+  { cblock with c_block = block } :: env
+let rec findall env i =
+  match env with
+    [] -> raise Not_found
+  | { c_block = b; c_state = st; c_write = wt } :: env ->
+      try
+  Hashtbl.find b.b_env i, st, wt
+      with
+  Not_found -> findall env i
+let find env i =
+  let id, _, _ = findall env i in
+  id

compiler/obc/ml/coiteration.ml

@@ -0,0 +1,848 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Lucid Synchrone                                                       *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* $Id: coiteration.ml,v 1.27 2008-06-10 06:54:36 delaval Exp $ *)
+
+
+(** Translating [declarative] code into sequential [caml] code. *)
+
+open Misc
+open Names
+open Declarative
+open Rw
+open Dmisc
+open Caml
+open Cenvironment
+
+let prefix_for_names = "_"
+let prefix_for_inits = "_init"
+let prefix_for_memos = "_pre"
+let prefix_for_statics = "_static"
+let prefix_for_clocks = "_cl"
+let prefix_for_lasts = "__last"
+
+let prefix_state_type = "_state_"
+let prefix_state_constr = "`St_"
+let prefix_state_label = "_mem_"
+let prefix_state_constr_nil = "`Snil_"
+let prefix_for_self_state = "_self_"
+let prefix_for_temp = "_temp_"
+
+(** the type of unknown states *)
+(* type 'a state = Snil | St of 'a *)
+let state_nil = Cconstruct(qualid prefix_state_constr_nil, [])
+let state_nil_pat = Cconstructpat(qualid prefix_state_constr_nil, [])
+let state_pat pat_list = Cconstructpat(qualid prefix_state_constr, pat_list)
+let state e_list = Cconstruct(qualid prefix_state_constr, e_list)
+let state_record name_e_list =
+  Crecord(List.map (fun (name, e) -> (qualid name), e) name_e_list)
+
+let intro_state_type () =
+  let tname = prefix_state_type in
+  let result_type =
+    Dconstr(qualid prefix_state_type, [Dtypvar(0)]) in
+  let variants =
+    [(qualid prefix_state_constr_nil, { arg = []; res = result_type });
+     (qualid prefix_state_constr, {arg = [Dtypvar(0)]; res = result_type})]
+  in
+  let type_def =
+    { d_type_desc = Dvariant_type(variants);
+      d_type_arity = [0] } in
+  add_type (tname, type_def)
+
+(** introduce a new type for enumerated states *)
+(* type ('a1,...,'an) state_k = St1 of 'a1 | ... Stm of 'an *)
+let intro_enum_type n =
+  let l = Misc.from n in
+  (* name of the result type *)
+  let tname = prefix_state_type ^ (string_of_int(symbol#name)) in
+  let result_type =
+    Dconstr(qualid tname, List.map (fun name -> Dtypvar(name)) l) in
+  let variants =
+    List.map
+      (fun name ->
+  (qualid (tname ^ prefix_state_constr ^ (string_of_int name)),
+   { arg = [Dtypvar(name)]; res = result_type })) l in
+  let type_def =
+    { d_type_desc = Dvariant_type(variants);
+      d_type_arity = l } in
+  add_type (tname, type_def);
+  tname ^ prefix_state_constr
+
+(** introduce a new type for record states *)
+(* type ('a1,...,'an) state_k = {mutable name1:a1;...;mutable namen:an} *)
+let intro_record_type name_value_list =
+  let l = Misc.from (List.length name_value_list) in
+  let tname = prefix_state_type ^ (string_of_int(symbol#name)) in
+  let result_type =
+    Dconstr(qualid tname, List.map (fun name -> Dtypvar(name)) l) in
+  let labels =
+    List.map2
+      (fun (name,_) ai ->
+  (qualid name,
+   true,
+   { res = Dtypvar(ai); arg = result_type })) name_value_list l in
+  let type_def =
+    { d_type_desc = Drecord_type(labels);
+      d_type_arity = l } in
+  add_type (tname, type_def)
+
+(** the intermediate code generated during the compilation process *)
+type tcode =
+    Tlet of pattern * cexp
+  | Tset of string * cexp
+  | Tlabelset of string * string * cexp
+  | Tletrec of (pattern * cexp) list
+  | Texp of cexp
+
+(* and its translation into caml code *)
+let rec clet tcode ce =
+  let code2c tcode ce =
+    match tcode with
+      Tlet(p, c) -> Clet(false, [p,c], ce)
+    | Tset(s, e) -> cseq (Cset(s,e)) ce
+    | Tlabelset(s, n, e) -> cseq (Clabelset(s, n, e)) ce
+    | Tletrec(l) -> Clet(true, l, ce)
+    | Texp(c) when ce = cvoid -> c
+    | Texp(c) -> cseq c ce in
+  match tcode with
+    [] -> ce
+  | tc :: tcode -> code2c tc (clet tcode ce)
+
+let cseq tcode = clet tcode cvoid
+let ifthen c ce =
+  match c with
+    Cconstant(Cbool(true)) -> ce
+  | _ -> Cifthen(c, ce)
+
+let merge code ce l =
+  (* we make special treatments for conditionals *)
+  match l with
+    [] -> code
+  | [Cconstantpat(Cbool(b1)), c1;
+     Cconstantpat(Cbool(b2)), c2] ->
+       if b1 then
+   Texp(Cifthenelse(ce, c1, c2)) :: code
+       else
+   Texp(Cifthenelse(ce, c2, c1)) :: code
+  (* general case *)
+  | _ -> Texp(Cmatch(ce, l)) :: code
+
+
+(** extract the set of static computations from an expression *)
+let rec static acc e =
+  let acc, desc = match e.d_desc with
+  | Dconstant _ | Dvar _ | Dfun _ -> acc, e.d_desc
+  | Dtuple l ->
+      let acc, l = static_list acc l in
+      acc, Dtuple(l)
+  | Dprim(g, e_list) ->
+      (* pointwise application *)
+      let acc, e_list = static_list acc e_list in
+      acc, Dprim(g, e_list)
+  | Dconstruct(g, e_list) ->
+      let acc, e_list = static_list acc e_list in
+      acc, Dconstruct(g, e_list)
+  | Drecord(gl_expr_list) ->
+      let static_record (gl, expr) (acc, gl_expr_list) =
+  let acc, e = static acc expr in
+  acc, (gl, e) :: gl_expr_list in
+      let acc, l =
+  List.fold_right static_record gl_expr_list (acc, []) in
+      acc, Drecord(l)
+  | Drecord_access(expr, gl) ->
+      let acc, e = static acc expr in
+      acc, Drecord_access(e, gl)
+  | Difthenelse(e0, e1, e2) ->
+      let acc, e0 = static acc e0 in
+      let acc, e1 = static acc e1 in
+      let acc, e2 = static acc e2 in
+      acc, Difthenelse(e0, e1, e2)
+  | Dlet(block, e_let) ->
+      let acc, block = static_block acc block in
+      let acc, e = static acc e_let in
+      acc, Dlet(block, e_let)
+  | Dapply(is_state, f, l) ->
+      let acc, f = static acc f in
+      let acc, l = static_list acc l in
+      acc, Dapply(is_state, f, l)
+  | Deseq(e1, e2) ->
+      let acc, e1 = static acc e1 in
+      let acc, e2 = static acc e2 in
+      acc, Deseq(e1, e2)
+  | Dwhen(e1) ->
+      let acc, e1 = static acc e1 in
+      acc, Dwhen(e1)
+  | Dclock(ck) ->
+      acc, Dclock(ck)
+  | Dlast _ | Dinit _ | Dpre _ | Dtest _ ->
+      (* this case should not arrive *)
+      fatal_error "static" in
+  acc, { e with d_desc = desc }
+
+and static_list acc l =
+  match l with
+    [] -> acc, []
+  | e :: l ->
+      let acc, e = static acc e in
+      let acc, l = static_list acc l in
+      acc, e :: l
+
+and static_block acc b =
+  let acc, eq = static_eq acc b.b_equations in
+  acc, { b with b_equations = eq }
+
+(* extract the set of static computations from an equation *)
+and static_eqs acc eq_list =
+  match eq_list with
+    [] -> acc, []
+  | eq :: eq_list ->
+      let acc, eq = static_eq acc eq in
+      let acc, eq_list = static_eqs acc eq_list in
+      acc, dcons eq eq_list
+
+and static_eq acc eq =
+  match eq with
+    Dget _ -> acc, eq
+  | Dequation(pat, e) ->
+      let acc, e = static acc e in
+      acc, Dequation(pat, e)
+  | Dwheneq(eq, ck) ->
+      let acc, eq = static_eq acc eq in
+      acc, Dwheneq(eq, ck)
+  | Dmerge(is_static, e, p_block_list) ->
+      let acc, e = static acc e in
+      let acc, p_block_list = static_pat_block_list acc p_block_list in
+      acc, Dmerge(is_static, e, p_block_list)
+  | Dnext(n, e) ->
+      let acc, e = static acc e in
+      acc, Dnext(n, e)
+  | Dseq(eq_list) ->
+      let acc, eq_list = static_eqs acc eq_list in
+      acc, Dseq(eq_list)
+  | Dpar(eq_list) ->
+      let acc, eq_list = static_eqs acc eq_list in
+      acc, Dpar(eq_list)
+  | Dblock(block) ->
+      let acc, block = static_block acc block in
+      acc, Dblock(block)
+  | Dstatic(pat, e) ->
+      (pat, e) :: acc, no_equation
+  | Demit _ | Dlasteq _ | Dautomaton _ | Dreset _ | Dpresent _ ->
+      (* these cases should not arrive since control structures have *)
+      (* been translated into the basic kernel *)
+      fatal_error "static_eq"
+
+and static_pat_block_list acc p_block_list =
+  (* treat one handler *)
+  let static_pat_block acc (pat, block) =
+    let acc, block = static_block acc block in
+    acc, (pat, block) in
+  match p_block_list with
+    [] -> acc, []
+  | pat_block :: pat_block_list ->
+      let acc, pat_block = static_pat_block acc pat_block in
+      let acc, pat_block_list = static_pat_block_list acc pat_block_list in
+      acc, pat_block :: pat_block_list
+
+(** Auxiliary definitions **)
+let string_of_ident ident =
+  let prefix =
+    match ident.id_kind with
+      Kinit -> prefix_for_inits
+    | Kstatic -> prefix_for_statics
+    | Kmemo -> prefix_for_memos
+    | Kclock -> prefix_for_clocks
+    | Klast -> prefix_for_lasts
+    | _ -> prefix_for_names in
+  let suffix =
+    match ident.id_original with
+      None -> ""
+    | Some(n) when (is_an_infix_or_prefix_operator n) -> "__infix"
+    | Some(n) -> "__" ^ n in
+  prefix ^ (string_of_int ident.id_name) ^ suffix
+
+let string_of_name env i =
+  (* find the original name when it exists *)
+  let ident = find env i in
+  string_of_ident ident
+
+let name i = prefix_for_names ^ (string_of_int i)
+let memo i = prefix_for_memos ^ (string_of_int i)
+let initial i = prefix_for_inits ^ (string_of_int i)
+let clock i = prefix_for_clocks ^ (string_of_int i)
+let stat i = prefix_for_statics ^ (string_of_int i)
+
+(* the name of the current state *)
+let selfstate env = prefix_for_self_state ^ (string_of_int (statename env))
+
+(* access to a write variable *)
+let access_write wt s = Cderef (Cvar s)
+
+(* makes an access to a name *)
+let access env i =
+  let ident, st, wt = findall env i in
+  let s = string_of_ident ident in
+  match ident.id_kind with
+    Kinit | Kmemo | Kstatic ->
+      Crecord_access(Cvar(prefix_for_self_state ^ (string_of_int st)),
+         qualid s)
+  | _ ->
+      if is_a_write ident
+      then access_write wt s
+      else Cvar(s)
+
+let set name c = Tset(name, c)
+let next self name c = Tlabelset(self, name, c)
+
+(** Compilation of functions *)
+(*  x1...xn.<init, code, res> is translated into
+
+   (1) combinatorial function
+
+       \x1...xn.code;res
+
+   (2) \x1...xn.self.
+       let self = match !self with
+                    Nil -> let v = { ... init ... } in
+                           self := St(v);v
+                  | St(self) -> self in
+       code;
+       res
+
+   r = f [...] x1...xn is translated into:
+
+   (1) combinatorial function
+
+   f = f [...] x1...xn
+
+   (2) state function
+
+   st = ref Nil       initialisation part
+
+   r = f x1...xn st   step part
+
+Rmk: we can also write: "if reset then self := { ... }"
+*)
+
+let co_apply env is_state (init_write, init_mem) f subst e_list =
+  if is_state then
+    (* state function *)
+    let st = prefix_for_names ^ (string_of_int symbol#name) in
+    let prefix = selfstate env in
+    (init_write, (st, Cref(state_nil)) :: init_mem),
+    Capply(f,
+     (subst @ e_list @ [Crecord_access(Cvar(prefix), qualid st)]))
+  else
+    (init_write, init_mem), Capply(f, subst @ e_list)
+
+(* prepare the initialization of memory variables *)
+let cmatchstate self states =
+  let v = prefix_for_names ^ (string_of_int (symbol#name)) in
+  let st = prefix_state_constr ^ (string_of_int (symbol#name)) in
+  Cmatch(Cderef(Cvar(self)),
+   [Cconstructpat(qualid st,[Cvarpat(self)]), Cvar(self);
+    Cwildpat, Clet(false, [Cvarpat(v), states],
+            Cseq[Cset(self,
+          Cconstruct(qualid st, [Cvar(v)]));
+           Cvar(v)])])
+
+(* prepare the initialization of write variables *)
+let define_init_writes env init_write code =
+  List.fold_right
+    (fun (name, e) code -> Clet(false, [Cvarpat(name), Cref e], code))
+    init_write code
+
+let co_fun env
+    is_state params p_list static (init_write, init_mem) code result =
+  if init_mem <> [] then intro_record_type init_mem;
+
+  let code = clet code result in
+  let code =
+    if init_write <> []
+    then define_init_writes env init_write code
+    else code in
+  let self = selfstate env in
+  if is_state
+  then
+    if init_mem = [] then Cfun(params @ p_list @ [Cvarpat(self)], code)
+    else Cfun(params @ p_list @ [Cvarpat(self)],
+        Clet(false, [Cvarpat(self),
+         cmatchstate self
+           (clet static (state_record init_mem))],
+       code))
+  else Cfun(params @ p_list, code)
+
+(** Compilation of pattern matching *)
+(*
+  match e with
+    P1 -> e1
+  | ...
+  | Pn -> en
+
+(1) e is a static computation
+
+- initialisation code
+  let memory = match e with
+               P1 -> St1 { ... }
+             | ...
+             | Pn -> Stn { ... }
+
+- step code
+  match memory with
+  St1{...} -> step1
+| ...
+| Stn{...} -> stepn
+
+(2) e may evolve at every instant
+
+- init code
+  ...i1...
+  ...in...
+
+- match e with
+    P1 -> step1
+  | ...
+  | Pn -> stepn
+
+for the moment, we treat case (1) as case (2) *)
+
+(*
+let co_static_merge e (pat, init_code_fvars_list) =
+  (* introduces the type definitions for the representation of states *)
+  let n = List.length init_code_fvars_list in
+  let prefix_constructor = intro_enum_type n in
+
+  (* builds a constructor value *)
+  let constructor prefix number f_vars =
+    Cconstruct(qualid (prefix ^ (string_of_int number)),
+         List.map (fun name -> Cvar(name)) fvars) in
+  let constructor_pat prefix number f_vars =
+    Cconstructpat(qualid (prefix ^ (string_of_int number)),
+      List.map (fun name -> Cvarpat(name)) fvars) in
+
+  (* computes the initialisation part *)
+  let rec states number init_code_fvars_list =
+    match init_code_fvars_list with
+      [] -> []
+    | (pat, init, _, fvars) :: init_code_fvars_list ->
+  let pat_code = (pat, clet init (constructor prefix number fvars)) in
+  let pat_code_list = states (number + 1) init_code_fvars_list in
+  pat_code :: code_list in
+
+  (* computes the transition part *)
+  let rec steps number init_code_fvars_list =
+    match init_code_fvars_list with
+      [] -> []
+    | (_, _, code, fvars) :: init_code_fvars_list ->
+  let pat_code = (constructor_pat prefix number fvars, code) in
+  let pat_code_list = steps (number + 1) init_code_fvars_list in
+  pat_code :: pat_code_list in
+
+  (* make the final code *)
+  let memory = symbol#name in
+  let init_code = Cmatch(e, states 0 init_code_fvars_list) in
+  let step_code = Cmatch(Cvar memory, steps 0 init_code_fvars_list) in
+  Tlet(memory, init_code), step_code
+
+*)
+
+(** Compilation of clocks *)
+let rec translate_clock env init ck =
+  match ck with
+    Dfalse ->  init, cfalse
+  | Dtrue -> init, ctrue
+  | Dclockvar(n) -> init, access env n
+  | Don(is_on, ck, car) ->
+      let init, ck = translate_clock env init ck in
+      let init, car = translate_carrier env init car in
+      init, if is_on then cand car ck
+      else cand (cnot car) ck
+
+and translate_carrier env init car =
+  match car with
+    Dcfalse -> init, cfalse
+  | Dctrue -> init, ctrue
+  | Dcvar(n) -> init, access env n
+  | Dcglobal(g, res, ck) ->
+      (* a global clock allocates memory *)
+      (* and is compiled as a function call *)
+      let res = match res with None -> cfalse | Some(n) -> access env n in
+      let init, c = translate_clock env init ck in
+      let init, new_ce =
+  co_apply env true init (Cglobal g) [c] [res] in
+      init, new_ce
+
+(** Compiling immediate. *)
+let translate_immediate i =
+  match i with
+  | Dbool(b) -> Cbool(b)
+  | Dint(i) -> Cint(i)
+  | Dfloat(f) -> Cfloat(f)
+  | Dchar(c) -> Cchar(c)
+  | Dstring(s) -> Cstring(s)
+  | Dvoid -> Cvoid
+
+(** Compiling variables. *)
+let translate_var env v =
+  match v with
+    Dglobal(g) -> Cglobal(g)
+  | Dlocal(n) -> access env n
+
+(** Compiling a pattern. *)
+let rec translate_pat env pat =
+  match pat with
+  | Dconstantpat(i) -> Cconstantpat(translate_immediate(i))
+  | Dvarpat(s) -> Cvarpat(string_of_name env s)
+  | Dtuplepat(l) -> Ctuplepat(List.map (translate_pat env) l)
+  | Dconstructpat(gl, pat_list) ->
+      Cconstructpat(gl, List.map (translate_pat env) pat_list)
+  | Dorpat(pat1, pat2) -> Corpat(translate_pat env pat1,
+         translate_pat env pat2)
+  | Drecordpat(gl_pat_list) ->
+      Crecordpat
+  (List.map (fun (gl, pat) -> (gl, translate_pat env pat))
+     gl_pat_list)
+  | Daliaspat(pat, i) -> Caliaspat(translate_pat env pat,
+           string_of_name env i)
+  | Dwildpat -> Cwildpat
+
+(*
+(* add accesses to write variables defined in patterns *)
+let rec add_write_access env code pat =
+  match pat with
+    Dconstantpat(i) -> code
+  | Dvarpat(s) when is_a_write (find env s) ->
+      Tset(string_of_name env s, access env s) :: code
+  | Dvarpat _ -> code
+  | Dtuplepat(l) | Dconstructpat(_, l) ->
+      List.fold_left (add_write_access env) code l
+  | Dorpat(pat1, pat2) ->
+      add_write_access env (add_write_access env code pat1) pat2
+  | Drecordpat(gl_pat_list) ->
+      List.fold_left (fun code (_, pat) -> add_write_access env code pat)
+  code gl_pat_list
+  | Daliaspat(pat, i) ->
+      add_write_access env (add_write_access env code pat) (Dvarpat(i))
+  | Dwildpat -> code
+*)
+
+(** Compiling an expression *)
+(* takes an environment giving information about variables *)
+(* and an expression and returns the new code              *)
+let rec translate env init e =
+  match e.d_desc with
+  | Dconstant(i) ->
+      let i = translate_immediate i in
+      init, Cconstant(i)
+  | Dvar(v, subst) ->
+      let v = translate_var env v in
+      let init, s = translate_subst env init subst in
+      let v = match s with [] -> v | l -> Capply(v, l) in
+      init, v
+  | Dtuple l ->
+      let init, lc = translate_list env init l in
+      init, Ctuple(lc)
+  | Dfun(is_state, params, p_list, body, result) ->
+      (* state function *)
+      let env = push_block body env in
+      (* compiles types and clock abstractions *)
+      let params = translate_forall env params in
+      (* compiles parameters *)
+      let p_list = List.map (translate_pat env) p_list in
+      (* remove static computation from the body *)
+      (* and put it in the allocation place for stateful functions *)
+      let (static_code, init_code, body, result) =
+  if is_state
+  then
+    let static_code, body = static_block [] body in
+    let static_code, result = static static_code result in
+    let static_code = List.rev static_code in
+    (* translate the static code *)
+    let static_code, init_code =
+      translate_static_code env static_code in
+    (static_code, init_code, body, result)
+  else
+    ([], ([], []), body, result) in
+      (* then translate the body *)
+      let init_code, body = translate_block env init_code body in
+      let init_code, result = translate env init_code result in
+      init,
+      co_fun env is_state params p_list static_code init_code body result
+  | Dprim(g, e_list) ->
+      (* pointwise application *)
+      let init, ce_list = translate_list env init e_list in
+      init, Capply(Cglobal(g), ce_list)
+  | Dconstruct(g, e_list) ->
+      let init, ce_list = translate_list env init e_list in
+      init, Cconstruct(g, ce_list)
+  | Drecord(gl_expr_list) ->
+      let translate_record (gl, expr) (init, gl_expr_list) =
+  let init, ce = translate env init expr in
+  init, (gl, ce) :: gl_expr_list in
+      let init, l =
+  List.fold_right translate_record gl_expr_list (init, []) in
+      init, Crecord(l)
+  | Drecord_access(expr, gl) ->
+      let init, ce = translate env init expr in
+      init, Crecord_access(ce, gl)
+  | Difthenelse(e0, e1, e2) ->
+      let init, c0 = translate env init e0 in
+      let init, c1 = translate env init e1 in
+      let init, c2 = translate env init e2 in
+      init, Cifthenelse(c0, c1, c2)
+  | Dlet(block, e_let) ->
+      let env = push block env in
+      let init, code = translate_block env init block in
+      let init, ce = translate env init e_let in
+      init, clet code ce
+  | Dapply(is_state, { d_desc = Dvar(f, subst) }, l) ->
+      let f = translate_var env f in
+      let init, l = translate_list env init l in
+      let init, subst = translate_subst env init subst in
+      co_apply env is_state init f subst l
+  | Dapply(is_state, f, l) ->
+      let init, f = translate env init f in
+      let init, l = translate_list env init l in
+      co_apply env is_state init f [] l
+  | Deseq(e1, e2) ->
+      let init, e1 = translate env init e1 in
+      let init, e2 = translate env init e2 in
+      init, Cseq [e1; e2]
+  | Dwhen(e1) ->
+      translate env init e1
+  | Dclock(ck) ->
+      translate_clock env init ck
+  | Dlast _ | Dinit _ | Dpre _ | Dtest _ ->
+      (* this case should not arrive *)
+      fatal_error "translate"
+
+and translate_list env init l =
+  match l with
+    [] -> init, []
+  | ce :: l ->
+      let init, ce = translate env init ce in
+      let init, l = translate_list env init l in
+      init, ce :: l
+
+and translate_block env init b =
+  (* allocate the memory in the initialisation part *)
+  let init = allocate_memory env init in
+  (* compiles the body *)
+  let init, code = translate_equation env init [] b.b_equations in
+  (* sets code in the correct order *)
+  let code = List.rev code in
+  (* returns the components of the block *)
+  init, code
+
+(* the input equations must be already scheduled *)
+and translate_equations env init code eq_list =
+  match eq_list with
+    [] -> init, code
+  | eq :: eq_list ->
+      let init, code = translate_equation env init code eq in
+      translate_equations env init code eq_list
+
+and translate_equation_into_exp env init eq =
+  let init, code = translate_equation env init [] eq in
+  (* sets code in the correct order *)
+  let code = List.rev code in
+  init, cseq code
+
+and translate_block_into_exp env init block =
+  let init, code = translate_block env init block in
+  init, cseq code
+
+and translate_equation env init code eq =
+  match eq with
+    Dget(pat, v) ->
+      let cpat = translate_pat env pat in
+      let n = translate_var env v in
+      init, Tlet(cpat, n) :: code
+  | Dequation(Dvarpat(n), e) when is_a_write (find env n) ->
+      let name = string_of_name env n in
+      let init, ce = translate env init e in
+      init, (set name ce) :: code
+  | Dequation(pat, e) | Dstatic(pat, e) ->
+      let is_rec = is_recursive pat e in
+      let pat = translate_pat env pat in
+      let init, ce = translate env init e in
+      init, if is_rec then Tletrec([pat, ce]) :: code
+            else Tlet(pat, ce) :: code
+  | Dwheneq(eq, ck) ->
+      let init, ce = translate_equation_into_exp env init eq in
+      let init, ck_ce = translate_clock env init ck in
+      init, Texp(ifthen ck_ce ce) :: code
+  | Dmerge(is_static, e, p_block_list) ->
+      let init, ce = translate env init e in
+      let init, l = translate_pat_block_list env init p_block_list in
+      init, merge code ce l
+  | Dnext(n, e) ->
+      (* n is either a memo or an initialisation variable *)
+      let init, ce = translate env init e in
+      init, (next (selfstate env) (string_of_name env n) ce) :: code
+  | Dseq(eq_list) | Dpar(eq_list) ->
+      translate_equations env init code eq_list
+  | Dblock(block) ->
+      translate_block env init block
+  | Demit _ | Dlasteq _ | Dautomaton _ | Dreset _ | Dpresent _ ->
+      (* these cases should not arrive since control structures have *)
+      (* been translated into the basic kernel *)
+      fatal_error "translate_equation"
+
+(* compilation of pattern matching *)
+and translate_pat_block_list env init p_block_list =
+  (* compile one handler *)
+  let translate_pat_block init (pat, block) =
+    let env = push block env in
+    let cpat = translate_pat env pat in
+    let init, ce = translate_block_into_exp env init block in
+    init, (cpat, ce) in
+  match p_block_list with
+    [] -> init, []
+  | pat_block :: pat_block_list ->
+      let init, pat_ce = translate_pat_block init pat_block in
+      let init, pat_ce_list =
+  translate_pat_block_list env init pat_block_list in
+      init, pat_ce :: pat_ce_list
+
+(* translate a pure (stateless) expression *)
+and translate_pure env e =
+  let init, ce = translate env ([], []) e in
+  assert (init = ([], []));
+  ce
+
+(* computes extra parameters for clock abstraction *)
+and translate_forall env params =
+  let p_clocks =
+    List.map (fun n -> Cvarpat(string_of_name env n)) params.s_clock in
+  let p_carriers =
+    List.map (fun n -> Cvarpat(string_of_name env n)) params.s_carrier in
+  p_clocks @ p_carriers
+
+(* generates an application for clock instanciation *)
+and translate_subst env init subst =
+  let rec translate_clock_list init cl_list =
+    match cl_list with
+      [] -> init, []
+    | cl :: cl_list ->
+  let init, cl = translate_clock env init cl in
+  let init, cl_list = translate_clock_list init cl_list in
+  init, cl :: cl_list in
+  let rec translate_carrier_list init car_list =
+    match car_list with
+      [] -> init, []
+    | car :: car_list ->
+  let init, car = translate_carrier env init car in
+  let init, car_list = translate_carrier_list init car_list in
+  init, car :: car_list in
+  let init, cl_list = translate_clock_list init subst.s_clock in
+  let init, car_list = translate_carrier_list init subst.s_carrier in
+  init, cl_list @ car_list
+
+(* Initialisation code *)
+and allocate_memory env init =
+  let allocate _ ident (acc_write, acc_mem) =
+    match ident.id_kind with
+      Kmemo ->
+  (* we allocate only one cell *)
+  let default = default_value env ident in
+  acc_write, (memo ident.id_name, default) :: acc_mem
+    | Kinit ->
+  (* init variables are considered to be state variables *)
+  acc_write, (initial ident.id_name, Cconstant(Cbool(true))) :: acc_mem
+    | _ when is_a_write ident ->
+  (* local write variables are allocated too *)
+  (* but they will be stored in a stack allocated structure *)
+  let name = string_of_name env ident.id_name in
+  let default = default_value env ident in
+  (name, default) :: acc_write, acc_mem
+    | _ -> acc_write, acc_mem in
+  Hashtbl.fold allocate (cblock env).b_env init
+
+(* add static code into the initialisation part *)
+and translate_static_code env static_code =
+  (* add one equation *)
+  (* we compute the list of introduced names and compile the equation *)
+  let translate_eq acc (pat, e) =
+    let acc = fv_pat acc pat in
+    let pat = translate_pat env pat in
+    let ce = translate_pure env e in
+    acc, Tlet(pat, ce) in
+  let rec translate_static_code acc static_code =
+    match static_code with
+      [] -> acc, []
+    | pat_e :: static_code ->
+        let acc, cpat_ce = translate_eq acc pat_e in
+        let acc, static_code = translate_static_code acc static_code in
+        acc, cpat_ce :: static_code in
+  (* introduced names must be added to the memory *)
+  let intro acc_mem n =
+    let v = string_of_name env n in
+    (* modify the kind of [n] *)
+    set_static (find env n);
+    (string_of_name env n, Cvar(v)) :: acc_mem in
+
+  (* first compile the static code *)
+  let acc, static_code = translate_static_code [] static_code in
+  (* introduced names must be added to the memory initialisation *)
+  let acc_mem = List.fold_left intro [] acc in
+  static_code, ([], acc_mem)
+
+(* default value *)
+and default_value env ident =
+  (* find a value from a type *)
+  let rec value ty =
+    match ty with
+      Dproduct(ty_l) -> Ctuple(List.map value ty_l)
+    | Dbase(b) ->
+  let v = match b with
+    Dtyp_bool -> Cbool(false)
+  | Dtyp_int -> Cint(0)
+  | Dtyp_float -> Cfloat(0.0)
+  | Dtyp_unit -> Cvoid
+  | Dtyp_char -> Cchar(' ')
+  | Dtyp_string -> Cstring("") in
+  Cconstant(v)
+    | Dsignal(ty) -> Ctuple[value ty; cfalse]
+    | Dtypvar _ | Darrow _ -> cdummy
+    | Dconstr(qualid, _) ->
+  try
+    let desc = find_type qualid in
+    match desc.d_type_desc with
+        Dabstract_type -> cdummy
+      | Dabbrev(ty) ->
+    value ty
+      | Dvariant_type l ->
+        let case = List.hd l in
+        begin match case with
+    (qual, { arg = ty_l }) ->
+      Cconstruct(qual, List.map value ty_l)
+        end
+    | Drecord_type l ->
+        let field_of_type (qual, _, ty_ty) = (qual, value ty_ty.res) in
+        Crecord (List.map field_of_type l)
+  with
+    Not_found -> cdummy  in
+  let value (Dtypforall(_, ty)) = value ty in
+  match ident.id_value with
+    None -> value ident.id_typ
+  | Some(e) -> translate_pure env e
+
+(** Compilation of a table of declarative code *)
+let translate table =
+  let translate (s, e) = (s, translate_pure empty_env e) in
+  (* introduce the type of states *)
+(*   intro_state_type (); *)
+  (* then translate *)
+  (* translate the code *)
+  { c_types = table.d_types;
+    c_code = List.map translate table.d_code;
+    c_vars = table.d_vars;
+  }

compiler/obc/ml/declarative.ml

@@ -0,0 +1,295 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Lucid Synchrone                                                       *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* $Id: declarative.ml,v 1.18 2007-01-11 07:35:53 pouzet Exp $ *)
+(* the intermediate format *)
+
+open Misc
+open Names
+
+(* one set of (unique) names *)
+type name = int
+
+type global =
+    Gname of string * name
+  | Gmodname of qualified_ident
+
+(* type definitions *)
+type type_definition =
+    { d_type_desc: type_components;
+      d_type_arity: int list
+    }
+
+and ('a, 'b) ptyp = { arg: 'a; res: 'b }
+
+and type_components =
+    Dabstract_type
+  | Dabbrev of typ
+  | Dvariant_type of (qualified_ident * (typ list, typ) ptyp) list
+  | Drecord_type of (qualified_ident * is_mutable * (typ, typ) ptyp) list
+
+and is_mutable = bool
+
+(* types *)
+and typs = Dtypforall of name list * typ
+and typ =
+  | Darrow of is_node * typ * typ
+  | Dproduct of typ list
+  | Dconstr of qualified_ident * typ list
+  | Dtypvar of name
+  | Dbase of base_typ
+  | Dsignal of typ
+
+and is_node = bool
+
+and base_typ =
+    Dtyp_bool | Dtyp_int | Dtyp_float | Dtyp_unit |
+    Dtyp_char | Dtyp_string
+
+type guard = clock
+
+and clock =
+  | Dfalse                         (* the false clock *)
+  | Dtrue                          (* the base clock *)
+  | Don of bool * clock * carrier  (* "cl on c" or "cl on not c" *)
+  | Dclockvar of name              (* 'a *)
+
+and carrier =
+    Dcfalse
+  | Dctrue
+  | Dcvar of name
+  | Dcglobal of qualified_ident * name option * clock
+                                   (* identifier, reset name and clock *)
+
+(* immediate values *)
+type immediate =
+  | Dbool of bool
+  | Dint of int
+  | Dfloat of float
+  | Dchar of char
+  | Dstring of string
+  | Dvoid
+
+type 'a desc =
+    { d_desc: 'a;
+      d_ty: typ;
+      d_guard: guard
+    }
+
+(* patterns *)
+type pattern =
+  | Dwildpat
+  | Dvarpat of name
+  | Dconstantpat of immediate
+  | Dtuplepat of pattern list
+  | Dconstructpat of qualified_ident * pattern list
+  | Drecordpat of (qualified_ident * pattern) list
+  | Daliaspat of pattern * name
+  | Dorpat of pattern * pattern
+
+(* signal expressions *)
+type spattern =
+  | Dandpat of spattern * spattern
+  | Dexppat of expr
+  | Dcondpat of expr * pattern
+
+(* expressions *)
+and expr = expr_desc desc
+
+and expr_desc =
+  | Dconstant of immediate
+  | Dvar of var * subst
+  | Dlast of name
+  | Dpre of expr option * expr
+  | Difthenelse of expr * expr * expr
+  | Dinit of clock * name option
+  | Dtuple of expr list
+  | Dconstruct of qualified_ident * expr list
+  | Drecord of (qualified_ident * expr) list
+  | Drecord_access of expr * qualified_ident
+  | Dprim of qualified_ident * expr list
+  | Dfun of is_state * params * pattern list * block * expr
+  | Dapply of is_state * expr * expr list
+  | Dlet of block * expr
+  | Deseq of expr * expr
+  | Dtest of expr (* testing the presence "?" *)
+  | Dwhen of expr (* instruction "when" *)
+  | Dclock of clock
+
+and is_state = bool
+
+and var =
+  | Dlocal of name
+  | Dglobal of qualified_ident
+
+and is_external = bool (* true for imported ML values *)
+
+(* type and clock instance *)
+and ('a, 'b, 'c) substitution =
+    { s_typ: 'a list;
+      s_clock: 'b list;
+      s_carrier: 'c list }
+
+and subst = (typ, clock, carrier) substitution
+and params = (name, name, name) substitution
+
+(* block *)
+and block =
+    { b_env: (name, ident) Hashtbl.t;   (* environment *)
+      mutable b_write: name list;       (* write variables *)
+      b_equations: equation;            (* equations *)
+    }
+
+(* equation *)
+and equation =
+    Dequation of pattern * expr             (* equation p = e *)
+  | Dnext of name * expr                    (* next x = e *)
+  | Dlasteq of name * expr                  (* last x = e *)
+  | Demit of pattern * expr                 (* emit pat = e *)
+  | Dstatic of pattern * expr               (* static pat = e *)
+  | Dget of pattern * var                   (* pat = x *)
+  | Dwheneq of equation * guard             (* eq when clk *)
+  | Dmerge of is_static * expr              (* control structure *)
+        * (pattern * block) list
+  | Dreset of equation * expr               (* reset *)
+  | Dautomaton of clock * (state_pat * block * block * escape * escape) list
+                                            (* automaton weak and strong *)
+  | Dpar of equation list                   (* parallel equations *)
+  | Dseq of equation list                   (* sequential equations *)
+  | Dblock of block                         (* block structure *)
+  | Dpresent of clock * (spattern * block) list * block
+                                            (* presence testing *)
+
+and escape = (spattern * block * is_continue * state) list
+
+and is_static = bool
+and is_strong = bool
+and is_continue = bool
+
+and state_pat = string * pattern list
+and state = string * expr list
+
+(* ident definition *)
+and ident =
+    { id_name: name;              (* its name (unique identifier) *)
+      id_original: string option; (* its original name when possible *)
+      id_typ: typs;               (* its type *)
+      id_value: expr option;      (* its initial value when possible *)
+      mutable id_kind: id_kind;   (* kind of identifier *)
+      mutable id_write: bool;     (* physically assigned or not *)
+      mutable id_last: bool;      (* do we need its last value also? *)
+      mutable id_signal: bool;    (* is-it a signal? *)
+    }
+
+(* a local variable in a block may be of four different kinds *)
+and id_kind =
+    Kinit   (* initialisation state variable *)
+  | Kclock  (* clock variable *)
+  | Kreset  (* reset variable *)
+  | Kmemo   (* state variable *)
+  | Kstatic (* static variable *)
+  | Klast   (* last variable *)
+  | Kvalue  (* defined variable *)
+  | Kshared (* shared variable with several definitions *)
+  | Kinput  (* input variable, i.e, argument *)
+
+(* global definition *)
+(* Invariant: expr must be bounded and static *)
+
+(* the declarative code associated to a file *)
+type declarative_code =
+    { mutable d_modname: string;                 (* module name *)
+      mutable d_types: (string, type_definition) Hashtbl.t;
+                                                 (* type definitions *)
+      mutable d_code: (string * expr) list;      (* value definitions *)
+      mutable d_vars: string list;               (* defined names     *)
+    }
+
+
+(* the generated code of a module *)
+let dc = { d_modname = "";
+     d_types = Hashtbl.create 7;
+     d_code = [];
+     d_vars = []
+   }
+
+let code () = dc
+
+(* thing to do when starting the production of declarative code *)
+(* for a file *)
+let start modname =
+  dc.d_modname <- modname;
+  dc.d_types <- Hashtbl.create 7;
+  dc.d_code <- [];
+  dc.d_vars <- []
+
+(* things to do at the end of the front-end*)
+let finish () =
+  dc.d_code <- List.rev dc.d_code
+
+(* apply a function to every value *)
+let replace translate =
+  let rec replace (s, e) =
+    let e = translate e in
+      dc.d_code <- (s, e) :: dc.d_code in
+  let code = dc.d_code in
+  dc.d_code <- [];
+  List.iter replace code;
+  dc.d_code <- List.rev dc.d_code
+
+
+(* add an input to the declarative code *)
+let add_dec (name, code) =
+  dc.d_code <- (name, code) :: dc.d_code;
+  dc.d_vars <- name :: dc.d_vars
+
+(* add a type definition to the declarative code *)
+let add_type (name, type_def) =
+  Hashtbl.add dc.d_types name type_def
+
+(* read code from and write code into a file *)
+let read_declarative_code ic = input_value ic
+
+let write_declarative_code oc =
+  output_value oc (code ())
+
+(* the list of opened modules *)
+let dc_modules = (Hashtbl.create 7 : (string, declarative_code) Hashtbl.t)
+
+(* add a module to the list of opened modules *)
+let add_module m =
+  let name = String.uncapitalize m in
+    try
+      let fullname = find_in_path (name ^ ".dcc") in
+      let ic = open_in fullname in
+      let dc = input_value ic in
+  Hashtbl.add dc_modules m dc;
+  close_in ic;
+  dc
+    with
+  Cannot_find_file _ ->
+    Printf.eprintf
+      "Cannot find the compiled declarative file %s.dcc.\n"
+      name;
+    raise Error
+
+let find_value qualid =
+  let dc =
+    if qualid.qual = dc.d_modname then dc
+    else raise Not_found
+(*
+      try
+  Hashtbl.find dc_modules qualid.qual
+      with
+    Not_found -> add_module qualid.qual *) in
+    List.assoc qualid.id dc.d_code
+
+let find_type qualid =
+  if qualid.qual = dc.d_modname then Hashtbl.find dc.d_types qualid.qual
+  else raise Not_found

compiler/obc/ml/declarative_printer.ml

@@ -0,0 +1,699 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Lucid Synchrone                                                       *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* $Id: declarative_printer.ml,v 1.13 2007-01-11 07:35:53 pouzet Exp $ *)
+
+open Misc
+open Names
+open Declarative
+open Modules
+open Format
+
+(* generic printing of a list *)
+let print_list print l =
+  let rec printrec l =
+    match l with
+      [] -> ()
+    | [x] ->
+  print x
+    | x::l ->
+  print x;
+  print_space ();
+  printrec l in
+  printrec l
+
+(* local name *)
+let print_name i =
+  print_string "/";print_int i
+
+(* global names *)
+let print_qualified_ident { qual = q; id = id } =
+  if (q = pervasives_module) or (q = compiled_module_name ())
+     or (q = "")
+  then print_string id
+  else
+    begin
+      print_string q;
+      print_string ".";
+      print_string id
+    end
+
+(* print types *)
+let rec print_type typ =
+  open_box 1;
+  begin match typ with
+    Darrow(is_node, typ1, typ2) ->
+      print_string "(";
+      if is_node then print_string "=>" else print_string "->";
+      print_space ();
+      print_list print_type [typ1;typ2];
+      print_string ")"
+  | Dproduct(ty_list) ->
+      print_string "(";
+      print_string "*";
+      print_space ();
+      print_list print_type ty_list;
+      print_string ")"
+  | Dconstr(qual_ident, ty_list) ->
+      if ty_list <> [] then print_string "(";
+      print_qualified_ident qual_ident;
+      if ty_list <> [] then
+  begin print_space ();
+    print_list print_type ty_list;
+    print_string ")"
+  end
+  | Dsignal(ty) -> print_type ty; print_space (); print_string "sig"
+  | Dtypvar(i) -> print_int i
+  | Dbase(b) -> print_base_type b
+  end;
+  close_box ()
+
+and print_base_type b =
+  match b with
+    Dtyp_bool -> print_string "bool"
+  | Dtyp_int -> print_string "int"
+  | Dtyp_float -> print_string "float"
+  | Dtyp_unit -> print_string "unit"
+  | Dtyp_string -> print_string "string"
+  | Dtyp_char -> print_string "char"
+
+let print_typs (Dtypforall(l, typ)) =
+  match l with
+    [] -> (* we do not print the quantifier when there is no type variable *)
+      print_type typ
+  | l ->
+      open_box 1;
+      print_string "(forall";
+      print_space ();
+      print_list print_name l;
+      print_space ();
+      print_type typ;
+      print_string ")";
+      close_box ()
+
+(* print clocks *)
+let rec print_clock clk =
+  match clk with
+  | Dfalse -> print_string "false"
+  | Dtrue -> print_string "true"
+  | Dclockvar(i) -> print_name i
+  | Don(b, clk, c) ->
+      print_string "(";
+      if b then print_string "on" else print_string "onot";
+      print_space ();
+      print_clock clk;
+      print_space ();
+      print_carrier c;
+      print_string ")"
+and print_carrier c =
+  match c with
+    Dcfalse -> print_string "false"
+  | Dctrue -> print_string "true"
+  | Dcvar(i) -> print_name i
+  | Dcglobal(qual_ident, res, clk) ->
+      print_qualified_ident qual_ident;
+      print_string "(";
+      (match res with
+  None -> ()
+      | Some(n) -> print_space ();print_name n;print_space ());
+      print_clock clk;
+      print_string ")"
+
+(* immediate values *)
+let print_immediate i =
+  match i with
+    Dbool(b) -> print_string (if b then "true" else "false")
+  | Dint(i) -> print_int i
+  | Dfloat(f) -> print_float f
+  | Dchar(c) -> print_char c
+  | Dstring(s) -> print_string s
+  | Dvoid -> print_string "()"
+
+(* print patterns *)
+let atom_pat pat =
+  match pat with
+    Dconstantpat _ | Dvarpat _ | Dwildpat -> true
+  | _ -> false
+
+let rec print_pat pat =
+  open_box 1;
+  if not (atom_pat pat) then print_string "(";
+  begin match pat with
+    Dwildpat -> print_string "_"
+  | Dconstantpat(i) -> print_immediate i
+  | Dvarpat(i) -> print_name i
+  | Dconstructpat(qual_ident, pat_list) ->
+      print_string "constr";
+      print_space ();
+      print_qualified_ident qual_ident;
+      if pat_list <> [] then print_space ();
+      print_list print_pat pat_list
+  | Dtuplepat(pat_list) ->
+      print_string ",";
+      print_space ();
+      print_list print_pat pat_list
+  | Drecordpat(l) ->
+      print_string "record";
+      print_list
+  (fun (qual_ident, pat) ->
+    open_box 1;
+    print_string "(";
+    print_qualified_ident qual_ident;
+    print_space ();
+    print_pat pat;
+    print_string ")";
+    close_box ()) l
+  | Dorpat(pat1, pat2) ->
+      print_string "orpat";
+      print_space ();
+      print_list print_pat [pat1;pat2]
+  | Daliaspat(pat, i) ->
+      print_string "as";
+      print_space ();
+      print_pat pat;
+      print_space ();
+      print_int i
+  end;
+  if not (atom_pat pat) then print_string ")";
+  close_box ()
+
+(* print statepat *)
+let print_statepat (s, l) =
+  match l with
+    [] -> print_string s
+  | l -> print_string "(";
+         print_string s;
+         print_space ();
+         print_list print_pat l;
+         print_string ")"
+
+(* print expressions *)
+let atom e =
+  match e.d_desc with
+    Dconstant _ -> true
+  | _ -> false
+
+(* print variables *)
+let print_var v =
+  match v with
+    Dlocal(n) ->
+      print_string "local";
+      print_space ();
+      print_name n
+  | Dglobal(qual_ident) ->
+      print_string "global";
+      print_space ();
+      print_qualified_ident qual_ident
+
+let rec print e =
+  open_box 1;
+  if not (atom e) then print_string "(";
+  begin match e.d_desc with
+    Dconstant(i) -> print_immediate i
+  | Dvar(v, subst) ->
+      print_var v;
+      print_subst subst
+  | Dlast(i) ->
+      print_string "last";
+      print_space ();
+      print_name i
+  | Dpre(opt_default, e) ->
+      print_string "pre";
+      print_space ();
+      begin match opt_default with
+  None -> print e
+      | Some(default) ->
+    print default; print_space (); print e
+      end
+  | Dinit(ck, None) ->
+      print_string "init";
+      print_space ();
+      print_clock ck
+  | Dinit(ck, Some(n)) ->
+      print_string "init";
+      print_space ();
+      print_clock ck;
+      print_space ();
+      print_name n
+  | Difthenelse(e0,e1,e2) ->
+      print_string "if";
+      print_space ();
+      print e0;
+      print_space ();
+      print e1;
+      print_space ();
+      print e2
+  | Dtuple(l) ->
+      print_string ",";
+      print_space ();
+      print_list print l
+  | Dconstruct(qual_ident,l) ->
+      print_string "constr";
+      print_space ();
+      print_qualified_ident qual_ident;
+      if l <> [] then print_space ();
+      print_list print l
+  | Dprim(qual_ident, l) ->
+      print_string "(";
+      print_qualified_ident qual_ident;
+      print_space ();
+      print_list print l;
+      print_string ")"
+  | Drecord(l) ->
+      print_string "record";
+      print_space ();
+      print_list (fun (qual_ident, e) ->
+  open_box 1;
+  print_string "(";
+  print_qualified_ident qual_ident;
+  print_space ();
+  print e;
+  print_string ")";
+  close_box ()) l
+  | Drecord_access(e,qual_ident) ->
+      print_string "access";
+      print_space ();
+      print e;
+      print_space ();
+      print_qualified_ident qual_ident
+  | Dfun(is_state, params, args, block, e) ->
+      print_string ("fun" ^ (if is_state then "(s)" else "(c)"));
+      print_space ();
+      print_params params;
+      print_space ();
+      print_list print_pat args;
+      print_space ();
+      print_block block;
+      print_space ();
+      print_string "return ";
+      print e
+  | Dapply(is_state, f, e_list) ->
+      print_string ("apply" ^ (if is_state then "(s)" else "(c)"));
+      print_space ();
+      print f;
+      print_space ();
+      print_list print e_list
+  | Dlet(block, e) ->
+      print_string "let";
+      print_space ();
+      print_block block;
+      print_space ();
+      print e
+  | Deseq(e1, e2) ->
+      print_string "seq";
+      print_space ();
+      print e1;
+      print_space ();
+      print e2
+  | Dtest(e1) ->
+      print_string "test";
+      print_space ();
+      print e1
+  | Dwhen(e1) ->
+      print_string "when";
+      print_space ();
+      print e1
+  | Dclock(ck) ->
+      print_string "clock";
+      print_space ();
+      print_clock ck
+  end;
+  if not (atom e) then print_string ")";
+  close_box()
+
+and print_block b =
+  (* print variable definitions *)
+  let print_env env =
+    open_box 1;
+    print_string "(env";
+    print_space ();
+    Hashtbl.iter (fun i ident -> print_ident ident;print_space ()) env;
+    print_string ")";
+    close_box () in
+  (* main function *)
+  open_box 1;
+  print_string "(";
+  (* environment *)
+  print_env b.b_env;
+  print_space ();
+  (* equations *)
+  print_equation b.b_equations;
+  print_space ();
+  (* write variables *)
+  print_string "(write";
+  print_space ();
+  print_list print_name b.b_write;
+  print_string ")";
+  print_string ")";
+  close_box ()
+
+(* print ident declarations *)
+(* e.g, "(kind x/412 (int) (cl) (write) (last) (signal) (= 412))" *)
+and print_ident id =
+  let print_kind () =
+    match id.id_kind with
+      Kinit -> print_string "init"
+    | Kclock -> print_string "clock"
+    | Kmemo -> print_string "memo"
+    | Kstatic -> print_string "static"
+    | Klast -> print_string "last"
+    | Kreset -> print_string "reset"
+    | Kvalue -> print_string "value"
+    | Kinput -> print_string "input"
+    | Kshared -> print_string "shared" in
+  let print_name () =
+    begin match id.id_original with
+      None -> ()
+    | Some(s) -> print_string s
+    end;
+    print_name id.id_name in
+  let print_typs () =
+    print_string "(";
+    print_typs id.id_typ;
+    print_string ")" in
+  let print_write () =
+    if id.id_write then
+      begin print_space (); print_string "(write)" end in
+  let print_last () =
+    if id.id_last then
+      begin print_space (); print_string "(last)" end in
+  let print_signal () =
+    if id.id_signal then
+      begin print_space (); print_string "(signal)" end in
+  let print_expr () =
+    match id.id_value with
+      None -> ()
+    | Some(e) ->
+  print_space ();print_string "(= "; print e; print_string ")" in
+  (* main function *)
+  open_box 1;
+  print_string "(";
+  print_kind ();
+  print_space ();
+  print_name ();
+  print_space ();
+  print_typs ();
+  print_space ();
+  print_write ();
+  print_last ();
+  print_signal ();
+  print_expr ();
+  print_string ")";
+  close_box ()
+
+(* prints a sequence of sets of parallel equations *)
+and print_equation eq =
+  open_box 1;
+  print_string "(";
+  begin match eq with
+    Dequation(pat, e) ->
+      print_string "let";
+      print_space ();
+      print_pat pat;
+      print_space ();
+      print e;
+      print_space ();
+      print_clock e.d_guard
+  | Dlasteq(n, e) ->
+      print_string "last";
+      print_space ();
+      print_name n;
+      print_space ();
+      print e;
+      print_space ();
+      print_clock e.d_guard
+  | Demit(pat, e) ->
+      print_string "emit";
+      print_space ();
+      print_pat pat;
+      print_space ();
+      print e;
+      print_space ();
+      print_clock e.d_guard
+  | Dstatic(pat, e) ->
+      print_string "static";
+      print_space ();
+      print_pat pat;
+      print_space ();
+      print e;
+      print_space ();
+      print_clock e.d_guard
+  | Dnext(n, e) ->
+      print_string "next";
+      print_space ();
+      print_name n;
+      print_space ();
+      print e;
+      print_space ();
+      print_clock e.d_guard
+  | Dget(pat, v) ->
+      print_string "get";
+      print_space ();
+      print_pat pat;
+      print_space ();
+      print_var v
+  | Dwheneq(eq, clk) ->
+      print_string "when";
+      print_space ();
+      print_clock clk;
+      print_space ();
+      print_equation eq
+  | Dmerge(is_static, e, pat_block_list) ->
+      print_string "merge";
+      print_space ();
+      if is_static then print_string "static"
+      else print_clock e.d_guard;
+      print_space ();
+      print e;
+      print_space ();
+      print_list (fun (pat, block) ->
+                  open_box 1;
+                  print_string "(";
+                        print_pat pat;
+                  print_space ();
+                  print_block block;
+                  print_string ")";
+                        close_box ()) pat_block_list
+  | Dpresent(ck, scondpat_block_list, block) ->
+      print_string "present";
+      print_space ();
+      print_clock ck;
+      print_space ();
+      print_list (fun (scondpat, block) ->
+                  open_box 1;
+                  print_string "(";
+                        print_spat scondpat;
+                  print_space ();
+                  print_block block;
+                  print_string ")";
+                        close_box ()) scondpat_block_list;
+      print_space ();
+      print_block block
+  | Dreset(eq, e) ->
+      print_string "reset";
+      print_space ();
+      print_equation eq;
+      print_space ();
+      print e
+  | Dautomaton(ck, handlers) ->
+      print_string "automaton";
+      print_space ();
+      print_clock ck;
+      print_space ();
+      print_list print_handler handlers
+  | Dpar(eq_list) ->
+      print_string "par";
+      print_space ();
+      print_list print_equation eq_list
+  | Dseq(eq_list) ->
+      print_string "seq";
+      print_space ();
+      print_list print_equation eq_list
+  | Dblock(b) ->
+      print_string "block";
+      print_space ();
+      print_block b
+  end;
+  print_string ")";
+  close_box ()
+
+(* print the handlers of an automaton *)
+and print_handler (statepat, b_weak, b_strong, weak_escape, strong_escape) =
+  open_box 1;
+  print_string "(state";
+  print_space ();
+  print_statepat statepat;
+  print_space ();
+  print_block b_weak;
+  print_space ();
+  print_block b_strong;
+  print_space ();
+  print_string "(weak ";
+  print_escape weak_escape;
+  print_string ")";
+  print_space ();
+  print_string "(strong ";
+  print_escape weak_escape;
+  print_string ")";
+  print_string ")";
+  close_box ()
+
+and print_escape escape_list =
+  print_list
+    (fun (spat, b, is_continue, state) ->
+      print_string "(";
+      if is_continue then print_string "continue " else print_string "then ";
+      print_spat spat;
+      print_space ();
+      print_block b;
+      print_space ();
+      print_state state;
+      print_string ")")
+    escape_list;
+  close_box ()
+
+
+(* print type and clock instance *)
+and print_subst { s_typ = st; s_clock = scl; s_carrier = sc } =
+  match st, scl, sc with
+    [],[],[] -> ()
+  | l1,l2,l3 ->
+      print_string "[";
+      print_list print_type l1;
+      print_string "]";
+      print_space ();
+      print_string "[";
+      print_list print_clock l2;
+      print_string "]";
+      print_space ();
+      print_string "[";
+      print_list print_carrier l3;
+      print_string "]";
+
+and print_params { s_typ = pt; s_clock = pcl; s_carrier = pc } =
+  match pt, pcl, pc with
+    [],[],[] -> ()
+  | l1,l2,l3 ->
+      print_string "[";
+      print_list print_name l1;
+      print_string "]";
+      print_space ();
+      print_string "[";
+      print_list print_name l2;
+      print_string "]";
+      print_space ();
+      print_string "[";
+      print_list print_name l3;
+      print_string "]"
+
+and print_state (s, l) =
+  match l with
+    [] -> print_string s
+  | l -> print_string "(";
+         print_string s;
+         print_space ();
+         print_list print l;
+   print_string ")"
+
+and atom_spat spat =
+  match spat with
+    Dexppat _ | Dcondpat _ -> true
+  | _ -> false
+
+and print_spat spat =
+  open_box 1;
+  if not (atom_spat spat) then print_string "(";
+  begin match spat with
+    Dandpat(spat1, spat2) ->
+      print_string "& ";
+      print_spat spat1;
+      print_space ();
+      print_spat spat2
+  | Dexppat(e) ->
+      print e
+  | Dcondpat(e, pat) ->
+      print_string "is ";
+      print e;
+      print_space ();
+      print_pat pat
+  end;
+  if not (atom_spat spat) then print_string ")";
+  close_box ()
+
+(* the main entry for printing definitions *)
+let print_definition (name, e) =
+  open_box 2;
+  print_string "(def ";
+  if is_an_infix_or_prefix_operator name
+  then begin print_string "( "; print_string name; print_string " )" end
+  else print_string name;
+  print_space ();
+  print e;
+  print_string ")";
+  print_newline ();
+  close_box ()
+
+(* print types *)
+let print_variant (qualid, { arg = typ_list; res = typ }) =
+  print_string "(";
+  print_qualified_ident qualid;
+  print_string "(";
+  print_list print_type typ_list;
+  print_string ")";
+  print_space ();
+  print_type typ;
+  print_string ")"
+
+let print_record (qualid, is_mutable, { arg = typ1; res = typ2 }) =
+  print_string "(";
+  if is_mutable then print_string "true" else print_string "false";
+  print_space ();
+  print_qualified_ident qualid;
+  print_space ();
+  print_type typ1;
+  print_space ();
+  print_type typ2;
+  print_string ")"
+
+let print_type_declaration s { d_type_desc = td; d_type_arity = arity } =
+  open_box 2;
+  print_string "(type[";
+  print_list print_name arity;
+  print_string "]";
+  print_space ();
+  print_string s;
+  print_space ();
+  begin match td with
+    Dabstract_type -> ()
+  | Dabbrev(ty) ->
+      print_type ty
+  | Dvariant_type variant_list ->
+      List.iter print_variant variant_list
+  | Drecord_type record_list ->
+      List.iter print_record record_list
+  end;
+  print_string ")";
+  print_newline ();
+  close_box ();;
+
+(* the main functions *)
+set_max_boxes max_int ;;
+
+let output_equations oc eqs =
+  set_formatter_out_channel oc;
+  List.iter print_equation eqs
+
+let output oc declarative_code =
+  set_formatter_out_channel oc;
+  (* print type declarations *)
+  Hashtbl.iter print_type_declaration declarative_code.d_types;
+  (* print value definitions *)
+  List.iter print_definition declarative_code.d_code;
+  print_flush ()
+

compiler/obc/ml/default_value.ml

@@ -0,0 +1,63 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Lucid Synchrone                                                       *)
+(*                                                                        *)
+(*  Author : Gregoire Hamon, Marc Pouzet                                  *)
+(*  Organization : SPI team, LIP6 laboratory, University Paris 6          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* $Id: default_value.ml,v 1.1.1.1 2005-11-03 15:45:23 pouzet Exp $ *)
+
+(** Computes a default value from a type *)
+
+open Misc
+open Names
+open Def_types
+open Types
+open Initialization
+open Caml
+
+let default x ty =
+  let rec def ty =
+    match ty with
+      TypeVar{contents = Typindex _} -> Cdummy ""
+    | TypeVar{contents = Typlink ty} -> def ty
+    | Tarrow _ -> x
+    | Tproduct(t_list) ->
+        if t_list = []
+        then Cdummy ""
+        else Ctuple (List.map def t_list)
+    | Tconstr (info, tlist) ->
+  if info.qualid.qual = pervasives_module then
+    match info.qualid.id with
+      | "int" -> Cim (Cint 0)
+      | "bool" | "clock" -> Cim (Cbool false)
+      | "float" -> Cim (Cfloat 0.0)
+      | "char" -> Cim (Cchar 'a')
+      | "string" -> Cim (Cstring "")
+      | "unit" -> Cim (Cvoid)
+      | _ -> Cdummy ""
+  else
+    match info.info_in_table.type_desc with
+      Abstract_type -> Cdummy ""
+    | Variant_type l ->
+        begin
+    let case = List.hd l in
+    match case.info_in_table.typ_desc with
+      Tarrow (ty1, ty2) ->
+        Cconstruct1 ({ cqual = case.qualid.qual;
+           cid = case.qualid.id }, def ty1)
+    |  _ ->
+        Cconstruct0 { cqual = case.qualid.qual;
+          cid = case.qualid.id }
+        end
+    | Record_type l ->
+        let field_of_type x =
+    let ty1,_ = filter_arrow x.info_in_table.typ_desc in
+    ({ cqual = x.qualid.qual; cid = x.qualid.id }, def ty1) in
+        Crecord (List.map field_of_type l)
+  in
+  def ty
+
+

compiler/obc/ml/misc.ml

@@ -0,0 +1,295 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Lucid Synchrone                                                       *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* $Id: misc.ml,v 1.11 2006-09-30 12:27:27 pouzet Exp $ *)
+
+(* version of the compiler *)
+let version = "3.0b"
+
+let date = DATE
+
+(* standard module *)
+let pervasives_module = Pervasives
+let standard_lib = STDLIB
+
+(* variable creation *)
+(* generating names *)
+class name_generator =
+  object
+    val mutable counter = 0
+    method name =
+      counter <- counter + 1;
+      counter
+    method reset =
+      counter <- 0
+    method init i =
+      counter <- i
+  end
+
+(* association table with memoization *)
+class name_assoc_table f =
+  object
+    val mutable counter = 0
+    val mutable assoc_table: (int * string) list = []
+    method name var =
+      try
+  List.assq var assoc_table
+      with
+  not_found ->
+    let n = f counter in
+    counter <- counter + 1;
+    assoc_table <- (var,n) :: assoc_table;
+    n
+    method reset =
+      counter <- 0;
+      assoc_table <- []
+  end
+
+(* error during the whole process *)
+exception Error
+
+(* internal error : for example, an abnormal pattern matching failure *)
+(* gives the name of the function *)
+exception Internal_error of string
+
+let fatal_error s = raise (Internal_error s)
+
+let not_yet_implemented s =
+  Printf.eprintf "The construction %s is not implemented yet.\n" s;
+  raise Error
+
+(* creating a name generator for type and clock calculus *)
+(* ensure unicity for the whole process *)
+let symbol = new name_generator
+
+(* generic and non generic variables in the various type systems *)
+let generic = -1
+let notgeneric = 0
+let maxlevel = max_int
+
+let binding_level = ref 0
+let top_binding_level () = !binding_level = 0
+
+let push_binding_level () = binding_level := !binding_level + 1
+let pop_binding_level () =
+  binding_level := !binding_level - 1;
+  assert (!binding_level > generic)
+let reset_binding_level () = binding_level := 0
+
+(* realtime mode *)
+let realtime = ref false
+
+(* assertions *)
+let no_assert = ref false
+
+(* converting integers into variable names *)
+(* variables are printed 'a, 'b *)
+let int_to_letter bound i =
+  if i < 26
+  then String.make 1 (Char.chr (i+bound))
+  else String.make 1 (Char.chr ((i mod 26) + bound)) ^ string_of_int (i/26)
+
+let int_to_alpha i = int_to_letter 97 i
+
+(* printing information *)
+class on_off =
+  object
+    val mutable status = false
+    method set = status <- true
+    method get = status
+  end
+
+let print_type = new on_off
+let print_clock = new on_off
+let print_init = new on_off
+let print_causality = new on_off
+let no_causality = ref false
+let no_initialisation = ref false
+
+let no_deadcode = ref false
+
+(* control what is done in the compiler *)
+exception Stop
+
+let only = ref ""
+let set_only_info o = only := o
+let parse_only () =
+  if !only = "parse" then raise Stop
+let type_only () =
+  if !only = "type" then raise Stop
+let clock_only () =
+  if !only = "clock" then raise Stop
+let caus_only () =
+  if !only = "caus" then raise Stop
+let init_only () =
+  if !only = "init" then raise Stop
+let dec_only () =
+  if !only = "parse" or !only = "type"
+  or !only = "clock" or !only = "init"
+  or !only = "dec" then raise Stop
+
+(* load paths *)
+let load_path = ref ([] : string list)
+
+(* no link *)
+let no_link = ref false
+
+(* simulation node *)
+let simulation_node = ref ""
+
+(* sampling rate *)
+let sampling_rate : int option ref = ref None
+
+(* level of inlining *)
+let inlining_level = ref 10
+
+(* emiting declarative code *)
+let print_declarative_code = ref false
+let print_auto_declarative_code = ref false
+let print_total_declarative_code = ref false
+let print_last_declarative_code = ref false
+let print_signals_declarative_code = ref false
+let print_reset_declarative_code = ref false
+let print_linearise_declarative_code = ref false
+let print_initialize_declarative_code = ref false
+let print_split_declarative_code = ref false
+let print_inline_declarative_code = ref false
+let print_constant_declarative_code = ref false
+let print_deadcode_declarative_code = ref false
+let print_copt_declarative_code = ref false
+
+(* total emission of signals *)
+let set_total_emit = ref false
+
+(* generating C *)
+let make_c_code = ref false
+
+(* profiling information about the compilation *)
+let print_exec_time = ref false
+
+exception Cannot_find_file of string
+
+let find_in_path filename =
+  if Sys.file_exists filename then
+    filename
+  else if not(Filename.is_implicit filename) then
+    raise(Cannot_find_file filename)
+  else
+    let rec find = function
+      [] ->
+        raise(Cannot_find_file filename)
+    | a::rest ->
+        let b = Filename.concat a filename in
+          if Sys.file_exists b then b else find rest
+    in find !load_path
+
+
+(* Prompts: [error_prompt] is printed before compiler error *)
+(*          and warning messages *)
+let error_prompt = ">"
+
+(* list intersection *)
+let intersect l1 l2 =
+  List.exists (fun el -> List.mem el l1) l2
+
+(* remove an entry from an association list *)
+let rec remove n l =
+  match l with
+    [] -> raise Not_found
+  | (m, v) :: l ->
+      if n = m then l else (m, v) :: remove n l
+
+(* list substraction. l1 - l2 *)
+let sub_list l1 l2 =
+  let rec sl l l1 =
+    match l1 with
+      [] -> l
+    | h :: t -> sl (if List.mem h l2 then l else (h :: l)) t in
+  sl [] l1
+
+(* union *)
+let rec union l1 l2 =
+  match l1, l2 with
+    [], l2 -> l2
+  | l1, [] -> l1
+  | x :: l1, l2 ->
+      if List.mem x l2 then union l1 l2 else x :: union l1 l2
+
+let addq x l = if List.memq x l then l else x :: l
+
+let rec unionq l1 l2 =
+  match l1, l2 with
+    [], l2 -> l2
+  | l1, [] -> l1
+  | x :: l1, l2 ->
+      if List.memq x l2 then unionq l1 l2 else x :: unionq l1 l2
+
+(* intersection *)
+let rec intersection l1 l2 =
+  match l1, l2 with
+    ([], _) | (_, []) -> []
+  | x :: l1, l2 -> if List.mem x l2 then x :: intersection l1 l2
+                   else intersection l1 l2
+
+(* the last element of a list *)
+let rec last l =
+  match l with
+    [] -> raise (Failure "last")
+  | [x] -> x
+  | _ :: l -> last l
+
+(* iterator *)
+let rec map_fold f acc l =
+  match l with
+    [] -> acc, []
+  | x :: l ->
+      let acc, v = f acc x in
+      let acc, l = map_fold f acc l in
+      acc, v :: l
+
+(* flat *)
+let rec flat l =
+  match l with
+    [] -> []
+  | x :: l -> x @ flat l
+
+(* reverse *)
+let reverse l =
+  let rec reverse acc l =
+    match l with
+      [] -> acc
+    | x :: l -> reverse (x :: acc) l in
+  reverse [] l
+
+(* generic printing of a list *)
+let print_list print print_sep l =
+  let rec printrec l =
+    match l with
+      [] -> ()
+    | [x] ->
+  print x
+    | x::l ->
+  print x;
+  print_sep ();
+  printrec l in
+  printrec l
+
+(* generates the sequence of integers *)
+let rec from n = if n = 0 then [] else n :: from (n-1)
+
+(* for infix operators, print parenthesis around *)
+let is_an_infix_or_prefix_operator op =
+  if op = "" then false
+  else
+    let c = String.get op 0 in
+    not (((c >= 'a') & (c <= 'z')) or ((c >= 'A') & (c <= 'Z')))
+
+(* making a list from a hash-table *)
+let listoftable t =
+  Hashtbl.fold (fun key value l -> (key, value) :: l) t []

compiler/obc/ml/ml.ml

@@ -0,0 +1,2 @@
+
+

compiler/obc/obc.ml

@@ -8,6 +8,21 @@
 (**************************************************************************)
 (* Object code internal representation *)
 
+(** { 3 Semantics }
+  Any variable is a reference to a constant memory.
+    Thus [p = e] is not the change of the reference,
+    but a recursive copy of what is referenced (deep copy).
+    As an example, [x = 3] but also [x = \[3; 4; 5\]]
+    and [t1 = t2] with the content of the array [t2] copied into the array [t1].
+  Obc is also "SSA" in the sens that a variable is assigned a value only once per call of [step] etc.
+    Thus arguments are passed as constant references to a constant memory.
+
+  One exception to the SSA rule is through the [mutable] variables.
+    Theses variables can be assigned multiple times.
+    Thus a [mutable] argument is passed as a reference to a constant memory.
+*)
+
+
 open Misc
 open Names
 open Idents
@@ -16,12 +31,12 @@ open Signature
 open Location
 
 type class_name = qualname
-type instance_name = qualname
-type obj_name = name
 type op_name = qualname
+type obj_ident = var_ident
+
 
 type type_dec =
-    { t_name : qualname;
+    { t_name : type_name;
       t_desc : tdesc;
       t_loc : location }
 
@@ -48,15 +63,15 @@ and pat_desc =
 and exp = { e_desc : exp_desc; e_ty : ty; e_loc : location }
 
 and exp_desc =
-  | Elhs of pattern
+  | Epattern of pattern
   | Econst of static_exp
   | Eop of op_name * exp list
   | Estruct of type_name * (field_name * exp) list
   | Earray of exp list
 
 type obj_ref =
-  | Oobj of obj_name
-  | Oarray of obj_name * pattern
+  | Oobj of obj_ident
+  | Oarray of obj_ident * pattern
 
 type method_name =
   | Mreset
@@ -66,7 +81,8 @@ type act =
   | Aassgn of pattern * exp
   | Acall of pattern list * obj_ref * method_name * exp list
   | Acase of exp * (constructor_name * block) list
-  | Afor of var_ident * static_exp * static_exp * block
+  | Afor of var_dec * static_exp * static_exp * block
+  | Ablock of block
 
 and block =
     { b_locals : var_dec list;
@@ -74,14 +90,14 @@ 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_name : obj_name;
-      o_class : instance_name;
+    { o_ident : obj_ident;
+      o_class : class_name;
       o_params : static_exp list;
-      o_size : static_exp option;
+      o_size : static_exp option; (** size of the array if the declaration is an array of obj *)
       o_loc : location }
 
 type method_def =
@@ -92,70 +108,19 @@ type method_def =
 
 type class_def =
     { cd_name : class_name;
+      cd_stateful : bool; (** when false, the class is a function with static parameters
+                              calling other functions with parameters *)
       cd_mems : var_dec list;
       cd_objs  : obj_dec list;
       cd_params : param list;
       cd_methods: method_def list;
       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 }
-
-let mk_var_dec ?(loc=no_location) name ty =
-  { v_ident = name; v_type = ty; v_loc = loc }
-
-let mk_exp ?(ty=invalid_type) ?(loc=no_location) desc = (* TODO master :  remove the invalid_type *)
-  { e_desc = desc; e_ty = ty; e_loc = loc }
-
-let mk_lhs ?(ty=invalid_type) ?(loc=no_location) desc = (* TODO master :  remove the invalid_type *)
-  { pat_desc = desc; pat_ty = ty; pat_loc = loc }
-
-let mk_lhs_exp ?(ty=invalid_type) desc = (* TODO master :  remove the invalid_type *)
-  let lhs = mk_lhs ~ty:ty desc in
-    mk_exp ~ty:ty (Elhs lhs)
-
-let mk_evar id =
-  mk_exp (Elhs (mk_lhs (Lvar id)))
-
-let mk_block ?(locals=[]) eq_list =
-  { b_locals = locals;
-    b_body = eq_list }
-
-let rec var_name x =
-  match x.pat_desc with
-    | Lvar x -> x
-    | Lmem x -> x
-    | Lfield(x,_) -> var_name x
-    | Larray(l, _) -> var_name l
-
-(** Returns whether an object of name n belongs to
-    a list of var_dec. *)
-let rec vd_mem n = function
-  | [] -> false
-  | vd::l -> vd.v_ident = n or (vd_mem n l)
-
-(** Returns the var_dec object corresponding to the name n
-    in a list of var_dec. *)
-let rec vd_find n = function
-  | [] -> Format.eprintf "Not found var %s@." (name n); raise Not_found
-  | vd::l ->
-      if vd.v_ident = n then vd else vd_find n l
-
-let lhs_of_exp e = match e.e_desc with
-  | Elhs l -> l
-  | _ -> assert false
-
-let find_step_method cd =
-  List.find (fun m -> m.m_name = Mstep) cd.cd_methods
-let find_reset_method cd =
-  List.find (fun m -> m.m_name = Mreset) cd.cd_methods
-
-let obj_ref_name o =
-  match o with
-    | Oobj obj
-    | Oarray (obj, _) -> obj
+      p_classes  : class_def list; }
 

compiler/obc/obc_mapfold.ml

@@ -44,9 +44,9 @@ and edesc_it funs acc ed =
   try funs.edesc funs acc ed
   with Fallback -> edesc funs acc ed
 and edesc funs acc ed = match ed with
-  | Elhs l ->
+  | Epattern l ->
      let l, acc = lhs_it funs acc l in
-        Elhs l, acc
+        Epattern l, acc
   | Econst se ->
       let se, acc = static_exp_it funs.global_funs acc se in
         Econst se, acc
@@ -108,6 +108,9 @@ and act funs acc a = match a with
       let idx2, acc = static_exp_it funs.global_funs acc idx2 in
       let b, acc = block_it funs acc b in
         Afor(x, idx1, idx2, b), acc
+  | Ablock b ->
+      let b, acc = block_it funs acc b in
+      Ablock b, acc
 
 and block_it funs acc b = funs.block funs acc b
 and block funs acc b =
@@ -144,7 +147,9 @@ and method_def funs acc md =
   , acc
 
 
-and class_def_it funs acc cd = funs.class_def funs acc cd
+and class_def_it funs acc cd =
+    Idents.enter_node cd.cd_name;
+    funs.class_def funs acc cd
 and class_def funs acc cd =
   let cd_mems, acc = var_decs_it funs acc cd.cd_mems in
   let cd_objs, acc = obj_decs_it funs acc cd.cd_objs in
@@ -183,8 +188,8 @@ and program_it funs acc p = funs.program funs acc p
 and program funs acc p =
   let td_list, acc = mapfold (type_dec_it funs) acc p.p_types in
   let cd_list, acc = mapfold (const_dec_it funs) acc p.p_consts in
-  let nd_list, acc = mapfold (class_def_it funs) acc p.p_defs in
-  { p with p_types = td_list; p_consts = cd_list; p_defs = nd_list }, acc
+  let nd_list, acc = mapfold (class_def_it funs) acc p.p_classes in
+  { p with p_types = td_list; p_consts = cd_list; p_classes = nd_list }, acc
 
 
 let defaults = {

compiler/obc/obc_printer.ml

@@ -14,7 +14,7 @@ let print_vd ff vd =
   fprintf ff "@]"
 
 let print_obj ff o =
-  fprintf ff "@[<v>"; print_name ff o.o_name;
+  fprintf ff "@[<v>"; print_ident ff o.o_ident;
   fprintf ff " : "; print_qualname ff o.o_class;
   fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "<<"","">>") o.o_params;
   (match o.o_size with
@@ -37,7 +37,7 @@ and print_exps ff e_list = print_list_r print_exp "" "," "" ff e_list
 
 and print_exp ff e =
   match e.e_desc with
-    | Elhs lhs -> print_lhs ff lhs
+    | Epattern lhs -> print_lhs ff lhs
     | Econst c -> print_static_exp ff c
     | Eop(op, e_list) -> print_op ff op e_list
     | Estruct(_,f_e_list) ->
@@ -65,16 +65,17 @@ let print_asgn ff pref x e =
   fprintf ff "@]"
 
 let print_obj_call ff = function
-  | Oobj o -> print_name ff o
+  | Oobj o -> print_ident ff o
   | Oarray (o, i) ->
       fprintf ff "%a[%a]"
-        print_name o
+        print_ident o
         print_lhs i
 
 let print_method_name ff = function
   | Mstep -> fprintf ff "step"
   | Mreset -> fprintf ff "reset"
 
+
 let rec print_act ff a =
   let print_lhs_tuple ff var_list = match var_list with
     | [] -> ()
@@ -87,8 +88,8 @@ let rec print_act ff a =
         print_tag_act_list ff tag_act_list;
         fprintf ff "@]@,}@]"
     | Afor(x, i1, i2, act_list) ->
-        fprintf ff "@[<v>@[<v 2>for %s = %a to %a {@, %a @]@,}@]"
-          (name x)
+        fprintf ff "@[<v>@[<v 2>for %a = %a to %a {@  %a @]@,}@]"
+          print_vd x
           print_static_exp i1
           print_static_exp i2
           print_block act_list
@@ -98,6 +99,8 @@ let rec print_act ff a =
           print_obj_call o
           print_method_name meth
           print_exps es
+    | Ablock b ->
+        fprintf ff "do@\n  %a@\ndone" print_block b
 
 and print_var_dec_list ff var_dec_list = match var_dec_list with
   | [] -> ()
@@ -149,6 +152,7 @@ let print_class_def ff
   print_list_r print_method "" "\n" "" ff m_list;
   fprintf ff "@]"
 
+
 let print_type_def ff { t_name = name; t_desc = tdesc } =
   match tdesc with
     | Type_abs -> fprintf ff "@[type %a@\n@]" print_qualname name
@@ -169,21 +173,19 @@ 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
     print_static_exp c.c_value
 
 let print_prog ff { p_opened = modules; p_types = types;
-                    p_consts = consts; p_defs = defs } =
+                    p_consts = consts; p_classes = classes; } =
   List.iter (print_open_module ff) modules;
   List.iter (print_type_def ff) types;
   List.iter (print_const_dec ff) consts;
   fprintf ff "@\n";
-  List.iter (fun def -> (print_class_def ff def; fprintf ff "@\n@\n")) defs
+  List.iter (fun cdef -> (print_class_def ff cdef; fprintf ff "@\n@\n")) classes
 
 let print oc p =
   let ff = formatter_of_out_channel oc in

compiler/obc/obc_utils.ml

@@ -8,16 +8,113 @@
 (**************************************************************************)
 
 open Names
+open Idents
+open Location
 open Misc
 open Types
 open Obc
 open Obc_mapfold
 open Global_mapfold
 
+let mk_var_dec ?(loc=no_location) ident ty =
+  { v_ident = ident; v_type = ty; v_loc = loc }
+
+let mk_exp ?(loc=no_location) ty desc =
+  { e_desc = desc; e_ty = ty; e_loc = loc }
+
+let mk_exp_int ?(loc=no_location) desc =
+  { e_desc = desc; e_ty = Initial.tint; e_loc = loc }
+
+let mk_exp_bool ?(loc=no_location) desc =
+  { e_desc = desc; e_ty = Initial.tbool; e_loc = loc }
+
+let mk_pattern ?(loc=no_location) ty desc =
+  { pat_desc = desc; pat_ty = ty; pat_loc = loc }
+
+let mk_pattern_int ?(loc=no_location) desc =
+  { pat_desc = desc; pat_ty = Initial.tint; pat_loc = loc }
+
+let mk_pattern_exp ty desc =
+  let pat = mk_pattern ty desc in
+    mk_exp ty (Epattern pat)
+
+let mk_evar ty id =
+  mk_exp ty (Epattern (mk_pattern ty (Lvar id)))
+
+let mk_evar_int id =
+  mk_exp Initial.tint (Epattern (mk_pattern Initial.tint (Lvar id)))
+
+let mk_block ?(locals=[]) eq_list =
+  { b_locals = locals;
+    b_body = eq_list }
+
+let rec var_name x =
+  match x.pat_desc with
+    | Lvar x -> x
+    | Lmem x -> x
+    | Lfield(x,_) -> var_name x
+    | Larray(l, _) -> var_name l
+
+(** Returns whether an object of name n belongs to
+    a list of var_dec. *)
+let rec vd_mem n = function
+  | [] -> false
+  | vd::l -> vd.v_ident = n or (vd_mem n l)
+
+(** Returns the var_dec object corresponding to the name n
+    in a list of var_dec. *)
+let rec vd_find n = function
+  | [] -> Format.eprintf "Not found var %s@." (name n); raise Not_found
+  | vd::l ->
+      if vd.v_ident = n then vd else vd_find n l
+
+(** Returns the type of a [var_dec list] *)
+let vd_list_to_type vd_l = match vd_l with
+  | [] -> Types.Tunit
+  | [vd] -> vd.v_type
+  | _ -> Tprod (List.map (fun vd -> vd.v_type) vd_l)
+
+let pattern_list_to_type p_l = match p_l with
+  | [] -> Types.Tunit
+  | [p] -> p.pat_ty
+  | _ -> Tprod (List.map (fun p -> p.pat_ty) p_l)
+
+let pattern_of_exp e = match e.e_desc with
+  | Epattern l -> l
+  | _ -> assert false
+
+let find_step_method cd =
+  List.find (fun m -> m.m_name = Mstep) cd.cd_methods
+let find_reset_method cd =
+  List.find (fun m -> m.m_name = Mreset) cd.cd_methods
+
+let obj_ref_name o =
+  match o with
+    | Oobj obj
+    | Oarray (obj, _) -> obj
+
+(** Input a block [b] and remove all calls to [Reset] method from it *)
+let remove_resets b =
+  let block funs _ b =
+    let b,_ = Obc_mapfold.block funs () b in
+    let is_not_reset a = match a with
+      | Acall( _,_,Mreset,_) -> false
+      | _ -> true
+    in
+    let b = { b with b_body = List.filter is_not_reset b.b_body } in
+    b, ()
+  in
+  let funs = { Obc_mapfold.defaults with block = block } in
+  let b,_ = block_it funs () b in
+  b
+
+
 module Deps =
 struct
 
-  let deps_longname deps { qual = modn; } = S.add modn deps
+  let deps_longname deps qn = match qn.qual with
+    | Module _ | QualModule _ -> ModulSet.add qn.qual deps
+    | _ -> deps
 
   let deps_static_exp_desc funs deps sedesc =
     let (sedesc, deps) = Global_mapfold.static_exp_desc funs deps sedesc in
@@ -66,6 +163,6 @@ struct
       act = deps_act;
       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)
+    let (_, deps) = Obc_mapfold.program funs ModulSet.empty p in
+    ModulSet.remove p.p_modname deps
 end

compiler/obc/transformations/scalarize.ml

@@ -0,0 +1,61 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Remove implicit array's deep copy. If ever some p = e with p of type array still exist,
+  they are only used as reference to the array, no copy is implied :
+  array assignation after [scalarize] is pointer wise assignation *)
+
+
+open Misc
+open Obc
+open Obc_utils
+open Obc_mapfold
+
+
+(** 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 = Idents.gen_var "scalarize" "i" in
+  let id = mk_var_dec i Initial.tint in
+  let ei = mk_evar_int i in
+  Afor (id, Initial.mk_static_int 0, size, mk_block (body ei))
+
+
+let act funs () a = match a with
+  | Aassgn (p,e) ->
+      (match e.e_ty with
+        | Types.Tarray (t, size) ->
+          (* a reference (alias) to the array, since we could have a full expression *)
+          let array_ref = Idents.gen_var "scalarize" "a_ref" in
+          let vd_array_ref = mk_var_dec array_ref (Types.Tmutable p.pat_ty) in
+          (* reference initialization *)
+          let pat_array_ref = mk_pattern ~loc:e.e_loc p.pat_ty (Lvar array_ref) in
+          let init_array_ref = Aassgn (pat_array_ref, e) in
+          (* the copy loop *)
+          let array_ref_i i = mk_pattern_exp t (Larray (pat_array_ref, i)) in
+          let p_i i = mk_pattern t (Larray (p, i)) in
+          let copy_i i =
+            (* recursive call to deal with multidimensional arrays (go deeper) *)
+            let a = Aassgn (p_i i, array_ref_i i) in
+            let a, _ = act_it funs () a in
+            [a]
+          in
+          let copy_array = fresh_for size copy_i in
+          (* resulting block *)
+          let block = mk_block ~locals:[vd_array_ref] [init_array_ref; copy_array] in
+          Ablock block, ()
+        | _ -> raise Errors.Fallback
+      )
+  | _ -> raise Errors.Fallback
+
+
+let program p =
+  let p, _ = program_it { defaults with act = act } () p in
+  p
+
+

compiler/utilities/global/compiler_options.ml

@@ -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
 
@@ -54,10 +54,10 @@ let assert_nodes : name list ref = ref []
 let add_assert nd = assert_nodes := nd :: !assert_nodes
 
 let simulation = ref false
-let simulation_node : name option ref = ref None
+let simulation_node : name ref = ref ""
 let set_simulation_node s =
   simulation := true;
-  simulation_node := Some s
+  simulation_node := s
 
 let create_object_file = ref false
 

compiler/utilities/global/compiler_utils.ml

@@ -58,14 +58,14 @@ let silent_pass d enabled f p =
   then do_silent_pass d f p
   else p
 
+let filename_of_name n =
+  String.uncapitalize n
+
 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 +74,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 =

compiler/utilities/misc.ml

@@ -64,6 +64,16 @@ let rec split_last = function
       let l, a = split_last l in
       v::l, a
 
+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
+  | 0, l -> [], l
+  | _, [] -> raise List_too_short
+  | n, x::l ->
+      let l1, l2 = split_at (n-1) l in
+        x::l1, l2
+
 let remove x l =
   List.filter (fun y -> x <> y) l
 
@@ -112,7 +122,7 @@ let rec assocd value = function
 
 (** { 3 Compiler iterators } *)
 
-(** Mapfold *)
+(** Mapfold *) (* TODO optim : lot's of place we don't need the List.rev *)
 let mapfold f acc l =
   let l,acc = List.fold_left
                 (fun (l,acc) e -> let e,acc = f acc e in e::l, acc)
@@ -158,16 +168,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,3 +219,4 @@ let split_string s separator = Str.split (separator |> Str.quote |> Str.regexp)
 
 let file_extension s = split_string s "." |> last_element
 
+

compiler/utilities/misc.mli

@@ -36,6 +36,11 @@ val last_element : 'a list -> 'a
     and the last element of the list .*)
 val split_last : 'a list -> ('a list * 'a)
 
+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. *)
+val split_at : int -> 'a list -> 'a list * 'a list
+
 (** [remove x l] removes all occurrences of x from list l.*)
 val remove : 'a -> 'a list -> 'a list
 
@@ -90,3 +95,9 @@ val (|>) : 'a -> ('a -> 'b) -> 'b
 
 (** Return the extension of a filename string *)
 val file_extension : string -> string
+
+(** Internal error : Is used when an assertion wrong *)
+val internal_error : string -> int -> 'a
+
+(** Unsupported : Is used when something should work but is not currently supported *)
+val unsupported : string -> int -> 'a

heptc

@@ -9,17 +9,25 @@ SCRIPT_DIR=$RUN_DIR/`dirname $0`
 
 COMPILER_DIR=$SCRIPT_DIR/compiler
 COMPILER=heptc.byte
+COMPILER_DEBUG=heptc.d.byte
 LIB_DIR=$SCRIPT_DIR/lib
 
 #the symlink
 HEPTC=$COMPILER_DIR/$COMPILER
+HEPTC_DEBUG=$COMPILER_DIR/$COMPILER_DEBUG
 
 #compile the compiler
 if [ ! -x $HEPTC ]
 then
-	cd $COMPILER_DIR
-	ocamlbuild -j 0 $COMPILER
-	cd -
+	if [ -x $HEPTC_DEBUG ]
+	then
+		#use the debug
+		HEPTC=$HEPTC_DEBUG
+	else
+		cd $COMPILER_DIR
+		ocamlbuild -j 0 $COMPILER
+		cd -
+	fi
 fi
 
 #compile the stdlib

lib/java/jeptagon/Pervasives.java

@@ -0,0 +1,128 @@
+package jeptagon;
+
+import java.util.concurrent.Executors;
+import java.util.concurrent.ExecutorService;
+import java.util.concurrent.Future;
+import java.util.concurrent.TimeUnit;
+
+public class Pervasives {
+
+    public static final ExecutorService executor_cached = Executors.newCachedThreadPool();
+
+    public static class StaticFuture<V> implements Future<V> {
+    	V v;
+    	
+    	public StaticFuture(V v) { this.v = v;	}
+    	
+    	public boolean cancel(boolean mayInterruptIfRunning) { return false; }
+    	
+    	public boolean isCancelled() { return false; }
+    	
+    	public boolean isDone() { return true; }
+    	
+    	public V get() { return v; }
+    	
+    	public V get(long timeout, TimeUnit unit) { return v; }	
+    }
+	
+    public static class Tuple1 {
+    	public final Object c0;
+    	public Tuple1(Object v) {
+    		c0 = v;
+    	}
+    }
+    
+    public static class Tuple2 {
+    	public final Object c0;
+    	public final Object c1;
+    	public Tuple2(Object v0, Object v1) {
+    		c0 = v0;
+    		c1 = v1;
+    	}
+    }
+    
+    public static class Tuple3 {
+    	public final Object c0;
+    	public final Object c1;
+    	public final Object c2;
+    	public Tuple3(Object v0, Object v1, Object v2) {
+    		c0 = v0;
+    		c1 = v1;
+    		c2 = v2;
+        }
+    }
+    
+    public static class Tuple4 {
+    	public final Object c0;
+    	public final Object c1;
+    	public final Object c2;
+    	public final Object c3;
+    	public Tuple4(Object v0, Object v1, Object v2, Object v3) {
+    		c0 = v0;
+    		c1 = v1;
+    		c2 = v2;
+    		c3 = v3;
+    	}
+    }
+    
+    public static class Tuple5 {
+    	public final Object c0;
+    	public final Object c1;
+    	public final Object c2;
+    	public final Object c3;
+    	public final Object c4;
+    	public Tuple5(Object v0, Object v1, Object v2, Object v3, Object v4) {
+    		c0 = v0;
+    		c1 = v1;
+    		c2 = v2;
+    		c3 = v3;
+    		c4 = v4;
+    	}
+    }
+    
+    public static class Tuple6 {
+    	public final Object c0;
+    	public final Object c1;
+    	public final Object c2;
+    	public final Object c3;
+    	public final Object c4;
+    	public final Object c5;
+    	public Tuple6(Object v0, Object v1, Object v2, Object v3, Object v4, Object v5) {
+    		c0 = v0;
+    		c1 = v1;
+    		c2 = v2;
+    		c3 = v3;
+    		c4 = v4;
+    		c5 = v5;
+    	}
+    }
+    
+    public static class Tuple7 {
+    	public final Object c0;
+    	public final Object c1;
+    	public final Object c2;
+    	public final Object c3;
+    	public final Object c4;
+    	public final Object c5;
+    	public final Object c6;
+    	public Tuple7(Object v0, Object v1, Object v2, Object v3, Object v4, Object v5, Object v6) {
+    		c0 = v0;
+    		c1 = v1;
+    		c2 = v2;
+    		c3 = v3;
+    		c4 = v4;
+    		c5 = v5;
+    		c6 = v6;
+    	}
+    }
+
+    public static int do_stuff(int coeff) {
+        int x = 13;
+        for (int i = 0; i < coeff; i++) {
+            for (int j = 0; j < 1000000; j++) {
+                x = (x + j) % (x + j/x) + 13;
+            }
+        }
+        return x;
+    }
+}

lib/pervasives.epi

@@ -27,4 +27,4 @@ val fun (or)(bool;bool) returns (bool)
 val fun (xor)(bool;bool) returns (bool)
 val fun (~-)(int) returns (int)
 val fun (~-.)(float) returns (float)
-
+val fun do_stuff(int) returns (int)

test/bad/t11-initialization.ept

@@ -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

test/check

@@ -91,7 +91,7 @@ launch_check () {
       score=`expr $score + 1`;
     fi
   done
-
+  echo
   echo "Tests goods"
   for f in ../good/*.ept; do
     echec=0
@@ -114,18 +114,18 @@ launch_check () {
       fi
     fi
     # Compil. java ?
-    if [[ ($echec == 0) && ($java == 1) ]]; then
-      pushd "${base_f}" > /dev/null
-      for java_file in *.java ; do
-        if $JAVAC -warn:-unused -sourcepath .:..:../t1 ${java_file} > /dev/null
-        then
-          echec=0
-        else
-          echec=3
-        fi
-      done
-      popd > /dev/null
-    fi
+    #if [[ ($echec == 0) && ($java == 1) ]]; then
+    #  pushd "${base_f}_java" > /dev/null
+    #  for java_file in *.java ; do
+    #    if $JAVAC -warn:-unused -sourcepath .:..:../t1 ${java_file} > /dev/null
+    #    then
+    #      echec=0
+    #    else
+    #      echec=3
+    #    fi
+    #  done
+    #  popd > /dev/null
+    #fi
     # Compil. c ?
     if [[ ($echec == 0) && ($c == 1) ]]; then
         pushd ${base_f}_c >/dev/null
@@ -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"

test/good/array1.ept

@@ -1,5 +1,5 @@
-const n:int = 42
-const m:int = 52
+const n:int = 10
+const m:int = 10
 
 node concatenate(a:int^n; b:int^m) returns (o1, o2: int^(n+m))
 let
@@ -41,3 +41,13 @@ node constant(a,b:int) returns (o:int^4)
 let
   o = [a,b,a,b];
 tel
+
+
+node test1() returns (r1,r2: int^3)
+var x,y : int^10; z,t : int^20;
+let
+  x = ten(3);
+  y = ten(4);
+  (z,t) = concatenate(x,y);
+  (r1,r2) = slicing(x);
+tel

test/good/array_fill.ept

@@ -1,9 +1,10 @@
 const n : int = 33
 
 node stopbb(shiftenable : bool) returns (dataout : bool^n)
-var last dataint : bool^n = false^n;
+var last dataint : bool^n; f : bool; 
 let
-  dataout = (false^n) fby dataint;
+  f = false;
+  dataout = (f^n) fby dataint;
   switch shiftenable
     | true do dataint = [true] @ dataout[0 .. n - 2];
     | false do

test/good/bad_updown.ept

@@ -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

test/good/flatten.ept

@@ -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;

test/good/statics2.ept

@@ -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
 

test/good/t1.ept

@@ -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)

test/good/t13.ept

@@ -1,7 +1,6 @@
 node count(c : int; r : bool) returns (res : int)
 let
-(*  res = c fby (if r then 0 else res + c);*)
-  res = 0;
+  res = c fby (if r then 0 else res + c);
 tel
 
 node fourth() returns (res : bool)

test/good/t2.ept

@@ -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
 

test/good/t5.ept

@@ -1,6 +1,5 @@
 (* pour debugger
    set arguments -v test/good/t1.mls *)
-type t
 
 node f(x,z:int) returns (o1:int)
    var o: int;

test/good/t9.ept

@@ -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

test/good/test.ept

@@ -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

test/good/when_merge1.ept

@@ -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)

todo.txt

@@ -1,6 +1,12 @@
 
 Plus ou moins ordonné du plus urgent au moins urgent.
 
+*- Bugs related to matching types without unaliasing it. In lots of parts. Use Modules.unalias_type. 
+
+*- Les types des patterns dans les boucles crées par concatenate ( entre autres ) sont faux.
+
+*- Collision entre les noms de params et les idents dans les noeuds.
+
 *- Optimisations du genre "if true then ... else ... " ou genre "x,y = if b then a,c else a2,c" qui devrait etre transformé en "x = if b then a else s2; y = c" ...
 
 *- Optimisation de la traduction des automates : pas besoin de variables de reset pour les états "continue", etc.