getEff.ml

(** Time-stamp: <modified the 26/05/2009 (at 15:27) by Erwan Jahier> *)


open Lxm
open Predef
open SyntaxTree
open SyntaxTreeCore
open Eff
open Errors
open Ident

(******************************************************************************)
exception GetEffType_error of string

(* exported *)
let rec (typ:Eff.id_solver -> SyntaxTreeCore.type_exp -> Eff.type_) =
  fun env texp ->
    try (
      match texp.it with
        | Bool_type_exp -> Bool_type_eff
        | Int_type_exp  -> Int_type_eff
        | Real_type_exp -> Real_type_eff
        | Named_type_exp s -> env.id2type s texp.src
        | Array_type_exp (elt_texp, szexp) ->
            let elt_teff = typ env elt_texp in
              try
                let sz = EvalConst.eval_array_size env szexp in
                  Array_type_eff (elt_teff, sz)
              with EvalConst.EvalArray_error msg -> raise(GetEffType_error msg)
    )
    with GetEffType_error msg ->
      raise (Compile_error(texp.src, "can't eval type: "^msg))


let (add_pack_name : id_solver -> Lxm.t -> Ident.idref -> Ident.idref) =
  fun id_solver lxm cc -> 
    try
      match Ident.pack_of_idref cc with
        | Some _ -> cc
        | None ->
            let id = Ident.of_idref cc in
            let pn = 
              SymbolTab.find_pack_of_const id_solver.symbols id lxm 
            in
              Ident.make_idref pn id
    with _ -> cc (* raise en error? *)


(* exported *)
let rec (clock : Eff.id_solver -> SyntaxTreeCore.var_info -> Eff.id_clock)=
  fun id_solver v ->
    match v.var_clock with
      | Base -> v.var_name, BaseEff

      | NamedClock({ it=(cc,cv) ; src=lxm }) ->
          let cc = add_pack_name id_solver lxm cc in
          let vi = id_solver.id2var (Ident.to_idref cv) lxm in
          let id, clk = vi.var_clock_eff in
            v.var_name, On((cc,cv), clk)

(******************************************************************************)
(* Checks that the left part has the same type as the right one. *)
and (type_check_equation: Eff.id_solver -> Lxm.t -> Eff.left list -> 
      Eff.val_exp -> unit) =
  fun id_solver lxm lpl_eff ve_eff -> 
    let lpl_teff = List.map Eff.type_of_left lpl_eff in
    let ve_eff, right_part = EvalType.f id_solver ve_eff in
      if (List.length lpl_teff <> List.length right_part) then
        raise (Compile_error(lxm, 
                             "tuple size error: \n*** the tuple size is\n***\t"^ 
                               (string_of_int (List.length lpl_teff)) ^
                               " for the left-hand-side, and \n***\t" ^ 
                               (string_of_int (List.length right_part)) ^
                               " for the right-hand-side (in " ^
                               (String.concat "," 
                                  (List.map LicDump.string_of_leff lpl_eff)) ^ " = " ^
                               (LicDump.string_of_val_exp_eff ve_eff) ^
                               ")\n"   
                            ))
      else
        List.iter2
          (fun le re -> 
             if le <> re then
               let msg = "type mismatch: \n***\t'" 
                 ^ (LicDump.string_of_type_eff4msg le) ^ 
                 "' (left-hand-side) \n*** is not compatible with \n***\t'" 
                 ^ (LicDump.string_of_type_eff4msg re) ^ "' (right-hand-side)"
               in
                 raise (Compile_error(lxm, msg))
          )
          lpl_teff
          right_part

(* Checks that the left part has the same clock as the right one. *)
and (clock_check_equation:Eff.id_solver -> Lxm.t -> UnifyClock.subst -> 
      Eff.left list -> Eff.val_exp -> unit) =
  fun id_solver lxm s lpl_eff ve_eff ->
    let clk_list = List.map Eff.clock_of_left lpl_eff in
    let _, right_part_clks, s = EvalClock.f lxm id_solver s ve_eff clk_list in
      EvalClock.check_res lxm s lpl_eff right_part_clks


