Plug back Meta operator Expansion.

Makefile

@@ -92,6 +92,8 @@ SOURCES =  \
 	$(OBJDIR)/l2lExpandArrays.ml \
 	$(OBJDIR)/l2lExpandNodes.mli \
 	$(OBJDIR)/l2lExpandNodes.ml \
+	$(OBJDIR)/l2lExpandMetaOp.ml \
+	$(OBJDIR)/l2lExpandMetaOp.mli \
 	$(OBJDIR)/l2lRmPoly.mli \
 	$(OBJDIR)/l2lRmPoly.ml \
 	$(OBJDIR)/l2lAliasType.mli \

src/compile.ml

-(* Time-stamp: <modified the 18/12/2012 (at 14:39) by Erwan Jahier> *)
+(* Time-stamp: <modified the 19/12/2012 (at 17:23) by Erwan Jahier> *)
 
 
 open Lxm
@@ -44,6 +44,10 @@ let (doit : AstV6.pack_or_model list -> Ident.idref option -> LicPrg.t) =
     let zelic = L2lRmPoly.doit zelic in
    (* alias des types array *)
     let zelic = L2lAliasType.doit zelic in
+    let zelic = if not !Global.inline_iterator then zelic else
+        (* Array and struct expansion: to do after polymorphism elimination *)
+        L2lExpandMetaOp.doit zelic 
+    in    
     let zelic = if not !Global.one_op_per_equation then zelic else 
         (* Split des equations (1 eq = 1 op) *)
         L2lSplit.doit zelic 

src/l2lExpandArrays.ml

