solveIdent.ml

(** Time-stamp: <modified the 23/10/2008 (at 10:53) by Erwan Jahier> *)


let (get_predef : Ident.idref -> Predef.op option) =
  fun idref -> 
    let get_op () =
      try Some (Predef.string_to_op (Ident.to_string (Ident.name_of_idref idref)))
      with Not_found -> None
    in
    match Ident.pack_of_idref idref with
      | None -> get_op () (* The Lustre package is used by default *) 
      | Some p -> if (Ident.pack_name_to_string p) = "Lustre" then get_op () else None

open SyntaxTree
open SyntaxTreeCore
open Lxm

let flag f x_flg = Lxm.flagit (f x_flg.it) x_flg.src

let fopt f = function None -> None | Some x -> Some (f x)


(* just a tedious recursive traversal of the syntax tree, replacing idref
   that match predef op with the Predef constructor *)
(* exported *)
let rec (recognize_predef_op : SyntaxTree.t -> SyntaxTree.t) = function
  | PRPackBody(sl,pb) -> PRPackBody(sl, r_packbody pb)
  | PRPack_or_models(sl,pml) -> PRPack_or_models(sl,List.map r_pack_or_model pml)

and r_pack_or_model = function   
  | NSPack(pi) -> NSPack(flag r_pack_info pi)
  | NSModel(mi) -> NSModel(flag r_model_info mi)

and r_pack_info pi = { pi with pa_def = r_pack_def pi.pa_def } 

and r_model_info mi = 
  { mi with 
      mo_needs = List.map (flag r_static_param) mi.mo_needs;
      mo_provides = r_item_info_flg_list mi.mo_provides;
      mo_body = r_packbody  mi.mo_body;
  }

and r_pack_def = function
  | PackGiven(pg) -> PackGiven(r_pack_given pg)
  | PackInstance(pi) -> PackInstance(r_pack_instance pi)

and r_pack_given pg = { 
  pg with
    pg_provides = r_item_info_flg_list pg.pg_provides;
    pg_body = r_packbody pg.pg_body;
}

and r_pack_instance pi = { pi with pi_args = List.map r_by_name_static_arg pi.pi_args }

and r_static_param sp = sp 

and r_by_name_static_arg (id,arg) = 
  let arg_it = 
    match arg.it with
      | StaticArgIdent(idref) -> (
          match get_predef idref with
	    | None -> StaticArgIdent idref
	    | Some predef -> StaticArgNode (Predef_n (predef,[]))
        )
      | StaticArgConst(ve) -> StaticArgConst(r_val_exp ve)
      | StaticArgType(te) -> StaticArgType(te)
      | StaticArgNode(by_pos_op) -> StaticArgNode(r_by_pos_op by_pos_op)
  in
    id, Lxm.flagit arg_it arg.src

and r_static_arg arg = 
  match arg with
    | StaticArgIdent(idref) -> (
        match get_predef idref with
	  | None -> StaticArgIdent idref
	  | Some predef -> StaticArgNode (Predef_n (predef,[]))
      )
    | StaticArgConst(ve) -> StaticArgConst(r_val_exp ve)
    | StaticArgType(te) -> StaticArgType(te)
    | StaticArgNode(by_pos_op) -> StaticArgNode(r_by_pos_op by_pos_op)

and r_by_pos_op = function
  | Predef_n(op,args)  -> Predef_n(op,args) (* assert false *)
  | CALL_n { src=lxm;it=(idref,sargs) } -> (
      match get_predef idref with
	| None -> CALL_n { src=lxm;it= r_node_exp (idref,sargs) }
	| Some op -> Predef_n (op, List.map (flag r_static_arg)  sargs)
    )
  | IDENT_n(idref) -> (
      match get_predef idref with
	| None -> IDENT_n(idref)
	| Some op -> Predef_n (op,[])
    )
  | ARRAY_ACCES_n(val_exp) -> ARRAY_ACCES_n(r_val_exp val_exp)
  | ARRAY_SLICE_n(slice_info) -> ARRAY_SLICE_n(r_slice_info slice_info)

  | x -> x

and r_node_exp (idref, sargs) =
  (idref, List.map (flag r_static_arg) sargs)

  
and r_slice_info si = {
  si_first = r_val_exp si.si_first;
  si_last  = r_val_exp si.si_last;
  si_step  = fopt r_val_exp si.si_step;
}

and r_val_exp = function
  | CallByPos (by_pos_op, Oper vel) -> 
      CallByPos(flag r_by_pos_op by_pos_op, Oper (List.map r_val_exp vel))
  | CallByName(by_name_op, args) -> 
      CallByName(by_name_op, List.map (fun (id, ve) -> id, r_val_exp ve) args)

and r_item_info_flg_list = function
  | None -> None
  | Some iil -> Some (List.map (flag r_item_info) iil)

and r_item_info = function
  | ConstInfo ci -> ConstInfo(r_const_info ci)
  | TypeInfo  ti -> TypeInfo (r_type_info ti)
  | NodeInfo  ni -> NodeInfo (r_node_info ni)

and r_const_info = function
  | ExternalConst(id,te,ve_opt) -> ExternalConst(id,te, fopt r_val_exp ve_opt)
  | EnumConst(id,te) -> EnumConst(id,te)
  | DefinedConst(id,te,ve) -> DefinedConst(id,te, r_val_exp ve)

and r_type_info = function 
  | ExternalType(id) -> ExternalType(id)
  | AliasedType(id,te) -> AliasedType(id,te)
  | EnumType(id,te) -> EnumType(id,te)
  | StructType(sti) -> StructType(r_struct_type_info sti)
  | ArrayType(id,te,ve) -> ArrayType(id,te, r_val_exp ve)

and r_node_info ni = {
  ni with
    static_params = List.map (flag r_static_param) ni.static_params;
    def = r_node_def ni.def;
}
and r_struct_type_info sti =
  Hashtbl.iter 
    (fun id fi -> Hashtbl.replace sti.st_ftable id (flag r_field_info fi)) 
    sti.st_ftable;
  sti

and r_field_info fi = { fi with fd_value = fopt r_val_exp fi.fd_value }

and r_node_def = function
  | Extern -> Extern
  | Abstract -> Abstract
  | Body(node_body) -> Body(r_node_body node_body)
  | Alias(by_pos_op) -> Alias(flag r_by_pos_op by_pos_op)

and r_packbody pb = 
  Hashtbl.iter 
    (fun id i -> Hashtbl.replace pb.pk_const_table id (flag r_const_info i))
       pb.pk_const_table;
  Hashtbl.iter
    (fun id i -> Hashtbl.replace pb.pk_type_table id (flag r_type_info i)) 
    pb.pk_type_table;
  Hashtbl.iter 
    (fun id i -> Hashtbl.replace pb.pk_node_table id (flag r_node_info i)) 
    pb.pk_node_table;
  pb

and r_node_body nb = {
  asserts = List.map (flag r_val_exp) nb.asserts;
  eqs     = List.map (flag r_eq_info) nb.eqs;
}
and r_eq_info (lpl,ve) = (List.map r_left_part lpl, r_val_exp ve)

and r_left_part = function 
  | LeftVar(id) -> LeftVar(id)
  | LeftField(lp,id) -> LeftField(r_left_part lp,id)
  | LeftArray(lp,ve) -> LeftArray(r_left_part lp, flag r_val_exp ve)  
  | LeftSlice(lp,si) -> LeftSlice(r_left_part lp, flag r_slice_info si)