(******************************************************************************)
(* exported *)
let (dump_polymorphic_nodes : Eff.type_ -> unit) =
  fun t -> 
    let nodes =
      Polymorphism.unstack_polymorphic_nodes StructArrayExpand.node t 
    in
      List.iter
        (fun (id_solver,nenv,node) -> 
	   let node = 
	     if !Global.inline_iterator 
	     then Inline.iterators nenv id_solver node
	     else node
	   in
	   let str = LicDump.node_of_node_exp_eff node in
	     output_string !Global.oc str
        )
        nodes;
      Polymorphism.reset_type ()        

(******************************************************************************)
let (get_static_params_from_idref : SymbolTab.t -> Lxm.t -> Ident.idref ->
      static_param srcflagged list) =
  fun symbols lxm idref ->
    try 
      match SymbolTab.find_node symbols (Ident.name_of_idref idref) lxm with
        | SymbolTab.Local ni -> ni.it.static_params
        | SymbolTab.Imported(imported_node, params) -> params
    with _  ->
      (* can occur for static node parameters, which cannot
         themselves have static parameters.  A better solution ougth
         to be to add node static parameters in the SymbolTab.t
         however (in Lazycompiler.node_check_do most probably).  *)
      []

(* exported *)
let rec (node : Eff.id_solver -> SyntaxTreeCore.node_exp srcflagged -> 
          Eff.node_exp) =
  fun id_solver { src = lxm; it=(idref, static_args) } ->
    let static_params = get_static_params_from_idref id_solver.symbols lxm idref in
    let static_args_eff = 
      let sp_l = List.length static_params 
      and sa_l = List.length static_args in
        if (sp_l <> sa_l) then
          let msg = "Bad number of (static) arguments: " ^ 
            (string_of_int sp_l) ^ " expected, and " ^ 
            (string_of_int sa_l) ^ " provided."
          in
            raise (Compile_error(lxm, msg))
        else
          List.map2 (check_static_arg id_solver) 
            static_params 
            static_args 
    in
      id_solver.id2node idref static_args_eff lxm

        
