Initial commit

Makefile

@@ -0,0 +1,228 @@
+# $Id$
+
+DATE = \`eval date\`
+LIBDIR = \`eval pwd\`/../lib
+BIN = hec
+TARGET = opt
+
+OCAMLFLAGS = -dtypes -g
+OCAMLOPTFLAGS = -dtypes -g
+CPP  = cpp
+#gcc -E
+CPPFLAGS = -P
+SED=sed
+
+# lablgtk
+LABLGTKPREFIX = /usr/lib/ocaml
+LABLGTKFLAGS = -I $(LABLGTKPREFIX)/lablgtk2 -I $(LABLGTKPREFIX)/stublibs
+LABLGTKLINKFLAGS = -dllpath $(LABLGTKPREFIX)/stublibs
+
+OCAMLC = ocamlc
+OCAMLLEX = ocamllex
+OCAMLYACC = ocamlyacc
+OCAMLOPT = ocamlopt
+OCAMLDEP = ocamldep
+
+UNIX = str.cma unix.cma
+UNIXX = str.cmxa unix.cmxa
+INCLUDES =
+
+DIRECTORIES = global parsing analysis translation dataflow sigali sequential  \
+	simulation main
+
+INCLUDES = $(DIRECTORIES:%=-I %)
+
+GENSOURCES = parsing/lexer.ml parsing/parser.mli parsing/parser.ml
+
+GLOBAL = global/names.cmo \
+	global/ident.cmo \
+	global/static.cmo \
+	global/location.cmo \
+	global/misc.cmo \
+	global/linearity.cmo \
+	global/graph.cmo \
+	global/dep.cmo \
+	global/parsetree.cmo \
+	global/heptagon.cmo \
+	global/global.cmo \
+	global/modules.cmo \
+	global/printer.cmo \
+	global/initial.cmo \
+	global/interference_graph.cmo \
+	global/scoping.cmo 
+PARSING = parsing/lexer.cmo \
+	parsing/parser.cmo
+ANALYSIS = analysis/typing.cmo \
+	analysis/causal.cmo \
+	analysis/causality.cmo \
+	analysis/interface.cmo \
+	analysis/initialization.cmo \
+	analysis/linear_typing.cmo \
+	analysis/automata_mem.cmo
+TRANSLATION = translation/completion.cmo \
+	translation/automata.cmo \
+	translation/present.cmo \
+	translation/last.cmo  \
+	translation/reset.cmo \
+	translation/reset_new.cmo \
+	translation/every.cmo 
+#	translation/inline.cmo
+DATAFLOW = dataflow/minils.cmo \
+	dataflow/merge.cmo \
+	dataflow/dfcausality.cmo \
+	dataflow/normalize.cmo \
+	dataflow/schedule.cmo \
+	dataflow/clocking.cmo \
+	dataflow/intermediate.cmo \
+	dataflow/cse.cmo \
+	dataflow/cmse.cmo \
+	dataflow/tomato.cmo \
+	dataflow/tommls.cmo \
+	dataflow/deadcode.cmo \
+	dataflow/mls2dot.cmo \
+	dataflow/interference2dot.cmo \
+	dataflow/interference.cmo \
+	dataflow/memalloc.cmo \
+	dataflow/splitting.cmo \
+	dataflow/schedule_interf.cmo \
+	dataflow/callgraph.cmo
+#	dataflow/init.cmo
+SIGALI = sigali/boolean.cmo \
+	sigali/sigali.cmo \
+	sigali/dynamic_system.cmo
+SEQUENTIAL = sequential/obc.cmo \
+	sequential/control.cmo \
+	sequential/translate.cmo \
+	sequential/c_old.cmo \
+	sequential/caml.cmo \
+	sequential/java.cmo \
+	sequential/c.cmo \
+	sequential/csubst.cmo \
+	sequential/rename.cmo \
+	sequential/cgen.cmo \
+	sequential/vhdl.cmo \
+	sequential/mls2vhdl.cmo 
+#       sequential/lustre.cmo
+MAIN = main/compiler.cmo \
+	main/main.cmo
+
+OBJ = $(GLOBAL) $(MODULES) $(PARSING) $(ANALYSIS) $(TRANSLATION) \
+			$(DATAFLOW) $(SEQUENTIAL) $(MAIN) \
+	$(SIMULATION)
+
+OBJ_OPT = $(OBJ:.cmo=.cmx)
+
+SRC = $(OBJ:.cmo=.ml)
+
+INTERFACES = $(SRC:.ml=.mli)
+
+SIM_BIN = hes
+
+# Objs needed for compiling simulator
+SIM_OBJ = global/misc.cmo \
+	global/heptagon.cmo \
+	global/global.cmo \
+	global/modules.cmo \
+	simulation/simulator.cmo
+SIM_LIBS = lablgtk.cma unix.cma
+
+SIM_OBJ_OPT = $(SIM_OBJ:.cmo=.cmx)
+
+SIM_LIBS_OPT = $(SIM_LIBS:.cma=.cmxa)
+
+world: all
+
+all: $(TARGET)
+
+opt: $(BIN).opt
+byte: $(BIN).byte
+
+$(BIN).opt: $(OBJ_OPT)
+	$(OCAMLOPT) $(UNIXX) $(OCAMLOPTFLAGS) $(INCLUDES) $(OBJ_OPT) -o $(BIN).opt
+
+$(BIN).byte: $(OBJ)
+	$(OCAMLC) -custom $(UNIX) $(OCAMLFLAGS) $(INCLUDES) $(OBJ) -o $(BIN).byte
+
+sim: $(SIM_BIN).byte
+simopt:$(SIM_BIN).opt
+
+$(SIM_BIN).opt: $(SIM_OBJ_OPT)
+	$(OCAMLOPT) $(OCAMLOPTFLAGS) \
+		$(LABLGTKFLAGS) \
+		$(INCLUDES) $(SIM_LIBS_OPT) $(SIM_OBJ_OPT) -o $(SIM_BIN).opt
+$(SIM_BIN).byte: $(SIM_OBJ)
+	$(OCAMLC) -custom $(UNIX) $(OCAMLFLAGS) \
+		$(LABLGTKFLAGS) $(LABLGTKLINKFLAGS) \
+		$(INCLUDES) $(SIM_LIBS) $(SIM_OBJ) -o $(SIM_BIN).byte
+
+
+debug: OCAMLFLAGS += -g
+debug: byte
+
+profile: OCAMLOPTFLAGS += -p
+profile: opt
+
+depend .depend: $(GENSOURCES)
+	(for d in $(DIRECTORIES); \
+		do $(OCAMLDEP) $(INCLUDES) $$d/*.mli $$d/*.ml; \
+		done) > .depend
+
+interfaces: $(INTERFACES)
+
+# Extra dependences
+parsing/parser.mli parsing/parser.ml: parsing/parser.mly
+	$(OCAMLYACC) -v parsing/parser.mly
+
+parsing/lexer.cmi: parsing/parser.mli
+
+parsing/lexer.ml: parsing/lexer.mll
+	$(OCAMLLEX) parsing/lexer.mll
+
+global/misc.cmo: OCAMLFLAGS := \
+	-pp "$(SED) -e \"s|DATE|`date`|\" -e \"s|STDLIB|$(LIBDIR)|\""
+# -pp "$(CPP) $(CPPFLAGS) -DSTDLIB=\\\"$(LIBDIR)\\\" \
+# -DDATE=\\\"\"`date`\"\\\""
+
+global/misc.cmx: OCAMLOPTFLAGS := \
+	-pp "$(SED) -e \"s|DATE|`date`|\" -e \"s|STDLIB|$(LIBDIR)|\""
+#	-pp "$(CPP) $(CPPFLAGS) -DSTDLIB=\\\"$(LIBDIR)\\\" \
+#	-DDATE=\\\"\"`date`\"\\\""
+
+simulation/simulator.cmo: OCAMLFLAGS += $(LABLGTKFLAGS)
+
+simulation/simulator.cmx: OCAMLOPTFLAGS += $(LABLGTKFLAGS)
+
+# Common rules
+.SUFFIXES : .mli .ml .cmi .cmo .cmx
+
+%.cmo: %.ml
+	$(OCAMLC) $(OCAMLFLAGS) -c $(INCLUDES) $<
+
+%.cmi: %.mli
+	$(OCAMLC) $(OCAMLFLAGS) -c $(INCLUDES) $<
+
+%.cmx: %.ml
+	$(OCAMLOPT) $(OCAMLOPTFLAGS) -c $(INCLUDES) $<
+
+# %.mli: %.ml
+# 	$(OCAMLC) $(OCAMLFLAGS) -i -c $(INCLUDES) $< > $@
+
+
+
+# Clean up
+clean:
+	rm -f $(GENSOURCES) parsing/parser.output
+        # to avoid the make warnings:
+	rm -f parsing/parser.ml
+	rm -f parsing/lexer.ml
+	(for d in $(DIRECTORIES); \
+		do rm -f $$d/*.annot $$d/*.cm[iox] $$d/*.o; \
+		done)
+	rm -f $(BIN).byte $(BIN).opt
+
+ML = $(OBJ:.cmo=.ml)
+
+wc:
+	wc $(ML)
+
+include .depend

_tags

@@ -0,0 +1,4 @@
+<**/*.ml>: debug, dtypes
+<global/misc.ml>: camlp4o, use_preproc
+<preproc.ml>: camlp4of, use_camlp4
+<**/*.{byte,native}>: use_unix, use_str, debug

global/global.ml

@@ -0,0 +1,68 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* global data in the symbol tables *)
+(* $Id$ *)
+open Names
+open Ident
+open Linearity
+open Heptagon
+open Static
+
+(** Warning: Whenever these types are modified, 
+    interface_format_version in misc.ml should be incremented. *)
+type arg_dec = 
+    { a_type : ty;
+      a_name : name option;
+      a_linearity : linearity;
+      a_pass_by_ref: bool; }
+
+type sig_desc = 
+    { inputs : arg_dec list;
+      outputs : arg_dec list;
+      contract : contract option;
+      node : bool;
+      safe : bool; 
+      targeting : (int*int) list; 
+      params: name list;
+      params_constraints : size_constr list; }
+
+and field_desc =
+    { arg: base_ty; (* if x:arg then x.m: res *)
+      res: base_ty;
+    }
+
+and struct_desc = 
+    { fields : (name * base_ty) list; }
+
+and typ_desc =
+    | Tabstract
+    | Tenum of name list
+    | Tstruct of (name * base_ty) list
+
+type 'a info = { qualid : qualident; info : 'a }
+
+type ivar =
+  | IVar of ident
+  | IField of ident * longname
+
+(** [filter_vars l] returns a list of variables identifiers from
+    a list of ivar.*)
+let rec filter_vars = function
+  | [] -> []
+  | (IVar id)::l -> id::(filter_vars l)
+  | _::l -> filter_vars l
+
+let names l =
+  List.map (fun ad -> ad.a_name) l
+
+let types l =
+  List.map (fun ad -> ad.a_type) l
+
+let linearities l =
+  List.map (fun ad -> ad.a_linearity) l

global/ident.ml

@@ -0,0 +1,71 @@
+(* naming and local environment *)
+
+type ident = {
+  num : int;        (* a unique index *)
+  source : string;  (* the original name in the source *)
+  is_generated : bool;
+}
+
+let compare id1 id2 = compare id1.num id2.num
+let sourcename id = id.source
+let name id = 
+  if id.is_generated then
+    id.source ^ "_" ^ (string_of_int id.num)
+  else
+    id.source
+
+let set_sourcename id v =
+  { id with source = v }
+
+let num = ref 0
+let fresh s = 
+  num := !num + 1; 
+  { num = !num; source = s; is_generated = true }
+
+let ident_of_var s = 
+  num := !num + 1; 
+  { num = !num; source = s; is_generated = false }
+
+let fprint_t ff id = Format.fprintf ff "%s" (name id)
+
+module M = struct
+  type t = ident
+  let compare = compare
+  let fprint = fprint_t
+end
+
+module Env =
+struct
+  include (Map.Make(M))
+
+  let append env0 env =
+    fold (fun key v env -> add key v env) env0 env
+
+  (* Environments union *)
+  let union env1 env2 =
+    fold (fun name elt env -> add name elt env) env2 env1
+      
+  (* Environments difference : env1 - env2 *)
+  let diff env1 env2 =
+    fold (fun name _ env -> remove name env) env2 env1
+      
+  (* Environments partition *)
+  let partition p env =
+    fold
+      (fun key elt (env1,env2) ->
+	 if p(key)
+	 then ((add key elt env1),env2)
+       else (env1,(add key elt env2)))
+      env
+      (empty, empty)
+end
+
+module IdentSet = struct
+  include (Set.Make(M))
+
+  let fprint_t ff s =
+    Format.fprintf ff "@[<hov>{@ ";
+    iter (fun e -> Format.fprintf ff "%a@ " M.fprint e) s;
+    Format.fprintf ff "}@]";
+end
+

global/ident.mli

@@ -0,0 +1,35 @@
+(** The (abstract) type of identifiers*)
+type ident 
+
+(** Get the source name from an identifier*)
+val sourcename : ident -> string
+(** Get the full name of an identifier (it is
+    guaranteed to be unique)*)
+val name : ident -> string
+(** [set_sourcename id v] returns id with its
+    source name changed to v. *)
+val set_sourcename : ident -> string -> ident
+
+(** [fresh n] returns a fresh identifier with source name n *)
+val fresh : string -> ident
+(** [ident_of_var n] returns an identifier corresponding
+    to a _source_ variable (do not use it for generated variables). *)
+val ident_of_var : string -> ident
+
+(** Maps taking an identifier as a key. *)
+module Env :
+  sig
+    include (Map.S with type key = ident)
+
+    val append : 'a t -> 'a t -> 'a t
+    val union : 'a t -> 'a t -> 'a t
+    val diff : 'a t -> 'b t -> 'a t
+    val partition : (key -> bool) -> 'a t -> 'a t * 'a t
+  end
+
+(** A set of identifiers. *)
+module IdentSet :
+  sig
+    include (Set.S with type elt = ident)
+    val fprint_t : Format.formatter -> t -> unit
+  end

global/initial.ml

@@ -0,0 +1,31 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* initialization of the typing environment *)
+
+(* $Id$ *)
+
+open Misc
+open Names
+open Global
+open Modules
+
+let tglobal = []
+let cglobal = []
+
+let pbool = Modname({ qual = "Pervasives"; id = "bool" })
+let ptrue = Modname({ qual = "Pervasives"; id = "true" })
+let pfalse = Modname({ qual = "Pervasives"; id = "false" })
+let por = Modname({ qual = "Pervasives"; id = "or" })
+let pint = Modname({ qual = "Pervasives"; id = "int" })
+let pfloat = Modname({ qual = "Pervasives"; id = "float" })
+
+(* build the initial environment *)
+let initialize () =
+  List.iter (fun (f, ty) -> add_type f ty) tglobal;
+  List.iter (fun (f, ty) -> add_constr f ty) cglobal

global/location.ml

@@ -0,0 +1,157 @@
+(* Printing a location in the source program *)
+(* taken from the source of the Caml Light 0.73 compiler *)
+
+(* $Id$ *)
+
+open Lexing
+open Parsing
+
+(* two important global variables: [input_name] and [input_chan] *)
+type location =
+    Loc of int     (* Position of the first character *)
+         * int     (* Position of the next character following the last one *)
+
+
+
+let input_name = ref ""                 (* Input file name. *)
+
+let input_chan = ref stdin             (* The channel opened on the input. *)
+
+let initialize iname ic =
+  input_name := iname;
+  input_chan := ic
+
+
+let no_location =  Loc(0,0)
+
+
+let error_prompt = ">"
+
+let get_current_location () =
+  Loc(symbol_start(), symbol_end())
+
+
+let output_lines oc char1 char2 charline1 line1 line2 =
+  let n1 = char1 - charline1
+  and n2 = char2 - charline1 in
+    if line2 > line1 then
+      Printf.fprintf oc 
+        ", line %d-%d, characters %d-%d:\n" line1 line2 n1 n2
+    else
+      Printf.fprintf oc ", line %d, characters %d-%d:\n" line1 n1 n2;
+    ()
+
+
+let output_loc oc input seek line_flag (Loc(pos1, pos2)) =
+  let pr_chars n c =
+    for i = 1 to n do output_char oc c done in
+  let skip_line () =
+    try
+      while input() != '\n' do () done
+    with End_of_file -> () in
+  let copy_line () =
+    let c = ref ' ' in
+      begin try
+        while c := input(); !c != '\n' do output_char oc !c done
+      with End_of_file ->
+        output_string oc "<EOF>"
+      end;
+      output_char oc '\n' in
+  let pr_line first len ch =
+    let c = ref ' '
+    and f = ref first
+    and l = ref len in
+      try
+        while c := input (); !c != '\n' do
+	  if !f > 0 then begin
+            f := !f - 1;
+            output_char oc (if !c == '\t' then !c else ' ')
+          end
+          else if !l > 0 then begin
+            l := !l - 1;
+            output_char oc (if !c == '\t' then !c else ch)
+          end
+          else ()
+        done
+      with End_of_file ->
+        if !f = 0 && !l > 0 then pr_chars 5 ch in
+  let pos = ref 0
+  and line1 = ref 1
+  and line1_pos = ref 0
+  and line2 = ref 1
+  and line2_pos = ref 0 in
+  seek 0;
+  begin try
+    while !pos < pos1 do
+      incr pos;
+      if input() == '\n' then begin incr line1; line1_pos := !pos; () end
+    done
+  with End_of_file -> ()
+  end;
+  line2 := !line1;
+  line2_pos := !line1_pos;
+  begin try
+    while !pos < pos2 do
+      incr pos;
+      if input() == '\n' then
+        begin incr line2; line2_pos := !pos; () end
+    done
+  with End_of_file -> ()
+  end;
+  if line_flag then output_lines oc pos1 pos2 !line1_pos !line1 !line2;
+  if !line1 == !line2 then begin
+    seek !line1_pos;
+    output_string oc error_prompt;
+    copy_line ();
+    seek !line1_pos;
+    output_string oc error_prompt;
+    pr_line (pos1 - !line1_pos) (pos2 - pos1) '^';
+    output_char oc '\n'
+  end else begin
+    seek !line1_pos;
+    output_string oc error_prompt;
+    pr_line 0 (pos1 - !line1_pos) '.';
+    seek pos1;
+    copy_line();
+    if !line2 - !line1 <= 8 then
+      for i = !line1 + 1 to !line2 - 1 do
+        output_string oc error_prompt;
+        copy_line()
+      done
+    else
+      begin
+        for i = !line1 + 1 to !line1 + 3 do
+          output_string oc error_prompt;
+          copy_line()
+        done;
+        output_string oc error_prompt; output_string oc "..........\n";
+        for i = !line1 + 4 to !line2 - 4 do skip_line() done;
+        for i = !line2 - 3 to !line2 - 1 do
+          output_string oc error_prompt;
+          copy_line()
+        done
+      end;
+    begin try
+      output_string oc error_prompt;
+      for i = !line2_pos to pos2 - 1 do
+        output_char oc (input())
+      done;
+      pr_line 0 100 '.'
+    with End_of_file -> output_string oc "<EOF>"
+    end;
+    output_char oc '\n'
+  end
+
+
+let output_location oc loc =
+  let p = pos_in !input_chan in
+  Printf.fprintf oc "File \"%s\"" !input_name;
+  output_loc
+    oc (fun () -> input_char !input_chan) (seek_in !input_chan) true
+    loc;
+  seek_in !input_chan p
+  
+
+let output_input_name oc =
+  Printf.fprintf oc "File \"%s\", line 1:\n" !input_name
+

global/modules.ml

@@ -0,0 +1,155 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* global symbol tables *)
+
+(* $Id$ *)
+
+open Misc
+open Heptagon
+open Global
+open Names
+
+exception Already_defined
+
+exception Cannot_find_file of string
+  
+(** Warning: Whenever this type is modified, 
+    interface_format_version in misc.ml should be incremented. *)
+type env =
+    { mutable name: string;
+      mutable values: sig_desc NamesEnv.t;
+      mutable types: typ_desc NamesEnv.t;
+      mutable constr: base_ty NamesEnv.t;
+      mutable field: field_desc NamesEnv.t;
+      mutable structs : struct_desc NamesEnv.t;
+      format_version : string;
+    }
+      
+type modules =
+    { current: env;                (* associated symbol table *)
+      mutable opened: env list;    (* opened tables *)
+      mutable modules: env NamesEnv.t;  (* tables loaded in memory *)
+    }
+      
+let current = 
+  { name = ""; values = NamesEnv.empty; types = NamesEnv.empty; 
+    constr = NamesEnv.empty; field = NamesEnv.empty; structs = NamesEnv.empty;
+    format_version = interface_format_version }
+    
+let modules = 
+  { current = current; opened = []; modules = NamesEnv.empty }
+    
+let findfile 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
+    
+let load_module modname =
+  let name = String.uncapitalize modname in
+    try
+      let filename = findfile (name ^ ".epci") in
+      let ic = open_in_bin filename in
+	try
+	  let m:env = input_value ic in
+	    if m.format_version <> interface_format_version then (
+	      Printf.eprintf "The file %s was compiled with \
+                       an older version of the compiler.\n \
+                       Please recompile %s.ept first.\n" filename name;
+	      raise Error
+	    );
+	    close_in ic;
+	    m
+	with
+	  | End_of_file | Failure _ ->
+	      close_in ic;
+	      Printf.eprintf "Corrupted compiled interface file %s.\n\
+                        Please recompile %s.ept first.\n" filename name;
+	      raise Error
+    with
+      | Cannot_find_file(filename) ->
+	  Printf.eprintf "Cannot find the compiled interface file %s.\n"
+	    filename;
+	  raise Error
+	    
+let find_module modname =
+  try
+    NamesEnv.find modname modules.modules
+  with
+      Not_found ->
+	let m = load_module modname in
+	  modules.modules <- NamesEnv.add modname m modules.modules;
+	  m
+	    
+let find where qualname =
+    let rec findrec ident = function
+      | [] -> raise Not_found
+      | m :: l ->
+	  try { qualid = { qual = m.name; id = ident };
+		info = where ident m }
+	  with Not_found -> findrec ident l in
+      
+      match qualname with
+	| Modname({ qual = m; id = ident } as q) -> 
+	    let current = if current.name = m then current else find_module m in
+	    { qualid = q; info = where ident current }
+	| Name(ident) -> findrec ident (current :: modules.opened)
+	    
+(* exported functions *)
+let open_module modname =
+  let m = find_module modname in
+  modules.opened <- m :: modules.opened
+      
+let initialize modname = 
+  current.name <- modname;
+  List.iter open_module !default_used_modules
+  
+let add_value f signature = 
+  if NamesEnv.mem f current.values then raise Already_defined;
+  current.values <- NamesEnv.add f signature current.values
+let add_type f typ_desc =
+  if NamesEnv.mem f current.types then raise Already_defined;
+  current.types <- NamesEnv.add f typ_desc current.types
+let add_constr f ty_res =
+  if NamesEnv.mem f current.constr then raise Already_defined;
+  current.constr <- NamesEnv.add f ty_res current.constr
+let add_field f ty_arg ty_res =
+  if NamesEnv.mem f current.field then raise Already_defined;
+  current.field <- NamesEnv.add f { arg = ty_arg; res = ty_res } current.field
+let add_struct f fields =
+  if NamesEnv.mem f current.structs then raise Already_defined;
+  current.structs <- NamesEnv.add f { fields = fields } current.structs    
+
+let find_value = find (fun ident m -> NamesEnv.find ident m.values)
+let find_type = find (fun ident m -> NamesEnv.find ident m.types)
+let find_constr = find (fun ident m -> NamesEnv.find ident m.constr)
+let find_field = find (fun ident m -> NamesEnv.find ident m.field)
+let find_struct = find (fun ident m -> NamesEnv.find ident m.structs)
+  
+let replace_value f signature =
+  current.values <- NamesEnv.remove f current.values;
+  current.values <- NamesEnv.add f signature current.values
+
+let write oc = output_value oc current
+
+let longname n = Modname({ qual = current.name; id = n })
+let currentname longname =
+  match longname with
+    | Name(n) -> longname
+    | Modname{ qual = q; id = id} -> 
+	if current.name = q then Name(id) else longname
+

global/names.ml

@@ -0,0 +1,41 @@
+(* long identifiers *)
+
+type name = string
+
+type longname =
+    | Name of name
+    | Modname of qualident
+
+and qualident = { qual: string; id: string }
+
+module NamesM = struct
+  type t = name
+  let compare = compare
+end
+
+module NamesEnv =
+struct
+  include (Map.Make(NamesM))
+
+  let append env0 env =
+    fold (fun key v env -> add key v env) env0 env
+end
+
+module S = Set.Make (struct type t = string let compare = compare end)
+
+let shortname = function
+  | Name s -> s
+  | Modname { id = id; } -> id
+
+let fullname = function
+  | Name s -> s
+  | Modname { qual = qual; id = id; } -> qual ^ "." ^ id
+
+let mk_longname s =
+  try
+    let ind = String.index s '.' in
+    let id = String.sub s (ind + 1) (String.length s - ind - 1) in
+    Modname { qual = String.sub s 0 ind; id = id; }
+  with Not_found -> Name s
+
+let fprint_t ff id = Format.fprintf ff "%s" (fullname id)

global/static.ml

@@ -0,0 +1,176 @@
+(** This module defines static expressions, used in arrays definition and anywhere 
+    a static value is expected. For instance:
+    const n:int = 3;
+    var x : int^n; var y : int^(n+2);
+    x[n-1], x[1+3],...
+*)
+open Names
+open Format
+
+type op = SPlus | SMinus | STimes | SDiv
+
+type size_exp =
+  | SConst of int
+  | SVar of name
+  | SOp of op * size_exp * size_exp
+
+(** Constraints on size expressions. *)
+type size_constr =
+  | Equal of size_exp * size_exp (* e1 = e2*)
+  | LEqual of size_exp * size_exp (* e1 <= e2 *)
+  | False (* unsatisfiable constraint *)
+
+exception Instanciation_failed 
+exception Not_static
+
+(** Returns the op from an operator full name. *)
+let op_from_app_name n =
+  match n with
+    | Modname({ qual = "Pervasives"; id = "+" }) | Name "+" -> SPlus
+    | Modname({ qual = "Pervasives"; id = "-" }) | Name "-" -> SMinus
+    | Modname({ qual = "Pervasives"; id = "*" }) | Name "*" -> STimes
+    | Modname({ qual = "Pervasives"; id = "/" }) | Name "/" -> SDiv
+    | _ -> raise Not_static
+
+(** [simplify env e] returns e simplified with the
+    variables values taken from env (mapping vars to integers).
+    Variables are replaced with their values and every operator
+    that can be computed is replaced with the value of the result. *)
+let rec simplify env = function
+  | SConst n -> SConst n
+  | SVar id -> 
+      (try 
+	simplify env (NamesEnv.find id env) 
+      with
+	  _ -> SVar id
+      )
+  | SOp(op, e1, e2) ->
+      let e1 = simplify env e1 in
+      let e2 = simplify env e2 in
+	(match e1, e2 with
+	   | SConst n1, SConst n2 -> 
+	       let n = (match op with
+		  | SPlus -> n1 + n2
+		  | SMinus -> n1 - n2
+		  | STimes -> n1 * n2
+		  | SDiv ->
+		      if n2 = 0 then
+			raise Instanciation_failed
+		      else
+			n1 / n2
+	       ) in
+		 SConst n
+	   | _, _ -> SOp(op, e1, e2)
+	)
+
+(** [int_of_size_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_size_exp env e =
+  match simplify env e with
+    | SConst n -> n
+    | _ -> raise Instanciation_failed      
+
+(** [is_true env constr] returns whether the constraint is satisfied
+    in the environment (or None if this can be decided)
+    and a simplified constraint. *)
+let is_true env = function
+  | Equal (e1,e2) when e1 = e2 -> 
+      Some true, Equal (simplify env e1, simplify env e2)
+  | Equal (e1, e2) ->
+      let e1 = simplify env e1 in
+      let e2 = simplify env e2 in
+	(match e1, e2 with
+	   | SConst n1, SConst n2 ->
+	       Some (n1 = n2), Equal (e1,e2)
+	   | _, _ -> None, Equal (e1,e2)
+	)
+  | LEqual (e1, e2) ->
+      let e1 = simplify env e1 in
+      let e2 = simplify env e2 in
+	(match e1, e2 with
+	   | SConst n1, SConst n2 ->
+	       Some (n1 <= n2), LEqual (e1,e2)
+	   | _, _ -> None, LEqual (e1,e2)
+	)
+  | False -> None, False
+
+exception Solve_failed of size_constr
+(** [solve env constr_list solves a list of constraints. It
+    removes equations that can be decided and simplify others. 
+    If one equation cannot be satisfied, it raises Solve_failed. ]*)
+let rec solve const_env = function
+  | [] -> []
+  | c::l -> 
+      let l = solve const_env l in
+      let res, c = is_true const_env c in
+	(match res with
+	   | None -> c::l
+	   | Some v -> if not v then raise (Solve_failed c) else l
+	)
+
+(** Substitutes variables in the size exp with their value
+    in the map (mapping vars to size exps). *)
+let rec size_exp_subst m = function
+  | SVar n ->
+      (try 
+	List.assoc n m
+      with 
+	  Not_found -> SVar n
+      )
+  | SOp(op,e1,e2) -> SOp(op, size_exp_subst m e1, size_exp_subst m e2)
+  | s -> s
+
+(** Substitutes variables in the constraint list with their value
+    in the map (mapping vars to size exps). *)
+let instanciate_constr m constr =
+  let replace_one m = function
+    | Equal(e1,e2) -> Equal(size_exp_subst m e1, size_exp_subst m e2)
+    | LEqual(e1,e2) -> LEqual(size_exp_subst m e1, size_exp_subst m e2)
+  in
+    List.map (replace_one m) constr 
+
+let op_to_string = function
+  | SPlus -> "+"
+  | SMinus -> "-"
+  | STimes -> "*"
+  | SDiv -> "/"
+
+let rec print_size_exp ff = function
+  | SConst i -> fprintf ff "%d" i
+  | SVar id -> fprintf ff "%s" id
+  | SOp (op, e1, e2) ->
+      fprintf ff "@[(";
+      print_size_exp ff e1;
+      fprintf ff " %s " (op_to_string op);
+      print_size_exp ff e2;
+      fprintf ff ")@]"
+
+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_size_constr ff = function
+  | Equal (e1, e2) ->      
+      fprintf ff "@[";
+      print_size_exp ff e1;
+      fprintf ff " = ";
+      print_size_exp ff e2;
+      fprintf ff "@]"
+  | LEqual (e1, e2) ->      
+      fprintf ff "@[";
+      print_size_exp ff e1;
+      fprintf ff " <= ";
+      print_size_exp ff e2;
+      fprintf ff "@]"
+  | False ->
+      fprintf ff "False"
+
+let psize_constr oc c =
+  let ff = formatter_of_out_channel oc in
+    print_size_constr ff c; fprintf ff "@?"

heptagon/analysis/automata_mem.ml

@@ -0,0 +1,43 @@
+open Ident
+open Names
+open Heptagon
+open Interference_graph
+
+let node_for_name s g =
+  try
+    node_for_value g s
+  with
+      Not_found -> 
+	let n = mk_node s in
+	  add_node g n;
+	  n
+
+let find_reset_jumps g sh =
+  let reset_escape state esc =
+    if esc.e_reset = true then 
+      ( Format.printf "Jump from %s to %s with reset\n" state esc.e_next_state;
+	let n1 = node_for_name state g in
+	let n2 = node_for_name esc.e_next_state g in
+	  add_interference_link n1 n2
+      ) else
+      (Format.printf "Jump from %s to %s is not resetted\n" state esc.e_next_state;
+      	let n1 = node_for_name state g in
+	let n2 = node_for_name esc.e_next_state g in
+	  add_affinity_link n1 n2
+      )
+  in
+    List.iter (reset_escape sh.s_state) sh.s_until
+
+let share_eq g eq =
+  match eq.eq_desc with
+    | Eautomaton sh_list ->
+	List.iter (find_reset_jumps g) sh_list
+    | _ -> Format.printf "Ignoring unsupported eq\n"
+
+let node f =
+  let g = mk_graph [] f.n_name in
+    List.iter (share_eq g) f.n_equs;
+    { f with n_states_graph = g; }
+
+let program p =
+  { p with p_nodes = List.map node p.p_nodes }

heptagon/analysis/causal.ml

@@ -0,0 +1,280 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* causality check of scheduling constraints *)
+
+(* $Id: causal.ml 615 2009-11-20 17:43:14Z pouzet $ *)
+
+open Misc
+open Names
+open Ident
+open Heptagon
+open Location
+open Graph
+open Format
+
+(* x = x + 1 is rejected because read(x) < write(x) is not causal *)
+(* build a dependency graph an checks for cycles *)
+(* for the moment, the # constructor is distributed which leads to a *)
+(* sub-optimal algorithm. *)
+
+(* constraints [c] are normalised into [a1 # ... # an] st: *)
+(* a ::= write(x) | read(x) | last(x) | a < a | a || a *)
+(* c ::= a # ... # a *)
+(* a constraint [a] is causal if its dependence graph is acyclic *)
+
+(* scheduling constraints *)
+type sc =
+  | Cor of sc * sc
+  | Cand of sc * sc
+  | Cseq of sc * sc
+  | Ctuple of sc list
+  | Cwrite of ident
+  | Cread of ident
+  | Clinread of ident
+  | Clastread of ident
+  | Cempty
+
+(* normalized constraints *)
+type ac =
+    | Awrite of ident
+    | Alinread of ident
+    | Aread of ident
+    | Alastread of ident
+    | Aseq of ac * ac
+    | Aand of ac * ac
+    | Atuple of ac list
+
+and nc =
+    | Aor of nc * nc
+    | Aac of ac
+    | Aempty
+
+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 output_ac ff ac =
+  let rec print priority ff ac =
+    fprintf ff "@[<hov 0>";
+    begin match ac with
+      | Aseq(ac1, ac2) ->
+          (if priority > 1
+          then fprintf ff "(%a@ < %a)"
+            else fprintf ff "%a@ < %a")
+            (print 1) ac1 (print 1) ac2
+      | Aand(ac1, ac2) ->
+          (if priority > 0
+          then fprintf ff "(%a || %a)"
+            else fprintf ff "%a || %a")
+            (print 0) ac1 (print 0) ac2
+      | Atuple(acs) ->
+	  fprintf ff "(";
+	  print_list ff (print 1) ", " acs ;
+	  fprintf ff ")"
+      | Awrite(m) -> fprintf ff "%s" (sourcename m)
+      | Aread(m) -> fprintf ff "^%s" (sourcename m)
+      | Alinread(m) -> fprintf ff "*%s" (sourcename m)
+      | Alastread(m) -> fprintf ff "last %s" (sourcename m)
+    end;
+    fprintf ff "@]" in
+    fprintf ff "@[%a@]@?" (print 0) ac
+
+
+type error =  Ecausality_cycle of ac
+
+exception Error of error
+
+let error kind = raise (Error(kind))
+
+let message loc kind =
+  let output_ac oc ac = 
+    let ff = formatter_of_out_channel oc in output_ac ff ac in
+    begin match kind with
+    | Ecausality_cycle(ac) ->
+        Printf.eprintf
+          "%aCausality error: the following constraint is not causal.\n%a\n."
+          output_location loc
+          output_ac ac
+  end;
+  raise Misc.Error
+
+let cor nc1 nc2 =
+  match nc1, nc2 with
+    | Aempty, Aempty -> Aempty
+    | _ -> Aor(nc1, nc2)
+
+let rec cseq nc1 nc2 =
+  match nc1, nc2 with
+    | Aempty, _ -> nc2
+    | _, Aempty -> nc1
+    | Aor(nc1, nc11), nc2 -> Aor(cseq nc1 nc2, cseq nc11 nc2)
+    | nc1, Aor(nc2, nc22) -> Aor(cseq nc1 nc2, cseq nc1 nc22)
+    | Aac(ac1), Aac(ac2) -> Aac(Aseq(ac1, ac2))
+
+let rec cand nc1 nc2 =
+  match nc1, nc2 with
+    | Aempty, _ -> nc2 | _, Aempty -> nc1
+    | Aor(nc1, nc11), nc2 -> Aor(cand nc1 nc2, cand nc11 nc2)
+    | nc1, Aor(nc2, nc22) -> Aor(cand nc1 nc2, cand nc1 nc22)
+    | Aac(ac1), Aac(ac2) -> Aac(Aand(ac1, ac2))
+
+let rec ctuple l = 
+  let conv = function
+    | Cwrite(n) -> Awrite(n)
+    | Cread(n) -> Aread(n)
+    | Clinread(n) -> Alinread(n)
+    | Clastread(n) -> Alastread(n)
+    | Ctuple(l) -> Atuple (ctuple l)
+    | Cand _ -> Format.printf "Unexpected and\n"; assert false
+    | Cseq _ -> Format.printf "Unexpected seq\n"; assert false
+    | Cor _ -> Format.printf "Unexpected or\n"; assert false
+    | _ -> assert false
+  in
+    match l with
+      | [] -> []
+      | Cempty::l -> ctuple l
+      | v::l -> (conv v)::(ctuple l)
+
+let rec norm = function
+  | Cor(c1, c2) -> cor (norm c1) (norm c2)
+  | Cand(c1, c2) -> cand (norm c1) (norm c2)
+  | Cseq(c1, c2) -> cseq (norm c1) (norm c2)
+  | Ctuple l -> Aac(Atuple (ctuple l))
+  | Cwrite(n) -> Aac(Awrite(n))
+  | Cread(n) -> Aac(Aread(n))
+  | Clinread(n) -> Aac(Alinread(n))
+  | Clastread(n) -> Aac(Alastread(n))
+  | _ -> Aempty
+
+(* building a dependence graph from a scheduling constraint *)
+let build ac =
+  (* associate a graph node for each name declaration *)
+  let nametograph n g n_to_graph = Env.add n g n_to_graph in
+
+  let rec associate_node g (n_to_graph,lin_map) = function
+    | Awrite(n) ->
+        nametograph n g n_to_graph, lin_map
+    | Alinread(n) ->
+	n_to_graph, nametograph n g lin_map
+    | Atuple l ->
+	List.fold_left (associate_node g) (n_to_graph, lin_map) l
+    | _ -> 
+	n_to_graph, lin_map
+  in
+
+  (* first build the association [n -> node] *)
+  (* for every defined variable *)
+  let rec initialize ac n_to_graph lin_map =
+    match ac with
+      | Aand(ac1, ac2) ->
+          let n_to_graph, lin_map = initialize ac1 n_to_graph lin_map in
+            initialize ac2 n_to_graph lin_map
+      | Aseq(ac1, ac2) ->
+          let n_to_graph, lin_map = initialize ac1 n_to_graph lin_map in
+            initialize ac2 n_to_graph lin_map
+      | _ ->
+          let g = make ac in
+	    associate_node g (n_to_graph, lin_map) ac
+  in
+
+  let make_graph ac n_to_graph lin_map =
+    let attach node n =
+      try
+        let g = Env.find n n_to_graph in add_depends node g
+      with
+        | Not_found -> () in
+
+    let attach_lin node n =
+      try
+        let g = Env.find n lin_map in add_depends g node
+      with
+        | Not_found -> () in     
+
+    let rec add_dependence g = function
+        | Aread(n) -> attach g n; attach_lin g n
+	| Alinread(n) -> let g = Env.find n lin_map in attach g n
+	| Atuple l -> List.iter (add_dependence g) l
+	| _ -> ()
+    in
+
+    let rec node_for_ac ac =
+      let rec node_for_tuple = function
+	| [] -> raise Not_found
+	| v::l -> 
+	    (try 
+	       node_for_ac v
+	    with
+		Not_found -> node_for_tuple l
+	    )
+      in 
+	match ac with 
+	  | Alinread n -> Env.find n lin_map
+	  | Awrite n -> Env.find n n_to_graph
+	  | Atuple l ->
+	      begin try
+		node_for_tuple l
+	      with Not_found
+		  _ -> make ac
+	      end
+	  | _ -> make ac
+    in
+
+    let rec make_graph ac =
+      match ac with
+        | Aand(ac1, ac2) ->
+            let top1, bot1 = make_graph ac1 in
+            let top2, bot2 = make_graph ac2 in
+              top1 @ top2, bot1 @ bot2
+        | Aseq(ac1, ac2) ->
+            let top1, bot1 = make_graph ac1 in
+            let top2, bot2 = make_graph ac2 in
+              (* add extra dependences *)
+              List.iter
+                (fun top -> List.iter (fun bot -> add_depends top bot) bot1)
+                top2;
+              top1 @ top2, bot1 @ bot2
+	| Awrite(n) -> let g = Env.find n n_to_graph in [g], [g]
+	| Aread(n) -> let g = make ac in attach g n; attach_lin g n; [g], [g]
+	| Alinread(n) -> let g = Env.find n lin_map in attach g n; [g], [g]
+	| Atuple(l) -> 
+	    let g = node_for_ac ac in
+	      List.iter (add_dependence g) l;
+	      [g], [g]
+        | _ -> [], [] in
+    let top_list, bot_list = make_graph ac in
+      graph top_list bot_list in
+
+  let n_to_graph, lin_map = initialize ac Env.empty Env.empty in
+  let g = make_graph ac n_to_graph lin_map in
+    g
+
+(* the main entry. *)
+let check loc c =
+  let check_ac ac =
+    let { g_bot = g_list } = build ac in
+    match cycle g_list with
+      | None -> ()
+      | Some _ -> error (Ecausality_cycle ac) in
+
+  let rec check = function
+    | Aempty -> ()
+    | Aac(ac) -> check_ac ac
+    | Aor(nc1, nc2) -> check nc1; check nc2 in
+
+  let nc = norm c in
+    try
+      check nc
+    with
+      | Error(kind) -> message loc kind

heptagon/analysis/causality.ml

@@ -0,0 +1,214 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* causality check *)
+
+(* $Id: causality.ml 615 2009-11-20 17:43:14Z pouzet $ *)
+
+open Misc
+open Names 
+open Ident
+open Heptagon
+open Location
+open Linearity
+open Graph
+open Causal
+
+let cempty = Cempty
+let is_empty c = (c = cempty)
+
+let cand c1 c2 =
+  match c1, c2 with
+  | Cempty, _ -> c2 | _, Cempty -> c1
+  | c1, c2 -> Cand(c1, c2)
+let rec candlist l =
+  match l with
+  | [] -> Cempty
+  | c1 :: l -> cand c1 (candlist l)
+
+let ctuplelist l =
+  Ctuple l
+
+let cor c1 c2 =
+  match c1, c2 with
+  | Cempty, Cempty -> Cempty
+  | _ -> Cor(c1, c2)
+let rec corlist l =
+  match l with
+  | [] -> Cempty
+  | [c1] -> c1
+  | c1 :: l -> cor c1 (corlist l)
+
+let cseq c1 c2 =
+  match c1, c2 with
+  | Cempty, _ -> c2
+  | _, Cempty -> c1
+  | c1, c2 -> Cseq(c1, c2)
+let rec cseqlist l =
+  match l with
+  | [] -> Cempty
+  | c1 :: l -> cseq c1 (cseqlist l)
+
+let read x = Cread(x)
+let linread x = Clinread(x)
+let lastread x = Clastread(x)
+let cwrite x = Cwrite(x)
+
+(* cutting dependences with a delay operator *)
+let rec pre = function
+  | Cor(c1, c2) -> Cor(pre c1, pre c2)
+  | Cand(c1, c2) -> Cand(pre c1, pre c2)
+  | Ctuple l -> Ctuple (List.map pre l)
+  | Cseq(c1, c2) -> Cseq(pre c1, pre c2)
+  | Cread(x) | Clinread (x) -> Cempty
+  | (Cwrite _ | Clastread _ | Cempty) as c -> c
+
+(* projection and restriction *)
+let clear env c =
+  let rec clearec c =
+    match c with
+    | Cor(c1, c2) ->
+        let c1 = clearec c1 in
+        let c2 = clearec c2 in
+        cor c1 c2
+    | Cand(c1, c2) ->
+        let c1 = clearec c1 in
+        let c2 = clearec c2 in
+        cand c1 c2
+    | Cseq(c1, c2) ->
+        let c1 = clearec c1 in
+        let c2 = clearec c2 in
+        cseq c1 c2
+    | Ctuple l -> Ctuple (List.map clearec l)
+    | Cwrite(id) | Cread(id) | Clinread(id) | Clastread(id) ->
+        if IdentSet.mem id env then Cempty else c
+    | Cempty -> c in
+  clearec c
+
+let build dec = 
+  List.fold_left (fun acc { v_name = n } -> IdentSet.add n acc) IdentSet.empty dec
+ 
+(** Main typing function *)
+let rec typing e =
+  match e.e_desc with
+    | Econst(c) -> cempty
+    | Econstvar(x) -> cempty
+    | Evar(x) -> 
+	(match e.e_linearity with
+	   | At _ -> linread x
+	   | _ -> read x
+	)
+    | Elast(x) -> lastread x
+    | Etuple(e_list) ->
+	candlist (List.map typing e_list)
+    | Eapp({a_op = op}, e_list) -> apply op e_list
+    | Efield(e1, _) -> typing e1
+    | Estruct(l) ->
+	let l = List.map (fun (_, e) -> typing e) l in
+	candlist l
+    | Earray(e_list) ->
+	candlist (List.map typing e_list)
+    | Ereset_mem _ -> assert false
+
+(** Typing an application *)
+and apply op e_list =
+  match op, e_list with
+    | Epre(_), [e] -> pre (typing e)
+    | Efby, [e1;e2] ->
+	let t1 = typing e1 in
+	let t2 = pre (typing e2) in
+	candlist [t1; t2]
+    | Earrow, [e1;e2] ->
+	let t1 = typing e1 in
+	let t2 = typing e2 in
+	candlist [t1; t2]
+    | Eifthenelse, [e1; e2; e3] ->
+	let t1 = typing e1 in
+	let i2 = typing e2 in
+	let i3 = typing e3 in
+	cseq t1 (cor i2 i3)
+    | (Enode _ | Eevery _ | Eop _ | Eiterator (_, _, _, _)
+      | Econcat | Eselect_slice | Emake _ | Eflatten _
+      | Eselect_dyn | Eselect _ | Erepeat | Ecopy), e_list ->
+	ctuplelist (List.map typing e_list)
+    | Eupdate _, [e1;e2] | Efield_update _, [e1;e2] ->
+	let t1 = typing e1 in
+	let t2 = typing e2 in
+	cseq t2 t1
+	
+let rec typing_pat = function
+  | Evarpat(x) -> cwrite(x)
+  | Etuplepat(pat_list) ->
+      candlist (List.map typing_pat pat_list)
+
+(** Typing equations *)
+let rec typing_eqs eq_list = candlist (List.map typing_eq eq_list)
+
+and typing_eq eq =
+  match eq.eq_desc with
+    | Eautomaton(handlers) -> typing_automaton handlers
+    | Eswitch(e, handlers) ->
+	cseq (typing e) (typing_switch handlers)
+    | Epresent(handlers, b) -> 
+	typing_present handlers b
+    | Ereset(eq_list, e) ->
+	cseq (typing e) (typing_eqs eq_list)
+    | Eeq(pat, e) ->
+	cseq (typing e) (typing_pat pat)
+
+and typing_switch handlers =
+  let handler { w_block = b } = typing_block b in
+  corlist (List.map handler handlers)
+
+and typing_present handlers b =
+  let handler { p_cond = e; p_block = b } =
+    cseq (typing e) (typing_block b) in
+  corlist ((typing_block b) :: (List.map handler handlers))
+
+and typing_automaton state_handlers =
+  (* typing the body of the automaton *)
+  let handler 
+      { s_state = _; s_block = b; s_until = suntil; s_unless = sunless } =
+    let escape { e_cond = e } = typing e in
+
+    (* typing the body *)
+    let tb = typing_block b in
+    let t1 = candlist (List.map escape suntil) in
+    let t2 = candlist (List.map escape sunless) in
+
+    cseq t2 (cseq tb t1) in
+  corlist (List.map handler state_handlers)
+
+and typing_block { b_local = dec; b_equs = eq_list; b_loc = loc } =
+  let teq = typing_eqs eq_list in
+  Causal.check loc teq;
+  clear (build dec) teq
+
+let typing_contract loc contract =
+  match contract with
+    | None -> cempty
+    | Some { c_local = l_list; c_eq = eq_list; c_assume = e_a; 
+	     c_enforce = e_g; c_controllables = c_list } ->
+	let teq = typing_eqs eq_list in
+	let t_contract = cseq (typing e_a) (cseq teq (typing e_g)) in
+	Causal.check loc t_contract;
+	let t_contract = clear (build l_list) t_contract in
+	t_contract
+
+let typing_node { n_name = f; n_input = i_list; n_output = o_list;
+		  n_contract = contract;
+		  n_local = l_list; n_equs = eq_list; n_loc = loc } =
+  let _ = typing_contract loc contract in
+  let teq = typing_eqs eq_list in
+  Causal.check loc teq
+
+let program ({ p_nodes = p_node_list } as p) =
+  List.iter typing_node p_node_list;
+  p
+

heptagon/analysis/initialization.ml

@@ -0,0 +1,374 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* simple initialization analysis. This is almost trivial since   *)
+(* input/outputs of a node are forced to be initialized           *)
+
+(* $Id: initialization.ml 615 2009-11-20 17:43:14Z pouzet $ *)
+
+open Misc
+open Names
+open Ident
+open Heptagon
+open Location
+open Format
+
+type typ =
+    | Iproduct of typ list
+    | Ileaf of init
+
+and init =
+    { mutable i_desc: init_desc;
+      mutable i_index: int }
+
+and init_desc =
+    | Izero
+    | Ione
+    | Ivar
+    | Imax of init * init
+    | Ilink of init
+
+type kind = | Last of init | Var
+
+type tenv = { i_kind : kind; i_typ : init }
+
+(* typing errors *)
+exception Unify
+
+let index = ref 0
+let gen_index () = incr index; !index
+let new_var () = { i_desc = Ivar; i_index = gen_index () }
+let izero = { i_desc = Izero; i_index = gen_index () }
+let ione = { i_desc = Ione; i_index = gen_index () }
+let imax i1 i2 = { i_desc = Imax(i1, i2); i_index = gen_index () }
+let product l = Iproduct(l)
+let leaf i = Ileaf(i)
+
+(* basic operation on initialization values *)
+let rec irepr i =
+  match i.i_desc with
+    | Ilink(i_son) ->
+        let i_son = irepr i_son in
+        i.i_desc <- Ilink(i_son);
+        i_son
+    | _ -> i
+
+(** Simplification rules for max. Nothing fancy here *)
+let max i1 i2 =
+  let i1 = irepr i1 in
+  let i2 = irepr i2 in
+  match i1.i_desc, i2.i_desc with
+    | (Izero, Izero) -> izero
+    | (Izero, _) -> i2
+    | (_, Izero) -> i1
+    | (_, Ione) | (Ione, _) -> ione
+    | _ -> imax i1 i2
+
+let rec itype = function
+  | Iproduct(ty_list) -> itype_list ty_list
+  | Ileaf(i) -> i
+
+and itype_list ty_list =
+  List.fold_left (fun acc ty -> max acc (itype ty)) izero ty_list
+
+(* saturate an initialization type. Every element must be initialized *)
+let rec initialized i =
+  let i = irepr i in
+  match i.i_desc with
+    | Izero -> ()
+    | Ivar -> i.i_desc <- Ilink(izero)
+    | Imax(i1, i2) -> initialized i1; initialized i2
+    | Ilink(i) -> initialized i
+    | Ione -> raise Unify
+
+(* build an initialization type from a type *)
+let rec skeleton i ty =
+  match ty with
+    | Tbase _ -> leaf i
+    | Tprod(ty_list) -> product (List.map (skeleton i) ty_list)
+
+(* sub-typing *)
+let rec less left_ty right_ty =
+  if left_ty == right_ty then ()
+  else
+    match left_ty, right_ty with
+      | Iproduct(l1), Iproduct(l2) -> List.iter2 less l1 l2
+      | Ileaf(i1), Ileaf(i2) -> iless i1 i2
+      | _ -> raise Unify
+
+and iless left_i right_i =
+  if left_i == right_i then ()
+  else
+    let left_i = irepr left_i in
+    let right_i = irepr right_i in
+    if left_i == right_i then ()
+    else
+      match left_i.i_desc, right_i.i_desc with
+        | (Izero, _) | (_, Ione) -> ()
+	| _, Izero -> initialized left_i
+	| Imax(i1, i2), _ ->
+	    iless i1 right_i; iless i2 right_i
+	| _, Ivar ->
+	    let left_i = occur_check right_i.i_index left_i in
+	    right_i.i_desc <- Ilink(left_i)
+	| _, Imax(i1, i2) ->
+	    let i1 = occur_check left_i.i_index i1 in
+	    let i2 = occur_check left_i.i_index i2 in
+	    right_i.i_desc <- Ilink(imax left_i (imax i1 i2))
+	| _ -> raise Unify
+
+(* an inequation [a < t[a]] becomes [a = t[0]] *)
+and occur_check index i =
+  match i.i_desc with
+    | Izero | Ione -> i
+    | Ivar -> if i.i_index = index then izero else i
+    | Imax(i1, i2) ->
+	max (occur_check index i1) (occur_check index i2)
+    | Ilink(i) -> occur_check index i
+
+module Printer = struct
+  open Format
+
+  let rec print_list_r print po sep pf ff = function
+  | [] -> ()
+  | x :: l ->
+      fprintf ff "@[%s%a" po print x;
+      List.iter (fprintf ff "%s@]@ @[%a" sep print) l;
+      fprintf ff "%s@]" pf
+
+  let rec fprint_init ff i = match i.i_desc with
+    | Izero -> fprintf ff "0"
+    | Ione -> fprintf ff "1"
+    | Ivar -> fprintf ff "0"
+    | Imax(i1, i2) -> fprintf ff "@[%a\\/%a@]" fprint_init i1 fprint_init i2
+    | Ilink(i) -> fprint_init ff i
+
+  let rec fprint_typ ff = function
+    | Ileaf(i) -> fprint_init ff i
+    | Iproduct(ty_list) ->
+        fprintf ff "@[%a@]" (print_list_r fprint_typ "("" *"")") ty_list
+
+  let output_typ oc ty =
+    let ff = formatter_of_out_channel oc in
+    fprintf ff "@[";
+    fprint_typ ff ty;
+    fprintf ff "@?@]"
+end
+
+module Error = struct
+  open Location
+
+  type error = | Eclash of typ * typ
+
+  exception Error of location * error
+
+  let error loc kind = raise (Error(loc, kind))
+
+  let message loc kind =
+    begin match kind with
+        | Eclash(left_ty, right_ty) ->
+            Printf.eprintf "%aInitialization error: this expression has type \
+              %a, \n\
+              but is expected to have type %a\n"
+              output_location loc
+              Printer.output_typ left_ty
+              Printer.output_typ right_ty
+    end;
+    raise Misc.Error
+end
+
+let less_exp e actual_ty expected_ty =
+  try
+    less actual_ty expected_ty
+  with | Unify -> Error.message e.e_loc (Error.Eclash(actual_ty, expected_ty))
+
+(** Is-it a safe imported value? *)
+let safe f =
+  let { Global.info = { Global.safe = s } } = Modules.find_value f in s
+
+(** Main typing function *)
+let rec typing h e =
+  match e.e_desc with
+    | Econst _ | Econstvar _ -> leaf izero
+    | Evar(x) | Elast(x) -> let { i_typ = i } = Env.find x h in leaf i
+    | Etuple(e_list) ->
+	product (List.map (typing h) e_list)
+    | Eapp({a_op = op}, e_list) ->
+	let i = apply h op e_list in
+	skeleton i e.e_ty
+    | Efield(e1, _) ->
+	let i = itype (typing h e1) in
+	skeleton i e.e_ty
+    | Estruct(l) ->
+	let i =
+	  List.fold_left
+	    (fun acc (_, e) -> max acc (itype (typing h e))) izero l in
+	skeleton i e.e_ty
+    | Earray(e_list) ->
+	product (List.map (typing h) e_list)
+    | Ereset_mem _ -> assert false
+
+(** Typing an application *)
+and apply h op e_list =
+  match op, e_list with
+    | Epre(None), [e] ->
+	initialized_exp h e;
+	ione
+    | Epre(Some _), [e] ->
+	initialized_exp h e;
+	izero
+    | Efby, [e1;e2] ->
+	initialized_exp h e2;
+	itype (typing h e1)
+    | Earrow, [e1;e2] ->
+	let ty1 = typing h e1 in
+	let _ = typing h e2 in
+	itype ty1
+    | Eifthenelse, [e1; e2; e3] ->
+	let i1 = itype (typing h e1) in
+	let i2 = itype (typing h e2) in
+	let i3 = itype (typing h e3) in
+	max i1 (max i2 i3)
+    | (Enode(f,_) | Eevery(f,_)), e_list ->
+	List.iter (fun e -> initialized_exp h e) e_list; izero
+    | Eop(f,_), e_list when safe f ->
+	(* unsafe primitives must have an initialized argument *)
+	List.fold_left (fun acc e -> itype (typing h e)) izero e_list
+    | Eop(f,_), e_list ->
+	List.iter (fun e -> initialized_exp h e) e_list; izero
+(*Array operators*)
+    | (Erepeat | Econcat | Eupdate _ | Efield_update _
+      | Eselect _ | Eselect_dyn | Eselect_slice
+      | Eiterator _ | Ecopy | Emake _ | Eflatten _), e_list ->
+	List.iter (fun e -> initialized_exp h e) e_list; izero
+    | _ -> assert false
+
+and expect h e expected_ty =
+  let actual_ty = typing h e in
+  less_exp e actual_ty expected_ty
+
+and initialized_exp h e = expect h e (skeleton izero e.e_ty)
+
+let rec typing_pat h = function
+  | Evarpat(x) -> let { i_typ = i } = Env.find x h in leaf i
+  | Etuplepat(pat_list) ->
+      product (List.map (typing_pat h) pat_list)
+
+(** Typing equations *)
+let rec typing_eqs h eq_list = List.iter (typing_eq h) eq_list
+
+and typing_eq h eq =
+  match eq.eq_desc with
+    | Eautomaton(handlers) -> typing_automaton h handlers
+    | Eswitch(e, handlers) ->
+	initialized_exp h e;
+	typing_switch h handlers
+    | Epresent(handlers, b) ->
+	typing_present h handlers b
+    | Ereset(eq_list, e) ->
+	initialized_exp h e; typing_eqs h eq_list
+    | Eeq(pat, e) ->
+	let ty_pat = typing_pat h pat in
+	expect h e ty_pat
+
+and typing_switch h handlers =
+  let handler { w_block = b } = ignore (typing_block h b) in
+  List.iter handler handlers
+
+and typing_present h handlers b =
+  let handler { p_cond = e; p_block = b } =
+    initialized_exp h e; ignore (typing_block h b) in
+  List.iter handler handlers; ignore (typing_block h b)
+
+and typing_automaton h state_handlers =
+  (* we make a special treatment for state variables defined in the *)
+  (* initial state *)
+  let weak { s_unless = sunless } =
+    match sunless with | [] -> true | _ -> false in
+
+  (* the set of variables which do have an initial value in the other states *)
+  let initialized h { s_block = { b_defnames = l } } =
+    Env.fold
+      (fun elt _ h ->
+            let { i_kind = k; i_typ = i } = Env.find elt h in
+            match k with
+              | Last _ ->
+		  let h = Env.remove elt h in
+		  Env.add elt { i_kind = Last(izero); i_typ = izero } h
+	      | _ -> h)
+      l h in
+
+  (* typing the body of the automaton *)
+  let handler h
+      { s_state = _; s_block = b; s_until = suntil; s_unless = sunless } =
+    let escape h { e_cond = e } =
+      initialized_exp h e in
+
+    (* typing the body *)
+    let h = typing_block h b in
+    List.iter (escape h) suntil;
+    List.iter (escape h) sunless in
+
+  match state_handlers with
+  (* we do a special treatment for state variables which *)
+  (* are defined in the initial state if it cannot be immediately *)
+  (* exited *)
+    | initial :: other_handlers when weak initial ->
+        let h = initialized h initial in
+        handler h initial;
+        List.iter (handler h) other_handlers
+    | _ -> List.iter (handler h) state_handlers
+
+and typing_block h { b_local = dec; b_equs = eq_list } =
+  let h_extended = build h dec in
+  typing_eqs h_extended eq_list;
+  h_extended
+
+(* build an typing environment of initialization types *)
+and build h dec =
+  let kind = function
+    | Heptagon.Var -> { i_kind = Var; i_typ = new_var () }
+    | Heptagon.Last(Some _) -> { i_kind = Last(izero); i_typ = izero }
+    | Heptagon.Last(None) -> { i_kind = Last(ione); i_typ = new_var () } in
+  List.fold_left
+    (fun h { v_name = n; v_last = last } -> Env.add n (kind last) h) h dec
+
+let sbuild h dec =
+  List.fold_left
+    (fun h { v_name = n } -> Env.add n { i_kind = Var; i_typ = izero } h) h dec
+
+let typing_contract h contract =
+  match contract with
+    | None -> h
+    | Some { c_local = l_list; c_eq = eq_list; c_assume = e_a;
+	     c_enforce = e_g; c_controllables = c_list } ->
+	let h = sbuild h c_list in
+	let h' = build h l_list in
+	typing_eqs h' eq_list;
+	(* assumption *)
+	expect h' e_a (skeleton izero e_a.e_ty);
+	(* property *)
+	expect h' e_g (skeleton izero e_g.e_ty);
+	h
+
+let typing_node { n_name = f; n_input = i_list; n_output = o_list;
+		  n_contract = contract;
+		  n_local = l_list; n_equs = eq_list } =
+  let h = sbuild Env.empty i_list in
+  let h = sbuild h o_list in
+  let h = typing_contract h contract in
+
+  let h = build h l_list in
+  typing_eqs h eq_list
+
+let program ({ p_nodes = p_node_list } as p) =
+  List.iter typing_node p_node_list;
+  p
+
+

heptagon/analysis/interface.ml

@@ -0,0 +1,131 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* Read an interface *)
+
+(* $Id$ *)
+
+open Misc
+open Ident
+open Names
+open Linearity
+open Heptagon
+open Global
+open Modules
+open Typing
+
+let rec split3 = function
+  | [] -> [], [], []
+  | (a,b,c)::l ->
+      let a_list, b_list, c_list = split3 l in
+	a::a_list, b::b_list, c::c_list
+
+let rec combine3 l1 l2 l3 = match l1, l2, l3 with
+  | [], [], [] -> []
+  | a::a_list, b::b_list, c::c_list ->
+      (a,b,c)::(combine3 a_list b_list c_list)
+
+module Type =
+  struct
+    let sigtype { sig_name = name; sig_inputs = i_list; sig_outputs = o_list; 
+		  sig_node = node; sig_safe = safe; sig_params = params } =
+      let arg_dec_of_tuple (n, ty, l) = 
+	{ a_name = n;
+	  a_type = Tbase(check_type ty);
+	  a_linearity = l;
+	  a_pass_by_ref = false } in
+      let i_inputs, t_inputs, l_inputs = split3 i_list in
+      let o_outputs, t_outputs, l_outputs = split3 o_list in
+	name, { inputs = List.map arg_dec_of_tuple i_list;
+		outputs = List.map arg_dec_of_tuple o_list;
+		contract = None;
+		node = node;
+		safe = safe; 
+	        targeting = [];
+		params = params;
+		params_constraints = []; }
+	  
+    let read { interf_desc = desc; interf_loc = loc } =
+      try
+	match desc with
+	  | Iopen(n) -> open_module n
+	  | Itypedef(tydesc) -> deftype NamesEnv.empty tydesc
+	  | Isignature(s) -> 
+	      let name, s = sigtype s in
+		add_value name s
+      with
+	  TypingError(error) -> message loc error
+
+    let main l = 
+      List.iter read l
+  end
+    
+module Printer =
+struct
+  open Format
+  open Printer
+    
+  let deftype ff name tdesc =
+    match tdesc with
+      | Tabstract -> fprintf ff "@[type %s@.@]" name
+      | Tenum(tag_name_list) ->
+	  fprintf ff "@[<hov 2>type %s = " name;
+	  print_list ff print_name " |" tag_name_list;
+	  fprintf ff "@.@]"
+      | Tstruct(f_ty_list) ->
+	  fprintf ff "@[<hov 2>type %s = " name;
+	  fprintf ff "@[<hov 1>{";
+	  print_list ff 
+	    (fun ff (field, ty) -> print_name ff field;
+              fprintf ff ": ";
+	      print_base_type ff ty) ";" f_ty_list;
+	  fprintf ff "}@]@.@]"
+
+  let signature ff name { inputs = inputs;
+			  outputs = outputs;
+			  contract = contract; node = node;
+			  safe = safe; params = params; params_constraints = constr } =
+    let print ff arg =
+      match arg.a_name with
+	| None -> print_type ff arg.a_type
+	| Some(name) -> 
+	    print_name ff name; fprintf ff ":"; print_type ff arg.a_type;
+	    fprintf ff " "; print_lin ff arg.a_linearity in
+
+    let print_node_params ff = function
+      | [] -> ()
+      | l -> 
+	  fprintf ff "<<";
+	  print_list ff print_name "," l;
+	  fprintf ff ">>" in
+      
+    fprintf ff "@[<v 2>val ";
+    if safe then fprintf ff "safe ";
+    if node then fprintf ff "node " else fprintf ff "fun ";
+    print_name ff name;
+    print_node_params ff params;
+    fprintf ff "(@[";
+    print_list ff print ";" inputs;
+    fprintf ff "@]) returns (@[";
+    print_list ff print ";" outputs;
+    fprintf ff "@])";
+    (match constr with
+       | [] -> ()
+       | constr -> 
+	   fprintf ff "\n with: @[";
+	   print_list ff Static.print_size_constr "," constr;
+	   fprintf ff "@]"
+    );
+    optunit (print_contract ff) contract;
+    fprintf ff "@.@]"
+	
+  let print oc =
+    let ff = formatter_of_out_channel oc in
+    NamesEnv.iter (fun key typdesc -> deftype ff key typdesc) current.types;
+    NamesEnv.iter (fun key sigtype -> signature ff key sigtype) current.values;
+end

heptagon/analysis/typing.ml

@@ -0,0 +1,932 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* type checking *)
+
+(* $Id$ *)
+
+open Misc
+open Names
+open Ident
+open Location
+open Heptagon
+open Global
+open Modules
+open Initial
+open Static
+
+type value = { ty: ty; mutable last: bool }
+
+type error = 
+    | Emissing of name
+    | Emissingcase of name
+    | Eundefined of name
+    | Elast_undefined of name
+    | Eshould_be_last of name
+    | Etype_clash of ty * ty
+    | Earity_clash of int * int
+    | Ealready_defined of name
+    | Eshould_be_a_node of longname
+    | Enon_exaustive
+    | Estate_clash
+    | Epartial_switch of name
+    | Etwo_many_outputs
+    | Esome_fields_are_missing
+    | Esubscripted_value_not_an_array of ty
+    | Earray_subscript_should_be_const 
+    | Eundefined_const of name
+    | Econstraint_solve_failed of size_constr
+    | Etype_should_be_static of ty
+
+exception Unify
+exception TypingError of error
+
+let error kind = raise (TypingError(kind))
+
+let message loc kind =
+  begin match kind with
+  | Emissing(s) ->
+      Printf.eprintf "%aNo equation is given for name %s.\n" 
+	output_location loc
+	s;
+  | Emissingcase(s) ->
+      Printf.eprintf "%aCase %s not defined.\n" 
+	output_location loc
+	s;
+  | Eundefined(s) ->
+      Printf.eprintf "%aThe name %s is unbound.\n" 
+	output_location loc
+	s;
+  | Elast_undefined(s) ->
+      Printf.eprintf "%aThe name %s does not have a last value.\n" 
+	output_location loc
+	s;
+  | Eshould_be_last(s) ->
+      Printf.eprintf "%aOnly the last value of %s can be accessed.\n" 
+	output_location loc
+	s;
+  | Etype_clash(actual_ty, expected_ty) ->
+      Printf.eprintf "%aType Clash: this expression has type %a, \n\
+            but is expected to have type %a.\n" 
+	output_location loc
+	Printer.ptype actual_ty
+	Printer.ptype expected_ty
+  | Earity_clash(actual_arit, expected_arit) ->
+      Printf.eprintf "%aType Clash: this expression expects %d arguments,\n\
+            but is expected to have %d.\n" 
+	output_location loc
+	expected_arit actual_arit
+  | Ealready_defined(s) ->
+      Printf.eprintf "%aThe name %s is already defined.\n"
+	output_location loc
+	s
+  | Enon_exaustive ->
+      Printf.eprintf "%aSome constructors are missing in this \
+                        pattern/matching.\n"
+	output_location loc
+  | Eshould_be_a_node(s) ->
+      Printf.eprintf "%a%s should be a combinatorial function.\n"
+	output_location loc
+	(fullname s)
+  | Estate_clash ->
+      Printf.eprintf 
+	"%aOnly stateless expressions should appear in a function.\n"
+	output_location loc
+ | Epartial_switch(s) ->
+      Printf.eprintf 
+	"%aThe case %s is missing.\n"
+	output_location loc
+	s
+ | Etwo_many_outputs ->
+      Printf.eprintf 
+	"%aA function may only returns a basic value.\n"
+	output_location loc
+ | Esome_fields_are_missing ->
+      Printf.eprintf 
+	"%aSome fields are missing.\n"
+	output_location loc
+ | Esubscripted_value_not_an_array  ty ->
+      Printf.eprintf 
+	"%aSubscript used on a non array type : %a.\n"
+	output_location loc 
+	Printer.ptype ty
+ | Earray_subscript_should_be_const ->
+      Printf.eprintf 
+	"%aSubscript has to be a static value.\n"
+	output_location loc   
+ | Eundefined_const id -> 
+     Printf.eprintf 
+       "%aThe const name '%s' is unbound.\n"
+       output_location loc      
+       id
+ | Econstraint_solve_failed c ->
+     Printf.eprintf 
+       "%aThe following constraint cannot be satisified:\n %a.\n"
+       output_location loc      
+       psize_constr c
+ | Etype_should_be_static ty ->
+     Printf.eprintf 
+       "%aThis type should be static : %a.\n"
+	output_location loc 
+	Printer.ptype ty
+  end;
+  raise Error
+
+let add_value f signature =
+  try add_value f signature with Already_defined -> error (Ealready_defined f)
+let add_type f typ_desc =
+  try add_type f typ_desc with Already_defined -> error (Ealready_defined f)
+let add_constr f ty_res =
+  try add_constr f ty_res with Already_defined -> error (Ealready_defined f)
+let add_field f ty_arg ty_res =
+  try add_field f ty_arg ty_res 
+  with Already_defined -> error (Ealready_defined f)
+
+let find_value f =
+  try find_value f with Not_found -> error (Eundefined(fullname f))
+let find_type f =
+  try find_type f with Not_found -> error (Eundefined(fullname f))
+let find_constr c =
+  try find_constr c with Not_found -> error (Eundefined(fullname c))
+let find_field c =
+  try find_field c with Not_found -> error (Eundefined(fullname c))
+
+let (curr_size_constr : size_constr list ref) = ref []
+let add_size_constr c =
+  curr_size_constr := c::(!curr_size_constr)
+let get_size_constr () = 
+  let l = !curr_size_constr in
+    curr_size_constr := [];
+    l
+
+let get_number_of_fields ty =
+  let { info = tydesc } = 
+    match ty with
+      | Tid(f) -> find_type f
+      | _ -> assert false in
+    match tydesc with
+      | Tstruct l -> List.length l
+      | _ -> assert false
+
+let element_type ty =
+  match ty with
+    | Tbase (Tarray (ty, _)) -> Tbase ty
+    | _ -> error (Esubscripted_value_not_an_array ty)
+
+let size_exp ty =
+  match ty with
+    | Tbase (Tarray (_, e)) -> e
+    | _ -> error (Esubscripted_value_not_an_array ty)
+
+let rec unify t1 t2 = 
+  match t1, t2 with
+    | Tprod(t1_list), Tprod(t2_list) ->
+	begin
+          try List.iter2 unify t1_list t2_list with _ -> raise Unify
+	end
+    | Tbase(b1), Tbase(b2) when b1 = b2 -> ()
+    | Tbase(Tbool), Tbase(Tid name_bool)  
+    | Tbase(Tid name_bool), Tbase(Tbool)
+	when name_bool = pbool -> ()
+    | Tbase(Tint), Tbase(Tid name_int)  
+    | Tbase(Tid name_int), Tbase(Tint)
+	when name_int = pint -> ()
+    | Tbase(Tfloat), Tbase(Tid name_float)  
+    | Tbase(Tid name_float), Tbase(Tfloat)
+	when name_float = pfloat -> ()
+    | Tbase(Tarray (ty1, e1)), Tbase(Tarray (ty2, e2)) ->
+	add_size_constr (Equal(e1,e2));
+	unify (Tbase ty1) (Tbase ty2)
+    | _ -> raise Unify
+
+let unify t1 t2 =
+  try unify t1 t2 with Unify -> error (Etype_clash(t1, t2))
+	
+let less_than statefull = if not statefull then error Estate_clash
+
+let kind f statefull = function
+  | { inputs = ty_list1;
+      outputs = ty_list2;
+      node = n } -> 
+      let ty_of_arg_dec v = v.a_type in
+      if n & not(statefull) then error (Eshould_be_a_node(f)) 
+      else n, List.map ty_of_arg_dec ty_list1, List.map ty_of_arg_dec ty_list2
+	
+let prod = function
+  | []      -> assert false
+  | [ty]    -> ty
+  | ty_list -> Tprod(ty_list)
+
+let rec typing_const c = 
+  let typed_c, base_ty = match c with
+    | Cint _     -> c, Tid(pint)
+    | Cfloat _   -> c, Tid(pfloat)
+    | Cconstr(c) -> 
+	let { qualid = q; info = base_ty } = find_constr c in
+	Cconstr(Modname(q)), base_ty
+    | Cconst_array(n, c) ->
+	let c, ty = typing_const c in
+	  Cconst_array(n,c), Tarray(base_type ty, n)
+  in
+  typed_c, Tbase(base_ty)
+	
+let typ_of_name h x = 
+  try 
+    let { ty = ty } = Env.find x h in ty
+  with 
+      Not_found -> error (Eundefined(sourcename x))
+
+let typ_of_varname h x = 
+  try 
+    let { ty = ty;last = last } = Env.find x h in
+    (* Don't understand that - GD 15/02/2009 *)
+    (*     if last then error (Eshould_be_last(x)); *)
+    ty
+  with 
+      Not_found -> error (Eundefined(sourcename x))
+
+let typ_of_last h x =
+  try
+    let { ty = ty; last = last } = Env.find x h in 
+    if not last then error (Elast_undefined(sourcename x));
+    (* v.last <- true;*)
+    ty
+  with
+      Not_found -> error (Eundefined(sourcename x))
+    
+let desc_of_ty = function 
+  | Tbase(Tid(ty_name)) -> 
+      let { info = tydesc } = find_type ty_name in tydesc
+  | Tbase(Tbool) -> Tenum ["true";"false"]
+  | _  -> Tabstract
+let set_of_constr = function
+  | Tabstract | Tstruct _  -> assert false
+  | Tenum(tag_list) -> List.fold_right S.add tag_list S.empty
+
+let name_mem n env =
+  let check_one id _ acc =
+    ((name id) = n) or acc 
+  in
+    Env.fold check_one env false
+
+(* [check_type t] checks that t exists *)
+let rec check_type = function
+  | Tint | Tfloat | Tbool as t -> t
+  | Tarray(ty, e) -> 
+      Tarray(check_type ty, e) 
+  | Tid(ty_name) ->
+      try Tid(Modname((find_type ty_name).qualid))
+      with Not_found -> error (Eundefined(fullname ty_name))
+
+let rec simplify_type const_env = function
+  | Tint | Tfloat | Tbool | Tid _ as t -> t
+  | Tarray(ty, e) ->
+      Tarray(simplify_type const_env ty, simplify const_env e)
+
+let simplify_type loc const_env ty = 
+  try
+    simplify_type const_env ty
+  with
+    Instanciation_failed -> message loc (Etype_should_be_static (Tbase ty))
+
+let rec subst_base_type_vars m = function
+  | Tarray(ty, e) -> Tarray(subst_base_type_vars m ty, size_exp_subst m e)
+  | t -> t
+
+let rec subst_type_vars m = function
+  | Tbase ty -> Tbase (subst_base_type_vars m ty)
+  | Tprod l -> Tprod (List.map (subst_type_vars m) l)
+
+let equal expected_tag_list actual_tag_list =
+   if not (List.for_all 
+	     (fun tag -> List.mem tag actual_tag_list) expected_tag_list)
+  then error Enon_exaustive
+
+(* add two sets of names provided they are distinct *)
+let add env1 env2 =
+  Env.fold 
+    (fun elt ty env -> 
+       if not (Env.mem elt env)
+       then Env.add elt ty env
+       else error (Ealready_defined(sourcename elt))) env1 env2
+
+(* checks that constructors are included in constructor list from type
+   def and returns the difference *)
+let included_const s1 s2 =
+  S.iter 
+    (fun elt -> if not (S.mem elt s2) then error (Emissingcase(elt))) 
+    s1
+
+let diff_const defined_names local_names =
+  included_const local_names defined_names;
+  S.diff defined_names local_names
+
+(* checks that local_names are included in defined_names and returns *)
+(* the difference *)
+let included_env s1 s2 =
+  Env.iter 
+    (fun elt _ -> if not (Env.mem elt s2) then error (Emissing(sourcename elt))) 
+    s1
+
+let diff_env defined_names local_names =
+  included_env local_names defined_names;
+  Env.diff defined_names local_names
+
+(* [merge [set1;...;setn]] returns a set of names defined in every seti *)
+(* and only partially defined names *)
+let rec merge local_names_list =
+  let two s1 s2 =
+    let total, partial = Env.partition (fun elt -> Env.mem elt s2) s1 in
+    let partial = 
+      Env.fold (fun elt ty env -> 
+		if not (Env.mem elt total) then Env.add elt ty env
+		else env)
+        s2 partial in
+    total, partial in
+  match local_names_list with
+    | [] -> Env.empty, Env.empty
+    | [s] -> s, Env.empty
+    | s :: local_names_list -> 
+	let total, partial1 = merge local_names_list in
+        let total, partial2 = two s total in
+        total, Env.union partial1 partial2
+
+(* checks that every partial name has a last value *)
+let all_last h env =
+  Env.iter 
+    (fun elt _ ->
+       if not (Env.find elt h).last then error (Elast_undefined(sourcename elt)))
+    env
+
+let last = function | Var -> false | Last _ -> true
+
+let rec typing statefull h e =
+  try
+    let typed_desc,ty = match e.e_desc with
+      |	Econst(c) ->
+	  let typed_c, ty = typing_const c in
+	  Econst(c),
+	  ty
+      | Econstvar(x) -> Econstvar x, Tbase Tint
+      | Evar(x) ->
+	  Evar(x),
+	  typ_of_varname h x
+      | Elast(x) -> 
+	  Elast(x),
+	  typ_of_last h x
+      | Etuple(e_list) ->
+	  let typed_e_list,ty_list =
+	    List.split (List.map (typing statefull h) e_list) in
+	  Etuple(typed_e_list),
+	  Tprod(ty_list)
+      | Eapp({ a_op = op } as app, e_list ) ->
+	  let ty, op, typed_e_list = typing_app statefull h op e_list in
+	  Eapp({ app with a_op = op }, typed_e_list),
+	  ty
+      | Efield(e, field) ->
+	  let { qualid = q;
+		info = { arg = ty_arg; res = ty_res } } = find_field field in
+	  let typed_e = expect statefull h (Tbase(ty_arg)) e in
+	  Efield(typed_e, Modname(q)),
+	  Tbase(ty_res)
+      | Estruct(l) ->
+	  let { qualid = q;
+		info = { arg = ty_arg } } = find_field (fst (List.hd l)) in
+	  let size = get_number_of_fields ty_arg in
+	  let rec fieldrec acc_l acc = function
+	    | [] -> 
+		List.rev acc_l, 
+		Tbase(ty_arg)
+	    | (field, e) :: l ->
+		if S.mem (shortname field) acc 
+		then error (Ealready_defined(fullname field));
+		let { qualid = q;
+		      info = { arg = ty; res = ty_res } } = find_field field in
+		let typed_e = expect statefull h (Tbase(ty_res)) e in
+		unify (Tbase(ty)) (Tbase(ty_arg));
+		fieldrec 
+		  ((Modname(q),typed_e)::acc_l) 
+		  (S.add (shortname field) acc)
+		  l in
+	  let typed_l, ty = fieldrec [] S.empty l in
+	  (* check that no field is missing *)
+	  if List.length l <> size then error Esome_fields_are_missing;
+	  Estruct(typed_l),
+	  ty
+      | Earray (exp::e_list) -> 
+	  let typed_exp, t1 = typing statefull h exp in
+	  let typed_e_list = List.map (expect statefull h t1) e_list in
+	    Earray(typed_exp::typed_e_list), 
+	    const_array_of t1 (List.length e_list + 1)
+      | Earray [] -> 
+	  error (Earity_clash (0, 1))
+      | Ereset_mem _ -> assert false
+    in
+      { e with
+	  e_desc = typed_desc;
+	  e_ty = ty; },
+      ty
+  with
+      TypingError(kind) -> message e.e_loc kind
+      
+and expect statefull h expected_ty e =
+  let typed_e, actual_ty = typing statefull h e in
+  try 
+    unify actual_ty expected_ty;
+    typed_e
+  with TypingError(kind) -> message e.e_loc kind
+
+and typing_app statefull h op e_list =
+  match op, e_list with
+    | Epre(None), [e] -> 
+	less_than statefull;
+	let typed_e,ty = typing statefull h e in
+	ty,op,[typed_e]
+    | Epre(Some(c)), [e] -> 
+	less_than statefull;
+	let typed_c, t1 = typing_const c in
+	let typed_e = expect statefull h t1 e in
+	t1, Epre(Some(typed_c)), [typed_e]
+    | (Efby | Earrow), [e1;e2] ->
+	less_than statefull;
+	let typed_e1, t1 = typing statefull h e1 in
+	let typed_e2 = expect statefull h t1 e2 in
+	t1, op, [typed_e1;typed_e2]
+    | Eifthenelse, [e1;e2;e3] ->
+	let typed_e1 = expect statefull h (Tbase tbool) e1 in
+	let typed_e2, t1 = typing statefull h e2 in
+	let typed_e3 = expect statefull h t1 e3 in
+	t1, op, [typed_e1; typed_e2; typed_e3]
+    | (Enode(f, params) | Eevery(f, params) | Eop(f, params)), e_list ->
+	let { qualid = q; info = ty_desc } = find_value f in
+	let k, expected_ty_list, result_ty_list = kind f statefull ty_desc in
+	let m = List.combine ty_desc.params params in
+	let expected_ty_list = List.map (subst_type_vars m) expected_ty_list in
+	let typed_e_list = typing_args statefull h expected_ty_list e_list in
+	let size_constrs = instanciate_constr m ty_desc.params_constraints in
+	let result_ty_list = List.map (subst_type_vars m) result_ty_list in
+	  List.iter add_size_constr size_constrs;
+	let f = Modname(q) in
+	(prod result_ty_list,
+	 (if k then Enode(f, params) else Eop(f, params)),
+	 typed_e_list)
+(*Array operators*)
+    | Erepeat, [e1; e2] -> 
+	let typed_e2 = expect statefull h (Tbase(Tint)) e2 in
+	let e2 = size_exp_of_exp e2 in
+	let typed_e1, t1 = typing statefull h e1 in
+	  add_size_constr (LEqual (SConst 1, e2));
+	  array_of t1 e2, op, [typed_e1; typed_e2]
+    | Eselect idx_list, [e1] -> 
+	let typed_e1, t1 = typing statefull h e1 in
+	  typing_array_subscript statefull h idx_list t1, op, [typed_e1]
+    | Eselect_dyn, e1::defe::idx_list ->
+	let typed_e1, t1 = typing statefull h e1 in
+	let typed_defe = expect statefull h (element_type t1) defe in
+	let ty, typed_idx_list = typing_array_subscript_dyn statefull h idx_list t1 in
+	  ty, op, typed_e1::typed_defe::typed_idx_list
+    | Eupdate idx_list, [e1;e2] ->
+	let typed_e1, t1 = typing statefull h e1 in
+	let base_ty = typing_array_subscript statefull h idx_list t1 in
+	let typed_e2 = expect statefull h base_ty e2 in
+	  t1, op, [typed_e1; typed_e2]
+    | Eselect_slice, [e; idx1; idx2] ->
+	let typed_idx1 = expect statefull h (Tbase(Tint)) idx1 in
+	let typed_idx2 = expect statefull h (Tbase(Tint)) idx2 in
+	let typed_e, t1 = typing statefull h e in
+	  (*Create the expression to compute the size of the array *)
+	let e1 = SOp (SMinus, size_exp_of_exp idx2, size_exp_of_exp idx1) in 
+	let e2 = SOp (SPlus, e1, SConst 1) in
+	  add_size_constr (LEqual (SConst 1, e2));
+	  array_of (element_type t1) e2, op, [typed_e; typed_idx1; typed_idx2]
+    | Econcat, [e1; e2] -> 
+	let typed_e1, t1 = typing statefull h e1 in
+	let typed_e2, t2 = typing statefull h e2 in
+	  begin try 
+	    unify (element_type t1) (element_type t2)
+          with 
+	      TypingError(kind) -> message e1.e_loc kind 
+	  end;
+	  let n = SOp (SPlus, size_exp t1, size_exp t2) in
+	    array_of (element_type t1) n, op, [typed_e1; typed_e2]
+    | Eiterator (it, f, params, reset), e::e_list ->
+	let { qualid = q; info = ty_desc } = find_value f in
+	let f = Modname(q) in
+	let _, expected_ty_list, result_ty_list = kind f statefull ty_desc in
+	let m = List.combine ty_desc.params params in
+	let expected_ty_list = List.map (subst_type_vars m) expected_ty_list in
+	let size_constrs = instanciate_constr m ty_desc.params_constraints in
+	let result_ty_list = List.map (subst_type_vars m) result_ty_list in
+	let typed_e = expect statefull h (Tbase Tint) e in
+	let e = size_exp_of_exp e in
+	let ty, typed_e_list = typing_iterator statefull h it e 
+	  expected_ty_list result_ty_list e_list in 
+	  add_size_constr (LEqual (SConst 1, e));
+	  List.iter add_size_constr size_constrs;
+	  ty, Eiterator(it, f, params, reset), typed_e::typed_e_list
+    | Ecopy, [e] -> 
+	let typed_e, ty = typing statefull h e in
+	  ty, op, [typed_e]
+    | Efield_update field, [e1; e2] -> 
+	  let { qualid = q;
+		info = { arg = ty_arg; res = ty_res } } = find_field field in
+	  let typed_e1 = expect statefull h (Tbase(ty_arg)) e1 in
+	  let typed_e2 = expect statefull h (Tbase(ty_res)) e2 in
+	    Tbase(ty_arg), op, [typed_e1; typed_e2]
+    | Eflatten n, [e] -> 
+	  let { qualid = q;
+		info = { fields = fields } } = find_struct n in	
+	  let typed_e = expect statefull h (Tbase(Tid (Modname q))) e in
+	    prod (List.map (fun (_, ty) -> Tbase (check_type ty)) fields), op, [typed_e]
+    | Emake n, e_list ->
+	  let { qualid = q;
+		info = { fields = fields } } = find_struct n in	
+	    if List.length e_list <> List.length fields then 
+	      error (Earity_clash(List.length e_list, List.length fields));
+	    let typed_e_list = List.map2 
+	      (fun e (_,ty) -> expect statefull h (Tbase (check_type ty)) e) 
+	      e_list fields in
+	      Tbase (Tid (Modname q)), op, typed_e_list
+(*Arity problems*)
+    | Epre _, _ ->
+	error (Earity_clash(List.length e_list, 1))
+    | (Efby | Earrow), _ ->
+	error (Earity_clash(List.length e_list, 2))
+    | Eifthenelse, _ ->
+	error (Earity_clash(List.length e_list, 2))
+    | Eiterator _, _ -> 
+	error (Earity_clash(List.length e_list, 1))
+    | Econcat, _ ->
+	error (Earity_clash(List.length e_list, 2))
+    | Eselect_slice, _ -> 
+	error (Earity_clash(List.length e_list, 3))
+    | Eupdate _, _ ->
+	error (Earity_clash(List.length e_list, 2))
+    | Eselect _, _ ->
+	error (Earity_clash(List.length e_list, 1))
+    | Eselect_dyn, _ ->
+	error (Earity_clash(List.length e_list, 2))
+    | Erepeat _, _ -> 
+	error (Earity_clash(List.length e_list, 2))
+    | Ecopy, _ -> 
+	error (Earity_clash(List.length e_list, 1))
+    | Efield_update field, _ ->
+	error (Earity_clash(List.length e_list, 2))
+		
+and typing_iterator statefull h it n args_ty_list result_ty_list e_list = 
+  match it with 
+    | Imap ->
+	let args_ty_list = List.map (fun ty -> array_of ty n) args_ty_list in
+	let result_ty_list = List.map (fun ty -> array_of ty n) result_ty_list in
+	let typed_e_list = typing_args statefull h args_ty_list e_list in
+	  prod result_ty_list, typed_e_list
+    | Ifold -> 
+	let args_ty_list = incomplete_map (fun ty -> array_of ty n) args_ty_list in
+	let typed_e_list = typing_args statefull h args_ty_list e_list in
+	  (*check accumulator type matches in input and output*)
+	  if List.length result_ty_list > 1 then
+	    error (Etwo_many_outputs);
+	  begin try
+	    unify (last_element args_ty_list) (List.hd result_ty_list)
+	  with 
+	      TypingError(kind) -> message (List.hd e_list).e_loc kind 
+	  end;
+	  (List.hd result_ty_list), typed_e_list
+    | Imapfold -> 
+	let args_ty_list = incomplete_map (fun ty -> array_of ty n) args_ty_list in
+	let result_ty_list = incomplete_map (fun ty -> array_of ty n) result_ty_list in
+	let typed_e_list = typing_args statefull h args_ty_list e_list in
+	  (*check accumulator type matches in input and output*)
+	   begin try
+	      unify (last_element args_ty_list) (last_element result_ty_list)
+	    with 
+		TypingError(kind) -> message (List.hd e_list).e_loc kind 
+	   end;
+	   prod result_ty_list, typed_e_list
+
+and typing_array_subscript statefull h idx_list ty  = 
+  match ty, idx_list with
+    | ty, [] -> ty 
+    | Tbase(Tarray(base_ty, exp)), idx::idx_list -> 
+	add_size_constr (LEqual (SConst 0, idx));
+	add_size_constr (LEqual (idx, SOp(SMinus, exp, SConst 1)));
+	typing_array_subscript statefull h idx_list (Tbase base_ty) 
+    | _, _ -> error (Esubscripted_value_not_an_array ty)
+
+(* This function checks that the array dimensions matches
+ the subscript. It returns the base type wrt the nb of indices. *)
+and typing_array_subscript_dyn statefull h idx_list ty = 
+  match ty, idx_list with
+    | ty, [] -> ty, [] 
+    | Tbase(Tarray(base_ty, exp)), idx::idx_list -> 
+	let typed_idx = expect statefull h (Tbase(Tint)) idx in 
+	let ty, typed_idx_list = 
+	  typing_array_subscript_dyn statefull h idx_list (Tbase base_ty) in
+	  ty, typed_idx::typed_idx_list 
+    | _, _ -> error (Esubscripted_value_not_an_array ty)
+
+and typing_args statefull h expected_ty_list e_list =
+  try 
+    List.map2 (expect statefull h) expected_ty_list e_list
+  with Invalid_argument _ ->
+    error (Earity_clash(List.length e_list, List.length expected_ty_list))
+
+let rec typing_pat h acc = function
+  | Evarpat(x) -> 
+      let ty = typ_of_name h x in
+      let acc = 
+        if Env.mem x acc 
+	then error (Ealready_defined (sourcename x)) 
+	else Env.add x ty acc in
+      acc, ty
+  | Etuplepat(pat_list) ->
+      let acc, ty_list =
+        List.fold_right 
+	  (fun pat (acc, ty_list) -> 
+	    let acc, ty = typing_pat h acc pat in acc, ty :: ty_list) 
+	  pat_list (acc, []) in
+      acc, Tprod(ty_list)
+
+let rec typing_eq statefull h acc eq =
+  let typed_desc,acc = match eq.eq_desc with
+    | Eautomaton(state_handlers) ->
+	let typed_sh,acc = 
+	  typing_automaton_handlers statefull h acc state_handlers in
+	Eautomaton(typed_sh),
+	acc
+    | Eswitch(e, switch_handlers) ->
+	let typed_e,ty = typing statefull h e in
+	let typed_sh,acc = 
+	  typing_switch_handlers statefull h acc ty switch_handlers in
+	Eswitch(typed_e,typed_sh),
+	acc
+    | Epresent(present_handlers, b) ->
+	let typed_b, def_names, _ = typing_block statefull h b in
+	let typed_ph, acc =
+	  typing_present_handlers statefull h acc def_names present_handlers in
+	Epresent(typed_ph,typed_b),
+	acc
+    | Ereset(eq_list, e) ->
+	let typed_e = expect statefull h (Tbase(tbool)) e in
+	let typed_eq_list, acc = typing_eq_list statefull h acc eq_list in
+	Ereset(typed_eq_list,typed_e),
+	acc
+    | Eeq(pat, e) ->
+	let acc, ty_pat = typing_pat h acc pat in
+	let typed_e = expect statefull h ty_pat e in
+	Eeq(pat, typed_e),
+	acc in
+  { eq with
+      eq_statefull = statefull;
+      eq_desc = typed_desc },
+  acc
+    
+and typing_eq_list statefull h acc eq_list =
+  let rev_typed_eq_list,acc =
+    List.fold_left 
+      (fun (rev_eq_list,acc) eq -> 
+	 let typed_eq, acc = typing_eq statefull h acc eq in
+	 (typed_eq::rev_eq_list),acc
+      )
+      ([],acc)
+      eq_list in
+  ((List.rev rev_typed_eq_list),
+   acc)
+
+and typing_automaton_handlers statefull h acc state_handlers =
+  (* checks unicity of states *)
+  let addname acc { s_state = n } =
+    if S.mem n acc then error (Ealready_defined(n)) else S.add n acc in
+  let states =  List.fold_left addname S.empty state_handlers in
+    
+  let escape statefull h ({ e_cond = e; e_next_state = n } as esc) =
+    if not (S.mem n states) then error (Eundefined(n));
+    let typed_e = expect statefull h (Tbase(tbool)) e in
+    { esc with e_cond = typed_e } in
+    
+  let handler 
+      ({ s_state = n; s_block = b; s_until = e_list1; s_unless = e_list2 } as s) =
+    let typed_b, defined_names, h0 = typing_block statefull h b in
+    let typed_e_list1 = List.map (escape statefull h0) e_list1 in
+    let typed_e_list2 = List.map (escape false h) e_list2 in
+    { s with 
+	s_block = typed_b;
+	s_until = typed_e_list1;
+	s_unless = typed_e_list2 },
+    defined_names in
+
+  let typed_handlers,defined_names_list = 
+    List.split (List.map handler state_handlers) in
+  let total, partial = merge defined_names_list in
+  all_last h partial;
+  typed_handlers,
+  (add total (add partial acc))
+
+and typing_switch_handlers statefull h acc ty switch_handlers =
+  (* checks unicity of states *)
+  let addname acc { w_name = n } =
+    let n = shortname(n) in
+    if S.mem n acc then error (Ealready_defined(n)) else S.add n acc in
+  let cases = List.fold_left addname S.empty switch_handlers in
+  let d = diff_const (set_of_constr (desc_of_ty ty)) cases in
+  if not (S.is_empty d) then error (Epartial_switch(S.choose d));
+  
+  let handler ({ w_block = b; w_name = name }) =
+    let typed_b, defined_names, _ = typing_block statefull h b in
+    { w_block = typed_b;
+      (* Replace handler name with fully qualified name *)
+      w_name = Modname((find_constr name).qualid)},
+    defined_names in
+
+  let typed_switch_handlers, defined_names_list = 
+    List.split (List.map handler switch_handlers) in
+  let total, partial = merge defined_names_list in
+  all_last h partial;
+  (typed_switch_handlers,
+   add total (add partial acc))
+
+and typing_present_handlers statefull h acc def_names present_handlers =
+  let handler ({ p_cond = e; p_block = b }) =
+    let typed_e = expect false h (Tbase(tbool)) e in
+    let typed_b, defined_names, _ = typing_block statefull h b in
+    { p_cond = typed_e; p_block = typed_b },
+    defined_names
+  in
+    
+  let typed_present_handlers, defined_names_list =
+    List.split (List.map handler present_handlers) in
+  let total, partial = merge (def_names :: defined_names_list) in
+  all_last h partial;
+  (typed_present_handlers,
+   (add total (add partial acc)))
+
+and typing_block statefull h 
+    ({ b_local = l; b_equs = eq_list; b_loc = loc } as b) =
+  try
+    let typed_l, local_names, h0 = build h Env.empty l in
+    let typed_eq_list, defined_names = 
+      typing_eq_list statefull h0 Env.empty eq_list in
+    let defnames = diff_env defined_names local_names in
+    { b with 
+	b_statefull = statefull;
+	b_defnames = defnames;
+	b_local = typed_l;
+	b_equs = typed_eq_list },
+    defnames, h0
+  with
+    | TypingError(kind) -> message loc kind
+
+and build h h0 dec =
+  List.fold_left
+    (fun (acc_dec, acc_defined, h) 
+      ({ v_name = n; v_type = btype; v_last = l; v_loc = loc } as v) ->
+      try
+	let ty = check_type btype in
+	(* update type longname with module name from check_type *)
+	v.v_type <- ty;
+	if (Env.mem n h0) or (Env.mem n h) 
+	then error (Ealready_defined(sourcename n))
+	else
+	  ({ v with v_type = ty }::acc_dec,
+	   Env.add n (Tbase(ty)) acc_defined, 
+	   Env.add n { ty = Tbase(ty); last = last l } h)
+      with
+	| TypingError(kind) -> message loc kind)
+    ([], Env.empty, h) dec
+
+let build_params h params =
+  let add_one h param =
+    if Env.mem param h then 
+      error (Ealready_defined(name param));
+    Env.add param { ty = Tbase Tint; last = false } h
+  in
+    List.fold_left add_one h params
+
+let typing_contract statefull h contract =
+
+  match contract with
+  | None -> None,Env.empty,h
+  | Some ({ c_local = l_list;
+	    c_eq = eq;
+	    c_assume = e_a;
+	    c_enforce = e_g;
+	    c_controllables = c_list }) ->
+      let typed_c_list, controllable_names, h = build h h c_list in
+      let typed_l_list, local_names, h' = build h h l_list in
+      
+      let typed_eq, defined_names = typing_eq_list statefull h' Env.empty eq in
+      
+      (* assumption *)
+      let typed_e_a = expect statefull h' (Tbase(tbool)) e_a in
+      (* property *)
+      let typed_e_g = expect statefull h' (Tbase(tbool)) e_g in
+      
+      included_env local_names defined_names;
+      included_env defined_names local_names;
+      
+      Some { c_local = typed_l_list;
+	     c_controllables = List.rev typed_c_list;
+	     c_eq = typed_eq;
+	     c_assume = typed_e_a;
+	     c_enforce = typed_e_g },
+      controllable_names, h
+
+let signature const_env statefull params returns contract node_params constraints = 
+  let arg_dec_of_var_dec vd =
+    { a_name = Some (sourcename vd.v_name);
+      a_type = Tbase(check_type vd.v_type);
+      a_linearity = vd.v_linearity;
+      a_pass_by_ref = false; } 
+  in
+    { inputs = List.map arg_dec_of_var_dec params;
+      outputs = List.map arg_dec_of_var_dec returns;
+      contract = contract;
+      node = statefull;
+      safe = false;
+      targeting = [];
+      params = node_params; 
+      params_constraints = constraints; }
+
+let solve loc env cl =
+  try 
+    solve env cl
+  with
+     Solve_failed c -> message loc (Econstraint_solve_failed c)
+
+let node const_env ({ n_name = f; n_statefull = statefull; 
+		  n_input = i_list; n_output = o_list;
+		  n_contract = contract;
+		  n_local = l_list; n_equs = eq_list; n_loc = loc;
+		  n_params = node_params; } as n) =
+  try
+    let typed_i_list, input_names, h = build Env.empty Env.empty i_list in
+    let typed_o_list, output_names, h = build h h o_list in
+    
+    (* typing contract *)
+    let typed_contract, controllable_names, h = typing_contract statefull h contract in
+
+    let typed_l_list, local_names, h = build h h l_list in
+    let typed_eq_list, defined_names = typing_eq_list statefull h Env.empty eq_list in
+    if not (statefull) & (List.length o_list <> 1) 
+    then error (Etwo_many_outputs);
+    let expected_names = add local_names output_names in
+    included_env expected_names defined_names;
+    included_env defined_names expected_names;
+
+    let cl = get_size_constr () in
+    let ff = Format.formatter_of_out_channel stdout in
+      Format.fprintf ff "Gathered constraints before solving for %s: %d\n " f (List.length cl);
+      print_list ff print_size_constr ", " cl; 
+      Format.fprintf ff "\n"; 
+
+      let cl = solve loc const_env cl in
+      Format.fprintf ff "Constraints after solving for %s: %d\n " f (List.length cl);
+      print_list ff print_size_constr ", " cl; 
+      Format.fprintf ff "\n"; 
+      Format.fprintf ff "@?" ;
+
+      add_value f (signature const_env statefull i_list o_list contract node_params cl);
+
+      { n with 
+	  n_input = List.rev typed_i_list;
+	  n_output = List.rev typed_o_list;
+	  n_local = typed_l_list;
+	  n_contract = typed_contract;
+	  n_equs = typed_eq_list }
+  with
+    | TypingError(error) -> message loc error
+
+let deftype const_env { t_name = n; t_desc = tdesc; t_loc = loc } =
+  try
+    match tdesc with
+      | Type_abs -> add_type n Tabstract
+      | Type_enum(tag_name_list) ->
+	  add_type n (Tenum(tag_name_list));
+	  List.iter (fun tag -> add_constr tag (Tid(longname n))) tag_name_list
+      | Type_struct(field_ty_list) ->
+	  let field_ty_list = 
+	    List.map (fun (n,ty) -> n, simplify_type loc const_env ty) field_ty_list in
+	  add_type n (Tstruct(field_ty_list));
+	  add_struct n field_ty_list;
+	  List.iter 
+	    (fun (field, ty) -> 
+	      add_field field (Tid(longname n)) (check_type ty)) field_ty_list
+  with
+      TypingError(error) -> message loc error
+
+let build_const_env cd_list =
+  List.fold_left (fun env cd -> NamesEnv.add cd.c_name cd.c_value env) NamesEnv.empty cd_list
+
+let program 
+    ({ p_opened = opened; p_types = p_type_list;
+       p_nodes = p_node_list; p_consts = p_consts_list } as p) =
+  let const_env = build_const_env p_consts_list in
+    List.iter open_module opened;
+    List.iter (deftype const_env) p_type_list;
+    let typed_node_list = List.map (node const_env) p_node_list in
+      { p with p_nodes = typed_node_list }

heptagon/heptagon.ml

@@ -0,0 +1,370 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* the internal representation *)
+(* $Id$ *)
+
+open Location
+open Misc
+open Names
+open Linearity
+open Ident
+open Interference_graph
+open Static
+
+type inlining_policy =
+  | Ino
+  | Ione
+  | Irec
+
+type ty =
+  | Tbase of base_ty
+  | Tprod of ty list
+
+and base_ty =
+  | Tint | Tfloat | Tbool
+  | Tid of longname
+  | Tarray of base_ty * size_exp
+
+and exp =
+    { e_desc: desc;
+      mutable e_ty: ty;
+      mutable e_linearity : linearity;
+      e_loc: location }
+
+and desc =
+  | Econst of const
+  | Evar of ident
+  | Econstvar of name
+  | Elast of ident
+  | Etuple of exp list
+  | Eapp of app * exp list
+  | Efield of exp * longname
+  | Estruct of (longname * exp) list
+  | Earray of exp list
+  | Ereset_mem of ident * exp * ident
+
+and app =
+    { mutable a_op : op; (* hange of global name after typing *)
+      a_inlined : inlining_policy; (* node to inline or not *)
+    }
+
+and op =
+  | Epre of const option
+  | Efby | Earrow | Eifthenelse | Enode of longname * size_exp list
+  | Eevery of longname * size_exp list | Eop of longname * size_exp list
+  | Erepeat | Eselect of size_exp list | Eselect_dyn
+  | Eupdate of size_exp list
+  | Eselect_slice
+  | Econcat | Ecopy
+  | Eiterator of iterator_name * longname * size_exp list * exp option
+  | Efield_update of longname
+  | Eflatten of longname | Emake of longname
+
+and const =
+  | Cint of int
+  | Cfloat of float
+  | Cconstr of longname
+  | Cconst_array of size_exp * const 
+
+and pat =
+  | Etuplepat of pat list
+  | Evarpat of ident
+
+type eq =
+    { eq_desc : eqdesc;
+      mutable eq_statefull : bool;
+      eq_loc : location }
+
+and eqdesc =
+  | Eautomaton of state_handler list
+  | Eswitch of exp * switch_handler list
+  | Epresent of present_handler list * block
+  | Ereset of eq list * exp
+  | Eeq of pat * exp
+
+and block =
+    { b_local: var_dec list;
+      b_equs: eq list;
+      mutable b_defnames: ty Env.t;
+      mutable b_statefull: bool;
+      b_loc: location; }
+
+and state_handler =
+    { s_state : name;
+      s_block : block;
+      s_until : escape list;
+      s_unless : escape list; }
+
+and escape =
+    { e_cond : exp;
+      e_reset : bool;
+      e_next_state : name; }
+
+and switch_handler =
+    { w_name : longname;
+      w_block : block; }
+
+and present_handler =
+    { p_cond : exp;
+      p_block : block; }
+
+and var_dec =
+    { v_name : ident;
+      mutable v_type : base_ty;
+      mutable v_linearity : linearity;
+      v_last : last;
+      v_loc  : location; }
+
+and last = Var | Last of const option
+
+type type_dec =
+    { t_name : name;
+      t_desc : type_desc;
+      t_loc  : location }
+
+and type_desc =
+  | Type_abs
+  | Type_enum of name list
+  | Type_struct of (name * base_ty) list
+
+type contract =
+    { c_assume : exp;
+      c_enforce : exp;
+      c_controllables : var_dec list;
+      c_local : var_dec list;
+      c_eq : eq list;
+    }
+
+type node_dec =
+    { n_name      : name;
+      n_statefull : bool;
+      n_input     : var_dec list;
+      n_output    : var_dec list;
+      n_local     : var_dec list;
+      n_contract  : contract option;
+      n_equs      : eq list;
+      n_loc       : location; 
+      n_states_graph : (name,name) interf_graph; 
+      n_params : name list;
+      n_params_constraints : size_constr list;
+    }
+
+type const_dec =
+    { c_name : name;
+      c_type : base_ty;
+      c_value : size_exp;
+      c_loc : location; }
+
+type program =
+    { p_pragmas: (name * string) list;
+      p_opened : name list;
+      p_types  : type_dec list;
+      p_nodes  : node_dec list;
+      p_consts : const_dec list; }
+
+type signature =
+    { sig_name    : name;
+      sig_inputs  : (name option * base_ty * linearity) list;
+      sig_outputs : (name option * base_ty * linearity) list;
+      sig_node    : bool;
+      sig_safe    : bool;
+      sig_params  : name list; }
+
+type interface = interface_decl list
+
+and interface_decl =
+    { interf_desc : interface_desc;
+      interf_loc  : location }
+
+and interface_desc =
+  | Iopen of name
+  | Itypedef of type_dec
+  | Isignature of signature
+
+let tbool = Tbool
+
+let edesc e = e.e_desc
+let eqdesc eq = eq.eq_desc
+
+(* Helper functions to create AST. *)
+let pbool = Modname({ qual = "Pervasives"; id = "bool" })
+let ptrue = Modname({ qual = "Pervasives"; id = "true" })
+let pfalse = Modname({ qual = "Pervasives"; id = "false" })
+let por = Modname({ qual = "Pervasives"; id = "or" })
+let pint = Modname({ qual = "Pervasives"; id = "int" })
+let pfloat = Modname({ qual = "Pervasives"; id = "float" })
+
+let emake desc ty = { e_desc = desc; e_ty = ty; 
+		      e_linearity = NotLinear; e_loc = no_location }
+let eop op = { a_op = op; a_inlined = Ino }
+let tmake name desc = { t_name = name; t_desc = desc; t_loc = no_location }
+let eqmake desc = { eq_desc = desc; eq_statefull = true; eq_loc = no_location }
+
+let tybool = Tbase(tbool)
+let cfalse = Cconstr(pfalse)
+let ctrue = Cconstr(ptrue)
+
+let make_bool desc = emake desc tybool
+let bool_var n = make_bool (Evar(n))
+let bool_param n =
+  { v_name = n; v_type = tbool; v_last = Var; 
+    v_loc = no_location; v_linearity = NotLinear }
+
+let dfalse = make_bool (Econst(Cconstr(pfalse)))
+let dtrue = make_bool (Econst(Cconstr(ptrue)))
+
+let var n ty = emake (Evar(n)) ty
+let param n ty =
+  { v_name = n; v_type = ty; v_linearity = NotLinear; 
+    v_last = Var; v_loc = no_location }
+let fby_state initial e =
+  { e with e_desc = Eapp(eop (Epre(Some(Cconstr initial))), [e]) }
+let fby_false e = emake (Eapp(eop (Epre(Some(cfalse))), [e])) tybool
+let last_false x = emake (Elast(x)) tybool
+let ifthenelse e1 e2 e3 = emake (Eapp(eop Eifthenelse, [e1;e2;e3])) e2.e_ty
+let rec or_op e1 e2 = { e1 with e_desc = Eapp(eop (Eop(por, [])), [e1; e2]) }
+let pair e1 e2 = emake (Etuple([e1;e2])) (Tprod [e1.e_ty;e2.e_ty])
+let block defnames eqs =
+  { b_local = []; b_equs = eqs; b_defnames = defnames;
+    b_statefull = true; b_loc = no_location }
+let eq pat e = eqmake (Eeq(pat, e))
+let reset eq_list e = eqmake (Ereset(eq_list, e))
+let switch e l = eqmake (Eswitch(e, l))
+
+let varpat n = Evarpat(n)
+
+(* Helper functions to work with type*)
+let base_type ty =
+  match ty with
+    | Tbase ty -> ty
+    | _ -> assert false
+
+let is_scalar_type ty =
+  let pint = Modname({ qual = "Pervasives"; id = "int" }) in
+  let pfloat = Modname({ qual = "Pervasives"; id = "float" }) in
+  let pbool = Modname({ qual = "Pervasives"; id = "bool" }) in
+    match ty with
+      | Tbase(Tint) | Tbase(Tfloat) | Tbase(Tbool) -> true
+      | Tbase(Tid name_int) when name_int = pint -> true
+      | Tbase(Tid name_float) when name_float = pfloat -> true
+      | Tbase(Tid name_bool) when name_bool = pbool -> true	  
+      | _ -> false 
+	
+let array_of ty exp =
+  Tbase(Tarray (base_type ty, exp))
+
+let const_array_of ty n =
+  array_of ty (SConst n)
+
+let op_from_app app =
+  match app.a_op with
+    | Eop (n,_) -> op_from_app_name n
+    | _ -> raise Not_static
+
+let rec size_exp_of_exp e =
+  match e.e_desc with 
+  | Econstvar n -> SVar n
+  | Econst (Cint i) -> SConst i
+  | Eapp(app, [e1;e2]) ->
+      let op = op_from_app app in
+	SOp(op, size_exp_of_exp e1, size_exp_of_exp e2)
+  | _ -> raise Not_static
+
+module Vars =
+struct
+  let rec vars_pat locals acc = function
+    | Evarpat(x) ->
+        if (IdentSet.mem x locals) or (IdentSet.mem x acc) then
+	  acc 
+	else 
+	  IdentSet.add x acc
+    | Etuplepat(pat_list) -> List.fold_left (vars_pat locals) acc pat_list
+
+  let rec left locals acc e =
+    match e.e_desc with
+      | Eapp({a_op = Epre _},[e]) -> acc
+      | Eapp({a_op = Efby}, [e1;e2]) -> left locals acc e1
+      | Etuple(e_list) | Eapp({a_op = _}, e_list) | Earray(e_list)->
+          List.fold_left (left locals) acc e_list
+      | Evar(n) | Ereset_mem (_, _, n) ->
+          if (IdentSet.mem n acc) or (IdentSet.mem n locals) then
+	    acc 
+	  else
+	    IdentSet.add n acc
+      | Efield(e, _) -> left locals acc e
+      | Estruct(f_e_list) ->
+          List.fold_left (fun acc (_, e) -> left locals acc e) acc f_e_list
+      | Elast _ | Econst _ | Econstvar _  -> acc
+
+  let rec read locals acc eq =
+    match eq.eq_desc with
+      | Eeq(pat, e) -> left locals acc e
+      | Ereset(eq_list, e) ->
+          List.fold_left (read locals) (left locals acc e) eq_list
+      | Eautomaton(state_handlers) ->
+          let escapes locals acc e_list =
+            List.fold_left
+              (fun acc { e_cond = e } -> left locals acc e) acc e_list in
+          List.fold_left
+            (fun acc {s_block = b; s_until = e_list1; s_unless = e_list2} ->
+               let new_locals, acc = read_and_locals_block locals acc b in
+               let acc = escapes new_locals acc e_list1 in
+               escapes locals acc e_list2)
+            acc state_handlers
+      | Eswitch(e, switch_handlers) ->
+          List.fold_left
+            (fun acc { w_block = b } -> read_block locals acc b)
+            (left locals acc e) switch_handlers
+      | Epresent(present_handlers, b) ->
+          List.fold_left
+            (fun acc { p_cond = e; p_block = b } ->
+               read_block locals (left locals acc e) b)
+            (read_block locals acc b) present_handlers
+
+  and read_and_locals_block locals acc { b_local = l; b_equs = eq_list } =
+    let locals =
+      List.fold_left
+        (fun acc { v_name = n } -> if IdentSet.mem n acc then acc else IdentSet.add n acc)
+        locals l in
+    locals, List.fold_left (read locals) acc eq_list
+
+  and read_block locals acc b =
+    let _, acc = read_and_locals_block locals acc b in acc
+
+  let rec def locals acc eq =
+    match eq.eq_desc with
+      | Eeq(pat, _) -> vars_pat locals acc pat
+      | Eautomaton(state_handler) ->
+          List.fold_left
+            (fun acc { s_block = b } ->
+               def_block locals acc b) acc state_handler
+      | Eswitch(_, switch_handler) ->
+          List.fold_left
+            (fun acc { w_block = b } ->
+               def_block locals acc b) acc switch_handler
+      | Epresent(present_handler, b) ->
+          List.fold_left
+            (fun acc { p_block = b } -> def_block locals acc b)
+            (def_block locals acc b) present_handler
+      | Ereset(eq_list, _) -> def_list locals acc eq_list
+
+  and def_block locals acc ({ b_local = l; b_equs = eq_list }) =
+    let locals =
+      List.fold_left
+        (fun acc { v_name = n } -> if IdentSet.mem n acc then acc else IdentSet.add n acc)
+        locals l in
+    def_list locals acc eq_list
+
+  and def_list locals acc def_list = List.fold_left (def locals) acc def_list
+
+  let read eq = IdentSet.elements (read IdentSet.empty IdentSet.empty eq)
+  let def eq = IdentSet.elements (def IdentSet.empty IdentSet.empty eq)
+  let antidep eq = false
+  let vars_list pat = IdentSet.elements (vars_pat IdentSet.empty IdentSet.empty pat)
+end

heptagon/parsing/lexer.mll

@@ -0,0 +1,315 @@
+(* lexer.mll *)
+
+(* $Id$ *)
+
+{
+open Lexing
+open Parser
+
+type lexical_error =
+    Illegal_character
+  | Unterminated_comment
+  | Bad_char_constant
+  | Unterminated_string;;
+
+exception Lexical_error of lexical_error * int * int;;
+
+let comment_depth = ref 0
+
+let keyword_table = ((Hashtbl.create 149) : (string, token) Hashtbl.t);;
+
+List.iter (fun (str,tok) -> Hashtbl.add keyword_table str tok) [
+ "node", NODE;
+ "fun", FUN;
+ "safe", SAFE;
+ "returns", RETURNS;
+ "var", VAR;
+ "val", VAL;
+ "const", CONST;
+ "unsafe", UNSAFE;
+ "let", LET;
+ "tel", TEL;
+ "end", END;
+ "fby", FBY;
+ "switch", SWITCH;
+ "when", WHEN;
+ "type", TYPE;
+ "every", EVERY;
+ "true", BOOL(true);
+ "false", BOOL(false);
+ "pre", PRE;
+ "or", OR;
+ "not", NOT;
+ "open", OPEN;
+ "automaton", AUTOMATON;
+ "switch", SWITCH;
+ "present", PRESENT;
+ "reset", RESET;
+ "state", STATE;
+ "unless", UNLESS;
+ "until", UNTIL;
+ "emit", EMIT;
+ "last", LAST;
+ "if", IF;
+ "then", THEN;
+ "else", ELSE;
+ "default", DEFAULT;
+ "continue", CONTINUE;
+ "case", CASE;
+ "do", DO;
+ "contract", CONTRACT;
+ "assume", ASSUME;
+ "enforce", ENFORCE;
+ "with", WITH;
+ "inlined", INLINED;
+ "at", AT;
+ "with", WITH;
+ "map", MAP;
+ "fold", FOLD;
+ "mapfold", MAPFOLD;
+ "copy", COPY;
+ "flatten", FLATTEN;
+ "make", MAKE;
+ "quo", INFIX3("quo");
+ "mod", INFIX3("mod");
+ "land", INFIX3("land");
+ "lor", INFIX2("lor");
+ "lxor", INFIX2("lxor");
+ "lsl", INFIX4("lsl");
+ "lsr", INFIX4("lsr");
+ "asr", INFIX4("asr")
+]
+
+
+(* To buffer string literals *)
+
+let initial_string_buffer = String.create 256
+let string_buff = ref initial_string_buffer
+let string_index = ref 0
+
+let reset_string_buffer () =
+  string_buff := initial_string_buffer;
+  string_index := 0;
+  ()
+
+(*
+let incr_linenum lexbuf =
+  let pos = lexbuf.Lexing.lex_curr_p in
+    lexbuf.Lexing.lex_curr_p <- { pos with
+      Lexing.pos_lnum = pos.Lexing.pos_lnum + 1;
+      Lexing.pos_bol = pos.Lexing.pos_cnum;
+    }
+*)
+
+let store_string_char c =
+  if !string_index >= String.length (!string_buff) then begin
+    let new_buff = String.create (String.length (!string_buff) * 2) in
+      String.blit (!string_buff) 0 new_buff 0 (String.length (!string_buff));
+      string_buff := new_buff
+  end;
+  String.set (!string_buff) (!string_index) c;
+  incr string_index
+
+
+let get_stored_string () =
+  let s = String.sub (!string_buff) 0 (!string_index) in
+    string_buff := initial_string_buffer;
+    s
+
+let char_for_backslash = function
+    'n' -> '\010'
+  | 'r' -> '\013'
+  | 'b' -> '\008'
+  | 't' -> '\009'
+  | c   -> c
+
+let char_for_decimal_code lexbuf i =
+  let c =
+    100 * (int_of_char(Lexing.lexeme_char lexbuf i) - 48) +
+     10 * (int_of_char(Lexing.lexeme_char lexbuf (i+1)) - 48) +
+          (int_of_char(Lexing.lexeme_char lexbuf (i+2)) - 48) in
+  char_of_int(c land 0xFF)
+
+
+}
+
+rule token = parse
+  | [' ' '\010' '\013' '\009' '\012'] +   { token lexbuf }
+  | "."             {DOT}
+  | "("             {LPAREN}
+  | ")"             {RPAREN}
+  | "*"             { STAR }
+  | "{"             {LBRACE}
+  | "}"             {RBRACE}
+  | ":"             {COLON}
+  | ";"             {SEMICOL}
+  | "="             {EQUAL}
+  | "=="            {EQUALEQUAL}
+  | "&"             {AMPERSAND}
+  | "&&"            {AMPERAMPER}
+  | "||"            {BARBAR}
+  | ","             {COMMA}
+  | "->"            {ARROW}
+  | "|"             {BAR}
+  | "-"             {SUBTRACTIVE "-"}
+  | "-."            {SUBTRACTIVE "-."}
+  | "^"             {POWER} 
+  | "["             {LBRACKET}
+  | "]"             {RBRACKET}
+  | "@"             {AROBASE}
+  | ".."            {DOUBLE_DOT}
+  | "<<"            {DOUBLE_LESS}
+  | ">>"            {DOUBLE_GREATER}
+  | (['A'-'Z']('_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9']) * as id)
+      {Constructor id}
+  | (['A'-'Z' 'a'-'z']('_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9']) * as id)
+      { let s = Lexing.lexeme lexbuf in
+          begin try
+	    Hashtbl.find keyword_table s
+          with 
+	      Not_found -> IDENT id
+	  end 
+      }
+  | ['0'-'9']+
+  | '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+
+  | '0' ['o' 'O'] ['0'-'7']+
+  | '0' ['b' 'B'] ['0'-'1']+
+      { INT (int_of_string(Lexing.lexeme lexbuf)) }
+  | ['0'-'9']+ ('.' ['0'-'9']*)? (['e' 'E'] ['+' '-']? ['0'-'9']+)?
+      { FLOAT (float_of_string(Lexing.lexeme lexbuf)) }
+  | "\""
+      { reset_string_buffer();
+        let string_start = lexbuf.lex_start_pos + lexbuf.lex_abs_pos in
+        begin try
+          string lexbuf
+        with Lexical_error(Unterminated_string, _, string_end) ->
+          raise(Lexical_error(Unterminated_string, string_start, string_end))
+        end;
+        lexbuf.lex_start_pos <- string_start - lexbuf.lex_abs_pos;
+        STRING (get_stored_string()) }
+  | "'" [^ '\\' '\''] "'"
+      { CHAR(Lexing.lexeme_char lexbuf 1) }
+  | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'"
+      { CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) }
+  | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
+      { CHAR(char_for_decimal_code lexbuf 2) }
+  | "(*@ " (['A'-'Z' 'a'-'z']('_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9']) * as id)
+      {
+	reset_string_buffer();
+	let pragma_start = lexbuf.lex_start_pos + lexbuf.lex_abs_pos in
+	begin try
+	  pragma lexbuf
+	with Lexical_error(Unterminated_comment, _, pragma_end) ->
+	  raise(Lexical_error(Unterminated_comment, pragma_start, pragma_end))
+	end;
+	lexbuf.lex_start_pos <- pragma_start - lexbuf.lex_abs_pos;
+	PRAGMA(id,get_stored_string())
+      }
+  | "(*"
+      { let comment_start = lexbuf.lex_start_pos + lexbuf.lex_abs_pos in
+        comment_depth := 1;
+        begin try
+          comment lexbuf
+        with Lexical_error(Unterminated_comment, _, comment_end) ->
+          raise(Lexical_error(Unterminated_comment,
+                              comment_start, comment_end))
+        end;
+        token lexbuf }
+   | ['!' '?' '~']
+      ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':'
+	  '<' '=' '>' '?' '@' '^' '|' '~'] *
+      { PREFIX(Lexing.lexeme lexbuf) }
+  | ['=' '<' '>' '&'  '|' '&' '$']
+      ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>'
+	  '?' '@' '^' '|' '~'] *
+      { INFIX0(Lexing.lexeme lexbuf) }
+  | ['@' '^']
+      ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>'
+	  '?' '@' '^' '|' '~'] *
+      { INFIX1(Lexing.lexeme lexbuf) }
+  | ['+' '-']
+      ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>'
+	  '?' '@' '^' '|' '~'] *
+      { INFIX2(Lexing.lexeme lexbuf) }
+  | "**"
+      ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>'
+	  '?' '@' '^' '|' '~'] *
+      { INFIX4(Lexing.lexeme lexbuf) }
+  | ['*' '/' '%']
+      ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>'
+	  '?' '@' '^' '|' '~'] *
+      { INFIX3(Lexing.lexeme lexbuf) }
+  | eof            {EOF}
+  | _              {raise (Lexical_error (Illegal_character,
+					  Lexing.lexeme_start lexbuf,
+					  Lexing.lexeme_end lexbuf))}
+
+and pragma = parse
+    "(*"
+      { let comment_start = lexbuf.lex_start_pos + lexbuf.lex_abs_pos in
+        comment_depth := 1;
+        begin try
+          comment lexbuf
+        with Lexical_error(Unterminated_comment, _, comment_end) ->
+          raise(Lexical_error(Unterminated_comment,
+                              comment_start, comment_end))
+        end;
+        pragma lexbuf }
+  | "@*)"
+      { }
+  | eof
+      { raise(Lexical_error(Unterminated_comment,0,
+                            Lexing.lexeme_start lexbuf)) }
+
+  | _
+      { store_string_char(Lexing.lexeme_char lexbuf 0);
+	pragma lexbuf }
+
+and comment = parse
+    "(*"
+      { comment_depth := succ !comment_depth; comment lexbuf }
+  | "*)"
+      { comment_depth := pred !comment_depth;
+        if !comment_depth > 0 then comment lexbuf }
+  | "\""
+      { reset_string_buffer();
+        let string_start = lexbuf.lex_start_pos + lexbuf.lex_abs_pos in
+        begin try
+          string lexbuf
+        with Lexical_error(Unterminated_string, _, string_end) ->
+          raise(Lexical_error(Unterminated_string, string_start, string_end))
+        end;
+        comment lexbuf }
+  | "''"
+      { comment lexbuf }
+  | "'" [^ '\\' '\''] "'"
+      { comment lexbuf }
+  | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'"
+      { comment lexbuf }
+  | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
+      { comment lexbuf }
+  | eof
+      { raise(Lexical_error(Unterminated_comment,0,
+                            Lexing.lexeme_start lexbuf)) }
+  | _
+      { comment lexbuf }
+
+and string = parse
+    '"'
+      { () }
+  | '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] *
+      { string lexbuf }
+  | '\\' ['\\' '"'  'n' 't' 'b' 'r']
+      { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1));
+        string lexbuf }
+  | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
+      { store_string_char(char_for_decimal_code lexbuf 1);
+         string lexbuf }
+  | eof
+      { raise (Lexical_error
+                (Unterminated_string, 0, Lexing.lexeme_start lexbuf)) }
+  | _
+      { store_string_char(Lexing.lexeme_char lexbuf 0);
+        string lexbuf }
+
+(* eof *)

heptagon/parsing/parser.mly

@@ -0,0 +1,607 @@
+%{
+(* $Id$ *)
+
+open Misc
+open Global
+open Location
+open Names
+open Linearity
+open Parsetree
+
+%}
+
+%token DOT LPAREN RPAREN LBRACE RBRACE COLON SEMICOL
+%token EQUAL EQUALEQUAL BARBAR COMMA BAR ARROW LET TEL
+%token <string> Constructor
+%token <string> IDENT
+%token <int> INT
+%token <float> FLOAT
+%token <bool> BOOL
+%token <char> CHAR
+%token <string> STRING
+%token <string * string> PRAGMA
+%token TYPE FUN NODE RETURNS VAR VAL UNSAFE IN OPEN SAFE END CONST
+%token FBY PRE SWITCH WHEN EVERY
+%token OR STAR NOT
+%token AMPERSAND
+%token AMPERAMPER
+%token AUTOMATON
+%token SWITCH
+%token PRESENT
+%token RESET
+%token STATE
+%token UNLESS
+%token UNTIL
+%token EMIT
+%token LAST
+%token IF
+%token THEN
+%token ELSE
+%token DEFAULT
+%token DO
+%token CONTINUE
+%token CASE
+%token CONTRACT
+%token ASSUME
+%token ENFORCE
+%token WITH
+%token INLINED
+%token AT
+%token POWER
+%token LBRACKET
+%token RBRACKET
+%token WITH DOUBLE_DOT
+%token AROBASE
+%token DOUBLE_LESS DOUBLE_GREATER
+%token MAP FOLD MAPFOLD
+%token <string> PREFIX
+%token <string> INFIX0
+%token <string> INFIX1
+%token <string> INFIX2
+%token <string> SUBTRACTIVE
+%token <string> INFIX3
+%token <string> INFIX4
+%token EOF
+%token COPY
+%token FLATTEN MAKE
+
+%right AROBASE
+%left WITH
+%nonassoc prec_ident
+%nonassoc LBRACKET
+%left IF ELSE
+%right ARROW
+%nonassoc EVERY
+%left OR
+%left AMPERSAND
+%left INFIX0 EQUAL
+%right INFIX1
+%left INFIX2 SUBTRACTIVE
+%left STAR INFIX3
+%left INFIX4
+%right NOT
+%right prec_uminus
+%right FBY
+%right PRE
+%right LAST
+%right prec_apply
+%left POWER
+%right PREFIX
+%left DOT
+
+%start program
+%type <Parsetree.program> program
+
+%start interface
+%type <Parsetree.interface> interface
+
+%%
+
+program:
+  | pragma_headers open_modules const_decs type_decs node_decs EOF 
+      {{ p_pragmas = $1;
+	 p_opened = List.rev $2;
+         p_types = $4;
+         p_nodes = $5;
+	 p_consts = $3; }}
+;
+
+pragma_headers:
+  | /* empty */ { [] }
+  | PRAGMA pragma_headers { $1 :: $2 }
+
+open_modules:
+  | /* empty */ { [] }
+  | open_modules OPEN Constructor { $3 :: $1 }
+;
+
+const_decs:
+  | /* empty */        { [] }
+  | const_dec const_decs { $1 :: $2 }
+;
+
+const_dec:
+  | CONST IDENT COLON ty_ident EQUAL exp
+      { cmake $2 $4 $6 }
+;
+
+type_decs:
+  | /* empty */        { [] }
+  | type_dec type_decs { $1 :: $2 }
+;
+
+type_dec:
+  | TYPE IDENT                      { tmake $2 Type_abs }
+  | TYPE IDENT EQUAL enum_ty_desc   { tmake $2 (Type_enum ($4)) }
+  | TYPE IDENT EQUAL struct_ty_desc { tmake $2 (Type_struct ($4)) }
+;
+
+enum_ty_desc:
+  | Constructor BAR Constructor   {[$1;$3]}
+  | BOOL BAR BOOL                 {[(if $1 then "true" else "false");
+                                    (if $3 then "true" else "false")]}
+  | Constructor BAR enum_ty_desc  {$1 :: $3}
+;
+
+struct_ty_desc:
+  | LBRACE label_ty_list RBRACE { $2 }
+;
+
+label_ty_list:
+  | label_ty { [$1] }
+  | label_ty SEMICOL label_ty_list { $1 :: $3 }
+;
+
+label_ty:
+  IDENT COLON ty_ident { ($1, fst $3) }
+;
+
+node_decs:
+  | /* empty */        {[]}
+  | node_dec node_decs {$1 :: $2}
+;
+
+node_dec:
+  | node_or_fun ident node_params LPAREN in_params RPAREN
+    RETURNS LPAREN out_params RPAREN
+    contract loc_vars LET equs TEL
+      {{ n_name   = $2;
+   n_statefull = $1;
+   n_input  = $5;
+   n_output = $9;
+   n_contract = $11;
+   n_local  = $12;
+   n_equs   = $14;
+   n_params = $3;
+   n_loc = Location.get_current_location () }}
+;
+
+node_or_fun:
+  | NODE { true }
+  | FUN { false }
+;
+
+safe:
+  | /* empty */ { false }
+  | SAFE { true }
+;
+
+in_params:
+  | params {$1}
+;
+
+params:
+  | /* empty */  { [] }
+  | nonmt_params { $1 }
+;
+
+nonmt_params:
+  | param               { $1 }
+  | param SEMICOL nonmt_params { $1 @ $3 }
+;
+
+param:
+  | ident_list COLON ty_ident
+      { List.map (fun id -> vmake id $3 Var) $1 }
+;
+
+out_params:
+  | /* empty */ { [] }
+  | nonmt_out_params { $1 }
+;
+
+nonmt_out_params:
+  | var_last { $1 }
+  | var_last SEMICOL nonmt_out_params { $1 @ $3 }
+;
+
+node_params:
+  | /* empty */ { [] }
+  | DOUBLE_LESS ident_list DOUBLE_GREATER { $2 }
+;
+
+contract:
+  | /* empty */ {None}
+  | CONTRACT loc_vars opt_equs opt_assume enforce opt_with
+      {Some{c_local = $2;
+	    c_eq = $3;
+	    c_assume = $4;
+	    c_enforce = $5;
+	    c_controllables = $6 }}
+;
+      
+opt_equs:
+  | /* empty */ { [] }
+  | LET equs TEL { $2 }
+;
+
+opt_assume:
+  | /* empty */ { e_true () }
+  | ASSUME exp { $2 }
+;
+
+enforce:
+  | ENFORCE exp { $2 }
+;
+
+opt_with:
+  | /* empty */ { [] }
+  | WITH LPAREN params RPAREN { $3 }
+;
+
+loc_vars:
+  | /* empty */    { [] }
+  | VAR loc_params { $2 }
+;
+
+loc_params:
+  | var_last SEMICOL            { $1 }
+  | var_last SEMICOL loc_params { $1 @ $3 }
+;
+
+var_last:
+  | ident_list COLON ty_ident
+      { List.map (fun id -> vmake id $3 Var) $1 }
+  | LAST IDENT COLON ty_ident EQUAL const
+      { [ vmake $2 $4 (Last(Some($6))) ] }
+  | LAST IDENT COLON ty_ident
+      { [ vmake $2 $4 (Last(None)) ] }
+;
+
+ident_list:
+  | IDENT  { [$1] }
+  | IDENT COMMA ident_list { $1 :: $3 }
+;
+
+ty_ident:
+  | ty_ident_base
+      { $1, NotLinear }
+  | ty_ident_base AT ident
+      { $1, At $3 }
+;
+
+ty_ident_base:
+  | IDENT
+      { Tid(Name($1)) }
+  | ty_ident_base POWER simple_exp
+      { Tarray ($1, $3) }
+;
+
+equs:
+  | /* empty */             { [] }
+  | non_empty_equs opt_semi { List.rev $1 }
+;
+
+non_empty_equs:
+  | equ                        { [$1] }
+  | non_empty_equs SEMICOL equ {$3 :: $1}
+;
+
+opt_semi:
+  | {}
+  | SEMICOL {}
+;
+
+opt_bar:
+  | {}
+  | BAR {}
+;
+
+equ:
+  | pat EQUAL exp { eqmake (Eeq($1, $3)) }
+  | AUTOMATON automaton_handlers END
+      { eqmake (Eautomaton(List.rev $2)) }
+  | SWITCH exp opt_bar switch_handlers END
+      { eqmake (Eswitch($2, List.rev $4)) }
+  | PRESENT opt_bar present_handlers END
+      { eqmake (Epresent(List.rev $3, bmake [] [])) }
+  | PRESENT opt_bar present_handlers DEFAULT loc_vars DO equs END
+      { eqmake (Epresent(List.rev $3, bmake $5 $7)) }
+  | IF exp THEN loc_vars DO equs ELSE loc_vars DO equs END
+      { eqmake (Eswitch($2,
+           [{ w_name = Name("true"); w_block = bmake $4 $6};
+      { w_name = Name("false"); w_block = bmake $8 $10 }])) }
+  | RESET equs EVERY exp
+      { eqmake (Ereset($2, $4)) }
+;
+
+automaton_handler:
+  | STATE Constructor loc_vars DO equs opt_until_escapes opt_unless_escapes
+      { { s_state = $2; s_block = bmake $3 $5;
+    s_until = $6; s_unless = $7 } }
+;
+
+automaton_handlers:
+  | automaton_handler
+      { [$1] }
+  | automaton_handlers automaton_handler
+      { $2 :: $1 }
+;
+
+opt_until_escapes:
+  | { [] }
+  | UNTIL escapes
+      { List.rev $2 }
+;
+
+opt_unless_escapes:
+  | { [] }
+  | UNLESS escapes
+      { List.rev $2 }
+;
+
+escape:
+  | exp THEN Constructor
+      { { e_cond = $1; e_reset = true; e_next_state = $3 } }
+  | exp CONTINUE Constructor
+      { { e_cond = $1; e_reset = false; e_next_state = $3 } }
+;
+
+escapes:
+  | escape
+      { [$1] }
+  | escapes BAR escape
+      { $3 :: $1 }
+;
+
+switch_handler:
+  | constructor loc_vars DO equs
+      { { w_name = $1; w_block = bmake $2 $4 } }
+;
+
+switch_handlers:
+  | switch_handler
+      { [$1] }
+  | switch_handlers BAR switch_handler
+      { $3 :: $1 }
+;
+
+present_handler:
+  | exp loc_vars DO equs
+      { { p_cond = $1; p_block = bmake $2 $4 } }
+;
+
+present_handlers:
+  | present_handler
+      { [$1] }
+  | present_handlers BAR present_handler
+      { $3 :: $1 }
+;
+
+pat:
+  | IDENT             {Evarpat $1}
+  | LPAREN ids RPAREN {Etuplepat $2}
+;
+
+ids:
+  | pat COMMA pat {[$1; $3]}
+  | pat COMMA ids {$1 :: $3}
+;
+
+nonmtexps:
+  | exp                 {[$1]}
+  | exp COMMA nonmtexps {$1 :: $3}
+;
+
+exps:
+  | /* empty */    {[]}
+  | nonmtexps      {$1}
+;
+
+simple_exp:
+  | IDENT                   { emake (Evar $1) }
+  | const                   { emake (Econst $1) }
+  | LBRACE field_exp_list RBRACE
+      { emake (Estruct($2)) }
+  | LBRACKET array_exp_list RBRACKET
+      { emake (Earray $2) }
+  | LPAREN tuple_exp RPAREN
+      { emake (Etuple $2) }
+  | LPAREN exp RPAREN
+      { $2 }
+;
+
+node_name:
+  | longname call_params
+      { Enode($1, $2) }
+
+exp:
+  | simple_exp { $1 }
+  | simple_exp FBY exp  
+      { emake (Eapp(eop (Efby), [$1; $3])) }
+  | PRE exp 
+      { emake (Eapp(eop (Epre(None)), [$2])) }
+  | node_name LPAREN exps RPAREN %prec prec_apply
+      { emake (Eapp(eop $1, $3)) }
+  | INLINED node_name LPAREN exps RPAREN %prec prec_apply
+      { emake (Eapp(eop_inlined $2, $4)) }
+  | NOT exp
+      { emake (Eapp(eop (Eop(Name("not"),[])), [$2])) }
+  | exp INFIX4 exp
+      { emake (Eapp(eop (Eop(Name($2),[])), [$1; $3])) }
+  | exp INFIX3 exp
+      { emake (Eapp(eop (Eop(Name($2),[])), [$1; $3])) }
+  | exp INFIX2 exp
+      { emake (Eapp(eop (Eop(Name($2),[])), [$1; $3])) }
+  | exp INFIX1 exp
+      { emake (Eapp(eop (Eop(Name($2),[])), [$1; $3])) }
+  | exp INFIX0 exp
+      { emake (Eapp(eop (Eop(Name($2),[])), [$1; $3])) }
+  | exp EQUAL exp
+      { emake (Eapp(eop (Eop(Name("="),[])), [$1; $3])) }
+  | exp OR exp
+      { emake (Eapp(eop (Eop(Name("or"),[])), [$1; $3])) }
+  | exp STAR exp
+      { emake (Eapp(eop (Eop(Name("*"),[])), [$1; $3])) }
+  | exp AMPERSAND exp
+      { emake (Eapp(eop (Eop(Name("&"),[])), [$1; $3])) }
+  | exp SUBTRACTIVE exp
+      { emake (Eapp(eop (Eop(Name($2),[])), [$1; $3])) }
+  | PREFIX exp
+      { emake (Eapp(eop (Eop(Name($1),[])), [$2])) }
+  | SUBTRACTIVE exp %prec prec_uminus
+      { emake (Eapp(eop (Eop(Name("~" ^ $1),[])), [$2])) }
+  | IF exp THEN exp ELSE exp
+      { emake (Eapp(eop Eifthenelse, [$2; $4; $6])) }
+  | simple_exp ARROW exp
+      { emake (Eapp(eop Earrow, [$1; $3])) }
+  | LAST IDENT
+      { emake (Elast($2)) }
+  | exp DOT longname { emake (Efield($1, $3)) }
+/*Array operations*/
+  | exp POWER simple_exp 
+      { emake (Eapp(eop (Erepeat), [$1; $3])) }
+  | exp indexes 
+      { emake (Eapp(eop (Eselect $2), [$1])) }
+  | exp DOT indexes DEFAULT exp 
+      { emake (Eapp(eop (Eselect_dyn), [$1; $5]@$3)) }
+  | exp WITH indexes EQUAL exp
+      { emake (Eapp(eop (Eupdate $3), [$1; $5])) }
+  | exp LBRACKET exp DOUBLE_DOT exp RBRACKET
+      { emake (Eapp(eop Eselect_slice, [$1; $3; $5])) }
+  | exp AROBASE exp 
+      {  emake (Eapp(eop Econcat, [$1; $3])) }
+/*Iterators*/
+  | iterator longname DOUBLE_LESS simple_exp DOUBLE_GREATER LPAREN exps RPAREN %prec prec_apply
+      {  emake (Eapp(eop (Eiterator ($1, $2, [])), $4::$7)) }
+  | iterator LPAREN longname DOUBLE_LESS array_exp_list DOUBLE_GREATER 
+      RPAREN DOUBLE_LESS simple_exp DOUBLE_GREATER LPAREN exps RPAREN %prec prec_apply
+      {  emake (Eapp(eop (Eiterator ($1, $3, $5)), $9::$12)) }
+  | COPY LPAREN exp RPAREN %prec prec_apply
+      {  emake (Eapp(eop Ecopy, [$3])) }
+/*Records operators */
+  | exp WITH DOT longname EQUAL exp
+      { emake (Eapp(eop (Efield_update $4), [$1; $6])) }
+  | LPAREN FLATTEN longname RPAREN LPAREN exps RPAREN
+      { emake (Eapp(eop (Eflatten $3), $6)) }
+  | LPAREN MAKE longname RPAREN LPAREN exps RPAREN
+      { emake (Eapp(eop (Emake $3), $6)) }
+;
+
+call_params:
+  | /* empty */ { [] }
+  | DOUBLE_LESS array_exp_list DOUBLE_GREATER { $2 }
+;
+
+iterator:
+  | MAP { Imap }
+  | FOLD { Ifold }
+  | MAPFOLD { Imapfold }
+;
+
+indexes:
+   LBRACKET exp RBRACKET { [$2] }
+  | LBRACKET exp RBRACKET indexes { $2::$4 }
+;
+
+constructor:
+  | Constructor { Name($1) } %prec prec_ident
+  | Constructor DOT Constructor { Modname({qual = $1; id = $3}) }
+  | BOOL { Name(if $1 then "true" else "false") }
+;
+
+longname:
+  | ident { Name($1) }
+  | Constructor DOT ident { Modname({qual = $1; id = $3}) }
+;
+
+const:
+  | INT { Cint($1) }
+  | FLOAT { Cfloat($1) }
+  | constructor { Cconstr($1) }
+;
+
+tuple_exp:
+  | exp COMMA exp       {[$1; $3]}
+  | exp COMMA tuple_exp {$1 :: $3}
+;
+
+field_exp_list:
+  | field_exp { [$1] }
+  | field_exp SEMICOL field_exp_list { $1 :: $3 }
+;
+
+array_exp_list:
+  | exp { [$1] }
+  | exp COMMA array_exp_list { $1 :: $3 }
+;
+
+field_exp:
+  | longname EQUAL exp { ($1, $3) }
+;
+
+/* identifiers */
+ident:
+  | IDENT
+      { $1 }
+  | LPAREN infx RPAREN
+      { $2 }
+;
+
+infx:
+  | INFIX0          { $1 }
+  | INFIX1          { $1 }    | INFIX2        { $1 }
+  | INFIX3          { $1 }    | INFIX4        { $1 }
+  | STAR            { "*" }
+  | EQUAL           { "=" }
+  | EQUALEQUAL      { "==" }
+  | SUBTRACTIVE     { $1 }    | PREFIX        { $1 }
+  | AMPERSAND       { "&" }   | AMPERAMPER    { "&&" }
+  | OR              { "or" }  | BARBAR        { "||" }
+  | NOT             { "not" }
+;
+
+interface:
+  | interface_decls EOF { List.rev $1 }
+;
+
+interface_decls:
+  | /* empty */ { [] }
+  | interface_decls interface_decl { $2 :: $1 }
+;
+
+interface_decl:
+  | type_dec         { imake (Itypedef($1)) }
+  | OPEN Constructor { imake (Iopen($2)) }
+  | VAL safe node_or_fun ident node_params LPAREN params_signature RPAREN
+    RETURNS LPAREN params_signature RPAREN
+    { imake (Isignature({ sig_name = $4; sig_inputs = $7; sig_outputs = $11;
+        sig_node = $3; sig_safe = $2; sig_params = $5; })) }
+;
+
+params_signature:
+  | /* empty */  {[]}
+  | nonmt_params_signature {$1}
+;
+
+nonmt_params_signature:
+  | param_signature            { [$1] }
+  | param_signature SEMICOL nonmt_params_signature { $1 :: $3 }
+;
+
+param_signature:
+  | IDENT COLON ty_ident { (Some($1), $3) }
+  | ty_ident { (None, $1) }
+;
+
+%%

heptagon/parsing/parsetree.ml

@@ -0,0 +1,195 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* the internal representation *)
+(* $Id$ *)
+
+open Location
+open Names
+open Linearity
+open Misc
+
+type inlining_policy =
+  | Ino
+  | Ione
+  | Irec
+
+type ty =
+  | Tprod of ty list
+  | Tid of longname
+  | Tarray of ty * exp
+
+and exp =
+    { e_desc: desc;
+      e_loc: location }
+
+and desc =
+  | Econst of const
+  | Evar of name
+  | Elast of name
+  | Etuple of exp list
+  | Eapp of app * exp list
+  | Efield of exp * longname
+  | Estruct of (longname * exp) list
+  | Earray of exp list
+
+and app =
+    { a_op : op; (* change of global name after typing *)
+      a_inlined : inlining_policy; (* node to inline or not *)
+    }
+
+and op =
+  | Epre of const option
+  | Efby | Earrow | Eifthenelse | Enode of longname * exp list
+  | Eevery of longname * exp list | Eop of longname * exp list
+  | Erepeat | Eselect of exp list | Eselect_dyn
+  | Eupdate of exp list
+  | Eselect_slice
+  | Econcat | Ecopy
+  | Eiterator of iterator_name * longname * exp list
+  | Efield_update of longname
+  | Eflatten of longname | Emake of longname
+
+and const =
+  | Cint of int
+  | Cfloat of float
+  | Cconstr of longname
+
+and pat =
+  | Etuplepat of pat list
+  | Evarpat of name
+
+type eq =
+    { eq_desc : eqdesc;
+      eq_loc : location }
+
+and eqdesc =
+  | Eautomaton of state_handler list
+  | Eswitch of exp * switch_handler list
+  | Epresent of present_handler list * block
+  | Ereset of eq list * exp
+  | Eeq of pat * exp
+
+and block =
+    { b_local: var_dec list;
+      b_equs: eq list;
+      b_loc: location; }
+
+and state_handler =
+    { s_state : name;
+      s_block : block;
+      s_until : escape list;
+      s_unless : escape list; }
+
+and escape =
+    { e_cond : exp;
+      e_reset : bool;
+      e_next_state : name; }
+
+and switch_handler =
+    { w_name : longname;
+      w_block : block; }
+
+and present_handler =
+    { p_cond : exp;
+      p_block : block; }
+
+and var_dec =
+    { v_name : name;
+      v_type : ty;
+      v_linearity : linearity;
+      v_last : last;
+      v_loc  : location; }
+
+and last = Var | Last of const option
+
+type type_dec =
+    { t_name : name;
+      t_desc : type_desc;
+      t_loc  : location }
+
+and type_desc =
+  | Type_abs
+  | Type_enum of name list
+  | Type_struct of (name * ty) list
+
+type contract =
+    { c_assume : exp;
+      c_enforce : exp;
+      c_controllables : var_dec list;
+      c_local : var_dec list;
+      c_eq : eq list;
+    }
+
+type node_dec =
+    { n_name      : name;
+      n_statefull : bool;
+      n_input     : var_dec list;
+      n_output    : var_dec list;
+      n_local     : var_dec list;
+      n_contract  : contract option;
+      n_equs      : eq list;
+      n_loc       : location;
+      n_params : name list; }
+
+type const_dec =
+    { c_name : name;
+      c_type : ty;
+      c_value : exp;
+      c_loc  : location; }
+
+type program =
+    { p_pragmas: (name * string) list;
+      p_opened : name list;
+      p_types  : type_dec list;
+      p_nodes  : node_dec list;
+      p_consts : const_dec list; }
+
+type signature =
+    { sig_name    : name;
+      sig_inputs  : (name option * (ty * linearity)) list;
+      sig_outputs : (name option * (ty * linearity)) list;
+      sig_node    : bool;
+      sig_safe    : bool;
+      sig_params  : name list; }
+
+type interface = interface_decl list
+
+and interface_decl =
+    { interf_desc : interface_desc;
+      interf_loc  : location }
+
+and interface_desc =
+  | Iopen of name
+  | Itypedef of type_dec
+  | Isignature of signature
+
+(* Helper functions to create AST. *)
+let emake desc =
+  { e_desc = desc; e_loc = get_current_location () }
+let e_true () =
+  emake (Econst(Cconstr(Modname{ qual="Pervasives"; id="true"})))
+let eop op = { a_op = op; a_inlined = Ino }
+let eop_inlined op = { a_op = op; a_inlined = Ione }
+let tmake name desc =
+  { t_name = name; t_desc = desc; t_loc = get_current_location () }
+let eqmake desc =
+  { eq_desc = desc; eq_loc = get_current_location () }
+let imake desc =
+  { interf_desc = desc; interf_loc = get_current_location () }
+let vmake name (ty, linearity) last =
+  { v_name = name; v_type = ty; v_linearity = linearity;
+    v_last = last; v_loc = get_current_location () }
+
+let bmake locals eqs =
+  { b_local = locals; b_equs = eqs; 
+    b_loc = get_current_location () }
+
+let cmake id (ty,_) e =
+  { c_name = id; c_type = ty; c_value = e;
+    c_loc = get_current_location (); }

heptagon/parsing/scoping.ml

@@ -0,0 +1,334 @@
+(** Scoping. Introduces unique indexes for local names and replace global
+    names by qualified names *)
+
+open Location
+open Parsetree
+open Names
+open Ident
+open Format
+open Printf
+open Static
+
+module Error =
+struct
+  type error =
+    | Evar of string
+    | Econst_var of string
+    | Evariable_already_defined of string
+    | Econst_variable_already_defined of string
+    | Estatic_exp_expected
+
+  let message loc kind =
+    begin match kind with
+      | Evar name ->
+          eprintf "%aThe value identifier %s is unbound.\n"
+            output_location loc 
+	    name
+      | Econst_var name ->
+          eprintf "%aThe const identifier %s is unbound.\n"
+            output_location loc 
+	    name
+      | Evariable_already_defined name ->
+          eprintf "%aThe variable %s is already defined.\n"
+            output_location loc 
+	    name
+      | Econst_variable_already_defined name ->
+          eprintf "%aThe const variable %s is already defined.\n"
+            output_location loc 
+	    name
+      | Estatic_exp_expected ->
+          eprintf "%aA static expression was expected.\n"
+            output_location loc 	  
+    end;
+    raise Misc.Error
+end
+
+module Rename =
+struct
+  include
+  (Map.Make (struct type t = string let compare = String.compare end))
+  let append env0 env =
+    fold (fun key v env -> add key v env) env0 env
+
+  let name loc env n =
+    try
+      find n env
+    with
+	Not_found -> Error.message loc (Error.Evar(n))    
+end
+	
+(*Functions to build the renaming map*)
+let add_var loc x env =
+  if Rename.mem x env then
+    Error.message loc (Error.Evariable_already_defined x)
+  else (* create a new id for this var and add it to the env *)
+    Rename.add x (ident_of_var x) env
+
+let add_const_var loc x env =
+  if NamesEnv.mem x env then
+    Error.message loc (Error.Econst_variable_already_defined x)
+  else (* create a new id for this var and add it to the env *)
+    NamesEnv.add x (ident_of_var x) env
+
+let rec build_pat loc env = function
+  | Evarpat x -> add_var loc x env
+  | Etuplepat l -> 
+      List.fold_left (build_pat loc) env l
+	
+let build_vd_list env l =
+  let build_vd env vd =
+    add_var vd.v_loc vd.v_name env
+  in
+    List.fold_left build_vd env l
+
+let build_cd_list env l =
+  let build_cd env cd =
+    add_const_var cd.c_loc cd.c_name env
+  in
+    List.fold_left build_cd env l
+
+let build_id_list loc env l =
+  let build_id env id =
+    add_const_var loc id env
+  in  
+    List.fold_left build_id env l
+
+(* Translate the AST into Heptagon. *)
+let translate_inlining_policy = function
+  | Ino -> Heptagon.Ino
+  | Ione -> Heptagon.Ione
+  | Irec -> Heptagon.Irec
+
+let translate_const = function
+  | Cint i -> Heptagon.Cint i
+  | Cfloat f -> Heptagon.Cfloat f
+  | Cconstr ln -> Heptagon.Cconstr ln
+
+let op_from_app loc app =
+  match app.a_op with
+    | Eop (op,_) -> op_from_app_name op
+    | _ -> Error.message loc Error.Estatic_exp_expected
+
+let check_const_vars = ref true
+let rec translate_size_exp const_env e =
+  match e.e_desc with 
+  | Evar n ->
+      if !check_const_vars & not (NamesEnv.mem n const_env) then
+	Error.message e.e_loc (Error.Econst_var n)
+      else
+	SVar n
+  | Econst (Cint i) -> SConst i
+  | Eapp(app, [e1;e2]) ->
+      let op = op_from_app e.e_loc app in
+	SOp(op, translate_size_exp const_env e1, translate_size_exp const_env e2)
+  | _ -> Error.message e.e_loc Error.Estatic_exp_expected
+
+let rec translate_type const_env = function
+  | Tprod ty_list -> 
+      Heptagon.Tprod(List.map (translate_type const_env) ty_list)
+  | Tid ln -> Heptagon.Tbase (Heptagon.Tid ln)
+  | Tarray (ty, e) -> 
+      let ty = Heptagon.base_type (translate_type const_env ty) in
+	Heptagon.Tbase (Heptagon.Tarray (ty, translate_size_exp const_env e))
+
+and translate_exp const_env env e = 
+  { Heptagon.e_desc = translate_desc e.e_loc const_env env e.e_desc;
+    Heptagon.e_ty = Heptagon.Tprod [];
+    Heptagon.e_linearity = Linearity.NotLinear;
+    Heptagon.e_loc = e.e_loc }
+
+and translate_app const_env env app =
+  let op = match app.a_op with
+    | Epre None -> Heptagon.Epre None
+    | Epre (Some c) -> Heptagon.Epre (Some (translate_const c))
+    | Efby -> Heptagon.Efby
+    | Earrow -> Heptagon.Earrow
+    | Eifthenelse -> Heptagon.Eifthenelse
+    | Erepeat -> Heptagon.Erepeat
+    | Eselect_slice -> Heptagon.Eselect_slice
+    | Econcat -> Heptagon.Econcat
+    | Ecopy -> Heptagon.Ecopy
+    | Eselect_dyn -> Heptagon.Eselect_dyn 
+    | Enode (ln, params) -> Heptagon.Enode (ln, List.map (translate_size_exp const_env) params)
+    | Eevery (ln, params) -> Heptagon.Eevery (ln, List.map (translate_size_exp const_env) params)
+    | Eop (ln, params) -> Heptagon.Eop (ln, List.map (translate_size_exp const_env) params)
+    | Eselect e_list -> Heptagon.Eselect (List.map (translate_size_exp const_env) e_list)
+    | Eupdate e_list -> Heptagon.Eupdate (List.map (translate_size_exp const_env) e_list)
+    | Eiterator (it, ln, params) -> 
+	Heptagon.Eiterator (it, ln, List.map (translate_size_exp const_env) params, None)
+    | Efield_update f -> Heptagon.Efield_update f
+    | Emake f -> Heptagon.Emake f
+    | Eflatten f -> Heptagon.Eflatten f
+  in
+    { Heptagon.a_op = op;
+      Heptagon.a_inlined = translate_inlining_policy app.a_inlined }
+    
+and translate_desc loc const_env env = function
+  | Econst c -> Heptagon.Econst (translate_const c)
+  | Evar x -> 
+      if Rename.mem x env then  
+	Heptagon.Evar (Rename.name loc env x)
+      else if NamesEnv.mem x const_env then (* var not defined, maybe a const var*)
+	Heptagon.Econstvar x
+      else
+	Error.message loc (Error.Evar x)  
+  | Elast x ->  Heptagon.Elast (Rename.name loc env x)
+  | Etuple e_list -> Heptagon.Etuple (List.map (translate_exp const_env env) e_list)
+  | Eapp ({ a_op = Erepeat} as app, e_list) ->
+      let e_list = List.map (translate_exp const_env env) e_list in
+	(match e_list with
+	   | [{ Heptagon.e_desc = Heptagon.Econst c }; e1 ] -> 
+	       Heptagon.Econst (Heptagon.Cconst_array (Heptagon.size_exp_of_exp e1, c))
+	   | _ -> Heptagon.Eapp (translate_app const_env env app, e_list)
+	)
+  | Eapp (app, e_list) ->
+      let e_list = List.map (translate_exp const_env env) e_list in
+	Heptagon.Eapp (translate_app const_env env app, e_list)
+  | Efield (e, field) -> Heptagon.Efield (translate_exp const_env env e, field)
+  | Estruct f_e_list ->
+      let f_e_list = List.map (fun (f,e) -> f, translate_exp const_env env e) f_e_list in
+	Heptagon.Estruct f_e_list
+  | Earray e_list -> Heptagon.Earray (List.map (translate_exp const_env env) e_list)
+
+and translate_pat loc env = function
+  | Evarpat x -> Heptagon.Evarpat (Rename.name loc env x)
+  | Etuplepat l -> Heptagon.Etuplepat (List.map (translate_pat loc env) l)
+
+let rec translate_eq const_env env eq =
+  { Heptagon.eq_desc = translate_eq_desc eq.eq_loc const_env env eq.eq_desc ;
+    Heptagon.eq_statefull = false; 
+    Heptagon.eq_loc = eq.eq_loc }
+
+and translate_eq_desc loc const_env env = function
+    | Eswitch(e, switch_handlers) ->
+	Heptagon.Eswitch (translate_exp const_env env e,
+			 List.map (translate_switch_handler loc const_env env) switch_handlers)
+    | Eeq(p, e) ->
+	Heptagon.Eeq (translate_pat loc env p, translate_exp const_env env e)
+    | Epresent (present_handlers, b) ->
+	Heptagon.Epresent (List.map (translate_present_handler const_env env) present_handlers,
+			  translate_block const_env env b)
+    | Eautomaton state_handlers ->
+	Heptagon.Eautomaton (List.map (translate_state_handler const_env env) state_handlers)
+    | Ereset (eq_list, e) ->
+	Heptagon.Ereset (List.map (translate_eq const_env env) eq_list,
+			translate_exp const_env env e)
+
+and translate_block const_env env b =
+  let env = build_vd_list env b.b_local in
+
+  { Heptagon.b_local = translate_vd_list const_env env b.b_local;
+    Heptagon.b_equs = List.map (translate_eq const_env env) b.b_equs;
+    Heptagon.b_defnames = Env.empty ;  
+    Heptagon.b_statefull = false; 
+    Heptagon.b_loc = b.b_loc }
+
+and translate_state_handler const_env env sh =
+  { Heptagon.s_state = sh.s_state;
+    Heptagon.s_block = translate_block const_env env sh.s_block;
+    Heptagon.s_until = List.map (translate_escape const_env env) sh.s_until;
+    Heptagon.s_unless = List.map (translate_escape const_env env) sh.s_unless; }
+
+and translate_escape const_env env esc =
+  { Heptagon.e_cond = translate_exp const_env env esc.e_cond;
+    Heptagon.e_reset = esc.e_reset;
+    Heptagon.e_next_state = esc.e_next_state }
+
+and translate_present_handler const_env env ph =
+  { Heptagon.p_cond = translate_exp const_env env ph.p_cond;
+    Heptagon.p_block = translate_block const_env env ph.p_block }
+
+and translate_switch_handler loc const_env env sh =
+  { Heptagon.w_name = sh.w_name;
+    Heptagon.w_block = translate_block const_env env sh.w_block }
+
+and translate_var_dec const_env env vd = 
+  { Heptagon.v_name = Rename.name vd.v_loc env vd.v_name;
+    Heptagon.v_type = Heptagon.base_type (translate_type const_env vd.v_type);
+    Heptagon.v_linearity = vd.v_linearity;
+    Heptagon.v_last = translate_last env vd.v_last;
+    Heptagon.v_loc = vd.v_loc } 
+
+and translate_vd_list const_env env =
+  List.map (translate_var_dec const_env env)
+
+and translate_last env = function
+  | Var -> Heptagon.Var
+  | Last (None) -> Heptagon.Last None
+  | Last (Some c) -> Heptagon.Last (Some (translate_const c))
+    
+let translate_contract const_env env ct =
+  { Heptagon.c_assume = translate_exp const_env env ct.c_assume;
+    Heptagon.c_enforce = translate_exp const_env env ct.c_enforce; 
+    Heptagon.c_controllables = translate_vd_list const_env env ct.c_controllables; 
+    Heptagon.c_local = translate_vd_list const_env env ct.c_local;
+    Heptagon.c_eq = List.map (translate_eq const_env env) ct.c_eq }
+
+let translate_node const_env env node =
+  let const_env = build_id_list node.n_loc const_env node.n_params in
+  let env = build_vd_list env (node.n_input @ node.n_output @ node.n_local) in
+  { Heptagon.n_name = node.n_name;
+    Heptagon.n_statefull = node.n_statefull;
+    Heptagon.n_input = translate_vd_list const_env env node.n_input;
+    Heptagon.n_output = translate_vd_list const_env env node.n_output;
+    Heptagon.n_local = translate_vd_list const_env env node.n_local;
+    Heptagon.n_contract = Misc.optional (translate_contract const_env env) node.n_contract;
+    Heptagon.n_equs = List.map (translate_eq const_env env) node.n_equs;
+    Heptagon.n_loc = node.n_loc; 
+    Heptagon.n_states_graph = Interference_graph.mk_graph [] "";
+    Heptagon.n_params = node.n_params;
+    Heptagon.n_params_constraints = []; }
+
+let translate_typedec const_env ty =
+  let onetype = function
+    | Type_abs -> Heptagon.Type_abs
+    | Type_enum(tag_list) -> Heptagon.Type_enum(tag_list)
+    | Type_struct(field_ty_list) ->
+	let translate_field_type (f,ty) = 
+	  f, Heptagon.base_type (translate_type const_env ty)
+	in
+	  Heptagon.Type_struct (List.map translate_field_type field_ty_list)
+  in
+    { Heptagon.t_name = ty.t_name; 
+      Heptagon.t_desc = onetype ty.t_desc;
+      Heptagon.t_loc = ty.t_loc }
+
+let translate_const_dec const_env cd =
+  { Heptagon.c_name = cd.c_name;
+    Heptagon.c_type = Heptagon.base_type (translate_type const_env cd.c_type);
+    Heptagon.c_value = translate_size_exp const_env cd.c_value;
+    Heptagon.c_loc = cd.c_loc; }
+
+let translate_program p =
+  let const_env = build_cd_list NamesEnv.empty p.p_consts in
+  { Heptagon.p_pragmas = p.p_pragmas;
+    Heptagon.p_opened = p.p_opened;
+    Heptagon.p_types = List.map (translate_typedec const_env) p.p_types;
+    Heptagon.p_nodes = List.map (translate_node const_env Rename.empty) p.p_nodes;
+    Heptagon.p_consts = List.map (translate_const_dec const_env) p.p_consts; }
+
+let translate_signature const_env s =
+  let translate_field_type (f,(ty,lin)) = 
+    f, Heptagon.base_type (translate_type const_env ty), lin
+  in
+    
+  let const_env = build_id_list no_location const_env s.sig_params in
+  { Heptagon.sig_name = s.sig_name;
+    Heptagon.sig_inputs = List.map translate_field_type s.sig_inputs;
+    Heptagon.sig_outputs = List.map translate_field_type s.sig_outputs;
+    Heptagon.sig_node = s.sig_node;
+    Heptagon.sig_safe = s.sig_safe;
+    Heptagon.sig_params = s.sig_params; }
+
+let translate_interface_desc const_env = function 
+  | Iopen n -> Heptagon.Iopen n
+  | Itypedef tydec -> Heptagon.Itypedef (translate_typedec const_env tydec)
+  | Isignature s -> Heptagon.Isignature (translate_signature const_env s) 
+
+let translate_interface_decl const_env idecl = 
+  { Heptagon.interf_desc = translate_interface_desc const_env idecl.interf_desc; 
+    Heptagon.interf_loc = idecl.interf_loc }
+
+let translate_interface = 
+  List.map (translate_interface_decl NamesEnv.empty)
+

heptagon/printer.ml

@@ -0,0 +1,459 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* the printer *)
+
+(* $Id$ *)
+
+open Location
+open Misc
+open Names
+open Ident
+open Heptagon
+open Modules
+open Static
+open Format
+
+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
+
+(* 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 ff 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
+  fprintf ff "%s" s
+
+let print_longname ff ln =
+  let ln = currentname ln in
+  match ln with
+    | Name(m) -> print_name ff m
+    | Modname({ qual = "Pervasives"; id = m }) ->
+        print_name ff m
+    | Modname({ qual = m1; id = m2 }) ->
+        fprintf ff "%s." m1; print_name ff m2
+
+let print_ident ff id =
+  fprintf ff "%s" (name id)
+
+let print_iterator ff it =
+  fprintf ff "%s" (iterator_to_string it)
+
+let rec print_pat ff = function
+  | Evarpat(n) -> print_ident ff n
+  | Etuplepat(pat_list) ->
+      fprintf ff "@[(";
+      print_list ff print_pat "," pat_list;
+      fprintf ff ")@]"
+
+let rec print_base_type ff = function
+  | Tint -> fprintf ff  "int"
+  | Tbool -> fprintf ff "bool"
+  | Tfloat -> fprintf ff  "float"
+  | Tid(id) -> print_longname ff id
+  | Tarray(ty, e) ->
+      print_base_type ff ty;
+      fprintf ff "^";
+      print_size_exp ff e;
+
+and print_type ff = function
+  | Tbase(base_ty) -> print_base_type ff base_ty
+  | Tprod(ty_list) ->
+      fprintf ff "@[(";
+      print_list ff print_type " *" ty_list;
+      fprintf ff ")@]"
+
+and print_c ff = function
+  | Cint i -> fprintf ff "%d" i
+  | Cfloat f -> fprintf ff "%f" f
+  | Cconstr(tag) -> print_longname ff tag
+  | Cconst_array (n, c) ->
+      print_c ff c;
+      fprintf ff "^";
+      print_size_exp ff n
+
+and print_vd ff { v_name = n; v_type = ty; v_last = last } =
+  fprintf ff "@[<v>";
+  begin match last with Last _ -> fprintf ff "last " | _ -> () end;
+  print_ident ff n;
+  fprintf ff ": ";
+  print_base_type ff ty;
+  begin
+    match last with Last(Some(v)) -> fprintf ff "= ";print_c ff v
+      | _ -> ()
+  end;
+  fprintf ff "@]"
+
+and print_exps ff e_list =
+  fprintf ff "@[("; print_list ff print_exp "," e_list; fprintf ff ")@]"
+
+and print_exp ff e =
+  if !Misc.full_type_info then fprintf ff "(";
+  begin match e.e_desc with
+    | Evar x -> print_ident ff x
+    | Econstvar x -> print_name ff x
+    | Elast x -> fprintf ff "last "; print_ident ff x
+    | Econst c -> print_c ff c
+    | Eapp({ a_op = op }, e_list) -> print_op ff op e_list
+    | Etuple(e_list) ->
+        fprintf ff "@[(";
+        print_list ff print_exp "," e_list;
+        fprintf ff ")@]"
+    | Efield(e, field) ->
+        print_exp ff e; fprintf ff ".";
+        print_longname ff field
+    | Estruct(f_e_list) ->
+        fprintf ff "@[<v 1>{";
+        print_list ff
+          (fun ff (field, e) -> print_longname ff field;fprintf ff " = ";
+             print_exp ff e)
+          ";" f_e_list;
+        fprintf ff "}@]"
+    | Earray(e_list) ->
+        fprintf ff "@[[";
+        print_list ff print_exp "," e_list;
+        fprintf ff "]@]"
+    | Ereset_mem(y,v,res) ->
+	fprintf ff "@[reset_mem ";
+	print_ident ff y;
+	fprintf ff " = ";
+	print_exp ff v;
+	fprintf ff " every ";
+	print_ident ff res;
+	fprintf ff "@]"
+  end;
+  if !Misc.full_type_info then fprintf ff " : %a)" print_type e.e_ty
+
+and print_call_params ff = function
+  | [] -> ()
+  | l -> 
+      fprintf ff "<<";
+      print_list ff print_size_exp "," l;
+      fprintf ff ">>"
+
+and print_op ff op e_list =
+  match op, e_list with
+    | Epre(None), [e] -> fprintf ff "pre "; print_exp ff e
+    | Epre(Some(c)), [e] -> print_c ff c; fprintf ff " fby "; print_exp ff e
+    | Efby, [e1;e2] -> print_exp ff e1; fprintf ff " fby "; print_exp ff e2
+    | Earrow, [e1;e2] -> print_exp ff e1; fprintf ff " -> "; print_exp ff e2
+    | Eifthenelse,[e1;e2;e3] ->
+        fprintf ff "@["; fprintf ff "if "; print_exp ff e1;
+        fprintf ff "@ then@ "; print_exp ff e2;
+        fprintf ff "@ else@ "; print_exp ff e3;
+        fprintf ff "@]"
+    | Enode(f, params), e_list ->
+        print_longname ff f;
+	print_call_params ff params;
+        fprintf ff "(@["; print_list ff print_exp "," e_list;
+        fprintf ff ")@]"
+    | Eevery(f,params), e_list ->
+        print_longname ff f;
+	print_call_params ff params;
+        fprintf ff "(@["; print_list ff print_exp "," e_list;
+        fprintf ff ")@]"
+    | Eop(f, params), e_list ->
+        print_longname ff f;
+	print_call_params ff params;
+        fprintf ff "(@["; print_list ff print_exp "," e_list;
+        fprintf ff ")@]"
+    | Erepeat, [e1; e2] ->
+	print_exp ff e1;
+	fprintf ff "^";
+	print_exp ff e2
+    | Eselect idx_list, [e] -> 
+	print_exp ff e;
+	fprintf ff "[";
+	print_list ff print_size_exp "][" idx_list;
+	fprintf ff "]"
+    | Eselect_dyn, e::defe::idx_list ->
+	fprintf ff "@[(";
+	print_exp ff e;
+	fprintf ff "[";
+	print_list ff print_exp "][" idx_list;
+	fprintf ff "] default ";
+	print_exp ff defe;
+	fprintf ff ")@]"
+    | Eupdate idx_list, [e1;e2] ->
+	fprintf ff "(@[";
+	print_exp ff e1;
+	fprintf ff " with [";
+	print_list ff print_size_exp "][" idx_list;
+	fprintf ff "] = ";
+	print_exp ff e2;
+	fprintf ff ")@]"
+    | Eselect_slice, [e; idx1; idx2] ->
+	print_exp ff e;
+	fprintf ff "[";
+	print_exp ff idx1;
+	fprintf ff "..";
+	print_exp ff idx2;
+	fprintf ff "]"	
+    | Eiterator (it, op, params, reset), e::e_list -> 
+	fprintf ff "("; 
+	print_iterator ff it;
+	fprintf ff " ";
+	(match params with
+	   | [] -> print_longname ff op
+	   | l -> 
+	       fprintf ff "(";
+	       print_longname ff op;
+	       print_call_params ff params;
+	       fprintf ff ")"
+	);
+	fprintf ff " <<";
+	print_exp ff e;
+	fprintf ff ">>) (@[";
+	print_list ff print_exp "," e_list;
+	fprintf ff ")@]";
+	(match reset with 
+	   | None -> ()
+	   | Some r -> fprintf ff " every %a" print_exp r
+	)
+    | Econcat, [e1;e2] -> 
+	fprintf ff "@[";
+	print_exp ff e1;
+	fprintf ff " @@ ";
+	print_exp ff e2;
+	fprintf ff "@]"
+    | Ecopy, [e] -> 
+	fprintf ff "@[copy (";
+	print_exp ff e;
+	fprintf ff ")@]"
+    | Efield_update f, [e1;e2] -> 
+	fprintf ff "(@[";
+	print_exp ff e1;
+	fprintf ff " with .";
+	print_longname ff f;
+	fprintf ff " = ";
+	print_exp ff e2;
+	fprintf ff ")@]"
+    | Eflatten n, e_list ->
+	fprintf ff "@[(flatten ";
+	print_longname ff n;
+	fprintf ff ")(";
+	print_list ff print_exp "," e_list;
+	fprintf ff ")@]"
+    | Emake n, e_list -> 
+	fprintf ff "@[(make ";
+	print_longname ff n;
+	fprintf ff ")(";
+	print_list ff print_exp "," e_list;
+	fprintf ff ")@]"
+    | _ -> assert false
+
+let rec print_eq ff eq =
+  match eq.eq_desc with
+    | Eeq(p, e) ->
+        fprintf ff "@[<hov 2>";
+        print_pat ff p;
+        fprintf ff " =@ ";
+        print_exp ff e;
+        fprintf ff "@]"
+    | Eautomaton(state_handler_list) ->
+        fprintf ff "@[<v>automaton@,";
+        fprintf ff "@[<v>";
+        print_list ff print_state_handler "" state_handler_list;
+        fprintf ff "@]@,";
+        fprintf ff "end@]"
+    | Eswitch(e, switch_handler_list) ->
+        fprintf ff "@[<v>switch ";
+        print_exp ff e;
+        fprintf ff "@,@[<v>";
+        print_list ff print_switch_handler "" switch_handler_list;
+        fprintf ff "@]@,";
+        fprintf ff "end@]"
+    | Epresent(present_handler_list, b) ->
+        fprintf ff "@[<v>present@,";
+        print_list ff print_present_handler "" present_handler_list;
+        if b.b_equs <> [] then begin
+          fprintf ff "  @[<v 2>default@,";
+          print_block ff b;
+          fprintf ff "@]"
+        end;
+        fprintf ff "@,end@]"
+    | Ereset(eq_list, e) ->
+        fprintf ff "@[<v>reset@,";
+        fprintf ff "  @[<v>";
+        print_eq_list ff eq_list;
+        fprintf ff "@]";
+        fprintf ff "@,every ";
+        print_exp ff e;
+        fprintf ff "@]"
+
+and print_eq_list ff = function
+  | [] -> ()
+  | [eq] -> print_eq ff eq;fprintf ff ";"
+  | eq :: l -> print_eq ff eq;fprintf ff ";@,";print_eq_list ff l
+
+and print_state_handler ff
+    { s_state = s; s_block = b; s_until = until; s_unless = unless } =
+  fprintf ff "  @[<v 2>state ";
+  fprintf ff "%s@," s;
+  print_block ff b;
+  if until <> [] then
+    begin
+      fprintf ff "@,@[<v 2>until ";
+      print_list ff print_escape "" until;
+      fprintf ff "@]"
+    end;
+  if unless <> [] then
+    begin
+      fprintf ff "@,@[<v 2>unless ";
+      print_list ff print_escape " " unless;
+      fprintf ff "@]"
+    end;
+  fprintf ff "@]"
+
+and print_switch_handler ff { w_name = tag; w_block = b } =
+  fprintf ff "  @[<v 2>| ";
+  print_longname ff tag;
+  fprintf ff "@,";
+  print_block ff b;
+  fprintf ff "@]"
+
+and print_present_handler ff { p_cond = e; p_block = b } =
+  fprintf ff "  @[<v 2>| ";
+  print_exp ff e;
+  fprintf ff "@,";
+  print_block ff b;
+  fprintf ff "@]"
+
+and print_escape ff { e_cond = e; e_reset = r; e_next_state = ns} =
+  fprintf ff "@,| ";
+  print_exp ff e;
+  if r then fprintf ff " then " else fprintf ff " continue ";
+  print_name ff ns
+
+and print_block ff { b_local = v_list; b_equs = eqs; b_defnames = defnames } =
+  if v_list <> [] then
+    begin
+      fprintf ff "@[<v 2>var ";
+      print_list ff print_vd ";" v_list;
+      fprintf ff "@]@,"
+    end;
+  (*   (\* DEBUG *\) *)
+  (*   fprintf ff "@[<hov 2>defines @,"; *)
+  (*   Env.iter (fun n t -> fprintf ff "%s," n) defnames; *)
+  (*   fprintf ff "@]@\n"; *)
+  (*   (\* END DEBUG *\) *)
+  fprintf ff "@[<v 2>do@,";
+  print_eq_list ff eqs;
+  fprintf ff "@]"
+
+let print_type_def ff { t_name = name; t_desc = tdesc } =
+  match tdesc with
+    | Type_abs -> fprintf ff "@[type %s@\n@]" name
+    | Type_enum(tag_name_list) ->
+        fprintf ff "@[type %s = " name;
+        print_list ff print_name "| " tag_name_list;
+        fprintf ff "@\n@]"
+    | Type_struct(f_ty_list) ->
+        fprintf ff "@[type %s = " name;
+        fprintf ff "@[<v 1>{";
+        print_list ff
+          (fun ff (field, ty) ->
+             print_name ff field;
+             fprintf ff ": ";
+             print_base_type ff ty) ";" f_ty_list;
+        fprintf ff "}@]@.@]"
+
+let print_const_dec ff c =
+  fprintf ff "@[const ";
+  print_name ff c.c_name;
+  fprintf ff " : ";
+  print_base_type ff c.c_type;
+  fprintf ff " = ";
+  print_size_exp ff c.c_value;
+  fprintf ff "@.@]"
+
+let print_contract ff {c_local = l;
+                       c_eq = eqs;
+                       c_assume = e_a;
+                       c_enforce = e_g;
+                       c_controllables = cl } =
+  if l <> [] then begin
+    fprintf ff "@[<v 2>contract@\n";
+    fprintf ff "@[<hov 4>var ";
+    print_list ff print_vd ";" l;
+    fprintf ff ";@]@\n"
+  end;
+  if eqs <> [] then begin
+    fprintf ff "@[<v 2>let @,";
+    print_eq_list ff eqs;
+    fprintf ff "@]"; fprintf ff "tel@\n"
+  end;
+  fprintf ff "assume %a@;enforce %a@;with (@[<hov>"
+    print_exp e_a
+    print_exp e_g;
+  print_list ff print_vd ";" cl;
+  fprintf ff "@])@]@\n"
+
+let print_node_params ff = function
+  | [] -> ()
+  | l -> 
+      fprintf ff "<<";
+      print_list ff print_name "," l;
+      fprintf ff ">>"
+
+let print_node ff
+    { n_name = n; n_statefull = statefull; n_input = ni;
+      n_local = nl; n_output = no; n_contract = contract; n_equs = ne;
+      n_params = params; } =
+  fprintf ff "@[<v 2>%s " (if statefull then "node" else "fun");
+  print_name ff n; 
+  print_node_params ff params;
+  fprintf ff "(@[";
+  print_list ff print_vd ";" ni;
+  fprintf ff "@]) returns (@[";
+  print_list ff print_vd ";" no;
+  fprintf ff "@])@,";
+  optunit (print_contract ff) contract;
+  if nl <> [] then begin
+    fprintf ff "@[<hov 4>var ";
+    print_list ff print_vd ";" nl;
+    fprintf ff ";@]@,"
+  end;
+  fprintf ff "@[<v 2>let @,";
+  print_eq_list ff ne;
+  fprintf ff "@]@;"; fprintf ff "tel";fprintf ff "@.@]"
+
+let print_open_module ff name =
+  fprintf ff "@[open ";
+  print_name ff name;
+  fprintf ff "@.@]"
+
+let ptype oc ty =
+  let ff = formatter_of_out_channel oc in
+  print_type ff ty; fprintf ff "@?"
+
+let print oc { p_opened = po; p_types = pt; p_nodes = pn; p_consts = pc } =
+  let ff = formatter_of_out_channel oc in
+  List.iter (print_open_module ff) po;
+  List.iter (print_const_dec ff) pc;
+  List.iter (print_type_def ff) pt;
+  List.iter (print_node ff) pn;
+  fprintf ff "@?"

heptagon/transformations/automata.ml

@@ -0,0 +1,204 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* removing automata statements *)
+
+(* $Id$ *)
+
+open Location
+open Misc
+open Names
+open Ident
+open Heptagon
+open Global
+open Initial
+open Interference_graph
+
+let rename_states env g = 
+  let rename_one n =
+    try
+      let olds = List.hd n.g_content in
+      let s = NamesEnv.find olds env in
+	Hashtbl.remove g.g_hash olds;
+	Hashtbl.add g.g_hash s n;
+	n.g_content <- [s]
+    with Not_found -> ()
+  in
+    List.iter rename_one g.g_nodes
+
+(* the list of enumerated types introduced to represent states *)
+let state_type_dec_list = ref []
+
+let intro_type states =
+  let list env = NamesEnv.fold (fun _ state l -> state :: l) env [] in
+  let n = gen_symbol () in
+  let state_type = "st" ^ n in
+  state_type_dec_list :=
+    (tmake state_type (Type_enum(list states))) :: !state_type_dec_list;
+  Name(state_type)
+
+(* an automaton may be a Moore automaton, i.e., with only weak transitions; *)
+(* a Mealy one, i.e., with only strong transition or mixed *)
+let moore_mealy state_handlers =
+  let handler (moore, mealy) { s_until = l1; s_unless = l2 } =
+    (moore or (l1 <> []), mealy or (l2 <> [])) in
+  List.fold_left handler (false, false) state_handlers
+
+let rec translate_eq g (v, eq_list) eq =
+  match eq.eq_desc with
+      Eautomaton(state_handlers) ->
+        translate_automaton g v eq_list state_handlers
+    | Eswitch(e, switch_handlers) ->
+        v,
+        { eq with eq_desc =
+            Eswitch(e, translate_switch_handlers g switch_handlers) }
+        :: eq_list
+    | Epresent(present_handlers, block) ->
+        v, { eq with eq_desc =
+            Epresent(translate_present_handlers g present_handlers,
+                     translate_block g block) } :: eq_list
+    | Ereset(r_eq_list, e) ->
+        let v, r_eq_list = translate_eqs g v r_eq_list in
+        v, { eq with eq_desc = Ereset(r_eq_list, e) } :: eq_list
+    | Eeq _ -> v, eq :: eq_list
+
+and translate_eqs g v eq_list = List.fold_left (translate_eq g) (v, []) eq_list
+
+and translate_block g ({ b_local = v; b_equs = eq_list } as b) =
+  let v, eq_list = translate_eqs g v eq_list in
+  { b with b_local = v; b_equs = eq_list }
+
+and translate_switch_handlers g handlers =
+  let translate_switch_handler { w_name = n; w_block = b } =
+    { w_name = n; w_block = translate_block g b } in
+  List.map translate_switch_handler handlers
+
+and translate_present_handlers g handlers =
+  let translate_present_handler { p_cond = e; p_block = b } =
+    { p_cond = e; p_block = translate_block g b } in
+  List.map translate_present_handler handlers
+
+and translate_automaton g v eq_list handlers =
+  let has_until, has_unless = moore_mealy handlers in
+  let states =
+    let suffix = gen_symbol () in
+    List.fold_left
+      (fun env { s_state = n } -> NamesEnv.add n (n ^ suffix) env)
+      NamesEnv.empty handlers in
+
+  let statetype = intro_type states in
+  let tstatetype = Tbase(Tid(statetype)) in
+  let initial = Name(NamesEnv.find (List.hd handlers).s_state states) in
+
+  let statename = Ident.fresh "s" in
+  let next_statename = Ident.fresh "ns" in
+  let resetname = Ident.fresh "r" in
+  let next_resetname = Ident.fresh "nr" in
+  let pre_next_resetname = Ident.fresh "pnr" in
+
+  (* update the states graph with the suffixed names *)
+  rename_states states g;
+
+  let name n = Name(NamesEnv.find n states) in
+  let state n =
+    emake (Econst(Cconstr(name n))) tstatetype in
+  let statevar n = var n tstatetype in
+  let boolvar n = var n tybool in
+
+  let escapes n s rcont =
+    let escape { e_cond = e; e_reset = r; e_next_state = n } cont =
+      ifthenelse e (pair (state n) (if r then dtrue else dfalse)) cont in
+    List.fold_right escape s (pair (state n) rcont) in
+  let strong { s_state = n; s_unless = su } =
+    block
+      (Env.add statename tstatetype
+         (Env.add resetname tybool Env.empty))
+      ([reset(
+          [eq (Etuplepat[Evarpat(statename);Evarpat(resetname)])
+             (escapes n su (boolvar pre_next_resetname))])
+          (boolvar pre_next_resetname)]) in
+
+  let weak { s_state = n; s_block = b; s_until = su } =
+    let b = translate_block g b in
+    { b with b_equs =
+        [reset ((eq (Etuplepat[Evarpat(next_statename);
+                               Evarpat(next_resetname)])
+                   (escapes n su dfalse)) :: b.b_equs)
+           (boolvar resetname)];
+        (* (or_op (boolvar pre_next_resetname) (boolvar resetname))]; *)
+        b_defnames =
+        Env.add next_statename tstatetype
+          (Env.add next_resetname tybool
+             b.b_defnames)
+    } in
+  let v =
+      (param next_statename (Tid(statetype))) ::
+      (param resetname tbool) ::
+      (param next_resetname tbool) ::
+      (param pre_next_resetname tbool) :: v in
+  (* we optimise the case of an only strong automaton *)
+  (* or only weak automaton *)
+  match has_until, has_unless with
+    | true, false ->
+	(* a Moore automaton with only weak transitions *)
+	v, (switch (fby_state initial (statevar next_statename))
+	       (List.map
+		   (fun ({ s_state = n } as case) ->
+		     { w_name = name n; w_block = weak case })
+		   handlers)) ::
+	  (eq (Evarpat pre_next_resetname) 
+	      (fby_false (boolvar (next_resetname)))) ::
+	      (eq (Evarpat resetname) (boolvar pre_next_resetname)) :: eq_list
+    | _ ->
+	(* the general case; two switch to generate,
+	   statename variable used and defined *)
+	(param statename (Tid(statetype))) :: v,
+	(switch (fby_state initial (statevar next_statename))
+	    (List.map
+		(fun ({ s_state = n } as case) ->
+		  { w_name = name n; w_block = strong case })
+		handlers)) ::
+	  (switch (statevar statename)
+	      (List.map
+		  (fun ({ s_state = n } as case) ->
+		    { w_name = name n; w_block = weak case })
+		  handlers)) ::
+	  (eq (Evarpat pre_next_resetname) 
+	      (fby_false (boolvar (next_resetname)))) ::
+	  eq_list
+
+let translate_contract g ({ c_local = v; c_eq = eq_list} as c) =
+  let v, eq_list = translate_eqs g v eq_list in
+  { c with c_local = v; c_eq = eq_list }
+
+let node ({ n_local = v; n_equs = eq_list; n_contract = contract; n_states_graph = g } as n) =
+  let v, eq_list = translate_eqs g v eq_list in
+  let contract = optional (translate_contract g) contract in
+  { n with n_local = v; n_equs = eq_list; n_contract = contract }
+
+let program ({ p_types = pt_list; p_nodes = n_list } as p) =
+  let n_list = List.map node n_list in
+  { p with p_types = !state_type_dec_list @ pt_list;
+      p_nodes = n_list }
+
+(*
+  A -> do ... unless c1 then A1 ... until c'1 then A'1 ...
+
+  match A fby next_state with
+  A -> resA = pre_next_res or (if c1 then ... else ..
+
+  match state with
+  A -> reset
+  next_res = if c'1 then true else ... else false
+  every resA
+
+  if faut donc: - une memoire pour pre(next_res) + n memoires (pre(resA),...)
+
+  merge state
+  (A -> reset ... when A(state) every pre_next_res or res)
+*)

heptagon/transformations/completion.ml

@@ -0,0 +1,86 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* complete partial definitions with [x = last(x)] *)
+
+(* $Id$ *)
+
+open Location
+open Ident
+open Misc
+open Heptagon
+open Global
+
+(* adds an equation [x = last(x)] for every partially defined variable *)
+(* in a control structure *)
+let complete_with_last defined_names local_defined_names eq_list =
+  let last n ty =
+    { e_desc = Elast(n); e_ty = ty; e_linearity = Linearity.NotLinear;
+      e_loc = no_location } in
+  let equation n ty eq_list =
+    { eq_desc = Eeq(Evarpat(n), last n ty); eq_statefull = false;
+      eq_loc = no_location } :: eq_list in
+  let d = Env.diff defined_names local_defined_names in
+  Env.fold equation d eq_list
+
+let rec translate_eq eq =
+  match eq.eq_desc with
+    | Ereset(eq_list, e) ->
+        { eq with eq_desc = Ereset(translate_eqs eq_list, e) }
+    | Eeq(pat, e) ->
+        { eq with eq_desc = Eeq(pat, e) }
+    | Eswitch(e, switch_handlers) ->
+        let defnames =
+          List.fold_left
+            (fun acc { w_block = { b_defnames = d } } -> Env.union acc d)
+            Env.empty switch_handlers in
+        let switch_handlers =
+          List.map (fun ({ w_block = b } as handler) ->
+                      { handler with w_block = translate_block defnames b })
+            switch_handlers in
+        { eq with eq_desc = Eswitch(e, switch_handlers) }
+    | Epresent(present_handlers, b) ->
+        let defnames =
+          List.fold_left
+            (fun acc { p_block = { b_defnames = d } } -> Env.union acc d)
+            b.b_defnames present_handlers in
+        let present_handlers =
+          List.map (fun ({ p_block = b } as handler) ->
+                      { handler with p_block = translate_block defnames b })
+            present_handlers in
+        let b = translate_block defnames b in
+        {eq with eq_desc = Epresent(present_handlers, b)}
+    | Eautomaton(state_handlers) ->
+        let defnames =
+          List.fold_left
+            (fun acc { s_block = { b_defnames = d } } -> Env.union acc d)
+            Env.empty state_handlers in
+        let state_handlers =
+          List.map (fun ({ s_block = b } as handler) ->
+                      { handler with s_block = translate_block defnames b })
+            state_handlers in
+        { eq with eq_desc = Eautomaton(state_handlers) }
+
+and translate_eqs eq_list = List.map translate_eq eq_list
+
+and translate_block defnames
+    ({ b_defnames = bdefnames; b_equs = eq_list } as b) =
+  let eq_list = translate_eqs eq_list in
+  let eq_list = complete_with_last defnames bdefnames eq_list in
+  { b with b_equs = eq_list; b_defnames = defnames }
+
+let translate_contract ({ c_eq = eqs } as c) =
+  { c with c_eq = translate_eqs eqs }
+
+let node ({ n_equs = eq_list; n_contract = contract } as n) =
+  { n with
+      n_equs = translate_eqs eq_list;
+      n_contract = optional translate_contract contract }
+
+let program ({ p_types = pt_list; p_nodes = n_list } as p) =
+  { p with p_types = pt_list; p_nodes = List.map node n_list }

heptagon/transformations/every.ml

@@ -0,0 +1,175 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* removing complex reset expressions :
+   equations
+   x = (f every e) e'
+   -->
+   r = e;
+   x = (f every r) e'
+*)
+
+(* $Id$ *)
+
+open Location
+open Misc
+open Ident
+open Heptagon
+open Global
+open Initial
+open Reset
+
+let eq pat e =
+  { eq_desc = Eeq(pat, e); eq_statefull = false; eq_loc = no_location }
+let statefulleq = Heptagon.eq
+
+(* add an equation *)
+let equation v acc_eq_list e =
+  let n = Ident.fresh "r" in
+  n,
+  (bool_param n) :: v,
+  { eq_desc = Eeq(Evarpat(n), e); eq_statefull = true; eq_loc = e.e_loc } ::
+    acc_eq_list
+
+let orthen v acc_eq_list res e =
+  match e.e_desc with
+      Evar(n) -> v, acc_eq_list, Rorthen(res, n)
+    | _ ->
+        let n, v, acc_eq_list = equation v acc_eq_list e in
+        v, acc_eq_list, Rorthen(res, n)
+
+let add_locals m n locals =
+  let rec loop locals i n =
+    if i < n then
+      loop ((bool_param m.(i)) :: locals) (i+1) n
+    else locals in
+  loop locals 0 n
+
+(*
+let defnames m n d =
+  let rec loop acc k = if k < n then loop (S.add m.(k) acc) (k+1) else acc in
+  loop d 0
+*)
+
+let statefull eq_list = List.exists (fun eq -> eq.eq_statefull) eq_list
+
+let is_var = function
+  | { e_desc = Evar(_) } -> true
+  | _ -> false
+
+let rec translate_eq v acc_eq_list eq =
+  match eq.eq_desc with
+    | Eeq(pat, e) ->
+        let v,acc_eq_list,e = translate v acc_eq_list e in
+        v, { eq with eq_desc = Eeq(pat, e) } :: acc_eq_list
+    | Eswitch(e, tag_block_list) ->
+        let v,acc_eq_list,e = translate v acc_eq_list e in
+        let tag_block_list, acc_eq_list =
+          translate_switch acc_eq_list tag_block_list in
+        v, { eq with eq_desc = Eswitch(e, tag_block_list) } :: acc_eq_list
+    | Ereset _ | Epresent _ | Eautomaton _ -> assert false
+
+and translate_eqs v acc_eq_list eq_list =
+  List.fold_left
+    (fun (v,acc_eq_list) eq ->
+       translate_eq v acc_eq_list eq) (v,acc_eq_list) eq_list
+
+and translate_switch acc_eq_list switch_handlers =
+
+  let body {w_name = c;
+            w_block = ({ b_local = lv; b_defnames = d; b_equs = eqs } as b)} =
+    let lv,eqs = translate_eqs lv [] eqs in
+    { w_name = c;
+      w_block = { b with b_local = lv; b_defnames = d; b_equs = eqs } } in
+
+  let rec loop switch_handlers =
+    match switch_handlers with
+        [] -> []
+      | handler :: switch_handlers ->
+          (body handler) :: (loop switch_handlers) in
+
+  loop switch_handlers, acc_eq_list
+
+and translate v acc_eq_list e =
+  match e.e_desc with
+      Econst _ | Evar _ | Econstvar _ | Elast _ -> v,acc_eq_list,e
+    | Etuple(e_list) ->
+        let v, acc_eq_list,e_list = translate_list v acc_eq_list e_list in
+        v,acc_eq_list,
+        { e with e_desc = Etuple(e_list) }
+    | Eapp({ a_op = Eevery(f,params) } as op, re :: e_list)
+        when not (is_var re) ->
+        let v, acc_eq_list,re = translate v acc_eq_list re in
+        let n, v, acc_eq_list = equation v acc_eq_list re in
+        let v, acc_eq_list, e_list = translate_list v acc_eq_list e_list in
+        v,acc_eq_list,
+          { e with e_desc =
+              Eapp({ op with a_op = Eevery(f,params) },
+		  { re with e_desc = Evar(n) } :: e_list) }
+    | Eapp({ a_op = Eiterator(it, f, params, Some re) } as op, e_list) 
+	when not (is_var re) ->
+        let v, acc_eq_list,re = translate v acc_eq_list re in
+        let n, v, acc_eq_list = equation v acc_eq_list re in
+        let v, acc_eq_list, e_list = translate_list v acc_eq_list e_list in
+	let re = { re with e_desc = Evar n } in
+        v,acc_eq_list,
+          { e with e_desc =
+              Eapp({ op with a_op = Eiterator(it, f, params, Some re) },e_list) }	
+    | Eapp(f, e_list) ->
+        let v, acc_eq_list, e_list = translate_list v acc_eq_list e_list in
+        v, acc_eq_list,
+        { e with e_desc = Eapp(f, e_list) }
+    | Efield(e', field) ->
+        let v, acc_eq_list, e' = translate v acc_eq_list e' in
+        v,acc_eq_list,
+        { e with e_desc = Efield(e', field) }
+    | Estruct(e_f_list) ->
+        let v,acc_eq_list,e_f_list =
+          List.fold_left
+            (fun (v,acc_eq_list,acc_e_f) (f,e) ->
+               let v,acc_eq_list,e = translate v acc_eq_list e in
+               (v,acc_eq_list,(f,e)::acc_e_f))
+            (v,acc_eq_list,[]) e_f_list in
+        v,acc_eq_list,
+        { e with e_desc = Estruct(List.rev e_f_list) }
+    | Earray(e_list) ->
+        let v, acc_eq_list,e_list = translate_list v acc_eq_list e_list in
+        v,acc_eq_list,
+        { e with e_desc = Earray(e_list) }
+    | Ereset_mem _ -> v,acc_eq_list,e
+
+and translate_list v acc_eq_list e_list =
+  let v,acc_eq_list,acc_e =
+    List.fold_left
+      (fun (v,acc_eq_list,acc_e) e ->
+         let v,acc_eq_list,e = translate v acc_eq_list e in
+         (v,acc_eq_list,e::acc_e))
+      (v,acc_eq_list,[]) e_list in
+  v,acc_eq_list,List.rev acc_e
+
+let translate_contract ({ c_local = v;
+                          c_eq = eq_list;
+                          c_assume = e_a;
+                          c_enforce = e_g } as c) =
+  let v,acc_eq,e_a = translate v [] e_a in
+  let v,acc_eq,e_g = translate v acc_eq e_g in
+  let v, eq_list = translate_eqs v acc_eq eq_list in
+  { c with
+      c_local = v;
+      c_eq = eq_list;
+      c_assume = e_a;
+      c_enforce = e_g }
+
+let node ({ n_local = v; n_equs = eq_list; n_contract = contract } as n) =
+  let contract = optional translate_contract contract in
+  let v, eq_list = translate_eqs v [] eq_list in
+  { n with n_local = v; n_equs = eq_list; n_contract = contract }
+
+let program ({ p_types = pt_list; p_nodes = n_list } as p) =
+  { p with p_types = pt_list; p_nodes = List.map node n_list }

heptagon/transformations/last.ml

@@ -0,0 +1,111 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* removing accessed to shared variables (last x)      *)
+
+(* $Id$ *)
+
+open Location
+open Misc
+open Ident
+open Heptagon
+open Global
+
+(* introduce a fresh equation [last_x = pre(x)] for every *)
+(* variable declared with a last *)
+let last (eq_list, env, v) { v_name = n; v_type = t; v_last = last } =
+  match last with
+    | Var -> (eq_list, env, v)
+    | Last(default) ->
+        let lastn = Ident.fresh ("last" ^ (sourcename n)) in
+        (eqmake (Eeq(Evarpat(lastn),
+                     emake
+                       (Eapp (eop (Epre(default)),
+			     [emake (Evar(n)) (Tbase(t))]))
+                       (Tbase(t)))))
+        :: eq_list,
+        Env.add n lastn env,
+        (param lastn t) :: v
+
+let extend_env env v = List.fold_left last ([], env, []) v
+
+let rec translate_eq env eq =
+  match eq.eq_desc with
+    | Ereset(eq_list, e) ->
+        { eq with eq_desc = Ereset(translate_eqs env eq_list, translate env e) }
+    | Eeq(pat, e) ->
+        { eq with eq_desc = Eeq(pat, translate env e) }
+    | Eswitch(e, handler_list) ->
+        let handler_list =
+          List.map (fun ({ w_block = b } as handler) ->
+                      { handler with w_block = translate_block env b })
+            handler_list in
+        { eq with eq_desc = Eswitch(translate env e, handler_list) }
+    | Epresent _ | Eautomaton _ -> assert false
+
+and translate_eqs env eq_list = List.map (translate_eq env) eq_list
+
+and translate_block env ({ b_local = v; b_equs = eq_list } as b) =
+  let eq_lastn_n_list, env, last_v = extend_env env v in
+  let eq_list = translate_eqs env eq_list in
+  { b with b_local = v @ last_v; b_equs = eq_lastn_n_list @ eq_list }
+
+and translate env e =
+  match e.e_desc with
+      Econst _ | Evar _ | Econstvar _ -> e
+    | Elast(x) ->
+        let lx = Env.find x env in { e with e_desc = Evar(lx) }
+    | Etuple(e_list) ->
+        { e with e_desc = Etuple(List.map (translate env) e_list) }
+    | Eapp(op, e_list) ->
+        { e with e_desc = Eapp(op, List.map (translate env) e_list) }
+    | Efield(e', field) ->
+        { e with e_desc = Efield(translate env e', field) }
+    | Estruct(e_f_list) ->
+        { e with e_desc =
+            Estruct(List.map (fun (f, e) -> (f, translate env e)) e_f_list) }
+    | Earray(e_list) ->
+	{ e with e_desc = Earray(List.map (translate env) e_list) }
+    | Ereset_mem _ -> assert false
+
+let translate_contract env contract =
+  match contract with
+    | None -> None, env
+    | Some { c_local = v;
+             c_eq = eq_list;
+             c_assume = e_a;
+             c_enforce = e_g;
+             c_controllables = cl } ->
+        let _, env, _ = extend_env env cl in
+        let eq_lastn_n_list, env', last_v = extend_env env v in
+        let eq_list = translate_eqs env' eq_list in
+        let e_a = translate env' e_a in
+        let e_g = translate env' e_g in
+        Some { c_local = v @ last_v;
+               c_eq = eq_lastn_n_list @ eq_list;
+               c_assume = e_a;
+               c_enforce = e_g;
+               c_controllables = List.rev cl },
+        env
+
+let node ({ n_input = i; n_local = v; n_output = o;
+            n_equs = eq_list; n_contract  = contract } as n) =
+  let _, env, _ = extend_env Env.empty i in
+  let eq_lasto_list, env, last_o = extend_env env o in
+  let contract, env = translate_contract env contract in
+  let eq_lastn_n_list, env, last_v = extend_env env v in
+  let eq_list = translate_eqs env eq_list in
+  { n with 
+      n_input = i;
+      n_output = o;
+      n_local = v @ last_o @ last_v;
+      n_contract = contract;
+      n_equs = eq_lasto_list @ eq_lastn_n_list @ eq_list }
+
+let program ({ p_types = pt_list; p_nodes = n_list } as p) =
+  { p with p_types = pt_list; p_nodes = List.map node n_list }

heptagon/transformations/present.ml

@@ -0,0 +1,73 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* removing present statements *)
+
+(* $Id$ *)
+
+open Misc
+open Location
+open Heptagon
+open Global
+open Initial
+
+let block defnames statefull eqs =
+  { b_local = []; b_equs = eqs; b_defnames = defnames;
+    b_statefull = statefull; b_loc = no_location }
+let switch statefull e l =
+  { eq_desc = Eswitch(e, l); eq_statefull = statefull; eq_loc = no_location }
+
+let rec translate_eq v eq =
+  match eq.eq_desc with
+    | Eswitch(e, switch_handlers) ->
+        v, { eq with eq_desc =
+            Eswitch(e, translate_switch_handlers switch_handlers) }
+    | Epresent(present_handlers, block) ->
+        v,
+        translate_present_handlers present_handlers (translate_block block)
+    | Ereset(eq_list, e) ->
+        let v, eq_list = translate_eqs v eq_list in
+        v, { eq with eq_desc = Ereset(eq_list, e) }
+    | Eeq _ -> v, eq
+    | Eautomaton _ -> assert false
+
+and translate_eqs v eq_list =
+  List.fold_left
+    (fun (v, eq_list) eq ->
+       let v, eq = translate_eq v eq in v, eq :: eq_list)
+    (v, []) eq_list
+
+and translate_block ({ b_local = v; b_equs = eq_list } as b) =
+  let v, eq_list = translate_eqs v eq_list in
+  { b with b_local = v; b_equs = eq_list }
+
+and translate_switch_handlers handlers =
+  let translate_switch_handler { w_name = n; w_block = b } =
+    { w_name = n; w_block = translate_block b } in
+  List.map translate_switch_handler handlers
+
+and 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
+    block b.b_defnames statefull
+      [switch statefull e [{ w_name = ptrue; w_block = b };
+                           { w_name = pfalse; w_block = cont }]] in
+  let b = List.fold_right translate_present_handler handlers cont in
+  List.hd (b.b_equs)
+
+let translate_contract ({ c_local = v; c_eq = eq_list} as c) =
+  let v, eq_list = translate_eqs v eq_list in
+  { c with c_local = v; c_eq = eq_list }
+
+let node ({ n_local = v; n_equs = eq_list; n_contract = contract } as n) =
+  let v, eq_list = translate_eqs v eq_list in
+  let contract = optional translate_contract contract in
+  { n with n_local = v; n_equs = eq_list; n_contract = contract }
+
+let program ({ p_types = pt_list; p_nodes = n_list } as p) =
+  { p with p_types = pt_list; p_nodes = List.map node n_list }

heptagon/transformations/reset.ml

@@ -0,0 +1,266 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* removing reset statements *)
+
+(* $Id$ *)
+
+open Location
+open Misc
+open Ident
+open Heptagon
+open Global
+open Initial
+
+(* We introduce an initialization variable for each block  *)
+(* Using an asynchronous reset would allow to produce      *)
+(* better code avoiding to introduce n local variables and *)
+(* n state variables                                       *)
+(* reset
+     switch e with
+       case C1 do ...
+     | case C2 do ...
+     | case C3 do ...
+     end
+   every r
+
+   switch e with
+     case C1 do ... (* l_m1 *)
+                m1 = false; m2 = l_m2; m3 = l_m3
+   | case C2 do ... (* l_m2 *)
+                m1 = l_m1; m2 = false; m3 = l_m3
+   | case C3 do ... (* l_m3 *)
+                m1 = l_m1; m2 = l_m2; m3 = false
+   end;
+   l_m1 = if res then true else true fby m1;...;
+   l_m3 = if res then true else true fby m3
+
+   e1 -> e2 is translated into if (true fby false) then e1 else e2 
+*)
+
+let pre_true e =
+  { e with e_desc = Eapp(eop (Epre(Some(Cconstr(ptrue)))), [e]) }
+let init e = pre_true { dfalse with e_loc = e.e_loc }
+let ifthenelse e1 e2 e3 =
+  { e3 with e_desc = Eapp(eop Eifthenelse, [e1; e2; e3]) }
+let eq pat e =
+  { eq_desc = Eeq(pat, e); eq_statefull = false; eq_loc = no_location }
+let statefulleq = Heptagon.eq
+
+(* the boolean condition for a structural reset *)
+type reset =
+  | Rfalse
+  | Rorthen of reset * ident
+
+let rfalse = Rfalse
+let rvar n = Rorthen(Rfalse, n)
+
+let true_reset = function
+  | Rfalse -> false
+  | _ -> true
+
+let rec or_op res e =
+  match res with
+    | Rfalse -> e
+    | Rorthen(res, n) ->
+        or_op res { e with e_desc = Eapp(eop (Eop(por,[])), [bool_var n; e]) }
+
+let default e =
+  match e.e_desc with
+    | Econst c -> Some(c)
+    | _ -> None
+
+let exp_of_res res =
+  match res with
+    | Rfalse -> dfalse
+    | Rorthen(res, n) -> or_op res (bool_var n)
+
+let ifres res e2 e3 =
+  match res with
+    | Rfalse -> ifthenelse (init e3) e2 e3
+    | _ -> (* a reset occurs *)
+	ifthenelse (exp_of_res res) e2 e3
+
+(* add an equation *)
+let equation v acc_eq_list e =
+  let n = Ident.fresh "r" in
+  n,
+  (bool_param n) :: v,
+  { eq_desc = Eeq(Evarpat(n), e); eq_statefull = true; eq_loc = e.e_loc } ::
+    acc_eq_list
+
+let orthen v acc_eq_list res e =
+  match e.e_desc with
+    | Evar(n) -> v, acc_eq_list, Rorthen(res, n)
+    | _ ->
+        let n, v, acc_eq_list = equation v acc_eq_list e in
+        v, acc_eq_list, Rorthen(res, n)
+
+let add_locals m n locals =
+  let rec loop locals i n =
+    if i < n then
+      loop ((bool_param m.(i)) :: locals) (i+1) n
+    else locals in
+  loop locals 0 n
+
+let add_local_equations i n m lm acc =
+  (* [mi = false;...; m1 = l_m1;...; mn = l_mn] *)
+  let rec loop acc k =
+    if k < n then
+      if k = i then loop ((eq (varpat(m.(k))) dfalse) :: acc) (k+1)
+      else
+        loop
+          ((eq (varpat(m.(k))) (bool_var lm.(k))) :: acc) (k+1)
+    else acc
+  in loop acc 0
+
+let add_global_equations n m lm res acc =
+  (* [ l_m1 = if res then true else true fby m1;...;
+     l_mn = if res then true else true fby mn ] *)
+  let rec loop acc k =
+    if k < n then
+      loop
+        ((statefulleq (varpat(lm.(k)))
+            (match res with
+              | Rfalse -> pre_true (bool_var m.(k))
+              | _ -> ifres res dtrue (pre_true (bool_var m.(k)))
+            )
+         ) :: acc) (k+1)
+    else acc in
+  loop acc 0
+
+let defnames m n d =
+  let rec loop acc k =
+    if k < n
+    then loop (Env.add m.(k) tybool acc) (k+1)
+    else acc in
+  loop d 0
+
+let statefull eq_list = List.exists (fun eq -> eq.eq_statefull) eq_list
+
+let rec translate_eq res v acc_eq_list eq =
+  match eq.eq_desc with
+    | Ereset(eq_list, e) ->
+        let e = translate res e in
+        if statefull eq_list then
+          let v, acc_eq_list, res = orthen v acc_eq_list res e in
+          translate_eqs res v acc_eq_list eq_list
+        else
+          let _, v, acc_eq_list = equation v acc_eq_list e in
+          translate_eqs res v acc_eq_list eq_list
+    | Eeq(pat, e) ->
+        v, { eq with eq_desc = Eeq(pat, translate res e) } :: acc_eq_list
+    | Eswitch(e, tag_block_list) ->
+        let e = translate res e in
+        let v, tag_block_list, acc_eq_list =
+          translate_switch res v acc_eq_list tag_block_list in
+        v, { eq with eq_desc = Eswitch(e, tag_block_list) } :: acc_eq_list
+    | Epresent _ | Eautomaton _ -> assert false
+
+and translate_eqs res v acc_eq_list eq_list =
+  List.fold_left
+    (fun (v, acc_eq_list) eq ->
+       translate_eq res v acc_eq_list eq) (v, acc_eq_list) eq_list
+
+and translate_switch res locals acc_eq_list switch_handlers =
+  (* introduce a reset bit for each branch *)
+  let tab_of_vars n = Array.init n (fun _ -> Ident.fresh "r") in
+  let n = List.length switch_handlers in
+  let m = tab_of_vars n in
+  let lm = tab_of_vars n in
+
+  let locals = add_locals m n locals in
+  let locals = add_locals lm n locals in
+
+  let body i {w_name = ci;
+              w_block = ({ b_local = li; b_defnames = d; b_equs = eqi } as b)} =
+    let d = defnames m n d in
+    let li, eqi = translate_eqs (rvar (lm.(i))) li [] eqi in
+    let eqi = add_local_equations i n m lm eqi in
+    { w_name = ci;
+      w_block = { b with b_local = li; b_defnames = d; b_equs = eqi } } in
+
+  let rec loop i switch_handlers =
+    match switch_handlers with
+        [] -> []
+      | handler :: switch_handlers ->
+          (body i handler) :: (loop (i+1) switch_handlers) in
+
+  let acc_eq_list = add_global_equations n m lm res acc_eq_list in
+
+  locals, loop 0 switch_handlers, acc_eq_list
+
+and translate res e =
+  match e.e_desc with
+    | Econst _ | Evar _ | Econstvar _ | Elast _ -> e
+    | Etuple(e_list) ->
+        { e with e_desc = Etuple(List.map (translate res) e_list) }
+    | Eapp({a_op = Efby } as op, [e1;e2]) ->
+        let e1 = translate res e1 in
+        let e2 = translate res e2 in
+        begin
+          match res, e1 with
+            | Rfalse, { e_desc = Econst(c) } ->
+                (* no reset *)
+		{ e with e_desc = 
+		    Eapp({ op with a_op = Epre(Some(c)) }, [e2]) }
+            | _ ->
+                ifres res e1
+                  { e with e_desc = 
+		      Eapp({ op with a_op = Epre(default e1) }, [e2]) }
+        end
+    | Eapp({ a_op = Earrow }, [e1;e2]) ->
+        let e1 = translate res e1 in
+        let e2 = translate res e2 in
+        ifres res e1 e2
+    | Eapp({ a_op = Enode(f,params) } as op, e_list) ->
+        let e_list = List.map (translate res) e_list in
+        if true_reset res then
+          { e with e_desc = Eapp({ op with a_op = Eevery(f, params) },
+				(exp_of_res res) :: e_list) }
+        else
+          { e with e_desc = Eapp({ op with a_op = Enode(f,params) }, e_list ) }
+    | Eapp( { a_op = Eiterator(it,f, params, _) } as op, e_list) ->
+        let e_list = List.map (translate res) e_list in
+	  if true_reset res then
+	    let r = Some (exp_of_res res) in
+              { e with e_desc = Eapp({ op with a_op = Eiterator(it,f,params,r) },
+				     e_list) }
+          else
+	    { e with e_desc = Eapp(op, e_list) }
+    | Eapp({ a_op = Eevery(f, params) } as op, re :: e_list) ->
+        let re = translate res re in
+        let e_list = List.map (translate res) e_list in
+        { e with e_desc = Eapp({ op with a_op = Eevery(f, params)},
+			       (or_op res re) :: e_list) }
+    | Eapp(op, e_list) ->
+        { e with e_desc = Eapp(op, List.map (translate res) e_list) }
+    | Efield(e', field) ->
+        { e with e_desc = Efield(translate res e', field) }
+    | Estruct(e_f_list) ->
+        { e with e_desc =
+            Estruct(List.map (fun (f, e) -> (f, translate res e)) e_f_list) }
+    | Earray(e_list) ->
+        { e with e_desc = Earray(List.map (translate res) e_list) }
+
+let translate_contract ({ c_local = v;
+                          c_eq = eq_list;
+                          c_assume = e_a;
+                          c_enforce = e_g } as c) =
+  let v, eq_list = translate_eqs rfalse v [] eq_list in
+  let e_a = translate rfalse e_a in
+  let e_g = translate rfalse e_g in
+  { c with c_local = v; c_eq = eq_list; c_assume = e_a; c_enforce = e_g }
+
+let node (n) =
+  let c = optional translate_contract n.n_contract in
+  let var, eqs = translate_eqs rfalse n.n_local [] n.n_equs in
+  { n with n_local = var; n_equs = eqs; n_contract = c }
+
+let program (p) =
+  { p with p_nodes = List.map node p.p_nodes }

main/compiler.ml

@@ -0,0 +1,345 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* $Id$ *)
+
+open Location
+open Misc
+open Global
+
+let lexical_error err loc =
+  Printf.eprintf "%aIllegal character.\n" output_location loc;
+  raise Error
+
+let syntax_error loc =
+  Printf.eprintf "%aSyntax error.\n" output_location loc;
+  raise Error
+
+let language_error lang =
+  Printf.eprintf "Unknown language: %s.\n" lang
+
+let parse parsing_fun lexing_fun lexbuf =
+  try
+    parsing_fun lexing_fun lexbuf
+  with
+    | Lexer.Lexical_error(err, pos1, pos2) ->
+        lexical_error err (Loc(pos1, pos2))
+    | Parsing.Parse_error ->
+        let pos1 = Lexing.lexeme_start lexbuf
+        and pos2 = Lexing.lexeme_end lexbuf in
+        let l = Loc(pos1,pos2) in
+        syntax_error l
+
+let comment s = Printf.printf "** %s done **\n" s; flush stdout
+
+let build_path suf =
+  match !target_path with
+    | None -> suf
+    | Some path -> Filename.concat path suf
+
+let clean_dir dir =
+  if Sys.file_exists dir && Sys.is_directory dir
+  then begin
+    let rm_file_in_dir fn = Sys.remove (Filename.concat dir fn) in
+    Array.iter rm_file_in_dir (Sys.readdir dir);
+  end else Unix.mkdir dir 0o740;
+  dir
+
+(** Generation of a dataflow target *)
+let dataflow_target filename p target_languages =
+  let rec one_target = function
+ (*   | "z3z" :: others ->
+        let dirname = build_path (filename ^ "_z3z") in
+        let dir = clean_dir dirname in
+        let p = Dynamic_system.program p in
+        if !verbose then
+          comment "Translation into dynamic system (Z/3Z equations)";
+        Sigali.Printer.print dir p;
+        one_target others *)
+    | ("vhdl_df" | "vhdl") :: others ->
+        let dirname = build_path (filename ^ "_vhdl") in
+        let dir = clean_dir dirname in
+        let vhdl = Mls2vhdl.translate (Filename.basename filename) p in
+        Vhdl.print dir vhdl;
+        one_target others
+    | unknown_lg :: others -> unknown_lg :: one_target others
+    | [] -> [] in
+  one_target target_languages
+
+(** Generation of a sequential target *)
+let sequential_target filename o target_languages =
+  let rec one_target = function
+    | "c-old" :: others ->
+        let dirname = build_path (filename ^ "_c-old") in
+        let dir = clean_dir dirname in
+        C_old.print o dir;
+          one_target others 
+    | "java" :: others ->
+        let dirname = build_path filename in
+        let dir = clean_dir dirname in
+        Java.print dir o;
+        one_target others
+    | "c" :: others ->
+        let dirname = build_path (filename ^ "_c") in
+        let dir = clean_dir dirname in
+        let c_ast = Cgen.translate filename o in
+        C.output dir c_ast;
+        one_target others
+    | "caml" :: others -> Caml.print filename o; one_target others
+    | unknown_lg :: others -> unknown_lg :: one_target others
+    | [] -> [] in
+  one_target target_languages
+
+(** Whole translation. *)
+let targets filename df obc target_languages =
+  let target_languages = dataflow_target filename df target_languages in
+  let target_languages = sequential_target filename obc target_languages in
+  match target_languages with
+    | [] -> ()
+    | target :: _ -> language_error target
+
+let parse_implementation lexbuf =
+  parse Parser.program Lexer.token lexbuf
+
+let parse_interface lexbuf =
+  parse Parser.interface Lexer.token lexbuf
+
+let interface modname filename =
+  (* input and output files *)
+  let source_name = filename ^ ".epi"
+  and obj_interf_name = filename ^ ".epci" in
+
+  let ic = open_in source_name
+  and itc = open_out_bin obj_interf_name in
+  let close_all_files () =
+    close_in ic;
+    close_out itc in
+
+  try
+    Location.initialize source_name ic;
+    Modules.initialize modname;
+    Initial.initialize ();
+
+    (* Parsing of the file *)
+    let lexbuf = Lexing.from_channel ic in
+    let l = parse_interface lexbuf in
+
+    (* Convert the parse tree to Heptagon AST *)
+    let l = Scoping.translate_interface l in
+
+    Interface.Type.main l;
+    Modules.write itc;
+    if !print_types then Interface.Printer.print stdout;
+    close_all_files ()
+  with
+    | x -> close_all_files (); raise x
+
+let do_pass f d p pp enabled =
+  if enabled
+  then
+    let r = f p in
+    if !verbose
+    then begin
+      comment d;
+      pp r;
+    end;
+    r
+  else p
+
+let do_silent_pass f d p enabled =
+  if enabled
+  then begin
+    let r = f p in
+    if !verbose then comment d; r
+  end
+  else p
+
+let compile modname filename =
+  (* input and output files *)
+  let source_name = filename ^ ".ept"
+  and obj_interf_name = filename ^ ".epci"
+  and mls_name = filename ^ ".mls"
+  and mls_norm_name = filename ^ "_norm.mls"
+  and obc_name = filename ^ ".obc"
+  and ml_name = filename ^ ".ml" in
+
+  let ic = open_in source_name
+  and itc = open_out_bin obj_interf_name
+  and mlsc = open_out mls_name
+  and mlsnc = open_out mls_norm_name
+  and obc = open_out obc_name
+  and mlc = open_out ml_name in
+
+  let close_all_files () =
+    close_in ic;
+    close_out itc;
+    close_out mlsc;
+    close_out obc;
+    close_out mlc in
+
+  try
+    Location.initialize source_name ic;
+    Modules.initialize modname;
+    Initial.initialize ();
+
+    let pp = Printer.print stdout in
+
+    (* Parsing of the file *)
+    let lexbuf = Lexing.from_channel ic in
+    let p = parse_implementation lexbuf in
+
+    (* Convert the parse tree to Heptagon AST *)
+    let p = Scoping.translate_program p in
+    if !verbose
+    then begin
+      comment "Parsing";
+      pp p
+    end;
+
+(*   Misc.reset_symbol (); *)
+
+    (* Typing *)
+    let p = do_pass Typing.program "Typing" p pp true in
+
+    (* Linear typing *)
+    let p = do_pass Linear_typing.program "Linear Typing" p pp (not !no_mem_alloc) in
+
+    if !print_types then Interface.Printer.print stdout;
+    Modules.write itc;
+
+    (* Causality check *)
+    let p =
+	do_silent_pass Causality.program "Causality check" p true in
+
+    (* Initialization check *)
+    let p =
+      do_silent_pass Initialization.program "Initialization check" p !init in
+
+    (* Mark nodes to be inlined *)
+(*      let to_inline = List.map Misc.mk_longname !nodes_to_inline in
+      let p = Inline.mark_calls_to to_inline p in
+      let p = match !node_to_flatten with
+      | None -> p
+      | Some nn -> Inline.flatten nn p in
+      if !verbose then comment "Inlining pre-pass";*)
+
+    (* Inline marked nodes *)
+(*      let p = do_pass Inline.program "Inlining" p pp true in  *)
+
+   (* Automata memory sharing *)
+    let p = do_pass Automata_mem.program "Automata memory sharing" p pp (not !no_mem_alloc) in
+
+    (* Completion of partial definitions *)
+    let p = do_pass Completion.program "Completion" p pp true in
+
+    (* Automata *)
+    let p = do_pass Automata.program "Automata" p pp true in
+
+    (* Present *)
+    let p = do_pass Present.program "Present" p pp true in
+
+    (* Shared variables (last) *)
+    let p = do_pass Last.program "Last" p pp true in
+
+    (* Reset *)
+    let reset_prog = if !use_new_reset_encoding then Reset_new.program else Reset.program in
+    let p = do_pass reset_prog "Reset" p pp true in
+
+    (* Every *)
+    let p = do_pass Every.program "Every" p pp true in
+
+    (* Merge and translate the heptagon program into the *)
+    (* clocked data-flow language mini-ls *)
+    let pp = Minils.Printer.print stdout in
+
+    let p = Merge.program p in
+    if !verbose then comment "Translation into clocked equations";
+    Minils.Printer.print mlsc p;
+
+    (* Annotation of expressions with their clock *)
+    let p = Clocking.program p in
+
+    (* Mls2dot.program "" p; *)
+
+    (** Start of data-flow optimizations *)
+    (* Normalization to maximize opportunities *)
+    let p = do_pass Normalize.program "Normalization" p pp true in
+
+    (* Back-end causality check. Only useful to check that *)
+    (* we did not make any mistake during code generation *)
+    let p =
+      do_silent_pass Dfcausality.program "Post-pass causality check" p true in
+
+    (* Check that the dataflow code is well initialized *)
+    (*
+      let p =
+      do_silent_pass Init.program "Post-pass initialization check" p true in
+    *)
+
+    let sigali = List.mem "z3z" !target_languages in
+
+    (* Boolean translation of enumerated values *)
+  (*  let p =
+      do_pass
+        Boolean.program "Boolean transformation" p pp (!boolean or sigali) in
+  *)
+
+    (* Normalization to maximize opportunities *)
+    let p = do_pass Normalize.program "Normalization" p pp true in
+
+    (* Mls2dot.program "normalized_" p; *)
+
+    let p =
+      do_pass Deadcode.program "Deadcode removal" p pp !deadcode in
+
+    (* Automata minimization *)
+    let p = do_pass Tommls.program "Automata minimization" p pp !tomato in
+
+    (* Common sub-expression elimination *)
+    let p =
+      do_pass Cmse.program "Common sub-expression elimination" p pp !cse in
+
+    (* Removing intermediate equations *)
+    let p =
+      do_pass Intermediate.program "Intermediate-equations removal"
+        p pp !intermediate in
+
+    Mls2dot.program "optimized_" p;
+
+    (* Splitting *)
+    let p = do_pass Splitting.program "Splitting" p pp (not !no_mem_alloc) in
+
+    (* Scheduling *)
+    let scheduler = if !use_interf_scheduler then Schedule_interf.program else Schedule.program in
+    let p = do_pass scheduler "Scheduling" p pp true in
+
+    (* Memory allocation *)
+    Interference.world.Interference.node_is_scheduled <- true;
+    let p = do_pass Memalloc.program 
+      "Interference graph building and Memory Allocation" p pp (not !no_mem_alloc) in
+
+    (* Parametrized functions instantiation *)
+    let p = do_pass Callgraph.program 
+      "Parametrized functions instantiation" p pp true in
+
+    Minils.Printer.print mlsnc p;
+
+    (* Producing Object-based code *)
+    let o = Translate.program p in
+    if !verbose then comment "Translation into Object-based code";
+    Obc.Printer.print obc o;
+
+    let pp = Obc.Printer.print stdout in
+      if !verbose then pp o;
+
+    (* Translation into dataflow and sequential languages *)
+    targets filename p o !target_languages;
+
+    close_all_files ();
+
+  with x -> close_all_files (); raise x

main/hept2mls.ml

@@ -0,0 +1,468 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* removing switch statements and translation into Minils *)
+
+(* $Id$ *)
+
+open Location
+open Misc
+open Names
+open Ident
+open Linearity
+open Static
+
+module HeptPrinter = Printer
+
+open Minils
+open Global
+
+module Env =
+  (* associate a clock level [base on C1(x1) on ... Cn(xn)] to every *)
+  (* local name [x]                                                  *)
+  (* then [x] is translated into [x when C1(x1) ... when Cn(xn)]     *)
+struct
+  type env =
+    | Eempty
+    | Ecomp of env * IdentSet.t
+    | Eon of env * longname * ident
+
+  let empty = Eempty
+
+  let push env tag c = Eon(env, tag, c)
+
+  let add l env =
+    Ecomp(env,
+          List.fold_left
+            (fun acc { Heptagon.v_name = n } -> IdentSet.add n acc) IdentSet.empty l)
+
+  (* sample e according to the clock [base on C1(x1) on ... on Cn(xn)] *)
+  let con env x e =
+    let rec conrec env =
+      match env with
+        | Eempty -> Format.printf "%s\n" (name x); assert false
+        | Eon(env, tag, name) ->
+            let e, ck = conrec env in
+            let ck_tag_name = Con(ck, tag, name) in
+            { e with e_desc = Ewhen(e, tag, name); e_ck = ck_tag_name },
+            ck_tag_name
+        | Ecomp(env, l) ->
+            if IdentSet.mem x l then (e, Cbase) else conrec env in
+    let e, _ = conrec env in e
+
+  (* a constant [c] is translated into [c when C1(x1) on ... on Cn(xn)] *)
+  let const env e =
+    let rec constrec env =
+      match env with
+        | Eempty -> e, Cbase
+        | Eon(env, tag, name) ->
+            let e, ck = constrec env in
+            let ck_tag_name = Con(ck, tag, name) in
+            { e with e_desc = Ewhen(e, tag, name); e_ck = ck_tag_name },
+            ck_tag_name
+        | Ecomp(env, l) -> constrec env in
+    let e, _ = constrec env in e
+end
+
+(* add an equation *)
+let equation locals l_eqs e =
+  let n = Ident.fresh "ck" in
+  n,
+  { v_name = n; v_copy_of = None;
+    v_type = exp_base_type e; v_linearity = NotLinear; v_clock = Cbase } :: locals,
+  { p_lhs = Evarpat(n); p_rhs = e } :: l_eqs
+
+(* inserts the definition [x,e] into the set of shared equations *)
+let rec add x e shared =
+  match shared with
+    | [] -> [x, e]
+    | (y, e_y) :: s ->
+        if x < y then (x, e) :: shared else (y, e_y) :: add x e s
+
+let add_locals ni l_eqs s_eqs s_handlers =
+  let rec addrec l_eqs s_eqs s_handlers =
+    match s_handlers with
+      | [] -> l_eqs, s_eqs
+      | (x, e) :: s_handlers ->
+          if IdentSet.mem x ni then addrec l_eqs (add x e s_eqs) s_handlers
+          else
+            addrec ({ p_lhs = Evarpat(x); p_rhs = e } :: l_eqs)
+              s_eqs s_handlers in
+  addrec l_eqs s_eqs s_handlers
+
+let rec translate_btype ty = 
+  let pint = Modname({ qual = "Pervasives"; id = "int" }) in
+  let pfloat = Modname({ qual = "Pervasives"; id = "float" }) in
+  let pbool = Modname({ qual = "Pervasives"; id = "bool" }) in
+    match ty with
+      | Heptagon.Tid (Name "int") -> Tint
+      | Heptagon.Tid name_int when name_int = pint -> Tint
+      | Heptagon.Tint -> Tint
+      | Heptagon.Tid name_bool when name_bool = pbool -> Tid(Name("bool"))
+      | Heptagon.Tbool -> Tid(Name("bool"))
+      | Heptagon.Tid (Name "float") -> Tfloat
+      | Heptagon.Tid name_float when name_float = pfloat -> Tfloat
+      | Heptagon.Tfloat -> Tfloat
+      | Heptagon.Tid(id) -> Tid(id)
+      | Heptagon.Tarray(ty, exp) ->
+	  Tarray (translate_btype ty, exp)
+
+let rec translate_type = function
+  | Heptagon.Tbase(ty) -> Tbase(translate_btype ty)
+  | Heptagon.Tprod(ty_list) -> Tprod(List.map translate_type ty_list)
+
+let translate_var { Heptagon.v_name = n; Heptagon.v_type = t; Heptagon.v_linearity = l } =
+  { v_name = n; v_copy_of = None;
+    v_type = translate_btype t; v_linearity = l;
+    v_clock = Cbase  }
+
+let translate_locals locals l =
+  List.fold_left (fun locals v -> translate_var v :: locals) locals l
+
+(*transforms [c1, [(x1, e11);...;(xn, e1n)];...;ck, [(x1,ek1);...;(xn,ekn)]] *)
+(*into [x1=merge x (c1, e11)...(ck, ek1);...;xn=merge x (c1, e1n)...(ck,ekn)]*)
+let switch x ci_eqs_list =
+  (* Defensive coherence check *)
+  let check ci_eqs_list =
+    let rec unique = function
+        [] -> true
+      | x :: h -> not (List.mem x h) && (unique h) in
+
+    let rec extract eqs_lists =
+      match eqs_lists with
+        | [] -> [],[]
+        | []::eqs_lists' ->
+            (* check length *)
+            assert (List.for_all (function [] -> true | _ -> false) eqs_lists');
+            [],[]
+        | ((x,e)::eqs)::eqs_lists' ->
+            let firsts,nexts = extract eqs_lists' in
+            (x,e)::firsts,eqs::nexts in
+
+    let rec check_eqs eqs_lists =
+      match eqs_lists with
+        | [] -> ()
+        | []::eqs_lists' ->
+            (* check length *)
+            assert (List.for_all (function [] -> true | _ -> false) eqs_lists')
+        | _ ->
+            let firsts,nexts = extract eqs_lists in
+            (* check all firsts defining same name *)
+            if (List.for_all (fun (x,e) -> x = (fst (List.hd firsts))) firsts)
+            then ()
+            else
+              begin
+                List.iter (fun (x,e) -> Printf.eprintf "|%s|, " (name x)) firsts;
+                assert false
+              end;
+            check_eqs nexts in
+
+    let ci,eqs = List.split ci_eqs_list in
+    (* constructors uniqueness *)
+    assert (unique ci);
+    check_eqs eqs in
+
+  let rec split ci_eqs_list =
+    match ci_eqs_list with
+      | [] | (_, []) :: _ -> [], []
+      | (ci, (y, e) :: shared_eq_list) :: ci_eqs_list ->
+          let ci_e_list, ci_eqs_list = split ci_eqs_list in
+          (ci, e) :: ci_e_list, (ci, shared_eq_list) :: ci_eqs_list in
+
+  let rec distribute ci_eqs_list =
+    match ci_eqs_list with
+      | [] | (_, []) :: _ -> []
+      | (ci, (y, { e_ty = ty; e_loc = loc }) :: _) :: _ ->
+          let ci_e_list, ci_eqs_list = split ci_eqs_list in
+          (y, make_exp (Emerge(x, ci_e_list)) ty NotLinear Cbase loc) ::
+            distribute ci_eqs_list in
+
+  check ci_eqs_list;
+  distribute ci_eqs_list
+
+let rec const = function
+  | Heptagon.Cint i -> Cint i
+  | Heptagon.Cfloat f -> Cfloat f
+  | Heptagon.Cconstr t -> Cconstr t
+  | Heptagon.Cconst_array(n, c) -> Cconst_array(n, const c)
+
+open Format
+
+(** [mpol_of_hpol b] translates Heptagon's inlining policies (plain booleans at
+    the moment) to MiniLS's subtler specifications. *)
+let mpol_of_hpol hp = match hp with
+  | Heptagon.Ino -> Ino
+  | Heptagon.Ione -> Ione
+  | Heptagon.Irec -> Irec
+
+let application env { Heptagon.a_op = op;  Heptagon.a_inlined = inlined } e_list =
+  match op, e_list with
+    | Heptagon.Epre(None), [e] -> Efby(None, e)
+    | Heptagon.Epre(Some(c)), [e] -> Efby(Some(const c), e)
+    | Heptagon.Efby, [{ e_desc = Econst(c) } ; e] -> Efby(Some(c), e)
+    | Heptagon.Eifthenelse, [e1;e2;e3] -> Eifthenelse(e1, e2, e3)
+    | Heptagon.Enode(f, params), _ -> 
+	Eapp({ a_op = f; a_inlined = mpol_of_hpol inlined }, params, e_list)
+    | Heptagon.Eevery(f, params), { e_desc = Evar(n) } :: e_list ->
+        Eevery({ a_op = f; a_inlined = mpol_of_hpol inlined }, params, e_list, n)
+    | Heptagon.Eop(f, params), _ -> Eop(f, params, e_list)
+(*Array operators*)
+    | Heptagon.Erepeat, [e; idx] -> 
+	Erepeat (size_exp_of_exp idx, e) 
+    | Heptagon.Eselect idx_list, [e] -> 
+	Eselect (idx_list, e)
+(*Little hack: we need the to access the type of the array being accessed to
+  store the bounds (which will be used at code generation time, where the types 
+  are harder to find). *)
+    | Heptagon.Eselect_dyn, e::defe::idx_list ->
+	let bounds = bounds_list (exp_base_type e)  in
+	Eselect_dyn (idx_list, bounds,
+		     e, defe)
+    | Heptagon.Eupdate idx_list, [e1;e2] ->
+	Eupdate (idx_list, e1, e2)
+    | Heptagon.Eselect_slice, [e; idx1; idx2] ->
+	Eselect_slice (size_exp_of_exp idx1, size_exp_of_exp idx2, e)
+    | Heptagon.Econcat, [e1; e2] -> 
+	Econcat (e1, e2)
+    | Heptagon.Eiterator(it, f, params, reset), idx::e_list -> 
+	(match reset with
+	   | None ->
+	       Eiterator(it, f, params, size_exp_of_exp idx, e_list, None)
+	   | Some { Heptagon.e_desc = Heptagon.Evar(n) } ->
+	       Eiterator(it, f, params, size_exp_of_exp idx, e_list, Some n)
+	   | _ -> assert false
+	)      
+    | Heptagon.Ecopy, [e] -> 
+	e.e_desc
+    | Heptagon.Efield_update f, [e1;e2] ->
+	Efield_update(f, e1, e2)
+    | _ -> assert false
+
+let rec translate env
+    { Heptagon.e_desc = desc; Heptagon.e_ty = ty; 
+      Heptagon.e_linearity = l; Heptagon.e_loc = loc } =
+  let ty = translate_type ty in
+    match desc with
+    | Heptagon.Econst(c) ->
+        Env.const env
+          { e_desc = Econst(const c); e_ty = ty;
+	    e_linearity = l; e_loc = loc; e_ck = Cbase }
+    | Heptagon.Evar(x) ->
+        Env.con env x
+          { e_desc = Evar(x); e_ty = ty;
+	     e_linearity = l; e_loc = loc; e_ck = Cbase  }
+    | Heptagon.Econstvar(x) ->
+        Env.const env
+          { e_desc = Econstvar(x); e_ty = ty;
+	     e_linearity = l; e_loc = loc; e_ck = Cbase  }
+    | Heptagon.Etuple(e_list) ->
+        { e_desc = Etuple (List.map (translate env) e_list);
+          e_ty = ty; e_linearity = l; e_loc = loc; e_ck = Cbase }
+    | Heptagon.Eapp ({ Heptagon.a_op = Heptagon.Eflatten n}, [e]) ->
+	let { qualid = q;
+	      info = { fields = fields } } = Modules.find_struct n in	
+	let e = translate env e in
+	{ e_desc = Etuple (List.map (fun (n,_) -> { e with e_desc = Efield(e, Name n) }) fields);
+	  e_ty = ty; e_linearity = l; e_loc = loc; e_ck = Cbase }
+    | Heptagon.Eapp ({ Heptagon.a_op = Heptagon.Emake n}, e_list) ->
+	let { qualid = q;
+	      info = { fields = fields } } = Modules.find_struct n in	
+	let e_list = List.map (translate env) e_list in
+	{ e_desc = Estruct (List.map2 (fun (n,_) e -> Name n,e) fields e_list);
+	  e_ty = ty; e_linearity = l; e_loc = loc; e_ck = Cbase }
+    | Heptagon.Eapp(app, e_list) ->
+        { e_desc = application env app (List.map (translate env) e_list);
+          e_ty = ty; e_linearity = l; e_loc = loc; e_ck = Cbase }
+    | Heptagon.Efield(e, field) ->
+        { e_desc = Efield(translate env e, field);
+          e_ty = ty; e_linearity = l; e_loc = loc; e_ck = Cbase }
+    | Heptagon.Estruct(f_e_list) ->
+        { e_desc = Estruct(List.map
+                             (fun (f, e) -> (f, translate env e))
+                             f_e_list);
+          e_ty = ty; e_linearity = l; e_loc = loc; e_ck = Cbase }
+    | Heptagon.Earray(e_list) ->
+	{ e_desc = Earray (List.map (translate env) e_list);
+          e_ty = ty; e_linearity = l; e_loc = loc; e_ck = Cbase }
+    | Heptagon.Elast _ -> assert false
+    | Heptagon.Ereset_mem (y, v, res) ->
+	(match v.Heptagon.e_desc with
+	   | Heptagon.Econst c -> 
+	       { e_desc = Ereset_mem(y, const c, res);
+		 e_ty = ty; e_linearity = l; e_loc = loc; e_ck = Cbase }
+	   | _ -> assert false
+	)
+
+let rec translate_pat = function
+  | Heptagon.Evarpat(n) -> Evarpat n
+  | Heptagon.Etuplepat(l) -> Etuplepat (List.map translate_pat l)
+
+let rec rename_pat ni locals s_eqs = function
+  | Heptagon.Evarpat(n), Heptagon.Tbase(base_ty) ->
+      if IdentSet.mem n ni then
+        let n_copy = Ident.fresh (sourcename n) in
+        let base_ty = translate_btype base_ty in
+        Evarpat(n_copy),
+      { v_name = n_copy; v_copy_of = None;
+	v_type = base_ty; v_linearity = NotLinear; v_clock = Cbase } :: locals,
+      add n (make_exp (Evar n_copy) (Tbase(base_ty)) NotLinear Cbase no_location)
+        s_eqs
+      else Evarpat n, locals, s_eqs
+  | Heptagon.Etuplepat(l), Heptagon.Tprod(l_ty) ->
+      let l, locals, s_eqs =
+        List.fold_right2
+          (fun pat ty (p_list, locals, s_eqs) ->
+             let pat, locals, s_eqs = rename_pat  ni locals s_eqs (pat,ty) in
+             pat :: p_list, locals, s_eqs) l l_ty
+          ([], locals, s_eqs) in
+      Etuplepat(l), locals, s_eqs
+  | _ -> assert false
+
+let all_locals ni p =
+  IdentSet.is_empty (IdentSet.inter (Heptagon.Vars.vars_pat IdentSet.empty IdentSet.empty p) ni)
+
+let rec translate_eq env ni (locals, l_eqs, s_eqs) eq =
+  match Heptagon.eqdesc eq with
+    | Heptagon.Eswitch(e, switch_handlers) ->
+        translate_switch_handlers env ni (locals,l_eqs,s_eqs) e switch_handlers
+    | Heptagon.Eeq(Heptagon.Evarpat(n), e) when IdentSet.mem n ni ->
+        locals,
+        l_eqs,
+        add n (translate env e) s_eqs
+    | Heptagon.Eeq(p, e) when all_locals ni p ->
+        (* all vars from [p] are local *)
+        locals,
+        { p_lhs = translate_pat p; p_rhs = translate env e } :: l_eqs,
+        s_eqs
+    | Heptagon.Eeq(p, e) (* some are local *) ->
+        (* transforms [p = e] into [p' = e; p = p'] *)
+        let p', locals, s_eqs = 
+	  rename_pat ni locals s_eqs (p,e.Heptagon.e_ty) in
+        locals,
+        { p_lhs = p'; p_rhs = translate env e } :: l_eqs,
+        s_eqs
+    | Heptagon.Epresent _ | Heptagon.Eautomaton _ | Heptagon.Ereset _ ->
+        assert false
+
+and translate_eqs env ni (locals, local_eqs, shared_eqs) eq_list =
+  List.fold_left
+    (fun (locals, local_eqs, shared_eqs) eq ->
+       translate_eq env ni (locals, local_eqs, shared_eqs) eq)
+    (locals, local_eqs, shared_eqs) eq_list
+
+and translate_block env ni (locals, l_eqs)
+    { Heptagon.b_local = l; Heptagon.b_equs = eq_list} =
+  let env = Env.add l env in
+  let locals = translate_locals locals l in
+  let locals, local_eqs, shared_eqs =
+    translate_eqs env ni (locals, l_eqs, []) eq_list in
+  locals, local_eqs, shared_eqs
+
+and translate_switch_handlers env ni (locals, l_eqs, s_eqs) e handlers =
+  let rec transrec x ni_handlers (locals, l_eqs, ci_s_eqs_list) handlers =
+    match handlers with
+        [] -> locals, l_eqs, ci_s_eqs_list
+      | { Heptagon.w_name = ci; Heptagon.w_block = b } :: handlers ->
+          let locals, l_eqs, s_eqs =
+            translate_block (Env.push env ci x) ni_handlers (locals, l_eqs) b in
+          transrec x ni_handlers (locals, l_eqs, (ci, s_eqs) :: ci_s_eqs_list)
+            handlers in
+
+  let def = function
+      [] -> IdentSet.empty
+    | { Heptagon.w_block = { Heptagon.b_defnames = env } } :: _ ->
+        (* Create set from env *)
+        (Ident.Env.fold (fun name _ set -> IdentSet.add name set) env IdentSet.empty) in
+
+  let ni_handlers = def handlers in
+  let x, locals, l_eqs = equation locals l_eqs (translate env e) in
+  let locals, l_eqs, ci_s_eqs_list =
+    transrec x ni_handlers (locals, l_eqs, []) handlers in
+  let s_handlers = switch x ci_s_eqs_list in
+  let l_eqs, s_eqs = add_locals ni l_eqs s_eqs s_handlers in
+  locals, l_eqs, s_eqs
+
+let translate_contract env contract =
+  match contract with
+    | None -> None, env
+    | Some { Heptagon.c_local = v;
+             Heptagon.c_eq = eq_list;
+             Heptagon.c_assume = e_a;
+             Heptagon.c_enforce = e_g;
+             Heptagon.c_controllables = cl } ->
+        let env = Env.add cl env in
+        let env' = Env.add v env in
+        let locals = translate_locals [] v in
+        let locals, l_eqs, s_eqs =
+          translate_eqs env' IdentSet.empty (locals, [], []) eq_list in
+        let l_eqs, _ = add_locals IdentSet.empty l_eqs [] s_eqs in
+        let e_a = translate env' e_a in
+        let e_g = translate env' e_g in
+        Some { c_local = locals;
+               c_eq = l_eqs;
+               c_assume = e_a;
+               c_enforce = e_g;
+               c_controllables = List.map translate_var cl },
+        env
+
+
+let node
+    { Heptagon.n_name = n; Heptagon.n_input = i; Heptagon.n_output = o;
+      Heptagon.n_contract = contract;
+      Heptagon.n_local = l; Heptagon.n_equs = eq_list; 
+      Heptagon.n_loc = loc; Heptagon.n_states_graph = states_graph;
+      Heptagon.n_params =  params; Heptagon.n_params_constraints = params_constr } =
+  let env = Env.add o (Env.add i Env.empty) in
+  let contract, env = translate_contract env contract in
+  let env = Env.add l env in
+  let locals = translate_locals [] l in
+  let locals, l_eqs, s_eqs =
+    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_input = List.map translate_var i;
+    n_output = List.map translate_var o;
+    n_contract = contract;
+    n_local = locals;
+    n_equs = l_eqs;
+    n_loc = loc ;
+    n_targeting = [];
+    n_mem_alloc = [];
+    n_states_graph = states_graph;
+    n_params = params;
+    n_params_constraints = params_constr;
+    n_params_instances = []; }
+
+let typedec
+    {Heptagon.t_name = n; Heptagon.t_desc = tdesc; Heptagon.t_loc = loc} =
+  let onetype = function
+    | Heptagon.Type_abs -> Type_abs
+    | Heptagon.Type_enum(tag_list) -> Type_enum(tag_list)
+    | Heptagon.Type_struct(field_ty_list) ->
+        Type_struct
+          (List.map (fun (f, ty) -> (f, translate_btype ty)) field_ty_list)
+  in
+  { t_name = n; t_desc = onetype tdesc; t_loc = loc }
+
+let const_dec cd =
+  { c_name = cd.Heptagon.c_name;
+    c_value = cd.Heptagon.c_value; 
+    c_loc = cd.Heptagon.c_loc; }
+
+let program 
+    { Heptagon.p_pragmas = pragmas;
+      Heptagon.p_opened = modules; 
+      Heptagon.p_types = pt_list; 
+      Heptagon.p_nodes = n_list;
+      Heptagon.p_consts = c_list; } =
+  { p_pragmas = pragmas;
+    p_opened = modules;
+    p_types = List.map typedec pt_list;
+    p_nodes = List.map node n_list;
+    p_consts = List.map const_dec c_list}

main/main.ml

@@ -0,0 +1,100 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* the main *)
+
+(* $Id$ *)
+
+open Misc
+open Compiler
+
+let compile file =
+  if Filename.check_suffix file ".ept"
+  then
+    let filename = Filename.chop_suffix file ".ept" in
+    let modname = String.capitalize(Filename.basename filename) in
+    compile modname filename
+  else if Filename.check_suffix file ".epi"
+  then
+    let filename = Filename.chop_suffix file ".epi" in
+    let modname = String.capitalize(Filename.basename filename) in
+    interface modname filename
+  else
+    raise (Arg.Bad ("don't know what to do with " ^ file))
+
+let doc_verbose = "\t\t\tSet verbose mode"
+and doc_version = "\t\tThe version of the compiler"
+and doc_print_types = "\t\t\tPrint types"
+and doc_include = "<dir>\t\tAdd <dir> to the list of include directories"
+and doc_stdlib = "<dir>\t\tDirectory for the standard library"
+and doc_sim = "<node>\t\tCreate simulation for node <node>"
+and doc_locate_stdlib = "\t\tLocate standard libray"
+and doc_no_pervasives = "\tDo not load the pervasives module"
+and doc_target =
+  "<lang>\tGenerate code in language <lang>\n\t\t\t(with <lang>=c, c-old,"
+  ^ " vhdl_seq, vhdl_df,\n\t\t\t java, caml or z3z)"
+and doc_full_type_info = "\t\t\tPrint full type information"
+and doc_target_path =
+  "<path>\tGenerated files will be placed in <path>\n\t\t\t(the directory is cleaned)"
+and doc_boolean = "\t\tTranslate enumerated values towards boolean vectors"
+and doc_deadcode = "\t\tDeadcode removal"
+and doc_noinit = "\t\tDisable initialization analysis"
+and doc_cse = "\t\t\tPerform common sub-expression elimination"
+and doc_tomato = "\t\tPerform auTOMATa minimizatiOn"
+and doc_sigali = "\t\t\tGenerate symbolic equations for Sigali (Z/3Z format)"
+and doc_flatten = "<node name>\tRecursively inline all calls in specified node"
+and doc_inline = "<node list>\tInline the list of nodes, separated by commas"
+and doc_dep2dot = "<node list>\tOutput to .dot files the dependency graph of "
+  ^ "the list of nodes, separated by commas"
+and doc_intermediate = "\t\tPerform intermediate-equations removal (buggy)"
+and doc_nomemalloc = "\t\tDisable memory allocation algorithm"
+and doc_interfscheduler = "\tUse the new scheduler, that tries to minimise interference" 
+and doc_main_node = "<node>\t\tUse <node> as the toplevel node"
+and doc_new_reset = "\t\tUse the new alternate encoding of resets" 
+
+let errmsg = "Options are:"
+
+let main () =
+  try
+    Arg.parse
+      [
+        "-v",Arg.Set verbose, doc_verbose;
+        "-version", Arg.Unit show_version, doc_version;
+        "-i", Arg.Set print_types, doc_print_types;
+        "-I", Arg.String add_include, doc_include;
+        "-where", Arg.Unit locate_stdlib, doc_locate_stdlib;
+        "-stdlib", Arg.String set_stdlib, doc_stdlib;
+        "-s", Arg.String set_simulation_node, doc_sim;
+        "-nopervasives", Arg.Unit set_no_pervasives, doc_no_pervasives;
+        "-target", Arg.String add_target_language, doc_target;
+        "-targetpath", Arg.String set_target_path, doc_target_path;
+        "-bool", Arg.Set boolean, doc_boolean;
+        "-deadcode", Arg.Set deadcode, doc_deadcode;
+	      "-noinit", Arg.Clear init, doc_noinit;
+        "-fti", Arg.Set full_type_info, doc_full_type_info;
+        "-cse", Arg.Set cse, doc_cse;
+        "-tomato", Arg.Set tomato, doc_tomato;
+        "-z3z", Arg.Unit set_sigali, doc_sigali;
+        "-inter", Arg.Set intermediate, doc_intermediate;
+        "-flatten", Arg.String (fun s -> node_to_flatten := Some s), doc_flatten;
+        ("-inline",
+         Arg.String (fun s -> nodes_to_inline := Misc.split_string s ','),
+         doc_inline);
+        ("-dep2dot",
+         Arg.String (fun s -> nodes_to_display := Misc.split_string s ','),
+         doc_dep2dot);
+	"-nomemalloc", Arg.Set no_mem_alloc, doc_nomemalloc;
+	"-interfscheduler", Arg.Set use_interf_scheduler, doc_interfscheduler;
+	"-new-reset-encoding", Arg.Set use_new_reset_encoding, doc_new_reset;
+      ]
+      compile
+      errmsg;
+  with
+    | Misc.Error -> exit 2;;
+
+main ()

minils/minils.ml

@@ -0,0 +1,753 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The internal MiniLustre representation *)
+
+(* $Id$ *)
+
+open Location
+open Dep
+open Misc
+open Names
+open Ident
+open Linearity
+open Interference_graph
+open Global
+open Static
+
+(** Inlining policies, to be held in app records. *)
+type inlining_policy =
+  | Ino (** Do not inline. *)
+  | Ione (** Just inline on one step. *)
+  | Irec (** Recursively inline all sub-calls. *)
+
+type type_dec =
+    { t_name: name;
+      t_desc: tdesc;
+      t_loc: location }
+
+and tdesc =
+  | Type_abs
+  | Type_enum of name list
+  | Type_struct of (name * base_ty) list
+
+and exp =
+    { e_desc: desc;        (* its descriptor *)
+      mutable e_ck: ck;
+      mutable e_ty: ty;
+      mutable e_linearity : linearity;
+      e_loc: location  }
+
+and desc =
+  | Econst of const
+  | Evar of ident
+  | Econstvar of name
+  | Efby of const option * exp
+  | Ereset_mem of ident * const * ident
+  | Etuple of exp list
+  | Eop of longname * size_exp list * exp list
+  | Eapp of app * size_exp list * exp list
+  | Eevery of app * size_exp list * exp list * ident
+  | Ewhen of exp * longname * ident
+  | Emerge of ident * (longname * exp) list
+  | Eifthenelse of exp * exp * exp
+  | Efield of exp * longname
+  | Estruct of (longname * exp) list
+(*Array operators*)
+  | Earray of exp list
+  | Erepeat of size_exp * exp
+  | Eselect of size_exp list * exp (*indices, array*)
+  | Eselect_dyn of exp list * size_exp list * exp * exp (*indices, bounds, array, default*)
+  | Eupdate of size_exp list * exp * exp (*indices, array, value*)
+  | Eselect_slice of size_exp * size_exp * exp (*lower bound, upper bound, array*)
+  | Econcat of exp * exp
+  | Eiterator of iterator_name * longname * size_exp list * size_exp * exp list * ident option
+  | Efield_update of longname * exp * exp (*field, record, value*)
+
+and app =
+    { a_op: longname;
+      a_inlined: inlining_policy
+    }
+
+and ct =
+  | Ck of ck
+  | Cprod of ct list
+
+and ck =
+  | Cbase
+  | Cvar of link ref
+  | Con of ck * longname * ident
+
+and link =
+  | Cindex of int
+  | Clink of ck
+
+and ty =
+  | Tbase of base_ty
+  | Tprod of ty list
+
+and base_ty =
+  | Tint | Tfloat
+  | Tid of longname
+  | Tarray of base_ty * size_exp
+
+and const =
+  | Cint of int
+  | Cfloat of float
+  | Cconstr of longname
+  | Cconst_array of size_exp * const 
+
+and pat =
+  | Etuplepat of pat list
+  | Evarpat of ident
+
+type eq =
+    { p_lhs : pat;
+      p_rhs : exp; }
+
+type var_dec =
+    { v_name : ident;
+      v_copy_of : ident option;
+      v_type : base_ty;
+      v_linearity : linearity;
+      v_clock : ck }
+
+type contract =
+    { c_assume : exp;
+      c_enforce : exp;
+      c_controllables : var_dec list;
+      c_local : var_dec list;
+      c_eq : eq list;
+    }
+
+type node_dec =
+    { n_name   : name;
+      n_input  : var_dec list;
+      n_output : var_dec list;
+      n_contract : contract option;
+      n_local  : var_dec list;
+      n_equs   : eq list;
+      n_loc    : location; 
+      n_targeting : (int*int) list;
+      n_mem_alloc : (base_ty * ivar list) list;
+      n_states_graph : (name,name) interf_graph;
+      n_params : name list; 
+      n_params_constraints : size_constr list;
+      n_params_instances : (int list) list; }
+
+type const_dec =
+    { c_name : name;
+      c_value : size_exp;
+      c_loc : location; }
+
+type program =
+    { p_pragmas: (name * string) list;
+      p_opened : name list;
+      p_types  : type_dec list;
+      p_nodes  : node_dec list;
+      p_consts : const_dec list; }
+
+(*Helper functions to build the AST*)
+let make_exp desc ty l ck loc =
+  { e_desc = desc; e_ty = ty; e_linearity = l; e_ck = ck; e_loc = loc }
+
+let make_dummy_exp desc ty =
+  { e_desc = desc; e_ty = ty; e_linearity = NotLinear; 
+    e_ck = Cbase; e_loc = no_location }
+
+(* Helper functions to work with types *)
+let base_type = function
+    | Tbase(bty) -> bty
+    | Tprod _ -> assert false
+
+(* get the type of an expression ; assuming that this type is a base type *)
+let exp_base_type e = 
+  base_type e.e_ty
+
+let rec size_exp_of_exp e =
+  match e.e_desc with 
+  | Econstvar n -> SVar n
+  | Econst (Cint i) -> SConst i
+  | Eop(op, _, [e1;e2]) ->
+      let sop = op_from_app_name op in
+	SOp(sop, size_exp_of_exp e1, size_exp_of_exp e2)
+  | _ -> raise Not_static
+
+(*Returns the list of bounds of an array type*)
+let rec bounds_list ty = 
+  match ty with
+    | Tarray(ty, n) -> n::(bounds_list ty)
+    | _ -> []
+
+(** Returns the var_dec object corresponding to the name n
+    in a list of var_dec. *)
+let rec vd_find n = function
+  | [] -> Format.printf "Not found var %s\n" (name n); raise Not_found
+  | vd::l -> 
+      if vd.v_name = n then vd else vd_find n 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_name = n or (vd_mem n l)
+
+(** Same as vd_mem but for an ivar value. *)
+let ivar_vd_mem var vds =
+  match var with 
+    | IVar id -> vd_mem id vds
+    | _ -> false
+
+(** [is_record_type ty] returns whether ty corresponds to a record type. *)
+let is_record_type ty =
+  match ty with
+    | Tid n ->
+	(try
+	   ignore (Modules.find_struct n);
+	   true
+	 with 
+	     Not_found -> false
+	)
+    | _ -> false
+
+
+module Vars =
+struct
+  let rec vars_pat acc = function
+    | Evarpat(x) -> x :: acc
+    | Etuplepat(pat_list) -> List.fold_left vars_pat acc pat_list
+
+  let rec vars_ck acc = function
+    | Con(ck, c, n) -> if List.mem (IVar n) acc then acc else (IVar n) :: acc
+    | Cbase | Cvar { contents = Cindex _ } -> acc
+    | Cvar { contents = Clink ck }         -> vars_ck acc ck
+
+  let rec read is_left acc e =
+    let add x acc = if List.mem (IVar x) acc then acc else (IVar x) :: acc in
+    let acc =
+      match e.e_desc with
+        | Emerge(x, c_e_list) ->
+            let acc = add x acc in
+            List.fold_left (fun acc (_, e) -> read is_left acc e) acc c_e_list
+        | Eifthenelse(e1, e2, e3) ->
+            read is_left (read is_left (read is_left acc e1) e2) e3
+        | Ewhen(e, c, x) ->
+            let acc = add x acc in
+            read is_left acc e
+        | Eop(_, _, e_list)
+        | Etuple(e_list) -> List.fold_left (read is_left) acc e_list
+        | Eapp(_, _, e_list) -> List.fold_left (read is_left) acc e_list
+        | Eevery(_, _, e_list, x) ->
+            let acc = add x acc in
+              List.fold_left (read is_left) acc e_list
+        | Efby(_, e) ->
+            if is_left then vars_ck acc e.e_ck else read is_left acc e
+	| Ereset_mem (_, _,res) -> add res acc
+        | Evar(n) -> add n acc
+	| Efield({ e_desc = Evar x }, f) -> 
+	    let acc = add x acc in
+	    let x = IField(x,f) in
+	      if List.mem x acc then acc else x::acc
+        | Efield(e, _) -> read is_left acc e
+        | Estruct(f_e_list) ->
+            List.fold_left (fun acc (_, e) -> read is_left acc e) acc f_e_list
+        | Econst _ | Econstvar _ -> acc 
+    (*Array operators*)
+	| Earray e_list -> List.fold_left (read is_left) acc e_list
+	| Erepeat (_,e) -> read is_left acc e
+	| Eselect (_,e) -> read is_left acc e
+	| Eselect_dyn (e_list, _, e1, e2) -> 
+	    let acc = List.fold_left (read is_left) acc e_list in 
+	      read is_left (read is_left acc e1) e2
+	| Eupdate (_, e1, e2) | Efield_update (_, e1, e2) ->
+	    read is_left (read is_left acc e1) e2 
+	| Eselect_slice (_ , _, e) -> read is_left acc e
+	| Econcat (e1, e2) ->
+	    read is_left (read is_left acc e1) e2 
+	| Eiterator (_, _, _, _, e_list, _) ->  
+	    List.fold_left (read is_left) acc e_list
+    in
+      vars_ck acc e.e_ck
+
+  let rec remove x = function
+    | [] -> []
+    | y :: l -> if x = y then l else y :: remove x l
+
+  let def acc { p_lhs = pat } = vars_pat acc pat
+
+  let read is_left { p_lhs = pat; p_rhs = e } =
+    match pat, e.e_desc with
+      |  Evarpat(n), Efby(_, e1) ->
+           if is_left
+           then remove (IVar n) (read is_left [] e1)
+           else read is_left [] e1
+      | _ -> read is_left [] e
+
+  let rec remove_records = function
+    | [] -> []
+    | (IVar x)::l -> (IVar x)::(remove_records l)
+    | (IField(x,f))::l -> 
+	let l = remove (IVar x) l in
+	  (IField(x,f))::(remove_records l)
+
+  let read_ivars is_left eq =
+    remove_records (read is_left eq)
+
+  let read is_left eq =
+    filter_vars (read is_left eq)
+
+  let antidep { p_rhs = e } =
+    match e.e_desc with Efby _ -> true | _ -> false
+  let clock { p_rhs = e } =
+    match e.e_desc with
+      | Emerge(_, (_, e) :: _) -> e.e_ck
+      | _ -> e.e_ck
+  let head ck =
+    let rec headrec ck l =
+      match ck with
+        | Cbase | Cvar { contents = Cindex _ } -> l
+        | Con(ck, c, n) -> headrec ck (n :: l)
+        | Cvar { contents = Clink ck } -> headrec ck l in
+    headrec ck []
+
+  let rec linear_use acc e =
+      match e.e_desc with
+        | Emerge(_, c_e_list) ->
+            List.fold_left (fun acc (_, e) -> linear_use acc e) acc c_e_list
+        | Eifthenelse(e1, e2, e3) ->
+            linear_use (linear_use (linear_use acc e1) e2) e3
+        | Ewhen(e, _, _) | Efield(e, _) | Efby(_, e) -> linear_use acc e
+        | Eop(_,_, e_list)
+        | Etuple(e_list) | Earray e_list
+        | Eapp(_,_, e_list) | Eiterator (_, _, _, _, e_list, _)
+        | Eevery(_,_, e_list, _) -> List.fold_left linear_use acc e_list
+        | Evar(n) ->
+	    (match e.e_linearity with
+	       | At _ -> if List.mem n acc then acc else n :: acc
+	       | _ -> acc
+	    )
+        | Estruct(f_e_list) ->
+            List.fold_left (fun acc (_, e) -> linear_use acc e) acc f_e_list
+        | Econst _ | Econstvar _ | Ereset_mem (_, _,_) -> acc 
+    (*Array operators*)
+	| Erepeat (_,e)
+	| Eselect (_,e) | Eselect_slice (_ , _, e) -> linear_use acc e
+	| Eselect_dyn (e_list, _, e1, e2) -> 
+	    let acc = List.fold_left linear_use acc e_list in 
+	      linear_use (linear_use acc e1) e2
+	| Eupdate (_, e1, e2) | Efield_update (_, e1, e2) 
+	| Econcat (e1, e2) ->
+	    linear_use (linear_use acc e1) e2 
+
+  let mem_reset { p_rhs = e } =
+    match e.e_desc with
+      | Ereset_mem (y, _, _) -> [y]
+      | _ -> []
+end
+
+(* data-flow dependences. pre-dependences are discarded *)
+module DataFlowDep = Make
+  (struct
+     type equation = eq
+     let read eq = Vars.read true eq
+     let def = Vars.def
+     let linear_read eq = Vars.linear_use [] eq.p_rhs
+     let mem_reset = Vars.mem_reset
+     let antidep = Vars.antidep
+   end)
+
+(* all dependences between variables *)
+module AllDep = Make
+  (struct
+     type equation = eq
+     let read eq = Vars.read false eq
+     let linear_read eq = Vars.linear_use [] eq.p_rhs
+     let mem_reset = Vars.mem_reset
+     let def = Vars.def
+     let antidep eq = false
+   end)
+
+module Printer =
+struct
+  open Format
+
+  let is_infix =
+    let module StrSet = Set.Make(String) in
+    let set_infix = StrSet.singleton "or" in
+    fun s ->
+      if (StrSet.mem s set_infix) then true
+      else begin
+        match (String.get s 0) with
+          | 'a' .. 'z' | 'A' .. 'Z' | '_' | '`' -> false
+          | _ -> true
+      end
+
+  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_name ff n =
+    let n = if is_infix n then
+      match n with
+        | "*" -> "( * )"
+        | _ -> "(" ^ n ^ ")"
+    else n
+    in fprintf ff "%s" n
+
+  let print_longname ff n =
+    match n with
+      | Name(m) -> print_name ff m
+      | Modname({ qual = "Pervasives"; id = m }) ->
+          print_name ff m
+      | Modname({ qual = m1; id = m2 }) ->
+          fprintf ff "%s." m1; print_name ff m2
+
+  let print_ident ff id =
+    fprintf ff "%s" (name id)
+
+  let rec print_pat ff = function
+    | Evarpat(n) -> print_ident ff n
+    | Etuplepat(pat_list) ->
+        fprintf ff "@[(";
+        print_list ff print_pat "," pat_list;
+        fprintf ff ")@]"
+
+  let rec print_base_type ff = function
+    | Tint -> fprintf ff  "int"
+    | Tfloat -> fprintf ff  "float"
+    | Tid(id) -> print_longname ff id
+    | Tarray(ty, n) -> 
+	print_base_type ff ty;
+	fprintf ff "^";
+	print_size_exp ff n
+
+  let rec print_type ff = function
+    | Tbase(base_ty) -> print_base_type ff base_ty
+    | Tprod(ty_list) ->
+        fprintf ff "@[(";
+        print_list ff print_type " *" ty_list;
+        fprintf ff ")@]"
+
+  let rec print_ck ff = function
+    | Cbase -> fprintf ff "base"
+    | Con(ck, c, n) ->
+        print_ck ff ck; fprintf ff " on ";
+        print_longname ff c; fprintf ff "(";
+        print_ident ff n; fprintf ff ")"
+    | Cvar { contents = Cindex n } -> fprintf ff "base"
+    | Cvar { contents = Clink ck } -> print_ck ff ck
+
+  let rec print_clock ff = function
+    | Ck(ck) -> print_ck ff ck
+    | Cprod(ct_list) ->
+        fprintf ff "@[(";
+        print_list ff print_clock " *" ct_list;
+        fprintf ff ")@]"
+
+  let print_vd ff { v_name = n; v_type = ty; v_clock = ck } =
+    fprintf ff "@[<v>";
+    print_ident ff n;
+    fprintf ff ":";
+    print_base_type ff ty;
+    fprintf ff " at ";
+    print_ck ff ck;
+    fprintf ff "@]"
+
+  let rec print_c ff = function
+    | Cint i -> fprintf ff "%d" i
+    | Cfloat f -> fprintf ff "%f" f
+    | Cconstr(tag) -> print_longname ff tag
+    | Cconst_array (n, c) ->
+	print_c ff c;
+	fprintf ff "^";
+	print_size_exp ff n
+
+  let print_call_params ff = function
+    | [] -> ()
+    | l -> 
+	fprintf ff "<<";
+	print_list ff print_size_exp "," l;
+	fprintf ff ">>"
+
+  let rec print_exps ff e_list =
+    fprintf ff "@[(";print_list ff print_exp "," e_list; fprintf ff ")@]"
+
+  and print_exp ff e =
+    if !Misc.full_type_info then fprintf ff "(";
+    begin match e.e_desc with
+      | Evar x -> print_ident ff x
+      | Econstvar x -> print_name ff x
+      | Econst c -> print_c ff c
+      | Efby(Some(c), e) ->
+          print_c ff c; fprintf ff " fby "; print_exp ff e
+      | Ereset_mem(y,v,res) ->
+	  fprintf ff "@[reset_mem ";
+	  print_ident ff y;
+	  fprintf ff " = ";
+	  print_c ff v;
+	  fprintf ff " every ";
+	  print_ident ff res;
+	  fprintf ff "@]"
+      | Efby(None, e) ->
+          fprintf ff "pre "; print_exp ff e
+      | Eop((Name(m) | Modname { qual = "Pervasives"; id = m }), params, [e1;e2])
+          when is_infix m ->
+          fprintf ff "(%a %s %a %a)"
+            print_exp e1
+            m
+	    print_call_params params
+            print_exp e2
+      | Eop(op, params, e_list) ->
+          print_longname ff op;
+	  print_call_params ff params;
+          print_exps ff e_list
+      | Eapp({ a_op = f }, params, e_list) ->
+          print_longname ff f;
+	  print_call_params ff params;
+          print_exps ff e_list
+      | Eevery({ a_op = f }, params, e_list, x) ->
+          print_longname ff f;
+	  print_call_params ff params;
+          print_exps ff e_list;
+          fprintf ff " every "; print_ident ff x
+      | Ewhen(e, c, n) ->
+          fprintf ff "(";
+          print_exp ff e;
+          fprintf ff " when ";
+          print_longname ff c; fprintf ff "(";
+          print_ident ff n; fprintf ff ")";
+          fprintf ff ")"
+      | Eifthenelse(e1, e2, e3) ->
+          fprintf ff "@[if ";print_exp ff e1;
+          fprintf ff "@ then ";
+          print_exp ff e2;
+          fprintf ff "@ else ";
+          print_exp ff e3;
+          fprintf ff "@]"
+      | Emerge(x, tag_e_list) ->
+          fprintf ff "@[<hov 2>merge ";print_ident ff x;fprintf ff "@ ";
+          fprintf ff "@[";
+          print_tag_e_list ff tag_e_list;
+          fprintf ff "@]@]"
+      | Etuple(e_list) ->
+          fprintf ff "@[(";
+          print_list ff print_exp "," e_list;
+          fprintf ff ")@]"
+      | Efield(e, field) ->
+          print_exp ff e;
+          fprintf ff ".";
+          print_longname ff field
+      | Estruct(f_e_list) ->
+          fprintf ff "@[<v 1>{";
+          print_list ff
+            (fun ff (field, e) -> print_longname ff field;fprintf ff " = ";
+               print_exp ff e)
+            ";" f_e_list;
+          fprintf ff "}@]"
+    (*Array operators*)
+      | Earray e_list -> 
+	  fprintf ff "@[[";
+          print_list ff print_exp ";" e_list;
+          fprintf ff "]@]"
+      | Erepeat (n,e) -> 
+	  print_exp ff e;
+	  fprintf ff "^";
+          print_size_exp ff n
+      | Eselect (idx,e) -> 
+	  print_exp ff e;
+	  fprintf ff "[";
+          print_list ff print_size_exp "][" idx;
+          fprintf ff "]" 
+      | Eselect_dyn (idx, _, e1, e2) ->
+	  fprintf ff "@[";
+	  print_exp ff e1;
+	  fprintf ff "[";
+          print_list ff print_exp "][" idx;
+	  fprintf ff "] default ";
+	  print_exp ff e2;
+	    fprintf ff "@]"
+      | Eupdate (idx, e1, e2) ->
+	  fprintf ff "@[";
+	  print_exp ff e1;
+          fprintf ff " with [";
+	  print_list ff print_size_exp "][" idx;
+	  fprintf ff "] = ";
+	  print_exp ff e2;
+	  fprintf ff "@]"
+      | Eselect_slice (idx1, idx2, e) -> 
+	  print_exp ff e;
+          fprintf ff "[";
+	  print_size_exp ff idx1;
+	  fprintf ff "..";
+	  print_size_exp ff idx2;
+	  fprintf ff "]"
+      | Econcat (e1, e2) ->
+	  print_exp ff e1;
+	  fprintf ff " @@ ";
+	  print_exp ff e2
+      | Eiterator (it, f, params, n, e_list, reset) -> 
+	  fprintf ff "("; 
+	  fprintf ff "%s" (iterator_to_string it);
+	  fprintf ff " ";
+	  (match params with
+	     | [] -> print_longname ff f
+	     | l -> 
+		 fprintf ff "(";
+		 print_longname ff f;
+		 print_call_params ff params;
+		 fprintf ff ")"
+	  );
+	  fprintf ff " <<";
+	  print_size_exp ff n;
+	  fprintf ff ">>) (@[";
+	  print_list ff print_exp "," e_list;
+	  fprintf ff ")@]";
+	  (match reset with 
+	     | None -> ()
+	     | Some r -> fprintf ff " every %s" (name r)
+	  )
+      | Efield_update (f, e1, e2) ->
+	  fprintf ff "@[";
+	  print_exp ff e1;
+          fprintf ff " with .";
+	  print_longname ff f;
+	  fprintf ff " = ";
+	  print_exp ff e2;
+	  fprintf ff "@]"
+    end;
+    if !Misc.full_type_info
+    then begin
+      fprintf ff " : %a)" print_type e.e_ty;
+      if e.e_loc = no_location then fprintf ff " (no loc)"
+    end
+  and print_tag_e_list ff tag_e_list =
+    print_list ff
+      (fun ff (tag, e) ->
+         fprintf ff "@[(";
+         print_longname ff tag;
+         fprintf ff " -> ";
+         print_exp ff e;
+         fprintf ff ")@]@,") ""
+      tag_e_list
+
+  let print_eq ff { p_lhs = p; p_rhs = e } =
+    fprintf ff "@[<hov 2>";
+    print_pat ff p;
+    (*     (\* DEBUG *\) *)
+    (*     fprintf ff " : "; *)
+    (*     print_ck ff e.e_ck; *)
+    (*     (\* END DEBUG *\) *)
+    fprintf ff " =@ ";
+    print_exp ff e;
+    if !Misc.full_type_info
+    then begin fprintf ff "@ at "; print_ck ff e.e_ck end;
+    fprintf ff ";@]"
+
+  let print_eqs ff l =
+    fprintf ff "@[<v>"; print_list ff print_eq "" l; fprintf ff "@]"
+
+  let print_open_module ff name =
+    fprintf ff "@[open ";
+    print_name ff name;
+    fprintf ff "@.@]"
+
+  let print_type_def ff { t_name = name; t_desc = tdesc } =
+    match tdesc with
+      | Type_abs -> fprintf ff "@[type %s@\n@]" name
+      | Type_enum(tag_name_list) ->
+          fprintf ff "@[type %s = " name;
+          print_list ff print_name "|" tag_name_list;
+          fprintf ff "@\n@]"
+      | Type_struct(f_ty_list) ->
+          fprintf ff "@[type %s = " name;
+          fprintf ff "@[<v 1>{";
+          print_list ff
+            (fun ff (field, ty) -> print_name ff field;
+               fprintf ff ": ";
+               print_base_type ff ty) ";" f_ty_list;
+          fprintf ff "}@]@\n@]"
+
+  let print_contract ff {c_local = l;
+                         c_eq = eqs;
+                         c_assume = e_a;
+                         c_enforce = e_g;
+                         c_controllables = cl } =
+    if l <> [] then begin
+      fprintf ff "contract\n";
+      fprintf ff "@[<hov 4>var ";
+      print_list ff print_vd ";" l;
+      fprintf ff ";@]\n"
+    end;
+    if eqs <> [] then begin
+      fprintf ff "@[<v 2>let @,";
+      print_eqs ff eqs;
+      fprintf ff "@]"; fprintf ff "tel\n"
+    end;
+    fprintf ff "assume@ %a@;enforce@ %a with ("
+      print_exp e_a
+      print_exp e_g;
+    print_list ff print_vd ";" cl;
+    fprintf ff ")"
+
+  let print_node_params ff = function
+    | [] -> ()
+    | l -> 
+	fprintf ff "<<";
+	print_list ff print_name "," l;
+	fprintf ff ">>"
+
+  let print_node ff
+      { n_name = n;n_input = ni;n_output = no;
+        n_contract = contract;
+        n_local = nl; n_equs = ne;
+	n_params = params; } =
+    fprintf ff "@[<v 2>node %s" n;
+    print_node_params ff params;
+    fprintf ff "(@["; 
+    print_list ff print_vd ";" ni;
+    fprintf ff "@]) returns (@[";
+    print_list ff print_vd ";" no;
+    fprintf ff "@])@,";
+    optunit (print_contract ff) contract;
+    if nl <> [] then begin
+      fprintf ff "@[<hov 2>var ";
+      print_list ff print_vd ";" nl;
+      fprintf ff ";@]@,"
+    end;
+    fprintf ff "@[<v 2>let @,";
+    print_eqs ff ne;
+    fprintf ff "@]@;"; fprintf ff "tel";fprintf ff "@.@]"
+
+  let print_exp oc e =
+    let ff = formatter_of_out_channel oc in
+    print_exp ff e;
+    fprintf ff "@."
+
+  let print_type oc ty =
+    let ff = formatter_of_out_channel oc in
+    print_type ff ty;
+    fprintf ff "@?"
+
+  let print_clock oc ct =
+    let ff = formatter_of_out_channel oc in
+    print_clock ff ct;
+    fprintf ff "@?"
+
+  let print oc { p_opened = pm; p_types = pt; p_nodes = pn } =
+    let ff = formatter_of_out_channel oc in
+    List.iter (print_open_module ff) pm;
+    List.iter (print_type_def ff) pt;
+    List.iter (print_node ff) pn;
+    fprintf ff "@?"
+end

minils/sequential/c.ml

@@ -0,0 +1,337 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* $Id$ *)
+
+open Format
+open List
+open Modules
+
+
+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
+
+
+(******************************)
+
+(** {2 C abstract syntax tree } *)
+
+(** Here is the C abstract syntax tree used by MiniLS for its C backend. It does
+    not try to completly model the C language, only the relatively small part
+    that were are interested in (e.g. no function pointers or local variable
+    initialization). *)
+
+(** C types relevant for Obc. Note the absence of function pointers. *)
+type cty =
+  | Cty_int (** C machine-dependent integer type. *)
+  | Cty_float (** C machine-dependent single-precision floating-point type. *)
+  | Cty_char (** C character type. *)
+  | Cty_id of string (** Previously defined C type, such as an enum or struct. *)
+  | Cty_ptr of cty (** C points-to-other-type type. *)
+  | Cty_arr of int * cty (** A static array of the specified size. *)
+  | Cty_void (** Well, [void] is not really a C type. *)
+
+(** A C block: declarations and statements. In source code form, it begins with
+    variable declarations before a list of semicolon-separated statements, the
+    whole thing being enclosed in curly braces. *)
+type cblock = {
+  (** Variable declarations, where each declaration consists of a variable
+      name and the associated C type. *)
+  var_decls : (string * cty) list;
+  (** The actual statement forming our block. *)
+  block_body : cstm list;
+}
+
+(* TODO: The following types for C expressions would be better using polymorphic
+   variants to define LHS expressions as a proper superset of general
+   expressions. *)
+
+(** C expressions. *)
+and cexpr =
+  | Cuop of string * cexpr (** Unary operator with its name. *)
+  | Cbop of string * cexpr * cexpr (** Binary operator. *)
+  | Cfun_call of string * cexpr list (** Function call with its parameters. *)
+  | 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, ...]. *)
+and cconst =
+  | Ccint of int (** Integer constant. *)
+  | Ccfloat of float (** Floating-point number constant. *)
+  | Ctag of string (** Tag, member of a previously declared enumeration. *)
+  | Cstrlit of string (** String literal, enclosed in double-quotes. *)
+      (** C left-hand-side (ie. affectable) expressions. *)
+and clhs =
+  | Cvar of string (** A local variable. *)
+  | Cderef of clhs (** Pointer dereference, *ptr. *)
+  | Cfield of clhs * string (** Field access to left-hand-side. *)
+  | Carray of clhs * cexpr (** Array access clhs[cexpr] *)
+      (** 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. **)
+  | Cskip (** A dummy instruction that does nothing and will not be printed. *)
+  | Caffect of clhs * cexpr (** Affect the result of an expression to a lhs. *)
+  | Cif of cexpr * cstm list * cstm list (** Alternative *)
+  | Cswitch of cexpr * (string * cstm list) list (** Case/switch over an enum. *)
+  | Cwhile of cexpr * cstm list (** While loop. *)
+  | Cfor of string * int * int * cstm list (** For loop. int <= string < int *)
+  | Creturn of cexpr (** Ends a procedure/function by returning an expression.*)
+
+(** C type declarations ; will {b always} correspond to a typedef in emitted
+    source code. *)
+type cdecl =
+    (** C enum declaration, with associated value tags. *)
+  | Cdecl_enum of string * string list
+      (** C structure declaration, with each field's name and type. *)
+  | Cdecl_struct of string * (string * cty) list
+      (** C function declaration. *)
+  | Cdecl_function of string * cty * (string * cty) list
+
+(** C function definitions *)
+type cfundef = {
+  f_name : string; (** The function's name. *)
+  f_retty : cty; (** The function's return type. *)
+  f_args : (string * cty) list; (** Each parameter's name and type. *)
+  f_body : cblock; (** Actual instructions, in the form of a block. *)
+}
+
+(** C top-level definitions. *)
+type cdef =
+  | Cfundef of cfundef (** Function definition, see [cfundef]. *)
+  | Cvardef of string * cty (** A variable definition, with its name and type. *)
+
+(** [cdecl_of_cfundef cfd] returns a declaration for the function def. [cfd]. *)
+let cdecl_of_cfundef cfd = match cfd with
+  | Cfundef cfd -> Cdecl_function (cfd.f_name, cfd.f_retty, cfd.f_args)
+  | _ -> invalid_arg "cdecl_of_cfundef"
+
+(** A C file can be a source file, containing definitions, or a header file,
+    containing declarations. *)
+type cfile = string * cfile_desc
+and cfile_desc =
+  | Cheader of string list * cdecl list (** Header dependencies * declaration
+                                            list *)
+  | Csource of cdef list
+
+(******************************)
+
+(** {3 Pretty-printing of the C ast.} *)
+
+(** [pp_list1 f sep fmt l] pretty-prints into the Format.formatter [fmt] elements
+    of the list [l] via the function [f], separated by [sep] strings and
+    breakable spaces. *)
+let rec pp_list1 f sep fmt l = match l with
+  | [] -> fprintf fmt ""
+  | [x] -> fprintf fmt "%a" f x
+  | h :: t -> fprintf fmt "%a%s@ %a" f h sep (pp_list1 f sep) t
+
+let rec pp_list f sep fmt l = match l with
+  | [] -> fprintf fmt ""
+  | h :: t -> fprintf fmt "@ %a%s%a" f h sep (pp_list f sep) t
+
+let pp_string fmt s = fprintf fmt "%s" s
+
+let rec pp_cty fmt cty = match cty with
+  | Cty_int -> fprintf fmt "int"
+  | Cty_float -> fprintf fmt "float"
+  | Cty_char -> fprintf fmt "char"
+  | Cty_id s -> fprintf fmt "%s" s
+  | Cty_ptr cty' -> fprintf fmt "%a*" pp_cty cty'
+  | Cty_arr (n, cty') -> fprintf fmt "%a[%d]" pp_cty cty' n
+  | Cty_void -> fprintf fmt "void"
+
+(** [pp_array_decl cty] returns the base type of a (multidimensionnal) array
+    and the string of indices. *)
+let rec pp_array_decl cty =
+  match cty with
+    | Cty_arr(n, cty') -> 
+	let ty, s = pp_array_decl cty' in
+	  ty, sprintf "%s[%d]" s n
+    | _ -> cty, ""
+
+(* pp_vardecl, featuring an ugly hack coping with C's inconsistent concrete
+   syntax! *)
+let rec pp_vardecl fmt (s, cty) = match cty with
+  | Cty_arr (n, cty') -> 
+      let base_ty, indices = pp_array_decl cty in
+	fprintf fmt "%a %s%s" pp_cty base_ty s indices
+  | _ -> fprintf fmt "%a %s" pp_cty cty s
+and pp_paramdecl fmt (s, cty) = match cty with
+  | Cty_arr (n, cty') -> fprintf fmt "%a* %s" pp_cty cty' s
+  | _ -> pp_vardecl fmt (s, cty)
+and pp_param_list fmt l = pp_list1 pp_paramdecl "," fmt l
+and pp_var_list fmt l = pp_list pp_vardecl ";" fmt l
+
+let rec pp_cblock fmt cb =
+  let pp_varlist = pp_list pp_vardecl ";" in
+  fprintf fmt "%a%a" pp_varlist cb.var_decls pp_cstm_list cb.block_body
+and pp_cstm_list fmt stml = pp_list pp_cstm ";" fmt stml
+and pp_cstm fmt stm = match stm with
+  | Csexpr e -> fprintf fmt "%a" pp_cexpr e
+  | Cswitch (e, cl) ->
+      let pp_clause fmt (tag, stml) =
+        fprintf fmt "@[<v 2>case %a:%a@ break;@]"
+          pp_cexpr (Cconst (Ctag tag)) pp_cstm_list stml in
+      fprintf fmt "@[<v>@[<v 2>switch (%a) {%a@]@ }@]"
+        pp_cexpr e (pp_list pp_clause "") cl
+  | Caffect (lhs, e) ->
+      fprintf fmt "%a = %a" pp_clhs lhs pp_cexpr e
+  | Cif (c, t, []) ->
+      fprintf fmt "@[<v>@[<v 2>if (%a) {%a@]@ }@]"
+        pp_cexpr c pp_cstm_list t
+  | Cif (c, t, e) ->
+      fprintf fmt "@[<v>@[<v 2>if (%a) {%a@]@ @[<v 2>} else {%a@]@ }@]"
+        pp_cexpr c pp_cstm_list t pp_cstm_list e
+  | Cfor(x, lower, upper, e) ->
+      fprintf fmt "@[<v>@[<v 2>for (int %s = %d; %s < %d; ++%s) {%a@]@ }@]"
+	x lower x upper x  pp_cstm_list e
+  | Cwhile (e, b) ->
+      fprintf fmt "@[<v>@[<v 2>while (%a) {%a@]@ }@]" pp_cexpr e pp_cstm_list b
+  | Csblock cb -> pp_cblock fmt cb
+  | Cskip -> fprintf fmt ""
+  | Creturn e -> fprintf fmt "return %a" pp_cexpr e
+and pp_cexpr fmt ce = match ce with
+  | Cuop (s, e) -> fprintf fmt "%s(%a)" s pp_cexpr e
+  | Cbop (s, l, r) -> fprintf fmt "(%a%s%a)" pp_cexpr l s pp_cexpr r
+  | Cfun_call (s, el) -> fprintf fmt "%s(@[%a@])" s (pp_list1 pp_cexpr ",") el
+  | Cconst (Ccint i) -> fprintf fmt "%d" i
+  | Cconst (Ccfloat f) -> fprintf fmt "%f" f
+  | Cconst (Ctag "true") -> fprintf fmt "TRUE"
+  | Cconst (Ctag "false") -> fprintf fmt "FALSE"
+  | Cconst (Ctag t) -> fprintf fmt "%s" t
+  | Cconst (Cstrlit t) -> fprintf fmt "\"%s\"" t
+  | Clhs lhs -> fprintf fmt "%a" pp_clhs lhs
+  | Caddrof lhs -> fprintf fmt "&%a" pp_clhs lhs
+  | Cstructlit (s, el) ->
+      fprintf fmt "(%s){@[%a@]}" s (pp_list1 pp_cexpr ",") el
+  | Carraylit el -> 
+      fprintf fmt "[@[%a@]]" (pp_list1 pp_cexpr ",") el
+and pp_clhs fmt lhs = match lhs with
+  | Cvar s -> fprintf fmt "%s" s
+  | Cderef lhs' -> fprintf fmt "*%a" pp_clhs lhs'
+  | Cfield (Cderef lhs, f) -> fprintf fmt "%a->%s" pp_clhs lhs f
+  | Cfield (lhs, f) -> fprintf fmt "%a.%s" pp_clhs lhs f
+  | Carray (lhs, e) ->
+      fprintf fmt "%a[%a]" 
+	pp_clhs lhs
+	pp_cexpr e
+
+let pp_cdecl fmt cdecl = match cdecl with
+  | Cdecl_enum (s, sl) ->
+      fprintf fmt "@[<v>@[<v 2>typedef enum {@ %a@]@ } %s;@ @]@\n"
+        (pp_list1 pp_string ",") sl s
+  | Cdecl_struct (s, fl) ->
+      let pp_field fmt (s, cty) =
+        fprintf fmt "@ %a;" pp_vardecl (s,cty) in
+      fprintf fmt "@[<v>@[<v 2>typedef struct %s {" s;
+      List.iter (pp_field fmt) fl;
+      fprintf fmt "@]@ } %s;@ @]@\n" s
+  | Cdecl_function (n, retty, args) ->
+      fprintf fmt "@[<v>%a %s(@[<hov>%a@]);@ @]@\n"
+        pp_cty retty n pp_param_list args
+
+let pp_cdef fmt cdef = match cdef with
+  | Cfundef cfd ->
+      fprintf fmt
+        "@[<v>@[<v 2>%a %s(@[<hov>%a@]) {%a@]@ }@ @]@\n"
+        pp_cty cfd.f_retty cfd.f_name pp_param_list cfd.f_args
+        pp_cblock cfd.f_body
+  | Cvardef (s, cty) -> fprintf fmt "%a %s;@\n" pp_cty cty s
+
+let pp_cfile_desc fmt filen cfile =
+  (** [filen_wo_ext] is the file's name without the extension. *)
+  let filen_wo_ext = String.sub filen 0 (String.length filen - 2) in
+  match cfile with
+    | Cheader (deps, cdecls) ->
+        let headern_macro = String.uppercase filen_wo_ext in
+        Misc.print_header_info fmt "/*" "*/";
+        fprintf fmt "#ifndef %s_H@\n" headern_macro;
+        fprintf fmt "#define %s_H@\n@\n" headern_macro;
+        (* fprintf fmt "#include \"types.h\"\n"; *)
+        iter (fun d -> fprintf fmt "#include \"%s.h\"@\n" d)
+          deps;
+        iter (pp_cdecl fmt) cdecls;
+        fprintf fmt "#endif // %s_H@\n" headern_macro
+    | Csource cdefs ->
+        let headern = filen_wo_ext ^ ".h" in
+        Misc.print_header_info fmt "/*" "*/";
+        fprintf fmt "#include <stdio.h>@\n";
+        fprintf fmt "#include <string.h>@\n";
+        fprintf fmt "#include \"%s\"@\n@\n" headern;
+        fprintf fmt "#define FALSE 0@\n#define TRUE 1@\n@\n";
+        iter (pp_cdef fmt) cdefs
+
+(******************************)
+
+(** [output_cfile dir cfile] pretty-prints the content of [cfile] to the
+    corresponding file in the [dir] directory. *)
+let output_cfile dir (filen, cfile_desc) =
+  if !Misc.verbose then Printf.printf "C-NG generating %s/%s\n" 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
+  pp_cfile_desc fmt filen cfile_desc;
+  Buffer.output_buffer oc buf;
+  close_out oc
+
+let output dir cprog =
+  List.iter (output_cfile dir) cprog
+
+(** { Lexical conversions to C's syntax } *)
+
+(** [cname_of_name name] translates the string [name] to a valid C identifier.
+    Copied verbatim from the old C backend. *)
+let cname_of_name name =
+  let buf = Buffer.create (String.length name) in
+  let rec convert c =
+    match c with
+      | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' ->
+          Buffer.add_char buf c
+      | '\'' -> Buffer.add_string buf "_prime"
+      | _ ->
+          Buffer.add_string buf "lex";
+          Buffer.add_string buf (string_of_int (Char.code c));
+          Buffer.add_string buf "_" in
+  String.iter convert name;
+  Buffer.contents buf
+
+(** Converts an expression to a lhs. *)
+let lhs_of_exp e =
+  match e with
+    | Clhs e -> e
+    | _ -> assert false
+
+(** Returns the type of a pointer to a type, except for 
+    types which are already pointers. *)
+let pointer_to ty = 
+  match ty with
+  | Cty_arr _ | Cty_ptr _ -> ty
+  | _ -> Cty_ptr ty
+
+(** Returns whether a type is a pointer. *)
+let is_pointer_type = function
+  | Cty_arr _ | Cty_ptr _ -> true
+  | _ -> false 
+
+(** [array_base_ctype ty idx_list] returns the base type of an array
+    type. If idx_list = [i1; ..; ip] and a is a variable of type ty,
+    then it returns a[i1]..[ip]. *)
+let rec array_base_ctype ty idx_list =
+  match ty, idx_list with
+    | Cty_arr (n, ty), [i] -> ty
+    | Cty_arr (n, ty), i::idx_list -> array_base_ctype ty idx_list
+    | _ -> assert false

minils/sequential/c.mli

@@ -0,0 +1,131 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* $Id$ *)
+
+(** Abstract syntax tree for C programs. *)
+(** {2 C abstract syntax tree } *)
+
+(** Here is the C abstract syntax tree used by MiniLS for its C backend. It does
+    not try to completly model the C language, only the relatively small part
+    that were are interested in (e.g. no function pointers or local variable
+    initialization). *)
+
+(** C types relevant for Obc. Note the absence of function pointers. *)
+type cty =
+  | Cty_int (** C machine-dependent integer type. *)
+  | Cty_float (** C machine-dependent single-precision floating-point type. *)
+  | Cty_char (** C character type. *)
+  | Cty_id of string (** Previously defined C type, such as an enum or struct. *)
+  | Cty_ptr of cty (** C points-to-other-type type. *)
+  | Cty_arr of int * cty (** A static array of the specified size. *)
+  | Cty_void (** Well, [void] is not really a C type. *)
+
+(** A C block: declarations and statements. In source code form, it begins with
+    variable declarations before a list of semicolon-separated statements, the
+    whole thing being enclosed in curly braces. *)
+type cblock = {
+  (** Variable declarations, where each declaration consists of a variable
+      name and the associated C type. *)
+  var_decls : (string * cty) list;
+  (** The actual statement forming our block. *)
+  block_body : cstm list;
+}
+
+(** C expressions. *)
+and cexpr =
+  | Cuop of string * cexpr (** Unary operator with its name. *)
+  | Cbop of string * cexpr * cexpr (** Binary operator. *)
+  | Cfun_call of string * cexpr list (** Function call with its parameters. *)
+  | 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, ...]. *)
+and cconst =
+  | Ccint of int (** Integer constant. *)
+  | Ccfloat of float (** Floating-point number constant. *)
+  | Ctag of string (** Tag, member of a previously declared enumeration. *)
+  | Cstrlit of string (** String literal, enclosed in double-quotes. *)
+(** C left-hand-side (ie. affectable) expressions. *)
+and clhs =
+  | Cvar of string (** A local variable. *)
+  | Cderef of clhs (** Pointer dereference, *ptr. *)
+  | Cfield of clhs * string (** Field access to left-hand-side. *)
+  | Carray of clhs * cexpr (** Array access clhs[cexpr] *)
+(** 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. **)
+  | Cskip (** A dummy instruction that does nothing and will not be printed. *)
+  | Caffect of clhs * cexpr (** Affect the result of an expression to a lhs. *)
+  | Cif of cexpr * cstm list * cstm list (** Alternative *)
+  | Cswitch of cexpr * (string * cstm list) list (** Case/switch over an enum. *)
+  | Cwhile of cexpr * cstm list (** While loop. *)
+  | Cfor of string * int * int * cstm list (** For loop. int <= string < int *)
+  | Creturn of cexpr (** Ends a procedure/function by returning an expression.*)
+
+(** C type declarations ; will {b always} correspond to a typedef in emitted
+    source code. *)
+type cdecl =
+  (** C enum declaration, with associated value tags. *)
+  | Cdecl_enum of string * string list
+  (** C structure declaration, with each field's name and type. *)
+  | Cdecl_struct of string * (string * cty) list
+  (** C function declaration. *)
+  | Cdecl_function of string * cty * (string * cty) list
+
+(** C function definition *)
+type cfundef = {
+  f_name : string; (** The function's name. *)
+  f_retty : cty; (** The function's return type. *)
+  f_args : (string * cty) list; (** Each parameter's name and type. *)
+  f_body : cblock; (** Actual instructions, in the form of a block. *)
+}
+
+(** C top-level definitions. *)
+type cdef =
+  | Cfundef of cfundef (** Function definition, see [cfundef]. *)
+  | Cvardef of string * cty (** A variable definition, with its name and type. *)
+
+val cdecl_of_cfundef : cdef -> cdecl
+
+(** A C file can be a source file, containing definitions, or a header file,
+    containing declarations. *)
+type cfile_desc =
+  | Cheader of string list * cdecl list (** Header dependencies * declaration
+                                            list *)
+  | Csource of cdef list
+
+type cfile = string * cfile_desc 	(** File name * file content *)
+
+(** [output dir cprog] pretty-prints the C program [cprog] to new files in the
+    directory [dir]. *)
+val output : string -> cfile list -> unit
+
+(** [cname_of_name name] translates the string [name] to a valid C identifier.
+    Copied verbatim from the old C backend. *)
+val cname_of_name : string -> string
+
+(** Converts an expression to a lhs. *)
+val lhs_of_exp : cexpr -> clhs
+
+(** Returns the type of a pointer to a type, except for 
+    types which are already pointers. *)
+val pointer_to : cty -> cty
+
+(** Returns whether a type is a pointer. *)
+val is_pointer_type : cty -> bool
+
+(** [array_base_ctype ty idx_list] returns the base type of an array
+    type. If idx_list = [i1; ..; ip] and a is a variable of type ty,
+    then it returns a[i1]..[ip]. *)
+val array_base_ctype : cty -> int list -> cty
+
+

minils/sequential/control.ml

@@ -0,0 +1,81 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* control optimisation *)
+
+(* $Id$ *)
+
+open Minils
+open Ident
+open Misc
+
+let var_from_name map x =
+  begin try
+    Env.find x map 
+  with
+      _ -> assert false
+  end
+
+let rec find c = function
+  | []    -> raise Not_found
+  | (c1, s1) :: h  ->
+      if c = c1 then s1, h else let s, h = find c h in s, (c1, s1) :: h
+
+let rec control map ck s =
+  match ck with
+    | Cbase | Cvar { contents = Cindex _ } -> s
+    | Cvar { contents = Clink ck } -> control map ck s
+    | Con(ck, c, n)  ->
+        let e = var_from_name map n in
+        control map ck (Obc.Case(Obc.Lhs e, [(c, s)]))
+
+let rec simplify act =
+  match act with
+  | Obc.Assgn (lhs, e) -> 
+      (match e with 
+	 | Obc.Lhs l when l = lhs -> Obc.Nothing 
+	 | _ -> act
+      )
+  | Obc.Case(lhs, h) ->
+      (match simplify_handlers h with
+	 | [] -> Obc.Nothing
+	 | h -> Obc.Case(lhs, h)
+      )
+  | _ -> act
+
+and simplify_handlers = function
+  | [] -> []
+  | (n,a)::h -> 
+      let h = simplify_handlers h in
+      (match simplify a with
+	 | Obc.Nothing -> h
+	 | a -> (n,a)::h
+      )
+
+let rec join s1 s2 =
+  match simplify s1, simplify s2 with
+    | Obc.Case(Obc.Lhs(n), h1), Obc.Case(Obc.Lhs(m), h2) when n = m ->
+        Obc.Case(Obc.Lhs(n), joinhandlers h1 h2)
+    | s1, Obc.Nothing -> s1
+    | Obc.Nothing, s2 -> s2
+    | s1, Obc.Comp(s2, s3) -> Obc.Comp(join s1 s2, s3)
+    | s1, s2 -> Obc.Comp(s1, s2)
+
+and joinhandlers h1 h2 =
+  match h1 with
+    | [] -> h2
+    | (c1, s1) :: h1' ->
+        let s1', h2' =
+          try let s2, h2'' = find c1 h2 in join s1 s2, h2''
+          with Not_found -> simplify s1, h2 in
+        (c1, s1') :: joinhandlers h1' h2'
+
+let rec joinlist = function
+  | []      -> Obc.Nothing
+  | s :: l  -> join s (joinlist l)

minils/sequential/csubst.ml

@@ -0,0 +1,65 @@
+open C
+open Obc
+open Ident
+open Names
+
+let rec subst_stm map stm = 
+  match stm with 
+    | Csexpr e -> Csexpr (subst_exp map e)
+    | Cskip -> Cskip
+    | Creturn e -> Creturn (subst_exp map e)
+    | Csblock cblock ->
+	Csblock (subst_block map cblock)
+    | Caffect (lhs, e) ->
+	Caffect(subst_lhs map lhs, subst_exp map e)
+    | Cif (e, truel, falsel) ->
+	Cif (subst_exp map e, subst_stm_list map truel, 
+	    subst_stm_list map falsel)
+    | Cswitch (e, l) ->
+	Cswitch (subst_exp map e, List.map (fun (s, sl) -> s, subst_stm_list map sl) l)
+    | Cwhile (e, l) -> 
+	Cwhile (subst_exp map e, subst_stm_list map l)
+    | Cfor (x, i1, i2, l) ->
+	Cfor (x, i1, i2, subst_stm_list map l)
+
+and subst_stm_list map =
+    List.map (subst_stm map)
+
+and subst_lhs map lhs = 
+  match lhs with
+    | Cvar n -> 
+	if NamesEnv.mem n map then
+	  NamesEnv.find n map
+	else
+	  lhs
+    | Cfield (lhs, s) -> Cfield (subst_lhs map lhs, s)
+    | Carray (lhs, n) -> Carray (subst_lhs map lhs, n)
+    | Cderef lhs -> Cderef (subst_lhs map lhs)
+
+and subst_exp map = function
+  | Cuop (op, e) -> Cuop (op, subst_exp map e)
+  | Cbop (s, l, r) -> Cbop (s, subst_exp map l, subst_exp map r)
+  | Cfun_call (s, el) -> Cfun_call (s, subst_exp_list map el)
+  | Cconst x -> Cconst x
+  | Clhs lhs -> Clhs (subst_lhs map lhs)
+  | Caddrof lhs -> Caddrof (subst_lhs map lhs)
+  | Cstructlit (s, el) -> Cstructlit (s, subst_exp_list map el)
+  | Carraylit el ->  Carraylit (subst_exp_list map el)
+
+and subst_exp_list map =
+  List.map (subst_exp map)
+
+and subst_block map b =
+  {b with block_body = subst_stm_list map b.block_body}
+
+let assoc_map_for_fun sf = 
+  match sf.out with
+    | [] -> NamesEnv.empty
+    | [vd] when Obc.is_scalar_type (List.hd sf.out) -> 
+	NamesEnv.empty
+    | out ->
+        let fill_field map vd =
+          NamesEnv.add (name vd.v_name) (Cfield (Cderef (Cvar "self"), name vd.v_name)) map
+	in
+          List.fold_left fill_field NamesEnv.empty out
+

minils/sequential/java.ml

@@ -0,0 +1,596 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* $Id$ *)
+
+open Global
+open Modules
+open Format
+open Obc
+open Misc
+open Names
+open Ident
+
+let actual_type ty =
+  match ty with
+    | Tid(tn) when (shortname tn) = "float" -> Tfloat
+    | Tid(tn) when (shortname tn) = "int" -> Tint
+    | _ -> ty
+
+(******************************)
+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 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 ff print_field "" 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 ff print_const_field "," sorted_fields;
+  fprintf ff "@]) {@ ";
+  (* constructor assignments *)
+  print_list ff print_assgt_field "" 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_name
+  | Mult of var_name 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(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 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) ->
+	      (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_name))
+    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_name));
+  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_name) s.out) ts single;
+  fprintf ff "@ @ return ";
+  if single then fprintf ff "%s" (jname_of_name (Ident.name (List.hd s.out).v_name))
+  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
+
+(******************************)

minils/sequential/mls2obc.ml

@@ -0,0 +1,414 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* translation from the source language to the target *)
+
+(* $Id$ *)
+
+open Misc
+open Names 
+open Ident
+open Global
+open Obc
+open Control
+open Normalize
+open Memalloc
+open Interference
+open Static
+
+(* merge x (C1 -> (merge y (C2 -> e2)) when C1(x)) *)
+
+(** Targeted inputs should be marked as passed by reference. *)
+let update_targeted_inputs targeting inv =
+  let rec aux i = function
+    | [] -> []
+    | vd::l -> 
+	let vd =  
+	  if List.mem_assoc i targeting then (*input is targeted*)
+	    { vd with v_pass_by_ref = true; }
+	  else (*not targeted, leave it*)
+	    vd
+	in
+	  vd::(aux (i+1) l) 
+  in 
+    aux 0 inv
+
+let rec encode_name_params n = function
+  | [] -> n
+  | p::params -> encode_name_params (n^"__"^(string_of_int p)) params
+
+let encode_longname_params n params = 
+  match n with
+    | Name n -> Name (encode_name_params n params)
+    | Modname { qual = qual; id = id } ->
+	Modname { qual = qual; id = encode_name_params id params }
+	
+let is_op = function
+  | Modname { qual = "Pervasives"; id = _ } -> true
+  | _ -> false
+
+let rec translate_type const_env = function
+  | Minils.Tbase(btyp) -> translate_base_type const_env btyp
+  | Minils.Tprod _     -> assert false
+
+and translate_base_type const_env = function
+  | Minils.Tint -> Tint
+  | Minils.Tfloat  -> Tfloat
+  | Minils.Tid(id) -> Tid(id)
+  | Minils.Tarray(ty, n) -> Tarray (translate_base_type const_env ty,
+				    int_of_size_exp const_env n)
+
+let rec translate_const const_env = function
+  | Minils.Cint(v) -> Cint(v)
+  | Minils.Cfloat(v) -> Cfloat(v)
+  | Minils.Cconstr(c) -> Cconstr(c)
+  | Minils.Cconst_array(n,c) -> 
+      Cconst_array(int_of_size_exp const_env n, translate_const const_env c)
+
+let rec translate_pat map = function
+  | Minils.Evarpat(x) -> [var_from_name map x]
+  | Minils.Etuplepat(pat_list) ->
+      List.fold_right (fun pat acc -> (translate_pat map pat) @ acc) pat_list []
+
+(* [translate e = c] *)
+let rec translate const_env map (m, si, j, s) ({ Minils.e_desc = desc } as e) =
+  match desc with
+    | Minils.Econst(v) -> Const(translate_const const_env v)
+    | Minils.Evar(n) -> Lhs (var_from_name map n)
+    | Minils.Econstvar(n) -> 
+	Const (Cint(int_of_size_exp const_env (SVar n)))
+    | Minils.Eop(n, _, e_list) ->
+        Op(n, List.map (translate const_env map (m, si, j, s)) e_list)
+    | Minils.Ewhen(e, _, _) -> translate const_env map (m, si, j, s) (e)
+    | Minils.Efield(e, field) ->
+	let e = translate const_env map (m, si, j, s) e in
+        Lhs (Field(lhs_of_exp e, field))
+    | Minils.Estruct(f_e_list) ->
+        let type_name =
+          begin match e.Minils.e_ty with
+              Minils.Tbase(Minils.Tid(name)) -> name
+            | _ -> assert false
+          end in
+        let f_e_list = List.map
+          (fun (f, e) -> (f,
+                          translate const_env map (m, si, j, s) e)) f_e_list in
+        Struct(type_name,f_e_list)
+(*Array operators*)	  
+    | Minils.Earray e_list -> 
+	Array (List.map (translate const_env map (m, si, j, s)) e_list)
+    | Minils.Eselect (idx,e) -> 
+	let e = translate const_env map (m, si, j, s) e in
+	Lhs ( Array (lhs_of_exp e, 
+		     List.map (int_of_size_exp const_env) idx) )
+    | _ -> Minils.Printer.print_exp stdout e; flush stdout; assert false
+
+(* [translate pat act = si, j, d, s] *)
+and translate_act const_env map ((m,_,_,_) as context) pat ({ Minils.e_desc = desc } as act) =
+  match pat, desc with
+    | Minils.Etuplepat(p_list), Minils.Etuple(act_list) ->
+        comp (List.map2 (translate_act const_env map context) p_list act_list)
+    | pat, Minils.Ewhen(e, _, _) ->
+	translate_act const_env map context pat e
+    | pat, Minils.Emerge(x, c_act_list) ->
+        let lhs = var_from_name map x in
+          (Case(Lhs lhs, translate_c_act_list const_env map context pat c_act_list))
+    | Minils.Evarpat(n), _ -> 
+	Assgn(var_from_name map n, translate const_env map context act)
+    | _ ->
+        Minils.Printer.print_exp stdout act;
+        assert false
+
+and translate_c_act_list const_env map context pat c_act_list =
+  List.map
+    (fun (c, act) -> (c, translate_act const_env map context pat act))
+    c_act_list
+
+and comp s_list =
+  List.fold_right (fun s rest -> Comp(s, rest)) s_list Nothing
+
+let rec translate_eq const_env map { Minils.p_lhs = pat; Minils.p_rhs = e } (m, si, j, s) =
+  let { Minils.e_desc = desc; Minils.e_ty = ty; Minils.e_ck = ck } = e in
+  match pat, desc with
+    | Minils.Evarpat(n), Minils.Efby(opt_c, e) ->
+	let x = var_from_name map n in
+        let si =
+          match opt_c with
+            | None -> si
+            | Some(c) ->
+		  if var_name x = n then 
+                    (Assgn(x, Const(translate_const const_env c))) :: si
+		  else
+		    si (*this mem is shared, no need to add a reset intruction*)
+	in
+        let ty = translate_type const_env ty in
+	let m = if var_name x = n then (n, ty) :: m else m in
+        m, si, j,
+        (control map ck (Assgn(var_from_name map n, translate const_env map (m, si, j, s) e))) :: s
+    | pat, Minils.Eapp({ Minils.a_op = n }, params, e_list) ->
+	let sig_info = (Modules.find_value n).info in
+        let name_list = translate_pat map pat in
+	let name_list = remove_targeted_outputs sig_info.targeting name_list in
+        let c_list = List.map (translate const_env map (m, si, j, s)) e_list in
+        let o = gen_symbol () in
+        let si = (Reinit(o)) :: si in
+	let params = List.map (int_of_size_exp const_env) params in
+        let j = (o, encode_longname_params n params, 1) :: j in
+        let s =
+          (control map ck (Step_ap(name_list, o, c_list))) :: s in
+        (m, si, j, s)
+    | pat, Minils.Eevery({ Minils.a_op = n }, params, e_list, r ) ->
+        let name_list = translate_pat map pat in
+        let c_list = List.map (translate const_env map (m, si, j, s)) e_list in
+        let o = gen_symbol () in
+        let si = (Reinit(o)) :: si in
+	let params = List.map (int_of_size_exp const_env) params in
+        let j = (o, encode_longname_params n params, 1) :: j in
+        let s =
+          (control map (Minils.Con(ck, Name("true"), r)) (Reinit(o))) ::
+            (control map ck (Step_ap(name_list, o, c_list))) :: s in
+        (m, si, j, s)
+    | Minils.Etuplepat(p_list), Minils.Etuple(act_list) ->
+        List.fold_right2
+          (fun pat e -> translate_eq const_env map { Minils.p_lhs = pat; Minils.p_rhs = e } )
+          p_list act_list (m, si, j, s)
+    | Minils.Evarpat(x), Minils.Eselect_slice(idx1, idx2, e) ->
+	let idx1 = int_of_size_exp const_env idx1 in
+	let idx2 = int_of_size_exp const_env idx2 in
+	let idx = 
+	let cpt = name (Ident.fresh "i") in
+	let e = translate const_env map (m, si, j, s) e in
+	let action = For( cpt, 0, idx2 - idx1 + 1,
+			 Assgn (Array (var_from_name map x, Var cpt), 
+			       Lhs (Array (lhs_of_exp e, idx))) )
+
+	let action = Array_select_slice (var_from_name map x, 
+					 translate const_env map (m, si, j, s) e,
+					 int_of_size_exp const_env idx1,
+					 int_of_size_exp const_env idx2) in
+	  m, si, j, ((control map ck action)::s)
+    | Minils.Evarpat(x), Minils.Eselect_dyn (idx, bounds, e1, e2) ->
+	let action = Array_select_dyn (var_from_name map x, 
+				       translate const_env map (m, si, j, s) e1,
+				       List.map (translate const_env map (m, si, j, s)) idx,
+				       List.map (int_of_size_exp const_env) bounds,
+				       translate const_env map (m, si, j, s) e2 ) in
+	   m, si, j, ((control map ck action)::s)
+    | Minils.Evarpat(x), Minils.Eupdate (idx, e1, e2) ->
+	let x = var_from_name map x in
+	let copy = Assgn (x, translate const_env map (m, si, j, s) e1) in
+	let action = Assgn (Array (x, List.map (int_of_size_exp const_env) idx),
+			    translate const_env map (m, si, j, s) e2) in
+	  m, si, j, ((control map ck copy)::(control map ck action)::s)
+    | Minils.Evarpat(x), Minils.Erepeat (n, e) ->
+	let cpt = name (Ident.fresh "i") in
+	let action = For (cpt, 0, int_of_size_exp const_env n,
+			  Assgn(Lhs (var_from_name map x, Var cpt),
+			       translate const_env map (m, si, j, s) e) in
+	  m, si, j, ((control map ck action)::s)
+    | Minils.Evarpat(x), Minils.Econcat(e1, e2) ->
+	let action = Array_concat (var_from_name map x, translate const_env map (m, si, j, s) e1,
+				  translate const_env map (m, si, j, s) e2) in
+	  m, si, j, ((control map ck action)::s)	
+    | pat, Minils.Eiterator(it, f, params, n, e_list, reset) ->
+	let sig_info = (Modules.find_value f).info in
+        let name_list = translate_pat map pat in
+	let name_list = remove_targeted_outputs sig_info.targeting name_list in
+	let c_list = List.map (translate const_env map (m, si, j, s)) e_list in
+	let o = gen_symbol () in
+	let n = int_of_size_exp const_env n in
+	let si = if is_op f then si else (Reinit(o)) :: si in
+	let params = List.map (int_of_size_exp const_env) params in
+        let j = (o, encode_longname_params f params, n) :: j in
+	let action = Array_iterate (name_list, it, o, n, c_list) in
+	let s = 
+	  (match reset with
+	     | None -> (control map ck action)::s
+	     | Some r -> 
+		 (control map (Minils.Con(ck, Name("true"), r)) (Reinit(o))) ::
+		   (control map ck action)::s
+	  ) in
+	  m, si, j, s
+    | Minils.Evarpat(x), Minils.Efield_update (f, e1, e2) ->
+	let action = Field_update (var_from_name map x, translate const_env map (m,si,j,s) e1,
+				   f, translate const_env map (m,si,j,s) e2) in
+	  m, si, j, ((control map ck action)::s)
+    | Minils.Etuplepat [], Minils.Ereset_mem(y, v, res) ->
+	let h = Initial.ptrue, Assgn(var_from_name map y, Const (translate_const const_env v)) in
+	let action = Case (Lhs (var_from_name map res), [h]) in
+	  (m, si, j, (control map ck action) :: s)
+    | pat, _ ->
+        let action = translate_act const_env map (m, si, j, s) pat e in
+        (m, si, j, (control map ck action) :: s)
+
+let translate_eq_list const_env map act_list =
+  List.fold_right (translate_eq const_env map) act_list ([], [], [], [])
+
+let remove m d_list =
+  List.filter (fun { Minils.v_name = n } -> not (List.mem_assoc n m)) d_list
+
+let var_decl l =
+  List.map (fun (x, t) -> { v_name = x; v_type = t; v_pass_by_ref = false }) l
+
+let obj_decl l = List.map (fun (x, t, i) -> { obj = x; cls = t; n = i }) l
+
+let translate_var_dec const_env map l =
+  let one_var { Minils.v_name = x; Minils.v_type = t } =
+     { v_name = x; v_type = translate_base_type const_env t; v_pass_by_ref = false }
+  in
+    (* remove unused vars *)
+  let l = List.filter (fun { Minils.v_name = x } -> 
+			 var_name (var_from_name map x) = x) l in
+    List.map one_var l
+
+let translate_contract const_env map = function
+  | None ->
+      [], [], [], [], [], []
+  | Some({ Minils.c_eq = eq_list;
+           Minils.c_local = d_list;
+           Minils.c_controllables = c_list;
+           Minils.c_assume = e_a;
+           Minils.c_enforce = e_c }) ->
+      let m, si, j, s_list = translate_eq_list const_env map eq_list in
+      let d_list = remove m d_list in
+      let d_list = translate_var_dec const_env map d_list in
+      let c_list = translate_var_dec const_env map c_list in
+      m, si, j, s_list, d_list, c_list
+
+let rec choose_record_field m = function
+  | [IVar x] -> Var x
+  | [IField(x,f)] -> Field(var_from_name m x,f)
+  | (IVar x)::l -> choose_record_field m l
+  | (IField(x,f))::l -> 
+      if var_name (var_from_name m x) <> x then
+	choose_record_field m l
+      else
+	Field(var_from_name m x,f)
+
+(** Chooses from a list of vars (with the same color in the interference graph)
+    the one that will be used to store every other. It can be either an input,
+    an output or any var if there is no input or output in the list. *)
+let choose_representative m inputs outputs mems vars =
+  let ivar_mem x vars =
+    match x with
+      | IVar x -> List.mem x vars
+      | _ -> false
+  in
+
+  let inputs = List.filter (fun var -> Minils.ivar_vd_mem var inputs) vars in
+  let outputs = List.filter (fun var -> Minils.ivar_vd_mem var outputs) vars in
+  let mems = List.filter (fun var -> ivar_mem var mems) vars in
+    match inputs, outputs, mems with 
+      | [], [], [] -> choose_record_field m vars
+      | [], [], (IVar m)::_ -> Mem m
+      | [IVar vin], [], [] -> Var vin
+      | [], [IVar vout], [] -> Var vout
+      | [IVar vin], [IVar vout], [] -> Var vin
+      | _, _, _ ->
+	  Format.printf "Something is wrong with the coloring : ";
+	  List.iter (fun vd -> Format.printf "%s," (ivar_to_string vd)) vars;
+	  Format.printf "\n Inputs : ";
+	  List.iter (fun vd -> Format.printf "%s," (ivar_to_string vd)) inputs;
+	  Format.printf "\n Outputs : ";
+	  List.iter (fun vd -> Format.printf "%s," (ivar_to_string vd)) outputs;
+	  Format.printf "\n Mem : ";
+	  List.iter (fun vd -> Format.printf "%s," (ivar_to_string vd)) mems;
+	  Format.printf "\n";
+	  assert false (*something went wrong in the coloring*)
+
+(** Returns a map, mapping variables names to the variables
+    where they will be stored, as a result of memory allocation. *)
+let subst_map_from_coloring subst_lists inputs outputs locals mems =
+  let rec add_to_map map value = function
+    | [] -> map
+    | var::l ->
+	let m = add_to_map map value l in
+	(match var with
+	   | IVar x -> Env.add x value m
+	   | _ -> m
+	)
+  in
+  let map_from_subst_lists m l =
+    List.fold_left 
+      (fun m (_,l) -> add_to_map m (choose_representative m inputs outputs mems l) l) 
+      m l
+  in
+    if !no_mem_alloc then (
+      (* Create a map that simply maps each var to itself *)
+      let m = List.fold_left 
+	(fun m { Minils.v_name = x } -> Env.add x (Var x) m) 
+	Env.empty (inputs @ outputs @ locals) in
+	List.fold_left (fun m x -> Env.add x (Mem x) m) m mems
+    ) else (
+      let record_lists, other_lists = List.partition
+	(fun (ty,_) -> Minils.is_record_type ty) subst_lists in
+      let m = map_from_subst_lists Env.empty record_lists in
+	map_from_subst_lists m other_lists
+    )
+
+let translate_node_aux const_env 
+    { 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_targeting = targeting; 
+      Minils.n_mem_alloc = mem_alloc; Minils.n_params = params } =
+
+  let mem_vars = List.flatten (List.map InterfRead.memory_vars eq_list) in
+  let subst_map = subst_map_from_coloring mem_alloc i_list o_list d_list mem_vars in
+  let m, si, j, s_list = translate_eq_list const_env subst_map eq_list in
+  let m', si', j', s_list', d_list', c_list = translate_contract const_env subst_map contract in
+  let d_list = remove m d_list in
+  let i_list = translate_var_dec const_env subst_map i_list in
+  let i_list = update_targeted_inputs targeting i_list in
+  let o_list = translate_var_dec const_env subst_map o_list in
+  let d_list = translate_var_dec const_env subst_map d_list in
+  let s = joinlist (s_list@s_list') in
+  let m = var_decl (m@m') in
+  let j = obj_decl (j@j') in
+  let si = joinlist (si@si') in
+  let step = { inp = i_list; out = o_list; 
+	       local = (d_list@d_list'@c_list);
+	       controllables = c_list;
+	       bd = s } in
+  { cl_id = f; mem = m; objs = j; reset = si; step = step }
+
+let build_params_list env params_names params_values =
+  List.fold_left2 (fun env n v -> NamesEnv.add n (SConst v) env) env params_names params_values
+
+let translate_node const_env n =
+  let translate_one p =
+    let const_env = build_params_list const_env n.Minils.n_params p in
+    let c = translate_node_aux const_env n in
+      { c with cl_id = encode_name_params c.cl_id p; } 
+  in
+    match n.Minils.n_params_instances with
+      | [] -> [translate_node_aux const_env n]
+      | params_lists -> List.map translate_one params_lists
+
+let translate_ty_def const_env { Minils.t_name = name; Minils.t_desc = tdesc } =
+  let tdesc = match tdesc with
+    | Minils.Type_abs  -> Type_abs
+    | Minils.Type_enum(tag_name_list) -> Type_enum(tag_name_list)
+    | Minils.Type_struct(field_ty_list) ->
+        Type_struct
+          (List.map (fun (f, ty) -> (f, translate_base_type const_env ty)) field_ty_list)
+  in
+  { t_name = name; t_desc = tdesc }
+
+let build_const_env cd_list =
+  List.fold_left (fun env cd -> NamesEnv.add cd.Minils.c_name cd.Minils.c_value env) NamesEnv.empty cd_list
+
+let program { Minils.p_pragmas = p_pragmas_list;
+	      Minils.p_opened = p_module_list;
+              Minils.p_types = p_type_list;
+              Minils.p_nodes = p_node_list;
+	      Minils.p_consts = p_const_list; } =
+  let const_env = build_const_env p_const_list in
+  { o_pragmas = p_pragmas_list;
+    o_opened = p_module_list;
+    o_types = List.map (translate_ty_def const_env) p_type_list;
+    o_defs = List.flatten (List.map (translate_node const_env) p_node_list) }

minils/sequential/obc.ml

@@ -0,0 +1,433 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* Object code internal representation *)
+
+(* $Id$ *)
+
+open Misc
+open Names
+open Ident
+
+type var_name = ident
+type type_name = longname
+type fun_name = longname
+type class_name = name
+type instance_name = longname
+type obj_name = name
+type op_name = longname
+type field_name = longname
+
+type ty =
+    | Tint
+    | Tfloat
+    | Tid of type_name
+    | Tarray of ty * int
+
+type type_dec =
+    { t_name : name;
+      t_desc : tdesc }
+
+and tdesc =
+    | Type_abs
+    | Type_enum of name list
+    | Type_struct of (name * ty) list
+
+type const =
+    | Cint of int
+    | Cfloat of float
+    | Cconstr of longname
+    | Cconst_array of int * const
+
+type lhs =
+  | Var of var_name
+  | Mem of var_name
+  | Field of lhs * field_name
+  | Array of lhs * exp
+
+type exp =
+  | Lhs of lhs
+  | Const of const
+  | Op of op_name * exp list
+  | Struct of type_name * (field_name * exp) list
+  | Array of exp list
+
+type act =
+    | Assgn of lhs * exp
+    | Step_ap of lhs list * obj_name * exp list
+    | Comp of act * act
+    | Case of exp * (longname * act) list
+    | For of var_name * int * int * act
+    | Reinit of obj_name
+    | Nothing
+    | Array_select_slice of lhs * exp * int * int
+    | Array_select_dyn of lhs * exp * exp list * int list * exp (* res, var, indices, bounds, def value*)
+    | Array_iterate of lhs list * iterator_name * obj_name * int * exp list
+    | Array_concat of lhs * exp * exp
+    | Field_update of lhs * exp * longname * exp (* var, record, field, value*)
+
+type var_dec =
+    { v_name : var_name;
+      v_type : ty;
+      v_pass_by_ref : bool; }
+
+type obj_dec =
+    { obj : obj_name;
+      cls : instance_name; 
+      n : int; }
+
+type step_fun =
+    { inp    : var_dec list;
+      out    : var_dec list;
+      local  : var_dec list;
+      controllables : var_dec list; (* GD : ugly patch to delay controllable
+				       variables definition to target code
+				       generation *)
+      bd     : act }
+
+type reset_fun = act
+
+type class_def =
+    { cl_id : class_name;
+      mem   : var_dec list;
+      objs  : obj_dec list;
+      reset : reset_fun;
+      step  : step_fun; }
+
+type program =
+    { o_pragmas: (name * string) list;
+      o_opened : name list;
+      o_types : type_dec list;
+      o_defs  : class_def list }
+
+(** [is_scalar_type vd] returns whether the type corresponding
+    to this variable declaration is scalar (ie a type that can
+    be returned by a C function). *)
+let is_scalar_type vd =
+  let pint = Modname({ qual = "Pervasives"; id = "int" }) in
+  let pfloat = Modname({ qual = "Pervasives"; id = "float" }) in
+  let pbool = Modname({ qual = "Pervasives"; id = "bool" }) in
+    match vd.v_type with
+      | Tint | Tfloat -> true
+      | Tid name_int when name_int = pint -> true
+      | Tid name_float when name_float = pfloat -> true
+      | Tid name_bool when name_bool = pbool -> true
+      | _ -> false 
+
+let actual_type ty =
+  match ty with
+    | Tid(Name("float"))
+    | Tid(Modname { qual = "Pervasives"; id = "float" }) -> Tfloat
+    | Tid(Name("int"))
+    | Tid(Modname { qual = "Pervasives"; id = "int" }) -> Tint
+    | _ -> ty
+
+let rec var_name x =
+  match x with
+    | Var x -> x
+    | Mem x -> x
+    | Field(x,_) -> var_name x
+
+(** 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_name = 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.printf "Not found var %s\n" (name n); raise Not_found
+  | vd::l -> 
+      if vd.v_name = n then vd else vd_find n l
+
+let lhs_of_exp = function
+  | Lhs l -> l
+  | _ -> assert false
+
+module Printer =
+struct
+  open Format
+
+  let rec print_list ff print sep = function
+    | []     -> ()
+    | [x]    -> print ff x
+    | x :: l ->
+        print ff x;
+        fprintf ff "%s@ " sep;
+        print_list ff print sep l
+
+  (* 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 ff 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
+      fprintf ff "%s" s
+
+  let print_longname ff ln =
+    let ln = (* currentname ln*) ln in
+      match ln with
+  | Name(m) -> print_name ff m
+  | Modname({ qual = "Pervasives"; id = m }) -> print_name ff m
+  | Modname({ qual = m1; id = m2 }) ->
+      fprintf ff "%s." m1; print_name ff m2
+
+  let print_ident ff id =
+    fprintf ff "%s" (name id)    
+
+  let rec print_type ff = function
+    | Tint    -> fprintf ff "int"
+    | Tfloat  -> fprintf ff "float"
+    | Tid(id) -> print_longname ff id
+    | Tarray(ty, n) -> 
+	print_type ff ty;
+	fprintf ff "^%d" n
+
+  let print_vd ff vd =
+    fprintf ff "@[<v>";
+    print_ident ff vd.v_name;
+    fprintf ff ": ";
+    if vd.v_pass_by_ref then 
+      fprintf ff "&";
+    print_type ff vd.v_type;
+    fprintf ff "@]"
+
+  let print_obj ff { cls = cls; obj = obj; n = n } =
+    fprintf ff "@[<v>"; print_name ff obj;
+    fprintf ff " : "; print_longname ff cls;
+    if n <> 1 then
+      fprintf ff "[%d]" n;
+    fprintf ff ";@]"
+
+  let rec print_c ff = function
+    | Cint i       -> fprintf ff "%d" i
+    | Cfloat f     -> fprintf ff "%f" f
+    | Cconstr(tag) -> print_longname ff tag
+    | Cconst_array(n,c) ->
+	print_c ff c;
+	fprintf ff "^%d" n
+
+  let rec print_lhs ff e = 
+    match e with
+    | Var x           -> print_ident ff x
+    | Mem x           -> fprintf ff "mem("; print_ident ff x; fprintf ff ")"
+    | Field (l, f)    -> print_lhs ff l; fprintf ff ".%s" (shortname f)
+
+  let rec print_exps ff e_list = print_list ff print_exp "," e_list
+
+  and print_exp ff = function
+    | Lhs lhs -> print_lhs ff lhs
+    | Const c         -> print_c ff c
+    | Op(op, e_list) -> print_op ff op e_list
+    | Struct(_,f_e_list) ->
+  fprintf ff "@[<v 1>{";
+  print_list ff
+    (fun ff (field, e) -> print_longname ff field;fprintf ff " = ";
+            print_exp ff e)
+    ";" f_e_list;
+  fprintf ff "}@]"
+    | Array e_list ->
+	fprintf ff "@[[";
+        print_list ff print_exp ";" e_list;
+        fprintf ff "]@]"
+    | Array_select(x, idx) ->
+	print_exp ff x;
+	fprintf ff "[";
+        print_list ff (fun ff -> fprintf ff "%d") "][" idx;
+        fprintf ff "]" 
+
+  and print_op ff op e_list =
+    print_longname ff op;
+    fprintf ff "(@["; print_list ff print_exp ", " e_list;
+    fprintf ff ")@]"
+
+  let print_asgn ff pref x e =
+    fprintf ff "@[%s" pref; print_lhs ff x; fprintf ff " = ";
+    fprintf ff "@["; print_exp ff e; fprintf ff "@]";
+    fprintf ff "@]"
+
+  let rec print_act ff a =
+    match a with
+      | Assgn (x, e) -> print_asgn ff "" x e
+      | Comp (a1, a2) ->
+    fprintf ff "@[<v>";
+    print_act ff a1;
+    fprintf ff ";@,";
+    print_act ff a2;
+    fprintf ff "@]"
+      | Case(e, tag_act_list) ->
+    fprintf ff "@[<v>@[<v 2>switch (";
+    print_exp ff e; fprintf ff ") {@,";
+    print_tag_act_list ff tag_act_list;
+    fprintf ff "@]@,}@]"
+      | Step_ap (var_list, o, es) ->
+    fprintf ff "@[(";
+    print_list ff print_lhs "," var_list;
+    fprintf ff "@])";
+    fprintf ff " = "; print_name ff o; fprintf ff ".step(";
+    fprintf ff "@["; print_exps ff es; fprintf ff "@]";
+    fprintf ff ")"
+      | Reinit o ->
+    print_name ff o; fprintf ff ".reset()"
+      | Nothing -> fprintf ff "()"
+      | Array_select_slice (var, e, idx1, idx2) -> 
+	  fprintf ff "@[";
+	  print_lhs ff var;
+	  fprintf ff " = ";
+	  print_exp ff e;
+          fprintf ff "[%d..%d]" idx1 idx2;
+	  fprintf ff "@]"
+      | Array_select_dyn (var, x, idx, _, defe) ->
+	  fprintf ff "@[";
+	  print_lhs ff var;
+	  fprintf ff " = ";
+	  fprintf ff "@[";
+	  print_exp ff x;
+	  fprintf ff "[";
+          print_list ff print_exp "][" idx;
+	  fprintf ff "] default ";
+	  print_exp ff defe;
+	  fprintf ff "@]"
+      | Array_update (x, e1, idx, e2) -> 
+	  fprintf ff "@[";
+	  print_lhs ff x;
+	  fprintf ff " = ";
+	  print_exp ff e1;
+          fprintf ff " with [";
+	  print_list ff (fun ff -> fprintf ff "%d") "][" idx;
+	  fprintf ff "] = ";
+	  print_exp ff e2;
+	  fprintf ff "@]"
+      | Array_repeat (x, n, e) ->
+	  fprintf ff "@[";
+	  print_lhs ff x;
+	  fprintf ff " = ";
+	  print_exp ff e;
+	  fprintf ff "^%d" n 
+      | Array_iterate (o_list, it, f, n, e_list) ->
+	  fprintf ff "@[(";
+	  print_list ff print_lhs ", " o_list;
+	  fprintf ff ") = ";
+	  fprintf ff "("; 
+	  fprintf ff "%s" (iterator_to_string it);
+	  fprintf ff " ";
+	  print_name ff f;
+	  fprintf ff " <<%d>>) (@[" n;
+	  print_list ff print_exp "," e_list;
+	  fprintf ff ")@]@]"
+      | Array_concat (x, e1, e2) ->
+	  fprintf ff "@[";
+	  print_lhs ff x;
+	  fprintf ff " = ";
+	  print_exp ff e1;
+	  fprintf ff " @@ ";
+	  print_exp ff e2
+     | Field_update (x, e1, f, e2) -> 
+	  fprintf ff "@[";
+	  print_lhs ff x;
+	  fprintf ff " = ";
+	  print_exp ff e1;
+          fprintf ff " with .";
+	  print_longname ff f;
+	  fprintf ff " = ";
+	  print_exp ff e2;
+	  fprintf ff "@]"
+
+  and print_tag_act_list ff tag_act_list =
+    print_list ff
+      (fun ff (tag, a) ->
+  fprintf ff "@[<hov 2>case@ ";
+  print_longname ff tag;
+  fprintf ff ":@ ";
+  print_act ff a;
+        fprintf ff "@]") "" tag_act_list
+
+  let print_step ff { inp = inp; out = out; local = nl; bd = bd } =
+    fprintf ff "@[<v 2>";
+    fprintf ff "step(@[";
+    print_list ff print_vd ";" inp;
+    fprintf ff "@]) returns (@[";
+    print_list ff print_vd ";" out;
+    fprintf ff "@]){@,";
+    if nl <> [] then begin
+      fprintf ff "@[<hov 4>var ";
+      print_list ff print_vd ";" nl;
+      fprintf ff ";@]@,"
+    end;
+    print_act ff bd;
+    fprintf ff "}@]"
+
+  let print_reset ff act =
+    fprintf ff "@[<v 2>";
+    fprintf ff "reset() {@,";
+    print_act ff act;
+    fprintf ff "}@]"
+
+  let print_def ff
+      { cl_id = id; mem = mem; objs = objs; reset = reset; step = step } =
+    fprintf ff "@[<v 2>machine "; print_name ff id; fprintf ff " =@,";
+    if mem <> [] then begin
+      fprintf ff "@[<hov 4>var ";
+      print_list ff print_vd ";" mem;
+      fprintf ff ";@]@,"
+    end;
+    if objs <> [] then begin
+      fprintf ff "@[<hov 4>obj ";
+      print_list ff print_obj ";" objs;
+      fprintf ff ";@]@,"
+    end;
+    print_reset ff reset;
+    fprintf ff "@,";
+    print_step ff step;
+    fprintf ff "@]"
+
+  let print_type_def ff { t_name = name; t_desc = tdesc } =
+    match tdesc with
+      | Type_abs -> fprintf ff "@[type %s@\n@]" name
+      | Type_enum(tag_name_list) ->
+    fprintf ff "@[type %s = " name;
+    print_list ff print_name "| " tag_name_list;
+    fprintf ff "@\n@]"
+      | Type_struct(f_ty_list) ->
+    fprintf ff "@[type %s = " name;
+    fprintf ff "@[<v 1>{";
+    print_list ff
+      (fun ff (field, ty) ->
+        print_name ff field;
+              fprintf ff ": ";
+        print_type ff ty) ";" f_ty_list;
+    fprintf ff "}@]@.@]"
+
+  let print_open_module ff name =
+    fprintf ff "@[open ";
+    print_name ff name;
+    fprintf ff "@.@]"
+
+  let print_prog ff { o_opened = modules; o_types = types; o_defs = defs } =
+    List.iter (print_open_module ff) modules;
+    List.iter (print_type_def ff) types;
+    List.iter (fun def -> (print_def ff def; fprintf ff "@ ")) defs
+
+  let print oc p =
+    let ff = formatter_of_out_channel oc in
+    fprintf ff "@[-- Code generated by the MiniLucid Compiler@.";
+      fprintf ff "@[<v>"; print_prog ff p; fprintf ff "@]@]@."
+end
+

minils/transformations/callgraph.ml

@@ -0,0 +1,127 @@
+open Misc
+open Minils
+open Names
+open Ident
+open Format
+open Location
+open Printf
+open Static
+
+module Error =
+struct
+  type error =
+    | Emain_node_no_params of name
+
+  let message loc kind =
+    begin match kind with
+      | Emain_node_no_params n ->
+          eprintf "%aThe main node '%s' cannot have parameters.\n"
+            output_location loc 
+	    n	  
+    end;
+    raise Misc.Error
+end
+
+let nodes_instances = ref NamesEnv.empty
+let global_env = ref NamesEnv.empty
+
+let rec string_of_int_list = function
+  | [] -> ""
+  | [n] -> (string_of_int n)
+  | n::l -> (string_of_int n)^", "^(string_of_int_list l)
+
+let add_node_params n params =
+  if NamesEnv.mem n !nodes_instances then 
+    nodes_instances := NamesEnv.add n (params::(NamesEnv.find n !nodes_instances)) !nodes_instances
+  else
+    nodes_instances := NamesEnv.add n [params] !nodes_instances
+
+let rec node_by_name s = function
+  | [] -> raise Not_found
+  | n::l -> 
+      if n.n_name = s then
+	n
+      else
+	node_by_name s l  
+
+let build env params_names params_values = 
+  List.fold_left2 (fun m n v -> NamesEnv.add n (SConst v) m) env params_names params_values
+
+let rec collect_exp nodes env e =
+  match e.e_desc with
+    | Emerge(_, c_e_list) ->
+	List.iter (fun (_, e) -> collect_exp nodes env e) c_e_list
+    | Eifthenelse(e1, e2, e3) ->
+	collect_exp nodes env e1;
+	collect_exp nodes env e2;
+	collect_exp nodes env e3
+    | Ewhen(e, _, _) | Efby(_, e) | Efield(e, _) | Erepeat (_,e) 
+    | Eselect (_,e) | Eselect_slice (_ , _, e) ->
+	collect_exp nodes env e
+    | Etuple e_list | Earray e_list 
+    | Eop(_, _, e_list)  ->
+	List.iter (collect_exp nodes env) e_list
+    | Evar _ | Econstvar _ | Econst _  | Ereset_mem _ -> ()
+    | Estruct(f_e_list) ->
+	List.iter (fun (_, e) -> collect_exp nodes env e) f_e_list
+    | Eselect_dyn (e_list, _, e1, e2) -> 
+	List.iter (collect_exp nodes env) e_list;
+	collect_exp nodes env e1;
+	collect_exp nodes env e2    
+    | Eupdate (_, e1, e2) | Econcat (e1, e2) | Efield_update(_, e1, e2) ->
+	collect_exp nodes env e1;
+	collect_exp nodes env e2
+    (* Do the real work: call node *)
+    | Eevery(ln, params, e_list, _) 
+    | Eapp(ln, params, e_list) -> 
+	List.iter (collect_exp nodes env) e_list;
+	let params = List.map (int_of_size_exp env) params in 
+	  (match params with
+	     | [] -> ()
+	     | params -> 
+		 let n = node_by_name (shortname ln.a_op) nodes in
+		   node_call nodes n params
+	  )
+    | Eiterator (_, ln, params, _, e_list, _) ->
+	List.iter (collect_exp nodes env) e_list;
+	let params = List.map (int_of_size_exp env) params in 
+	  (match params with
+	     | [] -> ()
+	     | params -> 
+		 let n = node_by_name (shortname ln) nodes in
+		   node_call nodes n params
+	  )
+	    
+and collect_eqs nodes env eq = 
+  collect_exp nodes env eq.p_rhs
+
+and node_call nodes n params =
+  match params with
+    | [] -> 
+	List.iter (collect_eqs nodes !global_env) n.n_equs
+    | params ->
+	add_node_params n.n_name params;
+	let env = build !global_env n.n_params params in
+	  List.iter (collect_eqs nodes env) n.n_equs
+
+let node n =
+  let inst = 
+    if NamesEnv.mem n.n_name !nodes_instances then 
+      NamesEnv.find n.n_name !nodes_instances
+    else
+      [] in
+    { n with n_params_instances = inst }
+
+let build_const_env cd_list =
+  List.fold_left (fun env cd -> NamesEnv.add cd.Minils.c_name cd.Minils.c_value env) NamesEnv.empty cd_list
+
+let program p =
+  let try_call_node n =
+    match n.n_params with
+      | [] -> node_call p.p_nodes n []
+      | _ -> ()
+  in
+    global_env := build_const_env p.p_consts;
+    List.iter try_call_node p.p_nodes;
+    { p with p_nodes = List.map node p.p_nodes }
+	  

minils/transformations/clocking.ml

@@ -0,0 +1,295 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  MiniLustre                                                            *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* clock checking *)
+
+(* $Id$ *)
+
+open Misc
+open Ident
+open Minils
+open Global
+open Location
+
+type error = | Etypeclash of ct * ct
+
+exception TypingError of error
+exception Unify
+
+let error kind = raise (TypingError(kind))
+
+let message e kind =
+  begin match kind with
+      Etypeclash(actual_ct, expected_ct) ->
+	Printf.eprintf "%aClock Clash: this expression has clock %a, \n\
+                  but is expected to have clock %a.\n" 
+	  Printer.print_exp e
+	  Printer.print_clock actual_ct
+	  Printer.print_clock expected_ct
+  end;
+  raise Error
+    
+let index = ref 0
+let gen_index () = incr index; !index
+let new_var () = Cvar { contents = Cindex (gen_index ()) }
+
+let rec repr ck =
+  match ck with
+      Cbase | Con _ | Cvar { contents = Cindex _ } -> ck
+    | Cvar ({ contents = Clink(ck) } as link) ->
+	let ck = repr ck in
+	link.contents <- Clink(ck);
+	ck
+  
+let rec occur_check index ck =
+  let ck = repr ck in
+    match ck with
+      Cbase -> ()
+    | Cvar { contents = Cindex n } when index <> n -> ()
+    | Con(ck, _, _) -> occur_check index ck
+    | _ -> raise Unify
+
+let rec ck_value ck =
+  match ck with
+    | Cbase | Con _ | Cvar { contents = Cindex _ } -> ck
+    | Cvar { contents = Clink(ck) } ->
+	ck_value ck
+
+let rec unify t1 t2 =
+  if t1 == t2 then ()
+  else match t1, t2 with
+      Ck(ck1), Ck(ck2) -> unify_ck ck1 ck2
+    | Cprod(ct_list1), Cprod(ct_list2) ->
+	begin try
+	  List.iter2 unify ct_list1 ct_list2
+	with
+	    _ -> raise Unify
+	end
+    | _ -> raise Unify
+
+and unify_ck ck1 ck2 =
+  let ck1 = repr ck1 in
+  let ck2 = repr ck2 in
+  if ck1 == ck2 then ()
+  else match ck1, ck2 with
+      Cbase, Cbase -> ()
+    | Cvar { contents = Cindex n1 }, Cvar { contents = Cindex n2 } 
+	when n1 = n2 -> ()
+    | Cvar ({ contents = Cindex n1 } as v), _ ->
+	occur_check n1 ck2;
+	v.contents <- Clink(ck2)
+    | _, Cvar ({contents = Cindex n2 } as v) ->
+	occur_check n2 ck1;
+	v.contents <- Clink(ck1)
+    | Con(ck1, c1, n1), Con(ck2, c2, n2) when (c1 = c2) & (n1 = n2) ->
+	unify_ck ck1 ck2
+    | _ -> raise Unify
+    
+let rec eq ck1 ck2 =
+  match repr ck1, repr ck2 with
+    | Cbase, Cbase -> true
+    | Cvar { contents = Cindex n1 }, Cvar { contents = Cindex n2 } -> true
+    | Con(ck1, _, n1), Con(ck2, _, n2) when (n1 = n2) -> eq ck1 ck2
+    | _ -> false
+	
+let rec unify t1 t2 =
+  match t1, t2 with
+      Ck(ck1), Ck(ck2) -> unify_ck ck1 ck2
+    | Cprod(t1_list), Cprod(t2_list) -> unify_list t1_list t2_list
+    | _ -> raise Unify
+
+and unify_list t1_list t2_list =
+  try
+    List.iter2 unify t1_list t2_list
+  with
+      _ -> raise Unify
+	
+let rec skeleton ck = function
+  | Tprod(ty_list) -> Cprod(List.map (skeleton ck) ty_list)
+  | Tbase _ -> Ck(ck)
+
+let ckofct = function
+  | Ck(ck) -> repr ck
+  | Cprod(ct_list) -> Cbase
+
+let prod = function
+  | [] -> assert false
+  | [ty] -> ty
+  | ty_list -> Tprod(ty_list)
+	
+let typ_of_name h x = Env.find x h
+
+let rec typing h e =
+  let ct = match e.e_desc with
+    | Econst _ | Econstvar _ -> Ck(new_var ())
+    | Evar(x) -> Ck(typ_of_name h x)
+    | Efby(c, e) -> typing h e
+    | Etuple(e_list) ->
+	Cprod(List.map (typing h) e_list)
+    | Eop(_,_, e_list) ->
+	let ck = new_var () in
+	  List.iter (expect h (Ck(ck))) e_list;
+	  skeleton ck e.e_ty
+    | Eapp(_,_, e_list) ->
+	let ck_r = new_var () in
+	List.iter (expect h (Ck(ck_r))) e_list;
+	skeleton ck_r e.e_ty
+    | Eevery(_,_, e_list, n) ->
+	let ck_r = typ_of_name h n in
+	List.iter (expect h (Ck(ck_r))) e_list;
+	skeleton ck_r 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
+    | Eifthenelse(e1, e2, e3) ->
+	let ck = new_var () in
+	let ct = skeleton  ck e.e_ty in
+	expect h (Ck(ck)) e1;
+	expect h ct e2;
+	expect h ct e3; ct
+    | Emerge(n, c_e_list) ->
+	let ck_c = typ_of_name h n in
+	typing_c_e_list h ck_c n c_e_list;
+	skeleton ck_c e.e_ty
+    | Efield(e1,n) ->
+	let ck = new_var () in
+	let ct = skeleton ck e1.e_ty in
+	expect h (Ck(ck)) e1;
+	ct
+    | Estruct(l) ->
+	let ck = new_var () in
+	List.iter
+	  (fun (n,e) ->
+	     let ct = skeleton ck e.e_ty in
+	     expect h ct e)
+	  l;
+	Ck(ck)
+  (*Array operators*)
+    | Earray e_list ->
+	let ck = new_var () in
+	  List.iter (expect h (Ck(ck))) e_list;
+	  skeleton ck e.e_ty
+    | Erepeat (_,e) -> 
+	typing h e
+    | Eselect (_,e) -> 
+	typing h e
+    | Eselect_dyn (e_list, _, e, defe) -> 
+	let ck = new_var () in
+	let ct = skeleton  ck e.e_ty in
+	expect h ct e;
+	List.iter (expect h ct) e_list;
+	ct
+    | Eupdate (_, e1, e2) | Efield_update (_, e1, e2) ->
+	let ck = new_var () in
+	let ct = skeleton ck e.e_ty in
+	expect h (Ck(ck)) e1;
+	expect h ct e2; 
+	ct
+    | Eselect_slice (_ , _, e) -> 
+	typing h e
+    | Econcat (e1, e2) ->
+	let ck = new_var () in
+	let ct = skeleton ck e.e_ty in
+	expect h (Ck(ck)) e1;
+	expect h ct e2; 
+	ct
+    | Eiterator (_, f, _, _, e_list, _) ->  
+	let ck_r = new_var () in
+	  List.iter (expect h (Ck(ck_r))) e_list;
+	  skeleton ck_r e.e_ty
+    | Ereset_mem (_, _, x) -> assert false
+  in
+  e.e_ck <- ckofct ct;
+  ct      
+
+and expect h expected_ty e =
+  let actual_ty = typing h e in
+    try unify actual_ty expected_ty
+    with Unify -> message e (Etypeclash(actual_ty, expected_ty))
+  
+and typing_c_e_list h ck_c n c_e_list =
+  let rec typrec = function
+    | [] -> ()
+    | (c, e) :: c_e_list ->
+         expect h (skeleton (Con(ck_c, c, n)) e.e_ty) e;
+         typrec c_e_list in
+    typrec c_e_list
+
+let rec typing_pat h = function
+  | Evarpat(x) -> Ck(typ_of_name h x)
+  | Etuplepat(pat_list) -> Cprod(List.map (typing_pat h) pat_list)
+
+let typing_eqs h eq_list =
+  List.iter 
+    (fun { p_lhs = pat; p_rhs = e } ->
+       (match e.e_desc with
+	  | Ereset_mem (_, _, x) -> 
+	      let ck = typ_of_name h x in
+		e.e_ck <- ck;
+	  | _ -> 
+	      let ty_pat = typing_pat h pat in
+		try
+		  expect h ty_pat e
+		with Error ->
+		  (* DEBUG *)
+		  Printf.eprintf "Complete expression: %a\n"
+		    Printer.print_exp e;
+		  Printf.eprintf "Clock pattern: %a\n"
+		    Printer.print_clock ty_pat;
+		  raise Error
+       )
+    ) eq_list
+    
+let build h dec =
+  List.fold_left (fun h { v_name = n } -> Env.add n (new_var ()) h) h dec    
+
+let sbuild h dec base =
+  List.fold_left (fun h { v_name = n } -> Env.add n base h) h dec    
+
+let typing_contract h contract base =
+  match contract with
+    | None -> h
+    | Some { c_local = l_list;
+	     c_eq = eq_list;
+	     c_assume = e_a;
+	     c_enforce = e_g;
+	     c_controllables = c_list } ->
+	let h = sbuild h c_list base in
+	let h' = build h l_list in
+	typing_eqs h' eq_list;
+	(* assumption *)
+	expect h' (Ck base) e_a;
+	(* property *)
+	expect h' (Ck base) e_g;
+	h
+
+let typing_node ({ n_name = f; n_input = i_list; n_output = o_list;
+		  n_contract = contract;
+		  n_local = l_list; n_equs = eq_list } as node) =
+  let base = Cbase in
+  let h = sbuild Env.empty i_list base in
+  let h = sbuild h o_list base in
+  
+  let h = typing_contract h contract base in
+
+  let h = build h l_list in
+    typing_eqs h eq_list;
+    
+    (*update clock info in variables descriptions *)
+    let set_clock vd = 
+      { vd with v_clock = ck_value (Env.find vd.v_name h) } in 
+      
+      { node with n_input = List.map set_clock i_list;
+	  n_output = List.map set_clock o_list;
+	  n_local = List.map set_clock l_list; }
+    
+
+let program ({ p_nodes = p_node_list } as p) =
+ { p with p_nodes = List.map typing_node p_node_list }

minils/transformations/init.ml

@@ -0,0 +1,314 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* simple initialization analysis. This is almost trivial since   *)
+(* input/outputs of a node are forced to be initialized           *)
+(* add a special treatment of clock state variables whose initial *)
+(* values are known. This allows to accept code generated         *)
+(* for automata *)
+(* if [clock c = C fby ec] then [merge c (C -> e) ...] is initialized *)
+(* if [e] is initialized only *)
+
+(* $Id: init.ml 615 2009-11-20 17:43:14Z pouzet $ *)
+
+open Misc
+open Names
+open Ident
+open Minils
+open Location
+open Format
+
+type typ =
+    | Iproduct of typ list
+    | Ileaf of init
+	
+and init =
+    { mutable i_desc: init_desc;
+      mutable i_index: int }
+      
+and init_desc =
+    | Izero
+    | Ione
+    | Ivar
+    | Imax of init * init
+    | Ilink of init
+
+type typ_env =
+    { t_init: init; (* its initialisation type *)
+      t_value: longname option; (* its initial value *)
+    }
+
+(* typing errors *)
+exception Unify
+
+let index = ref 0
+let gen_index () = incr index; !index
+let new_var () = { i_desc = Ivar; i_index = gen_index () }
+let izero = { i_desc = Izero; i_index = gen_index () }
+let ione = { i_desc = Ione; i_index = gen_index () }
+let imax i1 i2 = { i_desc = Imax(i1, i2); i_index = gen_index () }
+let product l = Iproduct(l)
+let leaf i = Ileaf(i)
+
+(* basic operation on initialization values *)
+let rec irepr i =
+  match i.i_desc with
+    | Ilink(i_son) ->
+        let i_son = irepr i_son in
+        i.i_desc <- Ilink(i_son);
+        i_son
+    | _ -> i
+
+(** Simplification rules for max. Nothing fancy here *)
+let max i1 i2 =
+  let i1 = irepr i1 in
+  let i2 = irepr i2 in
+  match i1.i_desc, i2.i_desc with
+    | (Izero, Izero) -> izero
+    | (Izero, _) -> i2
+    | (_, Izero) -> i1
+    | (_, Ione) | (Ione, _) -> ione
+    | _ -> imax i1 i2
+
+let rec itype = function
+  | Iproduct(ty_list) -> itype_list ty_list
+  | Ileaf(i) -> i
+
+and itype_list ty_list =
+  List.fold_left (fun acc ty -> max acc (itype ty)) izero ty_list
+
+(* saturate an initialization type. Every element must be initialized *)
+let rec initialized i =
+  let i = irepr i in
+  match i.i_desc with
+    | Izero -> ()
+    | Ivar -> i.i_desc <- Ilink(izero)
+    | Imax(i1, i2) -> initialized i1; initialized i2
+    | Ilink(i) -> initialized i
+    | Ione -> raise Unify
+
+(* build an initialization type from a type *)
+let rec skeleton i ty =
+  match ty with
+    | Tbase _ -> leaf i
+    | Tprod(ty_list) -> product (List.map (skeleton i) ty_list)
+
+(* sub-typing *)
+let rec less left_ty right_ty =
+  if left_ty == right_ty then ()
+  else
+    match left_ty, right_ty with
+      | Iproduct(l1), Iproduct(l2) -> List.iter2 less l1 l2
+      | Ileaf(i1), Ileaf(i2) -> iless i1 i2
+      | _ -> raise Unify
+
+and iless left_i right_i =
+  if left_i == right_i then ()
+  else
+    let left_i = irepr left_i in
+    let right_i = irepr right_i in
+    if left_i == right_i then ()
+    else
+      match left_i.i_desc, right_i.i_desc with
+        | (Izero, _) | (_, Ione) -> ()
+	| _, Izero -> initialized left_i
+	| Imax(i1, i2), _ ->
+	    iless i1 right_i; iless i2 right_i
+	| _, Ivar ->
+	    let left_i = occur_check right_i.i_index left_i in
+	    right_i.i_desc <- Ilink(left_i)
+	| _, Imax(i1, i2) ->
+	    let i1 = occur_check left_i.i_index i1 in
+	    let i2 = occur_check left_i.i_index i2 in
+	    right_i.i_desc <- Ilink(imax left_i (imax i1 i2))
+	| _ -> raise Unify
+
+(* an inequation [a < t[a]] becomes [a = t[0]] *)
+and occur_check index i =
+  match i.i_desc with
+    | Izero | Ione -> i
+    | Ivar -> if i.i_index = index then izero else i
+    | Imax(i1, i2) -> 
+	max (occur_check index i1) (occur_check index i2)
+    | Ilink(i) -> occur_check index i
+
+(* computes the initialization type of a merge *)
+let merge opt_c c_i_list =
+  let rec search c c_i_list =
+    match c_i_list with
+      | [] -> izero
+      | (c0, i) :: c_i_list -> if c = c0 then i else search c c_i_list in
+  match opt_c with
+    | None -> List.fold_left (fun acc (_, i) -> max acc i) izero c_i_list
+    | Some(c) -> search c c_i_list
+ 
+module Printer = struct
+  open Format
+
+  let rec print_list_r print po sep pf ff = function
+  | [] -> ()
+  | x :: l ->
+      fprintf ff "@[%s%a" po print x;
+      List.iter (fprintf ff "%s@]@ @[%a" sep print) l;
+      fprintf ff "%s@]" pf
+
+  let rec fprint_init ff i = match i.i_desc with
+    | Izero -> fprintf ff "0"
+    | Ione -> fprintf ff "1"
+    | Ivar -> fprintf ff "0"
+    | Imax(i1, i2) -> fprintf ff "@[%a\\/%a@]" fprint_init i1 fprint_init i2
+    | Ilink(i) -> fprint_init ff i
+
+  let rec fprint_typ ff = function
+    | Ileaf(i) -> fprint_init ff i
+    | Iproduct(ty_list) ->
+        fprintf ff "@[%a@]" (print_list_r fprint_typ "("" *"")") ty_list
+
+  let output_typ oc ty =
+    let ff = formatter_of_out_channel oc in
+    fprintf ff "@[";
+    fprint_typ ff ty;
+    fprintf ff "@?@]"
+end
+
+module Error = struct
+  open Location
+
+  type error = | Eclash of typ * typ
+
+  exception Error of location * error
+
+  let error loc kind = raise (Error(loc, kind))
+
+  let message loc kind =
+    begin match kind with
+        | Eclash(left_ty, right_ty) ->
+            Printf.eprintf "%aInitialization error: this expression has type \
+              %a, \n\
+              but is expected to have type %a\n"
+              output_location loc
+              Printer.output_typ left_ty
+              Printer.output_typ right_ty
+    end;
+    raise Misc.Error
+end
+
+let less_exp e actual_ty expected_ty =
+  try
+    less actual_ty expected_ty
+  with | Unify -> Error.message e.e_loc (Error.Eclash(actual_ty, expected_ty))
+  
+let rec typing h e =
+  match e.e_desc with
+    | Econst(c) -> leaf izero
+    | Evar(x) -> let { t_init = i } = Env.find x h in leaf i
+    | Efby(None, e) -> 
+	expect h e (skeleton izero e.e_ty); 
+	leaf ione
+    | Efby(Some _, e) -> 
+	expect h e (skeleton izero e.e_ty); 
+	leaf izero
+    | Etuple(e_list) ->
+	product (List.map (typing h) e_list)
+    | Eop(_, e_list) ->
+	let i = List.fold_left (fun acc e -> itype (typing h e)) izero e_list in
+	skeleton i e.e_ty
+    | Eapp(_, e_list) ->
+	List.iter (fun e -> expect h e (skeleton izero e.e_ty)) e_list;
+	skeleton izero e.e_ty
+    | Eevery(_, e_list, n) ->
+	List.iter (fun e -> expect h e (skeleton izero e.e_ty)) e_list;
+	let { t_init = i } = Env.find n h in
+	skeleton i e.e_ty
+    | Ewhen(e, c, n) ->
+	let { t_init = i1 } = Env.find n h in
+	let i2 = itype (typing h e) in
+	skeleton (max i1 i2) e.e_ty
+    | Eifthenelse(e1, e2, e3) ->
+	let i1 = itype (typing h e1) in
+	let i2 = itype (typing h e2) in
+	let i3 = itype (typing h e3) in
+	let i = max i1 (max i2 i3) in
+	skeleton i e.e_ty
+    | Emerge(n, c_e_list) ->
+	let { t_init = i; t_value = opt_c } = Env.find n h in
+        let i =
+	  merge opt_c 
+	    (List.map (fun (c, e) -> (c, itype (typing h e))) c_e_list)	in
+	skeleton i e.e_ty
+    | Efield(e1,n) ->
+	let i = itype (typing h e1) in
+	skeleton i e.e_ty
+    | Estruct(l) ->
+	let i =
+	  List.fold_left
+	    (fun acc (_, e) -> max acc (itype (typing h e))) izero l in
+	skeleton i e.e_ty
+
+and expect h e expected_ty =
+  let actual_ty = typing h e in
+  less_exp e actual_ty expected_ty
+
+let rec typing_pat h = function
+  | Evarpat(x) -> let { t_init = i } = Env.find x h in leaf i
+  | Etuplepat(pat_list) ->
+      product (List.map (typing_pat h) pat_list)
+
+let typing_eqs h eq_list =
+  List.iter 
+    (fun { p_lhs = pat; p_rhs = e } ->
+      let ty_pat = typing_pat h pat in
+      expect h e ty_pat) eq_list
+
+let build h eq_list =
+  let rec build_pat h = function
+    | Evarpat(x) -> Env.add x { t_init = new_var (); t_value = None } h
+    | Etuplepat(pat_list) -> List.fold_left build_pat h pat_list in
+  let build_equation h { p_lhs = pat; p_rhs = e } =
+    match pat, e.e_desc with
+      | Evarpat(x), Efby(Some(Cconstr c), _) -> 
+	  (* we keep the initial value of state variables *)
+	  Env.add x { t_init = new_var (); t_value = Some(c) } h 
+      | _ -> build_pat h pat in
+ List.fold_left build_equation h eq_list
+
+let sbuild h dec =
+  List.fold_left 
+    (fun h { v_name = n } -> Env.add n { t_init = izero; t_value = None } h)
+    h dec    
+
+let typing_contract h contract =
+  match contract with
+    | None -> h
+    | Some { c_local = l_list; c_eq = eq_list; c_assume = e_a; 
+	     c_enforce = e_g; c_controllables = c_list } ->
+	let h = sbuild h c_list in
+	let h' = build h eq_list in
+	typing_eqs h' eq_list;
+	(* assumption *)
+	expect h' e_a (skeleton izero e_a.e_ty);
+	(* property *)
+	expect h' e_g (skeleton izero e_g.e_ty);
+	h
+
+let typing_node { n_name = f; n_input = i_list; n_output = o_list;
+		  n_contract = contract;
+		  n_local = l_list; n_equs = eq_list } =
+  let h = sbuild Env.empty i_list in
+  let h = sbuild h o_list in
+  let h = typing_contract h contract in
+
+  let h = build h eq_list in
+  typing_eqs h eq_list
+
+let program ({ p_nodes = p_node_list } as p) =
+  List.iter typing_node p_node_list;
+  p
+
+

minils/transformations/normalize.ml

@@ -0,0 +1,261 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* $Id$ *)
+
+open Misc
+open Names
+open Ident
+open Global
+open Minils
+
+let ctrue = Name("true")
+and cfalse = Name("false")
+
+let equation (d_list, eq_list) ({ e_ty = te; e_linearity = l; e_ck = ck } as e) =
+  let n = Ident.fresh "_v" in
+  let d_list = { v_name = n; v_copy_of = None;
+		 v_type = base_type te; v_linearity = l; v_clock = ck } :: d_list
+  and eq_list = { p_lhs = Evarpat(n); p_rhs = e } :: eq_list in
+  (d_list, eq_list), n
+
+let intro context e =
+  match e.e_desc with
+      Evar(n) -> context, n
+    | _ -> equation context e
+
+(* distribution: [(e1,...,ek) when C(n) = (e1 when C(n),...,ek when C(n))] *)
+let rec whenc context e c n =
+  let when_on_c c n e =
+    { e with e_desc = Ewhen(e, c, n); e_ck = Con(e.e_ck, c, n) } in
+
+  match e.e_desc with
+    | Etuple(e_list) ->
+        let context, e_list =
+          List.fold_right
+            (fun e (context, e_list) -> let context, e = whenc context e c n in
+             (context, e :: e_list))
+            e_list (context, []) in
+        context, { e with e_desc = Etuple(e_list); e_ck = Con(e.e_ck, c, n) }
+    (* | Emerge _ -> let context, x = equation context e in
+      context, when_on_c c n { e with e_desc = Evar(x) } *)
+    | _ -> context, when_on_c c n e
+
+(* transforms [merge x (c1, (e11,...,e1n));...;(ck, (ek1,...,ekn))] into *)
+(* [merge x (c1, e11)...(ck, ek1),..., merge x (c1, e1n)...(ck, ekn)]    *)
+let rec merge e x ci_a_list =
+  let rec split ci_tas_list =
+    match ci_tas_list with
+      | [] | (_, _, []) :: _ -> [], []
+      | (ci, b, a :: tas) :: ci_tas_list ->
+          let ci_ta_list, ci_tas_list = split ci_tas_list in
+          (ci, a) :: ci_ta_list, (ci, b, tas) :: ci_tas_list in
+  let rec distribute ci_tas_list =
+    match ci_tas_list with
+      | [] | (_, _, []) :: _ -> []
+      | (ci, b, (eo :: _)) :: _ ->
+          let ci_ta_list, ci_tas_list = split ci_tas_list in
+          let ci_tas_list = distribute ci_tas_list in
+          (if b then
+             { eo with e_desc = Emerge(x, ci_ta_list);
+                 e_ck = e.e_ck; e_loc = e.e_loc }
+           else
+             merge e x ci_ta_list)
+          :: ci_tas_list in
+  let rec erasetuple ci_a_list =
+    match ci_a_list with
+      | [] -> []
+      | (ci, { e_desc = Etuple(l) }) :: ci_a_list ->
+          (ci, false, l) :: erasetuple ci_a_list
+      | (ci, e) :: ci_a_list ->
+          (ci, true, [e]) :: erasetuple ci_a_list in
+  let ci_tas_list = erasetuple ci_a_list in
+  let ci_tas_list = distribute ci_tas_list in
+  match ci_tas_list with
+    | [e] -> e
+    | l -> { e with e_desc = Etuple(l) }
+
+let ifthenelse context e1 e2 e3 =
+  let context, n = intro context e1 in
+  let context, e2 = whenc context e2 ctrue n in
+  let context, e3 = whenc context e3 cfalse n in
+  context, merge e1 n [ctrue, e2; cfalse, e3]
+
+let const e c =
+  let rec const = function
+    | Cbase | Cvar { contents = Cindex _ } -> c
+    | Con(ck_on, tag, x) ->
+        Ewhen({ e with e_desc = const ck_on; e_ck = ck_on }, tag, x)
+    | Cvar { contents = Clink ck } -> const ck in
+  const e.e_ck
+
+(* 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     *)
+(* - A-normal form: (e1,...,en) when c(x) = (e1 when c(x),...,en when c(x) *)
+type kind = VRefCond | VRef | Exp | Act | Any
+
+let function_args_kind = if !no_mem_alloc then Exp else VRefCond
+let merge_kind = if !no_mem_alloc then Act else VRef
+
+let rec constant e = match e.e_desc with
+  | Econst _ | Econstvar _ -> true
+  | Ewhen(e, _, _) -> constant e
+  | Evar _ -> true
+  | _ -> false
+
+let add context expected_kind ({ e_desc = de; e_linearity = l } as e) =
+  let up = match de, expected_kind with
+    | (Evar _ | Efield _ ) , VRefCond -> false
+    | Efby _, VRefCond -> true
+    | _ , VRefCond -> not (Linearity.is_not_linear l)
+    | (Evar _ | Efield _ ) , VRef -> false
+    | _ , VRef -> true
+    | ( Emerge _ | Etuple _
+      | Eapp _   | Eevery _ | Efby _ | Eselect_dyn _
+      | Eupdate _ | Econcat _ | Erepeat _ | Eiterator _
+      | Eselect_slice _ ), Exp -> true
+    | ( Eapp _ | Eevery _ | Efby _ ), Act -> true
+    | _ -> false in
+  if up then
+    let context, n = equation context e in
+    context, { e with e_desc = Evar(n) }
+  else context, e
+
+let rec translate kind context e =
+  let context, e = match e.e_desc with
+    | Emerge(n, tag_e_list) ->
+        let context, ta_list =
+          List.fold_right
+            (fun (tag, e) (context, ta_list) ->
+               let context, act = translate merge_kind context e in
+               context, ((tag, act) :: ta_list))
+            tag_e_list (context, []) in
+        context, merge e n ta_list
+    | Eifthenelse(e1, e2, e3) ->
+        let context, e1 = translate Any context e1 in
+        let context, e2 = translate Act context e2 in
+        let context, e3 = translate Act context e3 in
+        ifthenelse context e1 e2 e3
+    | Etuple(e_list) ->
+        let context, e_list = translate_list kind context e_list in
+        context, { e with e_desc = Etuple(e_list) }
+    | Ewhen(e1, c, n) ->
+        let context, e1 = translate kind context e1 in
+        whenc context e1 c n
+    | Eop(op, params, e_list) ->
+        let context, e_list = translate_list function_args_kind context e_list in
+        context, { e with e_desc = Eop(op, params, e_list) }
+    | Eapp(app, params, e_list) ->
+        let context, e_list = translate_list function_args_kind context e_list in
+        context, { e with e_desc = Eapp(app, params, e_list) }
+    | Eevery(app, params, e_list, n) ->
+        let context, e_list = translate_list function_args_kind context e_list in
+        context, { e with e_desc = Eevery(app, params, e_list, n) }
+    | Efby(v, e1) ->
+        let context, e1 = translate Exp context e1 in
+        let context, e1' =
+	  if constant e1 then context, e1 
+	  else let context, n = equation context e1 in
+	       context, { e1 with e_desc = Evar(n) } in
+        context, { e with e_desc = Efby(v, e1') }
+    | Ereset_mem (_, _, _) -> context, e
+    | Evar _ -> context, e
+    | Econst(c) -> context, { e with e_desc = const e (Econst c) }
+    | Econstvar x -> context, { e with e_desc = const e (Econstvar x) }
+    | Efield(e', field) ->
+        let context, e' = translate Exp context e' in
+        context, { e with e_desc = Efield(e', field) }
+    | Estruct(l) ->
+        let context, l =
+          List.fold_right
+            (fun (field, e) (context, field_desc_list) ->
+               let context, e = translate Exp context e in
+               context, ((field, e) :: field_desc_list))
+            l (context, []) in
+        context, { e with e_desc = Estruct(l) }
+(*Array operators*)
+    | Earray(e_list) -> 
+	let context, e_list = translate_list kind context e_list in
+	  context, { e with e_desc = Earray(e_list) }
+    | Erepeat (n,e') ->
+	let context, e' = translate VRef context e' in
+          context, { e with e_desc = Erepeat(n, e') }
+    | Eselect (idx,e') -> 
+	let context, e' = translate VRef context e' in
+          context, { e with e_desc = Eselect(idx, e') }
+    | Eselect_dyn (idx, bounds, e1, e2) ->
+	let context, e1 = translate VRef context e1 in
+	let context, idx = translate_list Exp context idx in
+	let context, e2 = translate Exp context e2 in  
+          context, { e with e_desc = Eselect_dyn(idx, bounds, e1, e2) }
+    | Eupdate (idx, e1, e2)  ->
+	let context, e1 = translate VRef context e1 in
+	let context, e2 = translate Exp context e2 in  
+          context, { e with e_desc = Eupdate(idx, e1, e2) }
+    | Eselect_slice (idx1, idx2, e') ->
+	let context, e' = translate VRef context e' in
+          context, { e with e_desc = Eselect_slice(idx1, idx2, e') }
+    | Econcat (e1, e2) -> 
+	let context, e1 = translate VRef context e1 in
+	let context, e2 = translate VRef context e2 in  
+          context, { e with e_desc = Econcat(e1, e2) }	
+    | Eiterator (it, f, params, n, e_list, reset) ->
+	let context, e_list = translate_list function_args_kind context e_list in
+	  context, { e with e_desc = Eiterator(it, f, params, n, e_list, reset) }
+    | Efield_update (f, e1, e2) ->
+	let context, e1 = translate VRef context e1 in
+	let context, e2 = translate Exp context e2 in  
+          context, { e with e_desc = Efield_update(f, e1, e2) }	
+  in add context kind e
+
+and translate_list kind context e_list =
+  match e_list with
+      [] -> context, []
+    | e :: e_list ->
+        let context, e = translate kind context e in
+        let context, e_list = translate_list kind context e_list in
+        context, e :: e_list
+
+let rec translate_eq context pat e =
+  (* applies distribution rules *)
+  (* [x = v fby e] should verifies that x is local *)
+  (* [(p1,...,pn) = (e1,...,en)] into [p1 = e1;...;pn = en] *)
+  let rec distribute ((d_list, eq_list) as context) pat e =
+    match pat, e.e_desc with
+      | Evarpat(x), Efby _ when not (vd_mem x d_list) ->
+          let (d_list, eq_list), n = equation context e in
+          d_list,
+          { p_lhs = pat; p_rhs = { e with e_desc = Evar(n) } } :: eq_list
+      | Etuplepat(pat_list), Etuple(e_list) ->
+          List.fold_left2 distribute context pat_list e_list
+      | _ -> d_list, { p_lhs = pat; p_rhs = e } :: eq_list in
+
+  let context, e = translate Any context e in
+  distribute context pat e
+
+let translate_eq_list d_list eq_list =
+  List.fold_left
+    (fun context { p_lhs = pat; p_rhs = e } -> translate_eq context pat e)
+    (d_list, []) eq_list
+
+let translate_contract ({ c_eq = eq_list; c_local = d_list } as c) =
+  let d_list,eq_list = translate_eq_list d_list eq_list in
+  { c with
+      c_local = d_list;
+      c_eq = eq_list }
+
+let translate_node ({ n_contract = contract;
+                      n_local = d_list; n_equs = eq_list } as node) =
+  let contract = optional translate_contract contract in
+  let d_list, eq_list = translate_eq_list d_list eq_list in
+  { node with n_contract = contract; n_local = d_list; n_equs = eq_list }
+
+let program ({ p_nodes = p_node_list } as p) =
+  { p with p_nodes = List.map translate_node p_node_list }

minils/transformations/schedule.ml

@@ -0,0 +1,86 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* scheduling of equations *)
+
+(* $Id$ *)
+
+open Misc
+open Minils
+open Graph
+open Dep
+
+(* possible overlapping between clocks *)
+let join ck1 ck2 =
+  let n1 = Vars.head ck1
+  and n2 = Vars.head ck2 in
+  (* C1(x1) on ... on Cn(xn) with C'1(x'1) on ... on C'k(x'k) *)
+  match n1, n2 with
+      [], [] -> true
+    | x1 ::_, x2 ::_ when x1 = x2 -> true
+    | _ -> false
+
+let join eq1 eq2 = join (Vars.clock eq1) (Vars.clock eq2)
+
+(* possible overlapping between nodes *)
+(*let head e =
+  match e with
+    | Emerge(_, c_e_list) -> List.fold (fun acc e -> Vars.head (clock e) :: acc)
+    | e -> [Vars.head (clock e)]
+
+(* e1 define a pieces of control structures with *)
+  (* paths on clock C1(x1) on ... on Cn(xn) ... *)
+  (* e1 can be merged if *)
+let n1_list = head e1 in
+  let n2_list = head e2 in
+*)
+
+  
+(* clever scheduling *)
+let schedule eq_list =
+  let rec recook = function
+    | [] -> []
+    | node :: node_list -> node >> (recook node_list)
+	  
+  and (>>) node node_list =
+    try
+      insert node node_list
+    with
+	Not_found -> node :: node_list
+	  
+  and insert node = function
+    | [] -> raise Not_found
+    | node1 :: node_list ->
+	if linked node node1 then raise Not_found
+	else
+	  try
+	    node1 :: (insert node node_list)
+	  with
+	    | Not_found ->
+		if join (containt node) (containt node1)
+	        then node :: node1 :: node_list
+		else raise Not_found in
+    
+  let node_list, _ = DataFlowDep.build eq_list in
+  let node_list = recook (topological node_list) in
+  let node_list = List.rev node_list in
+  let node_list = recook node_list in
+  let node_list = List.rev node_list in
+  List.map containt node_list
+
+let schedule_contract ({ c_eq = eqs } as c) =
+  let eqs = schedule eqs in
+  { c with c_eq = eqs }
+
+let node ({ n_contract = contract; n_equs = eq_list } as node) =
+  let contract = optional schedule_contract contract in 
+  let eq_list = schedule eq_list in
+  { node with n_equs = eq_list; n_contract = contract }
+
+let program ({ p_nodes = p_node_list } as p) =
+  { p with p_nodes = List.map node p_node_list }

myocamlbuild.ml

@@ -0,0 +1,26 @@
+open Ocamlbuild_plugin
+open Ocamlbuild_plugin.Options
+
+let sub_dirs = ["global"; "parsing"; "sigali"; "dataflow"; "sequential";
+                "analysis"; "translation"; "main"; "simulation"]
+
+let df = function
+  | Before_options ->
+      include_dirs := sub_dirs @ !include_dirs
+  | After_rules ->
+      (* Tell ocamlbuild about the camlp4 library. *)
+      ocaml_lib ~extern:true ~dir:"+camlp4" "camlp4";
+
+      (* Add preproc.cmo to the ocaml pre-processor when use_preproc is set *)
+      flag ["ocaml"; "pp"; "use_preproc"] (A "preproc.cmo");
+      (* Running ocamldep on ocaml code that is tagged with use_preproc will
+         require the cmo.  Note that you only need this declaration when the
+         syntax extension is part of the sources to be compiled with
+         ocamlbuild. *)
+      dep ["ocaml"; "ocamldep"; "use_preproc"] ["preproc.cmo"];
+
+      (* LablGTK use for graphical simulator *)
+      ocaml_lib ~extern:true ~dir:"+lablgtk2" "lablgtk"
+  | _ -> ()
+
+let _ = dispatch df

utilities/dep.ml

@@ -0,0 +1,80 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* dependences between equations *)
+(* $Id$ *)
+
+open Graph
+open Ident
+
+module type READ =
+sig
+  type equation
+  val read: equation -> ident list
+  val def: ident list -> equation -> ident list
+  val linear_read : equation -> ident list
+  val antidep: equation -> bool
+  val mem_reset : equation -> ident list
+end
+
+module Make (Read:READ) =
+struct
+  let build eqs =
+    (* associate a graph node for each name declaration *)
+    let rec nametograph g var_list is_antidep n_to_graph =
+      let add_node env x =
+	if Env.mem x env then
+	  let l = Env.find x env in
+	    Env.add x ((g, is_antidep)::l) env
+	else
+	  Env.add x [(g, is_antidep)] env
+      in
+	List.fold_left add_node n_to_graph var_list in
+
+    let rec nametograph_env g var_list node_env =
+      List.fold_left (fun env x -> Env.add x g env) node_env var_list in
+
+    let rec init_graph eqs g_list n_to_graph node_env =
+      match eqs with
+        | [] -> g_list, n_to_graph, node_env
+        | eq :: eqs ->
+            let g = make eq in
+            let node_env = nametograph_env g (Read.def [] eq) node_env in
+            let n_to_graph = nametograph g (Read.def [] eq) (Read.antidep eq) n_to_graph in
+	    let n_to_graph = nametograph g (Read.linear_read eq) true n_to_graph in
+	    let n_to_graph = nametograph g (Read.mem_reset eq) false n_to_graph in
+              init_graph eqs (g :: g_list) n_to_graph node_env
+    in
+
+    let rec make_graph g_list names_to_graph =
+      let attach_one node (g, is_antidep) =
+	if is_antidep then 
+	  add_depends g node
+	else
+	  add_depends node g
+      in
+
+      let attach node n =
+        try
+          let l = Env.find n names_to_graph in
+            List.iter (attach_one node) l
+        with
+          | Not_found -> () in
+
+      match g_list with
+        | [] -> ()
+        | node :: g_list ->
+            let names = Read.read (containt node) in
+              List.iter (attach node) names;
+              make_graph g_list names_to_graph in
+
+    let g_list, names_to_graph, node_env = init_graph eqs [] Env.empty Env.empty in
+    make_graph g_list names_to_graph;
+    g_list, node_env
+end
+

utilities/graph.ml

@@ -0,0 +1,143 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* graph manipulation *)
+(* $Id$ *)
+type 'a graph =
+  { g_top: 'a node list;
+    g_bot: 'a node list }
+
+and 'a node =
+    { g_containt: 'a;
+      g_tag: int;
+      mutable g_visited: bool;
+      mutable g_mark: int;
+      mutable g_depends_on: 'a node list;
+      mutable g_depends_by: 'a node list;
+    }
+
+exception Cycle of int (* returns the index of the node *)
+
+let tag = ref 0
+let new_tag () = incr tag; !tag
+let containt g = g.g_containt
+let linked g1 g2 =
+  (List.memq g2 g1.g_depends_on) or (List.memq g1 g2.g_depends_on)
+let make c =
+  { g_containt = c; g_tag = new_tag (); g_visited = false;
+    g_mark = -1; g_depends_on = []; g_depends_by = [] }
+let add_depends node1 node2 =
+  if not (node1.g_tag = node2.g_tag or linked node1 node2) then (
+    node1.g_depends_on <- node2 :: node1.g_depends_on;
+    node2.g_depends_by <- node1 :: node2.g_depends_by
+  )
+
+let remove_depends node1 node2 =
+  if not (node1.g_tag = node2.g_tag) then (
+    node1.g_depends_on <- List.filter (fun n -> n.g_tag <> node2.g_tag) node1.g_depends_on;
+    node2.g_depends_by <- List.filter (fun n -> n.g_tag <> node1.g_tag) node2.g_depends_by
+  )
+
+let graph top_list bot_list = { g_top = top_list; g_bot = bot_list }
+
+
+let topological g_list =
+  let rec sortrec g_list seq =
+    match g_list with
+    | [] -> seq
+    | g :: g_list ->
+        if g.g_visited then sortrec g_list seq
+        else
+          begin
+            g.g_visited <- true;
+            let seq = sortrec g.g_depends_on seq in
+            sortrec g_list (g :: seq)
+          end in
+  let seq = sortrec g_list [] in
+  List.iter
+    (fun ({ g_visited = _ } as node) -> node.g_visited <- false) g_list;
+  List.rev seq
+
+(** Detection of cycles *)
+(* Mark nodes with:
+   - -1 initially, for unvisited nodes
+   - 0 for "opened" nodes, currently visited, while visiting its descendents
+   - 1 for "closed" nodes, visited once, no circuits found from it.
+   A circuit is found when a node marked with 0 is visited again.
+*)
+
+let cycle g_list =
+  (* store nodes in a stack *)
+  let s = Stack.create () in
+  (* flush the connected component *)
+  let rec flush index =
+    if Stack.is_empty s then []
+    else let v = Stack.pop s in
+    v.g_containt :: flush v.g_tag in
+
+  let rec visit g =
+    match g.g_mark with
+      | -1 ->
+          (* Unvisited yet *)
+          (* Open node *)
+          Stack.push g s;
+          g.g_mark <- 0;
+          (* Visit descendents *)
+          List.iter visit g.g_depends_on;
+          (* Close node *)
+          ignore (Stack.pop s);
+          g.g_mark <- 1
+      | 0 ->
+          (* Visit an opened node (visited and not close) : circuit *)
+          raise (Cycle g.g_tag)
+      | 1 | _ ->
+          (* Visit a closed node (no existing circuit) : pass *)
+          () in
+  try
+    List.iter visit g_list; None
+  with
+    | Cycle(index) -> Some(flush index)
+
+(** [accessible useful_nodes g_list] returns the list of
+  accessible nodes starting from useful_nodes and belonging to
+  g_list. *)
+let accessible useful_nodes g_list =
+  let rec follow g =
+    if not g.g_visited then
+      begin
+        g.g_visited <- true;
+        List.iter follow g.g_depends_on
+      end in
+  let read acc g =
+    if g.g_visited then begin g.g_visited <- false; g :: acc end else acc in
+  List.iter follow useful_nodes;
+  List.fold_left read [] g_list
+
+(** [exists_path nodes n1 n2] returns whether there is a path
+  from n1 to n2 in the graph. nodes is the list of all the nodes
+  in the graph. *)
+let exists_path nodes n1 n2 =
+  List.mem n2 (accessible [n1] nodes)
+
+open Format
+
+let print_node print g =
+  printf "Node : @[<hov>";
+  print_int g.g_tag;
+  printf "@]";
+  printf "  Depends on :@\n";
+  printf "  @[<v>";
+  List.iter
+    (fun node ->
+       printf "@[<hov 2>";
+       print_int node.g_tag;
+       printf "@]@ ")
+    g.g_depends_on;
+  printf "@]"
+
+

utilities/misc.ml

@@ -0,0 +1,204 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+(* useful stuff *)
+(* $Id$ *)
+
+(* version of the compiler *)
+let version = "0.4"
+let interface_format_version = "5"
+let date = "DATE"
+
+(* standard module *)
+let pervasives_module = "Pervasives"
+let standard_lib = "STDLIB"
+let standard_lib = try Sys.getenv "HEPTLIB" with Not_found -> standard_lib
+
+(* list of modules initially opened *)
+let default_used_modules = ref [pervasives_module]
+let set_no_pervasives () = default_used_modules := []
+
+(* load paths *)
+let load_path = ref ([standard_lib])
+
+let set_stdlib p =
+  load_path := [p]
+and add_include d =
+  load_path := d :: !load_path;;
+
+(* where is the standard library *)
+let locate_stdlib () =
+  let stdlib = try
+    Sys.getenv "HEPTLIB"
+  with
+    Not_found -> standard_lib in
+  Printf.printf "Standard library in %s\n" stdlib
+
+let show_version () =
+  Printf.printf "The Heptagon compiler, version %s (%s)\n"
+    version date;
+  locate_stdlib ()
+
+(* other options of the compiler *)
+let verbose = ref false
+let print_types = ref false
+
+let simulation = ref false
+let simulation_node : string option ref = ref None
+let set_simulation_node s =
+  simulation := true;
+  simulation_node := Some s
+
+(* Target languages list for code generation *)
+let target_languages : string list ref = ref []
+
+let add_target_language s =
+  target_languages := s :: !target_languages
+
+(* Optional path for generated files (C or Java) *)
+let target_path : string option ref = ref None
+
+let set_target_path path =
+  target_path := Some path
+
+let full_type_info = ref false
+
+let boolean = ref false
+
+let deadcode = ref false
+
+let init = ref true
+
+let cse = ref false
+
+let tomato = ref false
+
+(* Backward compatibility *)
+let set_sigali () = add_target_language "z3z";;
+
+let intermediate = ref false
+
+let nodes_to_inline : string list ref = ref []
+
+let nodes_to_display : string list ref = ref []
+
+let node_to_flatten : string option ref = ref None
+
+let no_mem_alloc = ref false
+
+let use_interf_scheduler = ref false
+
+let use_new_reset_encoding = ref false
+
+let optional f = function
+  | None -> None
+  | Some x -> Some (f x)
+
+let optunit f = function
+  | None -> ()
+  | Some x -> f x
+
+(** [split_string s c] splits the string [s] in a list of sub-strings according
+    to separator [c]. *)
+let rec split_string s c =
+  try
+    let id = String.index s c in
+    let rest = String.sub s (id + 1) (String.length s - id - 1) in
+    String.sub s 0 id :: split_string rest c
+  with Not_found -> [s]
+
+(* error during the whole process *)
+exception Error
+
+(* creation of names. Ensure unicity for the whole compilation chain *)
+let symbol = ref 0
+
+let gen_symbol () = incr symbol; "_"^(string_of_int !symbol)
+let reset_symbol () = symbol := (*!min_symbol*) 0
+
+open Format
+open Unix
+
+let print_header_info ff cbeg cend =
+  let tm = Unix.localtime (Unix.time ()) in
+  fprintf ff "%s --- Generated the %d/%d/%d at %d:%d --- %s@\n"
+    cbeg tm.tm_mday (tm.tm_mon+1) (tm.tm_year + 1900) tm.tm_hour tm.tm_min cend;
+  fprintf ff "%s --- heptagon compiler, version %s (compiled %s) --- %s@\n"
+    cbeg version date cend;
+  fprintf ff "%s --- Command line: %a--- %s@\n@\n"
+    cbeg
+    (fun ff a ->
+       Array.iter (fun arg -> fprintf ff "%s " arg) a)
+    Sys.argv
+    cend
+
+let unique l =
+  let tbl = Hashtbl.create 10 in (* You could replace 10 with List.length l *)
+  List.iter (fun i -> Hashtbl.replace tbl i ()) l;
+  Hashtbl.fold (fun key data accu -> key :: accu) tbl []
+
+type iterator_name = 
+    Imap
+  | Ifold
+  | Imapfold
+
+let iterator_to_string i = 
+  match i with 
+    | Imap -> "map"
+    | Ifold -> "fold"
+    | Imapfold -> "mapfold"
+
+let rec incomplete_map f l =
+  match l with 
+    | [] -> []
+    | [a] -> [a]
+    | a::l -> (f a)::(incomplete_map f l)
+
+let rec last_element l =
+  match l with 
+    | [] -> assert false
+    | [v] -> v
+    | v::l -> last_element l
+
+(** [split_last l] returns l without its last element and
+    the last element of l. *)
+let rec split_last = function
+  | [] -> assert false
+  | [a] -> [], a
+  | v::l -> 
+      let l, a = split_last l in
+	v::l, a
+
+let remove x l =
+  List.filter (fun y -> x <> y) l
+
+let is_empty = function
+  | [] -> true
+  | _ -> false
+
+(** [repeat_list v n] returns a list with n times the value v. *)
+let repeat_list v n =
+  let rec aux = function
+    | 0 -> []
+    | n -> v::(aux (n-1))
+  in
+    aux n
+
+(** Same as List.mem_assoc but using the value instead of the key. *)
+let rec memd_assoc value = function
+  | [] -> false
+  | (k,d)::l -> (d = value) or (memd_assoc value l)
+
+(** Same as List.assoc but searching for a data and returning the key. *)
+let rec assocd value = function
+  | [] -> raise Not_found
+  | (k,d)::l -> 
+      if d = value then
+	k 
+      else
+	assocd value l

utilities/misc.mli

@@ -0,0 +1,158 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Heptagon                                                              *)
+(*                                                                        *)
+(*  Author : Marc Pouzet                                                  *)
+(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* $Id$ *)
+
+(* Version and date of compilation *)
+val version : string
+val interface_format_version: string
+val date : string
+
+(* List of modules initially opened *)
+val default_used_modules : string list ref
+
+(* Void the list of modules initially opened *)
+val set_no_pervasives : unit -> unit
+
+(* Path list to libraries *)
+val load_path : string list ref
+
+(* Set path to standard library *)
+val set_stdlib : string -> unit
+
+(* Add path to libraries *)
+val add_include : string -> unit
+
+(* Print the path to standard library *)
+val locate_stdlib : unit -> unit
+
+(* Print the compiler version and its compilation date *)
+val show_version : unit -> unit
+
+(* Verbose option *)
+val verbose : bool ref
+
+(* Print types option *)
+val print_types : bool ref
+
+(* Simulation mode *)
+val simulation : bool ref
+(* Simulated node *)
+val simulation_node : string option ref
+(* Set the simulation mode on *)
+val set_simulation_node : string -> unit
+
+(* List of target languages *)
+val target_languages : string list ref
+(* Add target language to the list *)
+val add_target_language : string -> unit
+
+(* Optional path for generated files (C or Java) *)
+val target_path : string option ref
+(* Set the optional target path *)
+val set_target_path : string -> unit
+
+(* Print full type information when pretty-printing MiniLS code. *)
+val full_type_info : bool ref
+
+(* Boolean transformation of enumerated types *)
+val boolean : bool ref
+
+(* Deadcode removal *)
+val deadcode : bool ref
+
+(* Initialization analysis (enabled by default) *)
+val init : bool ref
+
+(* Common sub-expression elimination *)
+val cse : bool ref
+
+(* Automata minimization *)
+val tomato : bool ref
+
+(* Z/3Z back-end mode *)
+val set_sigali : unit -> unit
+
+(* Intermediate-equations removal *)
+val intermediate : bool ref
+
+(* Nodes to be inlined *)
+val nodes_to_inline : string list ref
+
+(* Nodes which dependency graphics will be serialized to .dot file. *)
+val nodes_to_display : string list ref
+
+(* Node to flatten *)
+val node_to_flatten : string option ref
+
+(* Disable the memory allocation phase*)
+val no_mem_alloc : bool ref
+
+(* Whether to use the interference aware scheduler*)
+val use_interf_scheduler : bool ref
+
+(* Use the new encoding of resets using reset_mem. *)
+val use_new_reset_encoding : bool ref
+
+(* Misc. functions *)
+val optional : ('a -> 'b) -> 'a option -> 'b option
+val optunit : ('a -> unit) -> 'a option -> unit
+val split_string : string -> char -> string list
+
+(* Printing header informations (compiler version, generation date...) *)
+(* [print_header_info ff cbeg cend] prints header info, where [ff] is
+   the formatter used, [cbeg] and [cend] the string of begin and end
+   of commentaries in the target language *)
+val print_header_info : Format.formatter -> string -> string -> unit
+
+(* Error during the whole process *)
+exception Error
+
+(* Generation of unique names. Mandatory call of reset_symbol between
+   set_min_symbol and gen_symbol *)
+(*val set_min_symbol : int -> unit*)
+val gen_symbol : unit -> string
+val reset_symbol : unit -> unit
+
+type iterator_name = 
+    Imap
+  | Ifold
+  | Imapfold
+
+val iterator_to_string : iterator_name -> string
+
+(** [unique l] returns the [l] list without duplicates. O([length l]). *)
+val unique : 'a list -> 'a list
+
+(** [incomplete_map f l] applies f to all the elements of
+  l except the last element. *)
+val incomplete_map : ('a -> 'a) -> 'a list -> 'a list
+
+(** [last_element l] returns the last element of the list l.*)
+val last_element : 'a list -> 'a 
+
+(** [split_last l] returns the list l without its last element 
+    and the last element of the list .*)
+val split_last : 'a list -> ('a list * 'a) 
+
+(** [remove x l] removes all occurrences of x from list l.*)
+val remove : 'a -> 'a list -> 'a list
+
+(** [is_empty l] returns whether the list l is empty.*)
+val is_empty : 'a list -> bool
+
+(** [repeat_list v n] returns a list with n times the value v. *)
+val repeat_list : 'a -> int -> 'a list
+
+(** Same as List.mem_assoc but using the value instead of the key. *)
+val memd_assoc : 'b -> ('a * 'b) list -> bool
+
+(** Same as List.assoc but searching for a data and returning the key. *)
+val assocd: 'b -> ('a * 'b) list -> 'a
+