-(** Time-stamp: <modified the 18/12/2012 (at 14:46) by Erwan Jahier> *)
+(** Time-stamp: <modified the 18/12/2012 (at 15:54) by Erwan Jahier> *)
 
 (* Replace structures and arrays by as many variables as necessary.
    Since structures can be recursive, it migth be a lot of new variables...
@@ -292,7 +292,11 @@ and (var_trees_of_val_exp :
           )
           | CONST_REF idl -> (
             try
-              let const = LicPrg.find_const lctx.prg idl in 
+              let const = 
+                match LicPrg.find_const lctx.prg idl with 
+                  | Some c -> c 
+                  | None -> assert false 
+              in 
               let s, ve_const = 
                 UnifyClock.const_to_val_eff lxm true UnifyClock.empty_subst const
               in

src/l2lExpandMetaOp.ml

+(** Time-stamp: <modified the 20/12/2012 (at 09:49) by Erwan Jahier> *)
+
+open Lxm
+open Lic
+
+let dbg=Some (Verbose.get_flag "ei")
+
+(* pack useful info into a single struct *)
+type local_ctx = { 
+  idgen : LicPrg.id_generator;
+  node : Lic.node_exp;
+  prg : LicPrg.t;
+}
+
+(********************************************************************************)
+(* stuff to create fresh var names. *)
+let new_var str lctx type_eff clock_eff = 
+  let id = Ident.of_string (LicName.new_local_var str) in
+  let var =
+    { 
+      var_name_eff   = id;
+      var_nature_eff = AstCore.VarLocal;
+      var_number_eff = -1; (* this field is used only for i/o. 
+                              Should i rather put something sensible there ? *)
+      var_type_eff   = type_eff;
+      var_clock_eff  = id, clock_eff;
+    }
+  in
+    var
+
+(********************************************************************************)
+(* A small util function followed by a quick unit test. *)
+let rec fill i size = if i >= size then [] else i::(fill (i+1) size) 
+let _ = assert (fill 0 5 = [0;1;2;3;4])
+      
+let rec (list_map3: 
+           ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list) =
+  fun f l1 l2 l3 ->
+    match (l1, l2, l3) with
+      |	([], [], []) -> []
+      | (e1::t1, e2::t2, e3::t3) -> (f e1 e2 e3)::(list_map3 f t1 t2 t3)
+      | _ -> (* should not occur *) 
+          print_string "*** list_map3 called with lists of different size.\n";
+          flush stdout;
+          assert false
+(********************************************************************************)
+(* Some utililities to build Lic expressions *)
+
+(* We generate code that does not correspond to any use source one *)
+let lxm = Lxm.dummy "no_source"
+
+let (val_exp_of_var_info : Lic.var_info -> Lic.val_exp) =
+  fun vi -> 
+    { 
+      ve_core = CallByPosLic({src=lxm;it=Lic.VAR_REF vi.var_name_eff}, OperLic []); 
+      ve_typ  = [vi.var_type_eff];
+      ve_clk  = [snd vi.var_clock_eff];
+    }
+
+let (val_exp_of_int : int -> Lic.val_exp) =
+  fun i -> 
+    let id_of_int i = AstPredef.ICONST_n(Ident.of_string (string_of_int i)) in
+    { 
+      ve_clk = [BaseLic]; 
+      ve_typ = [Int_type_eff]; 
+      ve_core = CallByPosLic({it=PREDEF_CALL(id_of_int i,[]);src=lxm},OperLic[])
+    }
+
+let rec (elt_type_of_array : Lic.type_ -> Lic.type_) =
+  function
+    | Array_type_eff(t, _) -> t
+    | Abstract_type_eff(_,t) -> elt_type_of_array t
+    | _  -> assert false 
+
+let (array_var_to_val_exp : int -> var_info -> val_exp) =
+  fun i vi -> 
+    (* vi holds x of type array and returns  x.[i] *)
+    let t_elt = elt_type_of_array vi.var_type_eff in
+    let op_flg = {src = lxm ; it = ARRAY_ACCES(i)} in
+    { 
+      ve_core = CallByPosLic(op_flg, OperLic [val_exp_of_var_info vi]); 
+      ve_typ  = [t_elt];
+      ve_clk  = [snd vi.var_clock_eff];
+    }
+
+let (op_to_val_exp : AstPredef.op -> val_exp -> val_exp -> val_exp) =
+  fun op ve1 ve2 -> 
+    let op = { it = PREDEF_CALL(op,[]) ; src = lxm } in
+    {
+      ve_clk = ve1.ve_clk; 
+      ve_typ = ve1.ve_typ;
+      ve_core = CallByPosLic(op, OperLic [ve1; ve2]) 
+    } 
+let (ite_to_val_exp : val_exp -> val_exp -> val_exp -> val_exp) =
+  fun ve1 ve2 ve3 ->
+    let ite_op  = { it = PREDEF_CALL(AstPredef.IF_n,[]); src = lxm } in
+    {
+      ve_clk = ve2.ve_clk; 
+      ve_typ = ve2.ve_typ;
+      ve_core = CallByPosLic(ite_op, OperLic [ve1; ve2; ve3]) 
+    } 
+
+let (array_var_to_left : int -> var_info -> Lic.left) =
+  fun i vi -> 
+    let lp = LeftVarLic(vi,lxm) in
+    let t_elt = elt_type_of_array vi.var_type_eff in
+    LeftArrayLic(lp,i,t_elt)
+
+
+let (create_fillred_body: local_ctx -> Lic.static_arg list -> Lic.node_body * var_info list) =
+  fun lctx sargs ->
+    (* Given 
+       - a node n of type : tau * tau_1 * ... * tau_n -> tau * teta_1 * ... * teta_l
+       - a integer c
+       
+       the fillred expression has the profile: 
+       tau * tau_1^c * ... * tau_n^c  -> tau * teta_1^c * ... * teta_l^c
+    *)
+    let iter_node,c = match sargs with
+      | [ConstStaticArgLic(_,Int_const_eff(c)) ; NodeStaticArgLic(_,_node_key)]
+      | [NodeStaticArgLic(_,_node_key) ; ConstStaticArgLic(_,Int_const_eff(c))] -> 
+        _node_key,c
+      | _ -> assert false
+    in
+    let iter_node = Lxm.flagit iter_node lxm in
+        (*
+          Hence:
+          node(acc_in:tau; X1:tau_1^c ; ... ; Xn:tau_n^c) 
+          returns (acc_out:tau; Y1:teta_1^c; ... ; Yl:teta_l^c) = fillred<<n,c>>;
+        *)
+    let (acc_in : var_info)      = List.hd lctx.node.Lic.inlist_eff  in
+    let (y1_yl  : var_info list) = List.tl lctx.node.Lic.inlist_eff  in
+    let (acc_out: var_info)      = List.hd lctx.node.Lic.outlist_eff in
+    let (x1_xn  : var_info list) = List.tl lctx.node.Lic.outlist_eff in
+        (*
+          can be defined like this:
+          node(acc_in:tau; X1:tau_1^c ; ... ; Xn:tau_n^c) 
+          returns (acc_out:tau; Y1 : teta1^c; ... ; Yl: teta_l^c) =
+          var
+          acc_1, ..., acc_c-2 : tau;
+          let 
+          
+          acc_1, Y1[0], ... ,Yl[0] = n(acc_in,X1[0], ... ,Xk[0]);
+          acc_2, Y1[1], ... ,Yl[1] = n(acc_1, X1[1], ... ,Xk[1]);
+          ... 
+          acc_i+1, Y1[i], ... ,Yl[i] = n(acc_i,X1[i], ... ,Xk[i]);
+          ...
+          acc_out, Y1[c-1], ... ,Yl[c-1] = n(acc_c-1,X1[c-1], ... ,Xk[c-1]);
+          
+	       « for all i = 0, ..., c-1 » 
+          acc_i+1, Y1[i], ... ,Yl[i] = n(acc_i,X1[i], ... ,Xk[i])
+          tel
+        *)
+    let index_list = fill 0 c in        
+        (* Building this list "acc_left_list" as [acc_1, ..., acc_c-2, acc_out] *)
+    let type_exp,clock_exp = acc_in.var_type_eff, snd acc_in.var_clock_eff in
+    let (acc_vars : var_info list) =
+      let rec f i acc = if i = 0 then acc else
+          f (i-1) ((new_var "acc" lctx type_exp clock_exp)::acc)
+      in
+      List.rev(f (c-1) [])
+    in
+    let (acc_left_list : left list) =
+      (List.map (fun vi -> LeftVarLic(vi,lxm)) (acc_vars@[acc_out]))
+    in
+        (* Ditto for rigth part :  [acc_in, acc_1, ..., acc_c-1]*)
+    let (acc_rigth_list : val_exp list) =
+      List.map val_exp_of_var_info (acc_in::acc_vars)
+    in
+    let neqs =
+          (*
+            So now we build those equations ;
+            acc_1, Y1[0], ... ,Yl[0] = n(acc_in,X1[0], ... ,Xk[0]);
+            acc_2, Y1[1], ... ,Yl[1] = n(acc_1, X1[1], ... ,Xk[1]);
+            ... 
+            acc_i+1, Y1[i], ... ,Yl[i] = n(acc_i,X1[i], ... ,Xk[i]);
+            ...
+            acc_out, Y1[c-1], ... ,Yl[c-1] = n(acc_c-1,X1[c-1], ... ,Xk[c-1]);
+          *)
+      list_map3
+        (fun i acc_left acc_rigth ->
+          let (xi_j:val_exp list) = (* X1[i], ... ,Xn[i] *)
+            List.map (array_var_to_val_exp i) y1_yl
+          in
+          let args = acc_rigth::xi_j in
+          let (yi_k : left list) =  (* Y1[i], ... ,Yl[i] *)
+            List.map (array_var_to_left i) x1_xn
+          in
+          let lhs = acc_left::yi_k in
+		    let cl = 
+            List.map (fun l -> snd (Lic.var_info_of_left l).var_clock_eff) lhs
+          in
+          let rhs = {
+            ve_typ = List.map Lic.type_of_left lhs;
+            ve_clk = cl;
+            ve_core = CallByPosLic({src=lxm;it=(CALL iter_node)}, OperLic args) }
+          in
+		    let eq = { src = lxm ; it = (lhs, rhs) } in
+          eq 
+        )
+        index_list
+        acc_left_list
+        acc_rigth_list
+    in
+    { asserts_eff = []; eqs_eff = List.rev neqs }, acc_vars
+
+let (create_map_body: local_ctx -> Lic.static_arg list -> Lic.node_body * var_info list) =
+  fun lctx sargs ->
+	 (* Given
+	    - a node n of type: tau_1 * ... * tau_n -> teta_1 * ... * teta_l
+	    - and an integer c
+       
+	    The profile of map<<node,c>> is:
+  	    tau_1^c * ... * tau_n^c -> teta_1^c * ... * teta_l^c
+       and
+       
+	    Y1, ... ,Yl = map<<node; c>>(X1,...,Xk)
+       <=>
+	    for all i = 0, ..., c-1; (Y1[i], ... ,Yl[i]) = N(X_1[i], ... ,X_k[i])
+    *)
+    let iter_node,c = match sargs with
+      | [ConstStaticArgLic(_,Int_const_eff(c)) ; NodeStaticArgLic(_,_node_key)]
+      | [NodeStaticArgLic(_,_node_key) ; ConstStaticArgLic(_,Int_const_eff(c))] -> 
+        _node_key,c
+      | _ -> assert false
+    in
+    let iter_node = Lxm.flagit iter_node lxm in
+    let (y1_yl  : var_info list) = lctx.node.Lic.inlist_eff  in
+    let (x1_xn  : var_info list) = lctx.node.Lic.outlist_eff in
+    let index_list = fill 0 c in        
+    let neqs =
+      List.map
+        (fun  i ->
+          let (xi_j:val_exp list) = (* X1[i], ... ,Xn[i] *)
+            List.map (array_var_to_val_exp i) y1_yl
+          in
+          let (lhs : left list) =  (* Y1[i], ... ,Yl[i] *)
+            List.map (array_var_to_left i) x1_xn
+          in
+		    let cl = 
+            List.map (fun l -> snd (Lic.var_info_of_left l).var_clock_eff) lhs
+          in
+          let rhs = {
+            ve_typ = List.map Lic.type_of_left lhs;
+            ve_clk = cl;
+            ve_core = CallByPosLic({src=lxm;it=(CALL iter_node)}, OperLic xi_j) }
+          in
+		    let eq = { src = lxm ; it = (lhs, rhs) } in
+          eq 
+        )
+        index_list
+    in
+    { asserts_eff = []; eqs_eff = List.rev neqs }, []
+
+let (create_boolred_body: local_ctx -> int -> int -> int -> Lic.node_body * var_info list) =
+  fun lctx i j k ->
+    (* Given - 3 integers i, j, k boolred<<i,j,k>> has the profile: bool^n -> bool
+       and is defined by
+       node toto = boolred<<i,j,k>>(tab); 
+       <=>
+       node toto(tab:bool^n) returns (res:bool);
+       var 
+       cpt:int;
+       let 
+       cpt = (if tab[0] then 1 else 0) + ... + (if tab[k-1] then 1 else 0);
+       res = i <= cpt && cpt <= j;
+       tel
+    *)
+    assert(0 <= i && i <= j && j <= k && k>0);
+    let (tab_vi : var_info) = match lctx.node.Lic.inlist_eff with
+      | [vi] -> vi 
+      | _ -> assert false
+    in
+    let (res_vi : var_info) = match lctx.node.Lic.outlist_eff with
+      | [vi] -> vi 
+      | _ -> assert false
+    in
+    let (cpt_vi : var_info) = new_var "cpt" lctx Int_type_eff BaseLic in
+    let cpt_left = LeftVarLic (cpt_vi,lxm) in
+    let zero = val_exp_of_int 0
+    and one = val_exp_of_int  1 in
+    let index_list = fill 0 k in (* [0;1; ...;k-1]*)
+    let (ite_list:Lic.val_exp list) = List.map
+      (fun i -> (* returns [if A[i] then 1 else 0]_i=0,k-1 *)
+        let tab_ve_i = array_var_to_val_exp i tab_vi in
+        ite_to_val_exp tab_ve_i one zero
+      )
+      index_list
+    in
+    let cpt_rigth = List.fold_left (op_to_val_exp AstPredef.IPLUS_n)
+      (List.hd ite_list) (List.tl ite_list) in
+    let res_left = LeftVarLic (res_vi,lxm) in
+    let res_rigth = (* i <= cpt && cpt <= j; *)
+      let i_eff   = val_exp_of_int i in
+      let j_eff   = val_exp_of_int j in
+      let cpt_eff = val_exp_of_var_info cpt_vi in
+      let i_inf_cpt = op_to_val_exp AstPredef.LTE_n i_eff cpt_eff in
+      let cpt_inf_j = op_to_val_exp AstPredef.LTE_n cpt_eff j_eff in
+      op_to_val_exp AstPredef.AND_n i_inf_cpt cpt_inf_j
+    in 
+    let cpt_eq = { src = lxm ; it = ([cpt_left], cpt_rigth) } in
+    let res_eq = { src = lxm ; it = ([res_left], res_rigth) } in
+    { 
+      asserts_eff = []; 
+      eqs_eff = [cpt_eq; res_eq] 
+    }, [cpt_vi]
+
+let (create_condact_body: local_ctx -> Lic.static_arg list -> Lic.node_body * var_info list) =
+  fun lctx sargs ->
+    assert false (* XXX finish me! *)
+
+let (create_merge_body: local_ctx -> Lic.static_arg list -> Lic.node_body * var_info list) =
+  fun lctx sargs ->
+    assert false (* XXX finish me! *)
+
+let rec (create_meta_op_body:  local_ctx -> Lic.node_key -> Lic.node_body * var_info list) =
+  fun lctx (nk,sargs) ->
+    match nk with
+      | "Lustre", "fill" 
+      | "Lustre", "red" 
+      | "Lustre", "fillred" -> create_fillred_body lctx sargs
+      | "Lustre", "map"     -> create_map_body lctx sargs
+      | "Lustre", "boolred" -> (
+        let (i,j,k) =
+          match sargs with 
+            | [ConstStaticArgLic(_, Int_const_eff i);
+               ConstStaticArgLic(_, Int_const_eff j);
+               ConstStaticArgLic(_, Int_const_eff k)
+              ] -> 
+              (i,j,k)
+            | _ -> assert false
+        in
+        create_boolred_body lctx i j k  
+      )
+      | "Lustre", "diese" -> (
+        (* a diese is a particular kind of boolred:
+           #(A,...,an) = boolred(1,1,n)([a1,...,an])
+        *)
+        let n = List.length lctx.node.Lic.inlist_eff in
+        create_boolred_body lctx 1 1 n 
+      )
+      | "Lustre", "nor" -> (
+        (* a nor is a particular kind of boolred too:
+           nor(A,...,an) = boolred(0,0,n)([a1,...,an])
+        *)
+        let n = List.length lctx.node.Lic.inlist_eff in
+        create_boolred_body lctx 0 0 n 
+      )
+      | "Lustre", "condact" -> create_condact_body lctx sargs
+      | "Lustre", "merge"   -> create_merge_body lctx sargs
+      | _,_  -> assert false
+
+
+let rec (node : local_ctx -> Lic.node_exp -> Lic.node_exp) =
+  fun lctx n ->
+    let sonk = Lic.string_of_node_key in
+    Verbose.printf ~flag:dbg "#DBG: L2lInlineMetaOp %s\n" (sonk n.node_key_eff);
+    match n.def_eff with
+      | MetaOpLic nk ->
+        let nbody, nlocs = create_meta_op_body lctx nk in
+        { n with 
+          def_eff = BodyLic nbody;
+          loclist_eff = Some nlocs;
+        }
+      | ExternLic 
+      | AbstractLic None -> n
+      | AbstractLic (Some pn) ->
+        { n with def_eff = AbstractLic (Some (node lctx pn)) }
+      | BodyLic b -> n
+
+(* exported *)
+and (doit :  LicPrg.t -> LicPrg.t) =
+  fun inprg -> 
+    let outprg = LicPrg.empty in
+    (** types and constants do not change *)
+    let outprg = LicPrg.fold_types  LicPrg.add_type  inprg outprg in
+    let outprg = LicPrg.fold_consts LicPrg.add_const inprg outprg in
+    (** transform nodes *)
+    let rec (do_node : Lic.node_key -> Lic.node_exp -> LicPrg.t -> LicPrg.t) = 
+      fun nk ne outprg -> 
+        let lctx = {
+          idgen = LicPrg.fresh_var_id_generator inprg ne;
+          node = ne;
+          prg = outprg;
+        }
+        in
+        let ne = node lctx ne in
+        LicPrg.add_node nk ne outprg
+    in
+    let outprg = LicPrg.fold_nodes do_node inprg outprg in
+    outprg

src/l2lExpandMetaOp.mli

+(** Time-stamp: <modified the 19/12/2012 (at 17:26) by Erwan Jahier> *)
+
+
+(** Expand Meta operators (red, map, etc.)  *)
+
+val doit : LicPrg.t -> LicPrg.t

src/l2lRmPoly.ml

-(* Time-stamp: <modified the 18/12/2012 (at 10:20) by Erwan Jahier> *)
+(* Time-stamp: <modified the 18/12/2012 (at 15:57) by Erwan Jahier> *)
 
 (*
 Source 2 source transformation :
@@ -28,151 +28,159 @@ let static_args_of_matches matches =
    ) matches
 
 let rec doit (inprg : LicPrg.t) : LicPrg.t =
-   (* n.b. on fait un minumum d'effet de bord pour
-      pas avoir trop d'acummulateur ... *)
-   let res = ref LicPrg.empty in
+  (* n.b. on fait un minumum d'effet de bord pour
+     pas avoir trop d'acummulateur ... *)
+  let res = ref LicPrg.empty in
 
-   (** TRAITE LES TYPES *)
-   let do_type k (te:Lic.type_) =
-      res := LicPrg.add_type k te !res
-   in
-   LicPrg.iter_types do_type inprg;
+  (** TRAITE LES TYPES *)
+  let do_type k (te:Lic.type_) =
+    res := LicPrg.add_type k te !res
+  in
+  LicPrg.iter_types do_type inprg;
 
-   (** TRAITE LES CONSTANTES *)
-   let do_const k (ec: Lic.const) =
-      res := LicPrg.add_const k ec !res
-   in 
-   LicPrg.iter_consts do_const inprg ;
+  (** TRAITE LES CONSTANTES *)
+  let do_const k (ec: Lic.const) =
+    res := LicPrg.add_const k ec !res
+  in 
+  LicPrg.iter_consts do_const inprg ;
 
-   (** TRAITE LES NOEUDS : *)
-   let rec do_node k (ne:Lic.node_exp) = (
-      if node_is_poly ne then
-         (* pour les noeuds polymorphes/surchagés, on fait rien du tout *)
-         Verbose.printf "### Warning: no code generated for polymorphic/overloaded node '%s'\n"
-            (Lic.string_of_node_key ne.node_key_eff)
-      else
-         let def' = match ne.def_eff with
-         | MetaOpLic _
-         | ExternLic -> ne.def_eff 
-         | AbstractLic _ -> assert false
-         | BodyLic nb ->    BodyLic (do_body [] nb)
-         in
-         res := LicPrg.add_node k { ne with def_eff = def'} !res
-   )
-   (** TRAITEMENT DES BODY *)
-   and do_body (m: Lic.type_matches) (nb: Lic.node_body) : Lic.node_body =
-      (* parcours les expressions du body
-         à la recherche d'appel de noeuds poly *)
-      let do_assert a = Lxm.flagit (do_exp m a.it) a.src
-      and do_eq eq =
-         Lxm.flagit (
-            fst eq.it,
-            do_exp m (snd eq.it)
-         ) eq.src
+  (** TRAITE LES NOEUDS : *)
+  let rec do_node k (ne:Lic.node_exp) = (
+    if node_is_poly ne then
+      (* pour les noeuds polymorphes/surchagés, on fait rien du tout *)
+      Verbose.printf "### Warning: no code generated for polymorphic/overloaded node '%s'\n"
+        (Lic.string_of_node_key ne.node_key_eff)
+    else
+      let def' = match ne.def_eff with
+        | MetaOpLic _
+        | ExternLic -> ne.def_eff 
+        | AbstractLic _ -> assert false
+        | BodyLic nb ->    BodyLic (do_body [] nb)
       in
-      {
-         asserts_eff = List.map do_assert nb.asserts_eff;
-         eqs_eff = List.map do_eq nb.eqs_eff;
-      }
-   (* TRAITEMENT DES EXP : on passe en parametre un Lic.type_matches *)
-   and do_exp
+      res := LicPrg.add_node k { ne with def_eff = def'} !res
+  )
+  (** TRAITEMENT DES BODY *)
+  and do_body (m: Lic.type_matches) (nb: Lic.node_body) : Lic.node_body =
+    (* parcours les expressions du body
+       à la recherche d'appel de noeuds poly *)
+    let do_assert a = Lxm.flagit (do_exp m a.it) a.src
+    and do_eq eq =
+      Lxm.flagit (
+        fst eq.it,
+        do_exp m (snd eq.it)
+      ) eq.src
+    in
+    {
+      asserts_eff = List.map do_assert nb.asserts_eff;
+      eqs_eff = List.map do_eq nb.eqs_eff;
+    }
+  (* TRAITEMENT DES EXP : on passe en parametre un Lic.type_matches *)
+  and do_exp
       (m: Lic.type_matches)
-      (e: Lic.val_exp)
-   : Lic.val_exp =
-      let typ' = Lic.apply_type_matches m e.ve_typ in
-      let core' = match e.ve_core with
+  (e: Lic.val_exp)
+  : Lic.val_exp =
+    let typ' = Lic.apply_type_matches m e.ve_typ in
+    let core' = match e.ve_core with
       | CallByPosLic (posop, OperLic ops) -> (
-         let ops' = OperLic (List.map (do_exp m) ops) in
-         match posop.it with
-         | PREDEF_CALL (pop,sas) ->
+        let ops' = OperLic (List.map (do_exp m) ops) in
+        match posop.it with
+          | PREDEF_CALL (pop,sas) ->
             (* 12/07 ICI version provisoise : 
                les macros predef n'existe plus ! (ce sont des calls classiques)
             *)
             assert (sas = []);
             CallByPosLic (posop, ops')
-         | CALL nk ->
-            let ne = LicPrg.find_node inprg nk.it in
+          | CALL nk ->
+            let ne = 
+              match LicPrg.find_node inprg nk.it with 
+                | Some n -> n
+                | None -> assert false 
+            in
             let nk' = if node_is_poly ne then (
-               Verbose.exe ~flag:dbg (fun () ->
-                  Printf.fprintf stderr "#DBG: CALL poly node %s\n"
+              Verbose.exe ~flag:dbg (fun () ->
+                Printf.fprintf stderr "#DBG: CALL poly node %s\n"
                   (Lxm.details posop.src));
-               let intypes = types_of_operands ops' in
-               let (inpars, _) = Lic.profile_of_node_exp ne in
-               let tmatches =  UnifyType.is_matched inpars intypes in
-               {it=solve_poly tmatches nk.it ne; src=nk.src}
+              let intypes = types_of_operands ops' in
+              let (inpars, _) = Lic.profile_of_node_exp ne in
+              let tmatches =  UnifyType.is_matched inpars intypes in
+              {it=solve_poly tmatches nk.it ne; src=nk.src}
             ) else nk in
             let posop' = Lxm.flagit (CALL nk') posop.src in
             CallByPosLic (posop', ops')
-         | x ->
+          | x ->
             (* dans tout les autre cas, raf ? *)
             CallByPosLic (posop, ops')
       )
       | CallByNameLic (namop, idops) ->
-         let idops' = List.map (fun (id, ve) -> (id, (do_exp m) ve)) idops in
-         CallByNameLic (namop, idops')
-      in
-      { e with ve_core = core'; ve_typ = typ' }
-   (* TRAITEMENT DES PARAMS STATIQUES *)
-   and do_static_arg  
+        let idops' = List.map (fun (id, ve) -> (id, (do_exp m) ve)) idops in
+        CallByNameLic (namop, idops')
+    in
+    { e with ve_core = core'; ve_typ = typ' }
+  (* TRAITEMENT DES PARAMS STATIQUES *)
+  and do_static_arg  
       (m: Lic.type_matches)
-      (a: Lic.static_arg)
-   : Lic.static_arg =
-      match a with
+  (a: Lic.static_arg)
+  : Lic.static_arg =
+    match a with
       | ConstStaticArgLic (id, cst) -> a
       | TypeStaticArgLic (id, ty) -> a
       | NodeStaticArgLic (id, nk) -> (
-         match nk with
-         | (("Lustre",_),[]) -> a
-         | _ ->
-            let ne = LicPrg.find_node inprg nk in
+        match nk with
+          | (("Lustre",_),[]) -> a
+          | _ ->
+            let ne = 
+              match LicPrg.find_node inprg nk with 
+                | Some n -> n
+                | None -> assert false 
+            in
             let nk' = solve_poly m nk ne in
             NodeStaticArgLic (id, nk')
       )
-   (** Gros du boulot :
+  (** Gros du boulot :
       soit un noeud poly, soit un profil attendu,
       fabrique s'il n'existe pas déjà, un noeud non poly adéquat ...
-   *)
-   and solve_poly 
+  *)
+  and solve_poly 
       (tmatches: Lic.type_matches)
-      (nk: Lic.node_key)
-      (ne: Lic.node_exp)
-   : Lic.node_key = 
-      Verbose.printf ~flag:dbg
-         "#DBG: L2lRmPoly.solve_poly nk='%s'\n#  prof=%s'\n# matches='%s'\n"
-            (Lic.string_of_node_key nk)
-            (Lic.string_of_type_profile (Lic.profile_of_node_exp ne))
-            (Lic.string_of_type_matches tmatches)
-      ;
-      let do_var vi =
-        let nt = Lic.subst_matches tmatches vi.var_type_eff in
-        assert(not (Lic.type_is_poly nt));
-        { vi with var_type_eff = nt }
-      in
-      (* nouvelle clé unique = ancienne + tmatches *)
-      let (nid, sargs) = nk in
-      let sargs' = sargs@(static_args_of_matches tmatches) in
-      let nk' = (nid, sargs') in
-      let def' = match ne.def_eff with
-         | ExternLic
-         | AbstractLic _ -> assert false 
-         | MetaOpLic (bid, sas) -> MetaOpLic (bid, List.map (do_static_arg tmatches) sas)
-         | BodyLic nb -> BodyLic(do_body tmatches nb)
-      in 
-      let ne' = {
-         node_key_eff = nk';
-         inlist_eff = List.map do_var ne.inlist_eff;
-         outlist_eff = List.map do_var ne.outlist_eff;
-         loclist_eff = (match ne.loclist_eff with
-            | None -> None
-            | Some vl -> Some (List.map do_var vl)
-         );
-         def_eff = def';
-         has_mem_eff = ne.has_mem_eff;
-         is_safe_eff = ne.is_safe_eff;
-      } in
-      res := LicPrg.add_node nk' ne' !res;
-      nk'
-   in
-   (*LET's GO *)
-   LicPrg.iter_nodes do_node inprg;
-   !res
+  (nk: Lic.node_key)
+  (ne: Lic.node_exp)
+  : Lic.node_key = 
+    Verbose.printf ~flag:dbg
+      "#DBG: L2lRmPoly.solve_poly nk='%s'\n#  prof=%s'\n# matches='%s'\n"
+      (Lic.string_of_node_key nk)
+      (Lic.string_of_type_profile (Lic.profile_of_node_exp ne))
+      (Lic.string_of_type_matches tmatches)
+    ;
+    let do_var vi =
+      let nt = Lic.subst_matches tmatches vi.var_type_eff in
+      assert(not (Lic.type_is_poly nt));
+      { vi with var_type_eff = nt }
+    in
+    (* nouvelle clé unique = ancienne + tmatches *)
+    let (nid, sargs) = nk in
+    let sargs' = sargs@(static_args_of_matches tmatches) in
+    let nk' = (nid, sargs') in
+    let def' = match ne.def_eff with
+      | ExternLic
+      | AbstractLic _ -> assert false 
+      | MetaOpLic (bid, sas) -> MetaOpLic (bid, List.map (do_static_arg tmatches) sas)
+      | BodyLic nb -> BodyLic(do_body tmatches nb)
+    in 
+    let ne' = {
+      node_key_eff = nk';
+      inlist_eff = List.map do_var ne.inlist_eff;
+      outlist_eff = List.map do_var ne.outlist_eff;
+      loclist_eff = (match ne.loclist_eff with
+        | None -> None
+        | Some vl -> Some (List.map do_var vl)
+      );
+      def_eff = def';
+      has_mem_eff = ne.has_mem_eff;
+      is_safe_eff = ne.is_safe_eff;
+    } in
+    res := LicPrg.add_node nk' ne' !res;
+    nk'
+  in
+  (*LET's GO *)
+  LicPrg.iter_nodes do_node inprg;
+  !res

src/lic.ml

-(* Time-stamp: <modified the 13/12/2012 (at 16:16) by Erwan Jahier> *)
+(* Time-stamp: <modified the 19/12/2012 (at 10:18) by Erwan Jahier> *)
 
 
 (** Define the Data Structure representing Compiled programs. *)
@@ -174,11 +174,12 @@ and val_exp =
            a cleaner solution would be to define two versions of val_exp: one with
            type info, and one without. But it is a big mutually recursive thing,
            and doing that would be a little bit heavy...
+           XXX why not an option type?
         *)
       ve_clk : clock list
         (* ditto *)
     }
-(** CallByPosLicest (sans doute ?)
+(** CallByPosLic est (sans doute ?)
    le BON endroit pour stocker l'information de 'matches',
    i.e. est-ce qu'un 'type_matches' a été nécessaire
    pour typer l'appel de l'opérateur ?
@@ -320,8 +321,7 @@ and type_matches = (type_var * type_) list
 
 and node_def =
   | ExternLic
-  | MetaOpLic of node_key
-   (* ICI A QUOI CA SERT ???? *)
+  | MetaOpLic of node_key (* ICI A QUOI CA SERT ???? *)
   | AbstractLic of node_exp option (* None if extern in the provide part *)
   | BodyLic of node_body
 
@@ -637,7 +637,7 @@ let rec string_of_type = function
   | Abstract_type_eff (name, t) -> (string_of_ident name)
   | Enum_type_eff (name, _) -> (string_of_ident name)
   | Array_type_eff (ty, sz) ->
-      Printf.sprintf "%s^%d" (string_of_type ty) sz
+    Printf.sprintf "%s^%d" (string_of_type ty) sz
   | Struct_type_eff (name, _) -> (string_of_ident name)
   | TypeVar Any -> "any"
   | (TypeVar AnyNum) -> "anynum"
@@ -656,51 +656,51 @@ and string_of_clock = function
   | On (id, ck) -> " on "^(Ident.string_of_clk id)^(string_of_clock ck)
 
 and string_of_const = function
-   | Bool_const_eff true -> "true"
-   | Bool_const_eff false -> "false"
-   | Int_const_eff i -> (sprintf "%d" i)
-   | Real_const_eff r -> r
-   | Extern_const_eff (s,_) -> (string_of_ident s)
-   | Abstract_const_eff (s,t,v,_) -> (string_of_ident s)
-   | Enum_const_eff   (s,_) -> (string_of_ident s)
-   | Struct_const_eff (fl, t) -> 
-      let string_of_field (id, veff) =
-        (Ident.to_string id)^" = "^ (string_of_const veff)
-      in
-      Printf.sprintf "%s{%s}"
-         (string_of_type t)
-         (String.concat "; " (List.map string_of_field fl))
-   | Array_const_eff (ctab, t) ->
-      Printf.sprintf "[%s]"
-         (String.concat ", " (List.map string_of_const ctab))
-   | Tuple_const_eff   cl ->
-      Printf.sprintf "(%s)"
-         (String.concat ", " (List.map string_of_const cl))
+  | Bool_const_eff true -> "true"
+  | Bool_const_eff false -> "false"
+  | Int_const_eff i -> (sprintf "%d" i)
+  | Real_const_eff r -> r
+  | Extern_const_eff (s,_) -> (string_of_ident s)
+  | Abstract_const_eff (s,t,v,_) -> (string_of_ident s)
+  | Enum_const_eff   (s,_) -> (string_of_ident s)
+  | Struct_const_eff (fl, t) -> 
+    let string_of_field (id, veff) =
+      (Ident.to_string id)^" = "^ (string_of_const veff)
+    in
+    Printf.sprintf "%s{%s}"
+      (string_of_type t)
+      (String.concat "; " (List.map string_of_field fl))
+  | Array_const_eff (ctab, t) ->
+    Printf.sprintf "[%s]"
+      (String.concat ", " (List.map string_of_const ctab))
+  | Tuple_const_eff   cl ->
+    Printf.sprintf "(%s)"
+      (String.concat ", " (List.map string_of_const cl))
 
 and string_of_var_info x =
-   (Ident.to_string x.var_name_eff) ^ ":"^(string_of_type x.var_type_eff)^(string_of_clock (snd x.var_clock_eff))
+  (Ident.to_string x.var_name_eff) ^ ":"^(string_of_type x.var_type_eff)^(string_of_clock (snd x.var_clock_eff))
 and string_of_var_list vl = String.concat " ; " (List.map string_of_var_info vl)
 
 and string_of_node_key = function
-| (ik, []) ->
-   (string_of_ident ik)
-| (ik, sargs)  -> Printf.sprintf "%s<<%s>>"
-   (string_of_ident ik)
-   (String.concat ", " (List.map string_of_static_arg sargs))
+  | (ik, []) ->
+    (string_of_ident ik)
+  | (ik, sargs)  -> Printf.sprintf "%s<<%s>>"
+    (string_of_ident ik)
+    (String.concat ", " (List.map string_of_static_arg sargs))
 
 and string_of_static_arg = function
-| ConstStaticArgLic(id, ceff) -> Printf.sprintf "const %s = %s" id (string_of_const ceff)
-| TypeStaticArgLic (id, teff) -> Printf.sprintf "type %s = %s" id (string_of_type teff)
+  | ConstStaticArgLic(id, ceff) -> Printf.sprintf "const %s = %s" id (string_of_const ceff)
+  | TypeStaticArgLic (id, teff) -> Printf.sprintf "type %s = %s" id (string_of_type teff)
 (* | NodeStaticArgLic (id, ((long,sargs), _, _), _) -> *)
-| NodeStaticArgLic (id, nk) ->
-   Printf.sprintf "node %s = %s" id (string_of_node_key nk)
+  | NodeStaticArgLic (id, nk) ->
+    Printf.sprintf "node %s = %s" id (string_of_node_key nk)
 
 and string_of_type_var tv = string_of_type (TypeVar tv)
 and string_of_type_matches pm =
-   let sotm (tv,t) = Printf.sprintf "%s <- %s"
-      (string_of_type_var tv) (string_of_type t)
-   in
-   String.concat ", " (List.map sotm pm)
+  let sotm (tv,t) = Printf.sprintf "%s <- %s"
+    (string_of_type_var tv) (string_of_type t)
+  in
+  String.concat ", " (List.map sotm pm)
 
 let string_of_node_exp ne =
   (Printf.sprintf "   node_key_eff = %s\n" (string_of_node_key ne.node_key_eff))

src/licPrg.ml

@@ -58,9 +58,9 @@ let fresh_type_id this pname pfx =
    fresh 0
 
 (** RECHERCHE *)
-let find_type  this k = ItemKeyMap.find k this.types
-let find_const this k = ItemKeyMap.find k this.consts
-let find_node  this k = NodeKeyMap.find k this.nodes
+let find_type  this k = try Some(ItemKeyMap.find k this.types ) with Not_found -> None
+let find_const this k = try Some(ItemKeyMap.find k this.consts) with Not_found -> None
+let find_node  this k = try Some(NodeKeyMap.find k this.nodes ) with Not_found -> None
    
 let (find_var : Ident.t -> Lic.node_exp -> Lic.var_info option) = 
   fun id ne -> 

src/licPrg.mli

-(* Time-stamp: <modified the 18/12/2012 (at 14:25) by Erwan Jahier> *)
+(* Time-stamp: <modified the 18/12/2012 (at 15:51) by Erwan Jahier> *)
 
 (** The data structure resulting from the compilation process *)
 
@@ -43,12 +43,9 @@ val iter_nodes  : (Lic.node_key -> Lic.node_exp -> unit) -> t -> unit
 
 val to_file : out_channel -> t -> unit
 
-(* Raises Not_found. *)
-val find_type  : t -> Lic.item_key -> Lic.type_
-val find_const : t -> Lic.item_key -> Lic.const
-val find_node  : t -> Lic.node_key -> Lic.node_exp
-
-
+val find_type  : t -> Lic.item_key -> Lic.type_ option
+val find_const : t -> Lic.item_key -> Lic.const option
+val find_node  : t -> Lic.node_key -> Lic.node_exp option
 val find_var : Ident.t -> Lic.node_exp -> Lic.var_info option
 
 val fresh_type_id : t -> Ident.pack_name -> string -> Ident.long

src/uglyStuff.ml

 
 (** XXX REMOVE ME : Crutch for make it works
 
-   Des béquilles et autres trucs moches qui ne devraient etre refaits ... 
+   Des béquilles et autres trucs moches qui devraient etre refaits ... 
 *)
 
 
@@ -12,25 +12,19 @@ ACCES AUX INFOS DEJA COMPILEES,
 infos déjà compilées, alors que c'est pas fait pour...
 - Y'a un probleme de gestion d'environnement a revoir ... 
 *)
-let node_exp_of_node_key 
-    (id_solver: Lic.id_solver)
-    (node_key: Lic.node_key)
-    (lxm : Lxm.t)
+let node_exp_of_node_key
+    (id_solver: Lic.id_solver) (node_key: Lic.node_key) (lxm : Lxm.t)
     : Lic.node_exp =
   let (id, sargs) = node_key in
   id_solver.Lic.id2node (Ident.idref_of_long id) sargs lxm
 
 let var_info_of_ident 
-    (id_solver: Lic.id_solver)
-    (id: Ident.t)
-    (lxm : Lxm.t)
+    (id_solver: Lic.id_solver) (id: Ident.t) (lxm : Lxm.t)
     : Lic.var_info =
   id_solver.Lic.id2var (Ident.idref_of_id id) lxm
 
 let const_eff_of_item_key
-    (id_solver: Lic.id_solver)
-    (id: Lic.item_key)
-    (lxm : Lxm.t) 
+    (id_solver: Lic.id_solver) (id: Lic.item_key) (lxm : Lxm.t) 
     : Lic.const =
   id_solver.Lic.id2const (Ident.idref_of_long id) lxm