(** [check_static_arg this pn id sa (symbols, acc)] compile a static arg 
    into a static_arg
*)
and (check_static_arg : Eff.id_solver ->
      SyntaxTreeCore.static_param srcflagged  -> 
      SyntaxTreeCore.static_arg srcflagged -> 
      Eff.static_arg) =
  fun node_id_solver sp sa -> 

    let rec (eff_type_and_type_exp_are_equal: 
               Eff.type_ -> SyntaxTreeCore.type_exp_core -> bool) =
      fun teff texp -> 
        match teff, texp with       
          | Bool_type_eff, Bool_type_exp 
          | Real_type_eff, Real_type_exp 
          | Int_type_eff, Int_type_exp -> true
          | Abstract_type_eff(l,_), Named_type_exp idref  -> 
              l = Ident.long_of_idref idref
          | External_type_eff(l), Named_type_exp idref  -> 
              (* This seems a little bit wrong *)
              l = Ident.long_of_idref idref
      
          |  _ , Named_type_exp idref -> true 

          | Array_type_eff(teff_ext,i),Array_type_exp(texp,j) -> 
              i=(EvalConst.eval_array_size node_id_solver j) 
      & (eff_type_and_type_exp_are_equal teff texp.it)
      
          | Any,_  -> assert false (* for TTB, polymorphism is not supported *)
          | Overload, _ -> assert false (* ditto *)
          | Struct_type_eff(_),_ -> assert false (* impossible *)
          | Enum_type_eff(_),_ -> assert false (* ditto *)
          | _  -> false
    in
    let check_type_arg type_eff type_exp =
      if not (eff_type_and_type_exp_are_equal type_eff type_exp.it) then 
        let msg = "Bad (static) type argument: '" ^ 
          (LicDump.string_of_type_eff4msg type_eff) ^ 
          "' and '" ^ (string_of_type_exp type_exp) ^ "' differs."
        in
          raise (Compile_error(type_exp.src, msg))
      else ()
    in

    let type_check_var_info acc vi_eff vi_exp = acc &
      eff_type_and_type_exp_are_equal vi_eff.var_type_eff vi_exp.it.var_type.it
    in
    let type_check_var_info_list vil_eff vil_exp =
      List.fold_left2 type_check_var_info true vil_eff vil_exp
    in
    let check_node_arg neff vii vio =
      let str = "Bad (static) node argument: " in
        if (List.length neff.inlist_eff) <> (List.length vii) then
          raise (Compile_error(sa.src, str ^ "arity error (inputs)."))
        else if (List.length neff.outlist_eff) <> (List.length vio) then
          raise (Compile_error(sa.src, str ^ "arity error (outputs)."))
        else if not (type_check_var_info_list neff.inlist_eff vii) then 
          raise (Compile_error(sa.src, str ^ "wrong input type profile."))
        else if not (type_check_var_info_list neff.outlist_eff vio) then 
          raise (Compile_error(sa.src, str ^ "wrong output type profile.")) 
        else (neff.inlist_eff, neff.outlist_eff)
    in

    let sa_eff =
      match sa.it, sp.it with
        | StaticArgIdent idref, StaticParamConst(id, type_exp) ->
            let ceff = node_id_solver.id2const idref sa.src in
            let t_ceff = type_of_const ceff in
              check_type_arg t_ceff type_exp;
              ConstStaticArgEff (id, ceff)

        | StaticArgIdent idref, StaticParamType(id) ->
            let teff = node_id_solver.id2type idref sa.src in
              TypeStaticArgEff (id, teff)
                
        | StaticArgConst ce, StaticParamConst(id, type_exp) -> (
            let ceff = EvalConst.f node_id_solver ce in
            let t_ceff = type_of_const (List.hd ceff) in
              check_type_arg t_ceff type_exp;
              match ceff with
                | [ceff] -> ConstStaticArgEff (id,ceff)
                | _ -> assert false (* should not occur *)
          )
        | StaticArgType te, StaticParamType id -> 
            let teff = typ node_id_solver te in
              TypeStaticArgEff (id, teff)

	| StaticArgIdent idref, StaticParamNode(id, vii, vio,_) ->
            (* idref is an alias, hence it cannot have static argument *)
            let sargs = [] in
            let neff = node_id_solver.id2node idref sargs sa.src in
            let (inlist, outlist) = check_node_arg neff vii vio in
            let neff = fst neff.node_key_eff in
              NodeStaticArgEff (id, (neff, inlist, outlist))

        | StaticArgNode(CALL_n ne), StaticParamNode(id,vii,vio,_) ->
            let neff = node node_id_solver ne in
            let (inlist, outlist) = check_node_arg neff vii vio in
            let neff = fst neff.node_key_eff in
              NodeStaticArgEff (id, (neff, inlist, outlist))

        | StaticArgNode(Predef_n (op,sargs)), StaticParamNode(id,vii,vio,_) ->
            let sargs_eff = 
              translate_predef_static_args node_id_solver sargs sa.src
            in
            let opeff = PredefEvalType.make_node_exp_eff None op sa.src sargs_eff in
            let (inlist, outlist) = check_node_arg opeff vii vio in
            let opeff = fst opeff.node_key_eff in
              NodeStaticArgEff (id, (opeff, inlist, outlist))

        | StaticArgNode(      
            (MERGE_n _|ARRAY_SLICE_n _|ARRAY_ACCES_n _|STRUCT_ACCESS_n _|IDENT_n _
            |ARRAY_n|HAT_n|CONCAT_n|WITH_n(_)|TUPLE_n|WHEN_n(_)|CURRENT_n|FBY_n
            |ARROW_n|PRE_n)), _ -> assert false

        | StaticArgType _, StaticParamNode(id,_,_,_) 
        | StaticArgType _, StaticParamConst(id,_) 

        | StaticArgNode _, StaticParamType(id) 
        | StaticArgNode _, StaticParamConst(id,_) 
            
        | StaticArgConst _, StaticParamNode(id,_,_,_) 
        | StaticArgConst _, StaticParamType(id) 
            -> 
            assert false (* can it occur actually? Let's wait it occurs...*)
    in
      sa_eff

(******************************************************************************)


(* exported *)
and (eq:Eff.id_solver -> SyntaxTreeCore.eq_info srcflagged -> Eff.eq_info srcflagged) =
  fun id_solver eq_info -> 
    let (lpl, ve) = eq_info.it in
    let lpl_eff = List.map (translate_left_part id_solver) lpl
    and clk_subst,ve_eff  = translate_val_exp id_solver UnifyClock.empty_subst ve
    in
      type_check_equation id_solver eq_info.src lpl_eff ve_eff;
      clock_check_equation id_solver eq_info.src clk_subst lpl_eff ve_eff;
      flagit (lpl_eff, ve_eff) eq_info.src


and (translate_left_part : id_solver -> SyntaxTreeCore.left_part -> Eff.left) =
  fun id_solver lp_top -> 
    match lp_top with
      | LeftVar id -> 
          let vi_eff = 
            id_solver.id2var (Ident.idref_of_string (Ident.to_string id.it)) id.src 
          in
            LeftVarEff (vi_eff, id.src)
              
      | LeftField (lp, id) -> (
          let lp_eff = translate_left_part id_solver lp in
          let teff = Eff.type_of_left lp_eff in
            (* check that [lp_eff] is a struct that have a field named [id] *)
            match teff with
              | Struct_type_eff(_, fl) -> (
                  try let (teff_field,_) = List.assoc id.it fl in
                    LeftFieldEff(lp_eff, id.it, teff_field)
                  with Not_found ->
                    raise (Compile_error(id.src, "bad field name in structure"))
                )
              | _  -> raise (Compile_error(id.src, "a structure was expected"))
        )
      | LeftArray (lp, vef) -> (
          let lp_eff = translate_left_part id_solver lp in
          let teff = Eff.type_of_left lp_eff in
          let lxm = vef.src in
            match teff with
              | Array_type_eff(teff_elt, size) ->
                  let index = EvalConst.eval_array_index id_solver vef.it lxm in
                    LeftArrayEff(lp_eff, index, teff_elt)
                      
              | _ -> raise (Compile_error(vef.src, "an array was expected"))
        )
      | LeftSlice (lp, sif) -> (
          let lp_eff = translate_left_part id_solver lp in
          let teff = Eff.type_of_left lp_eff in
            match teff with  
              | Array_type_eff(teff_elt, size) -> 
                  let sieff = translate_slice_info id_solver sif.it sif.src in
                  let size_slice = sieff.se_width in
                  let teff_slice = Array_type_eff(teff_elt, size_slice) in
                    LeftSliceEff(lp_eff, sieff, teff_slice)
              | _ -> raise (Compile_error(sif.src, "an array was expected"))
        )


and (translate_val_exp : Eff.id_solver -> UnifyClock.subst -> 
      SyntaxTreeCore.val_exp -> UnifyClock.subst * Eff.val_exp) =
  fun id_solver s ve ->
    let s, vef_core, lxm =
      match ve with
        | CallByName(by_name_op, field_list) ->
            let s,fl = List.fold_left 
              (fun (s,fl) f -> 
                 let s,f = translate_field id_solver s f in
                   s,f::fl
              )
              (s,[])
              field_list
            in
            let fl = List.rev fl in
              s, 
            (CallByNameEff(
               flagit (translate_by_name_op id_solver by_name_op) by_name_op.src, fl)),
            by_name_op.src
              
        | CallByPos(by_pos_op, Oper vel) ->
            let s, vel_eff = 
              List.fold_left 
                (fun (s,vel) ve -> 
                   let s, ve = translate_val_exp id_solver s ve in
                     s,ve::vel
                )
                (s,[]) vel 
            in
            let vel_eff = List.rev vel_eff in
            let lxm = by_pos_op.src in
            let by_pos_op = by_pos_op.it in
            let mk_by_pos_op by_pos_op_eff =
              CallByPosEff(flagit by_pos_op_eff lxm, OperEff vel_eff)
            in
            let s, vef_core =
              match by_pos_op with
                  (* put that in another module ? yes, see above.*)
                | Predef_n(Map,  sargs)
                | Predef_n(Fill, sargs)
                | Predef_n(Red,  sargs)
                | Predef_n(FillRed, sargs)
                | Predef_n(BoolRed, sargs) -> 
                    (* We will make use of [vel_eff] to resolve the polymorphism *)
                    let vel_eff, type_ll = 
                      List.split (List.map (EvalType.f id_solver) vel_eff) 
                    in
                    let type_l : Eff.type_ list = List.flatten type_ll in
                    let sargs_eff = translate_predef_static_args id_solver sargs lxm in
                    let iter_op = match by_pos_op with 
                        Predef_n(op,_) -> op | _ -> assert false
                    in
                    let iter_profile = match by_pos_op with
                      | Predef_n(Map,_) ->  
                          PredefEvalType.map_profile lxm sargs_eff
                      | Predef_n(Fill,_) | Predef_n(Red,_) | Predef_n(FillRed,_) ->
                          PredefEvalType.fillred_profile lxm sargs_eff
                      | Predef_n(BoolRed,_) ->   
                          PredefEvalType.boolred_profile lxm sargs_eff
                      | _  -> assert false
                    in
                    let type_l_exp = snd (List.split (fst iter_profile)) in
                    let sargs_eff = 
                      if List.length type_l <> List.length type_l_exp then
                        raise (Compile_error(lxm, "the iterator has a wrong arity."))
                      else
                      match UnifyType.f type_l type_l_exp with
                        | UnifyType.Equal -> sargs_eff
                        | UnifyType.Unif typ ->
                            (* the iterated nodes was polymorphic, but we know here
                               that the type variable was [typ]. 
                            *)
                            dump_polymorphic_nodes typ;
			    List.map (instanciate_type typ) sargs_eff
                              
                        | UnifyType.Ko str -> raise (Compile_error(lxm,  str))
                    in
                      s, mk_by_pos_op (Eff.Predef(iter_op, sargs_eff)) 

                (* other predef operators *)
                | Predef_n(op, args) -> 
                    assert (args=[]); s, mk_by_pos_op(Predef (op,[]))
                      
                | CALL_n node_exp_f -> 
                    s, mk_by_pos_op(Eff.CALL (flagit (node id_solver node_exp_f) 
                                             node_exp_f.src))
                | IDENT_n idref -> (
                    try 
                      let s, const = UnifyClock.const_to_val_eff lxm false s
                        (id_solver.id2const idref lxm)
                      in
                        s, const.core
                    with _ -> (* In case idref is not a static constant. *)
                      match Ident.pack_of_idref idref with
                        | Some pn -> s, mk_by_pos_op(Eff.IDENT idref)
                            (** Constant with a pack name are treated as
                                Eff.IDENT. *)
                        | None ->
                            try
                              (* try to add its pack name... *)
                              let id = Ident.of_idref idref in 
                              let pn = 
                                SymbolTab.find_pack_of_const id_solver.symbols id lxm 
                              in
                              let idref = Ident.make_idref pn id in
                                s, mk_by_pos_op(Eff.IDENT (idref))
                            with _ ->
                              s, mk_by_pos_op(Eff.IDENT idref)
                  )
                | CURRENT_n -> s, mk_by_pos_op Eff.CURRENT
                | PRE_n -> s, mk_by_pos_op Eff.PRE

                | ARROW_n -> s, mk_by_pos_op Eff.ARROW
                | FBY_n -> s, mk_by_pos_op Eff.FBY
                | CONCAT_n -> s, mk_by_pos_op Eff.CONCAT
                | TUPLE_n -> s, mk_by_pos_op Eff.TUPLE
                | ARRAY_n -> 
                    s, CallByPosEff(flagit (Eff.ARRAY vel_eff) lxm, OperEff [])

                | WITH_n(c,e1,e2) ->
                    let c_eff = EvalConst.f id_solver c in
                      if c_eff = [ Bool_const_eff true ] then
                        let s, ve1 = translate_val_exp id_solver s e1 in
                          s, mk_by_pos_op (Eff.WITH (ve1))
                      else 
                        let s, ve2 = translate_val_exp id_solver s e2 in
                          s, mk_by_pos_op (Eff.WITH (ve2))
                | STRUCT_ACCESS_n fid ->
                      s, mk_by_pos_op (Eff.STRUCT_ACCESS (fid))

                | WHEN_n Base -> s, mk_by_pos_op (Eff.WHEN Base)
                | WHEN_n (NamedClock { it = (cc,cv) ; src = lxm }) -> 
                    let cc = add_pack_name id_solver lxm cc in
                      s, 
                    mk_by_pos_op (Eff.WHEN (NamedClock { it = (cc,cv) ; src = lxm }))

                | ARRAY_ACCES_n ve_index ->
                      s, mk_by_pos_op (
                        Eff.ARRAY_ACCES(
                          EvalConst.eval_array_index id_solver ve_index lxm))

                | ARRAY_SLICE_n si ->
                    s, mk_by_pos_op 
                      (Eff.ARRAY_SLICE(
                         EvalConst.eval_array_slice id_solver si lxm))
                        
                | HAT_n -> (
                    match vel with
                      | [exp; ve_size] -> 
                          let size_const_eff = EvalConst.f id_solver ve_size 
                          and s, exp_eff = translate_val_exp id_solver s exp in 
                            (match size_const_eff with
                               | [Int_const_eff size] -> 
                                   s, mk_by_pos_op (Eff.HAT(size, exp_eff))
                               | _ -> assert false)
                      | _ -> assert false
                  )

                | MERGE_n(id, idl) -> s, mk_by_pos_op (Eff.MERGE(id, idl))
            in
              s, vef_core, lxm
    in
    let vef, tl = EvalType.f id_solver { core=vef_core; typ=[]; clk = [] } in
    let vef, _, s =  EvalClock.f lxm id_solver s vef [] in
      s, vef

and translate_by_name_op id_solver op = 
  match op.it with
    | STRUCT_anonymous_n -> STRUCT_anonymous
    | STRUCT_n idref -> 
        match Ident.pack_of_idref idref with
          | None -> 
              (* If no pack name is provided, we lookup it in the symbol table *)
              let id = Ident.of_idref idref in
              let pn = SymbolTab.find_pack_of_type id_solver.symbols id op.src in
                STRUCT (pn, idref)
          | Some pn -> STRUCT (pn, idref)

and translate_field id_solver s (id, ve) = 
  let s, ve = translate_val_exp id_solver s ve in
    s, (id, ve)

(* XXX autre nom, autre module ? 
   ca fait partie de la definition des iterateurs d'une certaine maniere...
   -> crer 2 modules, Iterator + IteratorSemantics 
*)
and get_const id_solver const_or_const_ident lxm = 
  match const_or_const_ident with
    | StaticArgConst(c) -> List.hd (EvalConst.f id_solver c) 
    | StaticArgIdent(id) -> id_solver.id2const id lxm 
    | StaticArgType _
    | StaticArgNode _ -> raise (Compile_error(lxm, "a constant was expected"))



and get_node id_solver node_or_node_ident lxm =
  match node_or_node_ident with
    | StaticArgIdent(id) -> 
        let sargs = [] in (* it is an alias: no static arg *)
          id_solver.id2node id sargs lxm 

    | StaticArgNode(CALL_n ne) -> node id_solver ne
    | StaticArgNode(Predef_n (op,sargs)) ->
        let sargs_eff = translate_predef_static_args id_solver sargs lxm in
          PredefEvalType.make_node_exp_eff None op lxm sargs_eff 
    | StaticArgNode(_) -> assert false

    | StaticArgType _ 
    | StaticArgConst _ -> raise (Compile_error(lxm, "a node was expected"))


and (instanciate_type: Eff.type_ -> Eff.static_arg -> Eff.static_arg) =
  fun t sarg ->
    let make_long pstr idstr = 
      Ident.long_of_idref { id_pack = Some pstr ; id_id = idstr } 
    in
    let instanciate_var_info vi =
      { vi with var_type_eff = Eff.subst_type t vi.var_type_eff }
    in    
      match sarg with
	| ConstStaticArgEff _ -> sarg
	| TypeStaticArgEff _ -> sarg (* we cannot denote polymorphic type... *)
	| NodeStaticArgEff(id,(node,il,ol)) ->
	    let node = match Ident.idref_of_long node with
	      |  { id_pack = Some "Lustre" ; id_id = "times" } -> 
		   let op = if t = Int_type_eff then "itimes" else "rtimes" in
		     make_long "Lustre" op
	      |  { id_pack = Some "Lustre" ; id_id = "slash" } -> 
		   let op = if t = Int_type_eff then "islash" else "rslash" in
		     make_long "Lustre" op
	      |  { id_pack = Some "Lustre" ; id_id = "plus" } -> 
		   let op = if t = Int_type_eff then "iplus" else "rplus" in
		     make_long "Lustre" op
	      |  { id_pack = Some "Lustre" ; id_id = "minus" } -> 
		   let op = if t = Int_type_eff then "iminus" else "rminus" in
		     make_long "Lustre" op
	      |  { id_pack = Some "Lustre" ; id_id = "uminus" } -> 
		   let op = if t = Int_type_eff then "iuminus" else "ruminus" in
		     make_long "Lustre" op
	      |  { id_pack = Some "Lustre" ; id_id = "div" } -> 
		   let op = if t = Int_type_eff then "div" else "rdiv" in
		     make_long "Lustre" op

	      (* polymorphic op. what should be done for type different from
		 int and real? 
	      *)

              (* Lustre::ilt and co are not compiled yet.  *)
              (* 	      |  { id_pack = Some "Lustre" ; id_id = "lt" } ->   *)
              (* 		   let op = if t = Int_type_eff then "ilt"   *)
              (* 		   else if t = Real_type_eff then "rlt" else "lt" in  *)
              (* 		     make_long "Lustre" op *)
              (* 	      |  { id_pack = Some "Lustre" ; id_id = "gt" } ->  *)
              (* 		   let op = if t = Int_type_eff then "igt"  *)
              (* 		   else if t = Real_type_eff then "rgt" else "gt" in *)
              (* 		     make_long "Lustre" op *)
              (* 	      |  { id_pack = Some "Lustre" ; id_id = "lte" } ->  *)
              (* 		   let op = if t = Int_type_eff then "ilte"  *)
              (* 		   else if t = Real_type_eff then "rlte" else "lte" in *)
              (* 		     make_long "Lustre" op *)
              (* 	      |  { id_pack = Some "Lustre" ; id_id = "gte" } ->  *)
              (* 		   let op = if t = Int_type_eff then "igte"  *)
              (* 		   else if t = Real_type_eff then "rgte" else "gte" in *)
              (* 		     make_long "Lustre" op *)

	      |  { id_pack = Some "Lustre" ; id_id = "equal" } -> 
		   let op = if t = Int_type_eff then "iequal" 
		   else if t = Real_type_eff then "requal"
		   else if t = Bool_type_eff then "bequal" else "equal" in
		     make_long "Lustre" op
	      |  { id_pack = Some "Lustre" ; id_id = "diff" } -> 
		   let op = if t = Int_type_eff then "idiff" 
		   else if t = Real_type_eff then "rdiff" 
		   else if t = Bool_type_eff then "bdiff" else "diff" in
		     make_long "Lustre" op

	      | _ -> node
	    in
	    let il = List.map instanciate_var_info il 
	    and ol = List.map instanciate_var_info ol 
	    in
	      NodeStaticArgEff(id,(node,il,ol))

(* exported *)
and (translate_predef_static_args: Eff.id_solver -> 
      SyntaxTreeCore.static_arg srcflagged list -> Lxm.t -> 
      Eff.static_arg list) =
  fun id_solver sargs lxm -> 
    match sargs with
      | [] -> []
      | [{src=lxm_c1;it=c1}; {src=lxm_c2;it=c2}; {src=lxm_c3;it=c3}] -> 
          [
            ConstStaticArgEff(Ident.of_string "min", get_const id_solver c1 lxm_c1);
            ConstStaticArgEff(Ident.of_string "max", get_const id_solver c2 lxm_c2);
            ConstStaticArgEff(Ident.of_string "size",get_const id_solver c3 lxm_c3)
          ]

      | [{src=lxm_n;it=node}; {src=lxm_c;it=const}] -> 
          let node_eff = get_node id_solver node lxm_n in
            (* There is two cases:
               
               - node_eff is a simple node (no static arg). Then there
               is nothing special todo. We use it to build the static arg.

               - node_eff is a node with static arguments. We need to
               unnest this. Therefore, we create on-the-fly an alias
               pointing to this node_eff, compile it, and use the
               result (which is then a simple node) as the current
               node_eff.  *)

          let node_eff =
            if snd node_eff.node_key_eff = [] then
              node_eff
            else
              (* 
                 - create a fresh node alias name (node_alias)
                 - build a fake node_info containing the alias definition
                 - add this entry in the SymbolTab (via id_solver.symbols)
                 - call id_solver.id2node on node_alias to compile this new node
              *)
              let node_alias_str =  Name.node_key node_eff.node_key_eff "node_alias" in
              let node_alias_idref = Ident.idref_of_string node_alias_str in
              let node_alias_ident = Ident.of_string node_alias_str in
              let by_pos_op  =
                match node with
                  | StaticArgNode(by_pos_op) -> by_pos_op
                  | StaticArgIdent(id) -> assert false
                  | StaticArgType _ 
                  | StaticArgConst _ -> 
                      raise (Compile_error(lxm_n, "a node was expected"))
              in 
              let node_alias_info = 
                { src = lxm_n ;
                  it =  {
                    name = node_alias_ident;
                    static_params = [] ;
                    vars = None;
                    def  = Alias { src = lxm_n ; it = by_pos_op };
                    has_mem = node_eff.has_mem_eff;
                    is_safe = node_eff.is_safe_eff;
                  }
                }
              in
              let _ = 
                SymbolTab.add_node id_solver.symbols node_alias_ident node_alias_info
              in
                id_solver.id2node node_alias_idref [] lxm_n
          in            
          let node_arg = 
            fst node_eff.node_key_eff, node_eff.inlist_eff, node_eff.outlist_eff 
          in

            [NodeStaticArgEff(Ident.of_string "node", node_arg);
             ConstStaticArgEff(Ident.of_string "size",get_const id_solver const lxm_c)]
      | _ ->  
          raise (Compile_error(lxm, "bad arguments number for array iterator"))

            
and (translate_slice_info  : Eff.id_solver -> SyntaxTreeCore.slice_info -> 
      Lxm.t -> Eff.slice_info) =
  fun id_solver si lxm ->
    EvalConst.eval_array_slice id_solver si lxm


(**********************************************************************************)
(* exported *)
let (assertion : Eff.id_solver -> SyntaxTreeCore.val_exp Lxm.srcflagged -> 
      Eff.val_exp Lxm.srcflagged) =
  fun id_solver vef ->
    let s, val_exp_eff = translate_val_exp id_solver UnifyClock.empty_subst vef.it in
    (* Check that the assert is a bool. *)
    let val_exp_eff, evaled_exp = EvalType.f id_solver val_exp_eff in
      List.iter
        (fun ve -> 
           if ve <> Bool_type_eff then
             let msg = "type mismatch: \n\tthe content of the assertion is of type " 
               ^ (LicDump.string_of_type_eff4msg ve) 
               ^ " whereas it shoud be a Boolean\n"
             in
               raise (Compile_error(vef.src, msg))
        )
        evaled_exp;
      (* type is ok *)

      (* Clock check the assertion*)
      let _, clock_eff_list, _s = 
        EvalClock.f vef.src id_solver s val_exp_eff [BaseEff]
      in
        match clock_eff_list with
          | [id, BaseEff] 
          | [id, On(_,BaseEff)]
          | [id, ClockVar _] -> Lxm.flagit val_exp_eff vef.src
          | [id, ce] -> 
              let msg = "clock error: assert should be on the base clock, "^
                "but it is on "^ (LicDump.string_of_clock2 ce) ^ "\n"
              in
                raise (Compile_error(vef.src, msg))

          | _ -> assert false
      

(******************************************************************************)