getEff.ml

(** Time-stamp: <modified the 01/06/2011 (at 13:38) by Erwan Jahier> *)


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

(** debug flag: on prend le meme que LazyCompiler ... *)
let dbg = Verbose.get_flag "lazyc"

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

(* exported *)
let rec (of_type: 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 = of_type 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.global_symbols id lxm 
            in
              Ident.make_idref pn id
    with _ -> cc (* raise en error? *)


(* exported *)
let rec (of_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'" 
                 ^ (Eff.string_of_type le) ^ 
                 "' (left-hand-side) \n*** is not compatible with \n***\t'" 
                 ^ (Eff.string_of_type 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

(******************************************************************************)
(* 
ICI : BEQUILLE(S)
on fait un lookup dans la table des operateurs
pour rechercher leurs (ventuels) parametres statiques : 

TRAITER LES MACROS PREDEF :
- ici, on juste besoin de fabriquer les arguments statiques effectifs
   partir des arguments donns et des args attendus.
- on cherche pas  faire rentrer dans le moule, on dlgue 

*)

(* pour abstraire la nature des params statiques *)
type abstract_static_param =
   | ASP_const of Ident.t
   | ASP_type of Ident.t
   | ASP_node of Ident.t

let do_abstract_static_param x = 
match x.it with
   | StaticParamType id -> ASP_type id
   | StaticParamConst (id,_) -> ASP_const id
   | StaticParamNode (id,_,_,_) -> ASP_node id


let get_abstract_static_params
   (symbols: SymbolTab.t)
   (lxm: Lxm.t)
   (idref: Ident.idref)
: abstract_static_param list =
                     
   Verbose.exe ~flag:dbg (fun () ->
      Printf.fprintf stderr "#DBG: GetEff.get_abstract_static %s\n"
         (Ident.raw_string_of_idref idref)
   ) ;
   match (idref.id_pack, idref.id_id) with
      | (Some "Lustre", "map")
      | (Some "Lustre", "red")
      | (Some "Lustre", "fill")
      | (Some "Lustre", "fillred") -> [ ASP_node "oper"; ASP_const "size" ]
      | (Some "Lustre", "boolred") -> [ ASP_const "min"; ASP_const "max"; ASP_const "size"]
      | (Some "Lustre", "condact") -> [  ASP_node "oper";  ASP_const "dflt" ]
      | _ -> (
         try 
            let spl = 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
            in List.map do_abstract_static_param spl
         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). 
      
               OUI MAIS GROS BUG : qu'est-ce-qui se passe si si le
               'static node parameter' porte le meme nom qu'un noeud
               existant dans SymbolTab ???
      
               C'est clairement pas la bonne mthode ...
               Voir + bas ...
      
            *)
            []
     ) 
(* exported *)

let rec of_node
   (id_solver : Eff.id_solver) (ne: SyntaxTreeCore.node_exp srcflagged) : Eff.node_exp =
   let lxm = ne.src in
   let (idref, static_args) = ne.it in

   (* BUG des param statique node avec le meme nom
         qu'un node template global : 
      pis-aller : si static_args = [],
      on a peut-etre affaire  un static param node, donc
      on appelle directement id_solver.id2node et c'est lui
      qui plantera si ce n'est pas le cas et qu'il fallait
      des static_args...
      si static_args <> [], de toute maniere ca ne peut PAS
      etre un static param node
   *)

   (* NOUVELLE VERSION PURE :
      ON ne fait AUCUNE vrif de cohrence de types pour les param staiques,
      on ne vrifie QUE la nature (pour pouvoir rsoudre les args qui sont des idents
      A FAIRE + TARD ? !!
   *)
   let static_args_eff = match static_args with
   | [] -> []
   | _ ->
      let static_params = get_abstract_static_params id_solver.global_symbols lxm idref in
      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

and check_static_arg
   (node_id_solver: Eff.id_solver)
   (asp: abstract_static_param) 
   (sa: SyntaxTreeCore.static_arg srcflagged) 
: Eff.static_arg =
(
   (* 1ere passe :
      on utilise expected juste pour rsoudre la nature,
      on "compile" les args 
   *)
   let nature_error nat =
      let msg = Printf.sprintf "Bad static argument nature, a %s was expected" nat in
      raise (Compile_error(sa.src, msg))
   in
   let res = match (sa.it, asp) with
   (* ident vs type *)
   | (StaticArgIdent idref, ASP_type id) ->
      let teff = node_id_solver.id2type idref sa.src in
      TypeStaticArgEff (id, teff)
   (* type_exp vs type *)
   | (StaticArgType te, ASP_type id) ->
      let teff = of_type node_id_solver te in
      TypeStaticArgEff (id, teff)
   (* ident vs const *)
   | (StaticArgIdent idref, ASP_const id) ->
      let ceff = node_id_solver.id2const idref sa.src in
      ConstStaticArgEff (id, ceff)
   (* val_exp vs const *)
   | (StaticArgConst ce, ASP_const id) -> (
      let ceff = EvalConst.f node_id_solver ce in
      match ceff with
      | [ceff] -> ConstStaticArgEff (id,ceff)
      | _ -> assert false (* should not occur *)
   )
   (* id vs node *)
   | (StaticArgIdent idref, ASP_node id) ->
      let sargs = [] in
      let neff = node_id_solver.id2node idref sargs sa.src in
      NodeStaticArgEff (id, neff.node_key_eff)
   (* node exp vs node *)
   | (StaticArgNode (CALL_n ne), ASP_node id) ->
      let neff = of_node node_id_solver ne in
      NodeStaticArgEff (id, neff.node_key_eff)
   (* node exp vs node *)
   | (StaticArgNode (Predef_n (op,sargs)), ASP_node id) ->
      (* ICI : campagne de suppression de Eff.PREDEF_CALL: pas de macros ! *)
      assert (sargs = []);
      let opeff = PredefEvalType.make_node_exp_eff node_id_solver None op.it sa.src [] in
      NodeStaticArgEff (id, opeff.node_key_eff)
   | (_, ASP_type _) -> nature_error "type"
   | (_, ASP_const _) -> nature_error "constant"
   | (_, ASP_node _) -> nature_error "node"
   in res
)
        
(******************************************************************************)

(* exported *)
and (of_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(op, sargs) -> (
                  (* 12/07 SOLUTION INTERMEDIAIRE 
                     - les macros predefs ne sont plus  traites ici
                       on les transforme en CALL standard 
                     N.B. on garde pour l'instant la notion de 
                     PREDEF_CALL pour les op simple, mais  terme 
                     a devrait disparaitre aussi ...
                  *)
                  (* OBSOLETE 
                   try translate_predef_macro id_solver lxm op sargs (s, vel_eff)
                   with Not_found -> 
                      assert (sargs=[]);
                      s, mk_by_pos_op(PREDEF_CALL (op,[]))
                   *)
                     match sargs with
                     | [] -> s, mk_by_pos_op(PREDEF_CALL (op.it,[]))
                     | _ -> 
                     (* on re-construit une SyntaxTreeCore.node_exp srcflagged
                        parce que c'est ca qu'attend of_node ...
                     *)
                     let node_exp_f = flagit (Predef.op_to_idref op.it, sargs) op.src in
                     let neff = of_node id_solver node_exp_f in
                     let ceff = Eff.CALL (flagit neff.node_key_eff node_exp_f.src) in
                     Verbose.exe ~flag:dbg (fun () ->
                        Printf.fprintf stderr "#DBG: GetEff.translate_val_exp CALL '%!";
                        SyntaxTreeDump.print_node_exp stderr node_exp_f.it;
                        Printf.fprintf stderr " gives type: %s\n%!"
                           (Eff.string_of_type_profile (profile_of_node_exp neff))
                     ) ;
                     (s, mk_by_pos_op ceff)
                )
                | CALL_n node_exp_f -> 
                    let neff = of_node id_solver node_exp_f in
                    let ceff = Eff.CALL (flagit neff.node_key_eff node_exp_f.src) in
                    Verbose.exe ~flag:dbg (fun () ->
                       Printf.fprintf stderr "#DBG: GetEff.translate_val_exp CALL_n ";
                       SyntaxTreeDump.print_node_exp stderr node_exp_f.it;
                       Printf.fprintf stderr " gives type: %s\n%!"
                         (Eff.string_of_type_profile (profile_of_node_exp neff))
                    ) ;
                    (s, mk_by_pos_op ceff)
                | IDENT_n idref -> (
                   try
                     let var = id_solver.id2var idref lxm in
                     s, mk_by_pos_op(Eff.VAR_REF var.var_name_eff)
                   with _ ->
                      let s, const = UnifyClock.const_to_val_eff lxm false s
                        (id_solver.id2const idref lxm)
                      in
                        s, const.ve_core
                ) 
(* OBSOLETE et un peu faux ?
                | IDENT_n idref -> (
                    try 
                      let s, const = UnifyClock.const_to_val_eff lxm false s
                        (id_solver.id2const idref lxm)
                      in
                        s, const.ve_core
                    with 
                      | Unknown_constant _ -> (* In case idref is not a static constant. *) (
                          match Ident.pack_of_idref idref with
                            | Some pn -> s, mk_by_pos_op(Eff.CONST_REF 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.global_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 { ve_core=vef_core; ve_typ=[]; ve_clk = [] } in
    let vef, _, s =  EvalClock.f lxm id_solver s vef [] in
      s, vef

(*
OBSOLETE
Un peu ad hoc :
- on traite  part,
- on peut sans doute faire plus propre ?
--> raise Not_found 
and translate_predef_macro id_solver lxm zemacro sargs (s,vel_eff) =
   (* ??? *)
   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

   (* Vrif lgre du profil statique : vrifie si le nombre et la nature
      d'arg peut convenir *)
   let sargs_eff = translate_predef_static_args id_solver zemacro.it sargs lxm in
   (* Vrif complte du type, on utilise des fonctions ad hoc pour
      chaque macro predef, (AFAIRE : pas trs beau ...)
      N.B. le resultat est un Eff.node_profile = ins -> outs
      o les in/out sont des ident * type_
    *)
   let iter_profile = match zemacro.it with
   | Map ->
      PredefEvalType.map_profile id_solver lxm sargs_eff
   | Fill | Red | FillRed ->
      PredefEvalType.fillred_profile id_solver lxm sargs_eff
   | BoolRed ->
      PredefEvalType.boolred_profile id_solver lxm sargs_eff
   | CondAct ->
      PredefEvalType.condact_profile id_solver lxm sargs_eff
   | _  -> raise Not_found
   in

   (* Filtre uniquement la liste des types d'entres attendus *)
   let type_l_exp = snd (List.split (fst iter_profile)) in
                    
   (* Correction ventuelle des static args par le
      "any(num)" ncssaire  l'unification des 
      types d'entre AFAIRE : moche moche ...
   *)
   let sargs_eff = 
      if List.length type_l <> List.length type_l_exp then
         let str = Printf.sprintf 
            "the iterator has a wrong arity: %s instead of %s"
               (string_of_int (List.length type_l))
               (string_of_int (List.length type_l_exp))
                        
         in
         raise (Compile_error(lxm, str))
      else
         let tmatches = try UnifyType.is_matched type_l_exp type_l
         with UnifyType.Match_failed msg -> raise (Compile_error(lxm,  msg))
         in
         match tmatches with
         | [] -> sargs_eff
         | _ -> 
            (** ICI Est-ce qu'on garde la match ?
               peut-tre qq chose  faire mais
               sans doute pas le 'instanciate_type' *)         
            sargs_eff
   in
(*
         match U nifyType.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 MISSING type variable was [typ]. 
         *)
            (* dump_polymorphic_nodes typ; *)
            List.map (instanciate_type typ) sargs_eff
         | UnifyType.Ko str -> raise (Compile_error(lxm,  str))
*)
   let mk_by_pos_op by_pos_op_eff =
      CallByPosEff(flagit by_pos_op_eff lxm, OperEff vel_eff)
   in s, mk_by_pos_op (Eff.PREDEF_CALL(zemacro.it, sargs_eff)) 
*) 

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.global_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 ? 
   node_of_static_arg : appel QUAND ON SAIT qu'un sarg doit etre un NODE
   const_of_static_arg : appel QUAND ON SAIT qu'un sarg doit etre une CONST

   -> sert pour les macros predefs
   ca fait partie de la definition des iterateurs d'une certaine maniere...
   -> crer 2 modules, Iterator + IteratorSemantics 
*)
and const_of_static_arg id_solver const_or_const_ident lxm = 
  match const_or_const_ident with
    | StaticArgConst(c) -> (
		match EvalConst.f id_solver c with
		| [x] -> x
		| xl -> 
			(* EvalConst.f ne fabrique PAS de tuple, on le fait ici *)
			Tuple_const_eff xl
	 )
    | StaticArgIdent(id) -> id_solver.id2const id lxm 
    | StaticArgType _
    | StaticArgNode _ -> raise (Compile_error(lxm, "a constant was expected"))



and node_of_static_arg 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) -> of_node id_solver ne
    | StaticArgNode(Predef_n (op,sargs)) ->
        let sargs_eff = translate_predef_static_args id_solver op.it sargs lxm in
          PredefEvalType.make_node_exp_eff id_solver None op.it lxm sargs_eff 
    | StaticArgNode(_) -> assert false

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


(** OBSOLETE 
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, sargs),il,ol),neff) ->
       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
            let neff = { 
              neff with 
                node_key_eff = (node,sargs);
                inlist_eff = il;
                outlist_eff = ol;
            }
            in
         NodeStaticArgEff(id,((node,sargs),il,ol),neff)
*)

(* exported *)
and translate_predef_static_args
   (id_solver: Eff.id_solver)
   (op: Predef.op)
   (sargs: SyntaxTreeCore.static_arg srcflagged list)
   (lxm: Lxm.t) : Eff.static_arg list = 

   match op with
   | BoolRed -> (
      (* expects 3 constants *)
      match sargs with
      | [c1; c2; c3] ->
         [
            ConstStaticArgEff(Ident.of_string "min", const_of_static_arg id_solver c1.it c1.src);
            ConstStaticArgEff(Ident.of_string "max", const_of_static_arg id_solver c2.it c2.src);
            ConstStaticArgEff(Ident.of_string "size",const_of_static_arg id_solver c3.it c3.src)
         ]
      | _ -> raise (Compile_error(lxm, "bad arguments number for boolred iterator"))
   )
   | Map | Fill | Red | FillRed -> (
      (* expects 1 node, 1 constant *)
      match sargs with
      | [n; s] ->
          let node_eff = node_of_static_arg id_solver n.it n.src in
          (* OBSO *)
          (* let node_arg = node_eff.node_key_eff, node_eff.inlist_eff, node_eff.outlist_eff in *)
          [
            NodeStaticArgEff(Ident.of_string "node", node_eff.node_key_eff);
            ConstStaticArgEff(Ident.of_string "size", const_of_static_arg id_solver s.it s.src)
          ]
      | _ -> raise (Compile_error(lxm, "bad arguments number for array iterator"))
   )
   | CondAct -> (
      (* expects 1 node, 1 (tuple) constant *)
      match sargs with
      | [n; d] ->
(*
(match d.it with StaticArgConst ve ->
	Printf.fprintf stdout "=== default =";
	SyntaxTreeDump.print_val_exp stdout ve;
	Printf.fprintf stdout "\n\n";
);
*)

         let node_eff = node_of_static_arg id_solver n.it n.src in
         (* let node_arg = node_eff.node_key_eff, node_eff.inlist_eff, node_eff.outlist_eff in *)
			let dflt = const_of_static_arg id_solver d.it d.src in

         [
            NodeStaticArgEff(Ident.of_string "node", node_eff.node_key_eff);
            ConstStaticArgEff(Ident.of_string "default", dflt)
         ]
      | _ -> raise (Compile_error(lxm, "bad arguments number for condact macro"))
   )
   | _ -> (
      (* expects 0 sargs ! *)
      match sargs with
      | [] -> []
      | _ ->  
         raise (Compile_error(lxm, "bad arguments number for predef macro"))
   )

            
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 (of_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 " 
               ^ (Eff.string_of_type 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
      

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