parserUtils.ml

(** Time-stamp: <modified the 01/09/2008 (at 16:59) by jahier> *)



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

open Lxm
open SyntaxTree
open SyntaxTreeCore
open Predef

let (build_node_var : var_info srcflagged list -> var_info srcflagged list -> 
      var_info srcflagged list option -> node_vars) =
  fun invars outvars locvars_opt -> 
    let get_var_name vif = vif.it.var_name in
      {
        inlist  = List.map get_var_name invars;
        outlist = List.map get_var_name outvars;
        loclist = (
          match locvars_opt with
            | None -> None
            | Some locvars -> Some (List.map get_var_name locvars)
        );
        vartable = 
          let tbl = Hashtbl.create 0 in
          let add_var_in_tbl vif = Hashtbl.add tbl vif.it.var_name vif in
            List.iter add_var_in_tbl invars;
            List.iter add_var_in_tbl outvars;
            (match locvars_opt with
               | None -> ()
               | Some locvars -> List.iter add_var_in_tbl locvars
            );
            tbl;
      }

(* Une collection de "meta fonctions" pour faciliter la vie *)


(*------------------------------------------------------
flat_flagged_list
--------------------------------------------------------
Entre :
--------
- inlist : ('a list * 'b) list
- makeitem : 'a -> 'b -> c' 
--------------------------------------------------------
Sortie :
--------
- outlist : c' list
--------------------------------------------------------
Effets de bords :
---------------
- aucun en interne
- makeitem est appele de gauche  droite
--------------------------------------------------------
Exemple :
-----------------
flat_flagged_list [ ([a1;a2;a3], b1) ; ([a4;a5], b2) ] f
<=>
let c1 = (f a1 b1) in
let c2 = (f a2 b1) in
let c3 = (f a3 b1) in
let c4 = (f a4 b2) in
let c5 = (f a5 b2) in
[ c1; c2; c3; c4; c5 ]
------------------------------------------------------*)
let flat_flagged_list 
    (inlist:   ('a list * 'b) list)
    (makeitem: 'a -> 'b -> 'c) 
    = (
      (*g: concatene les 'c list*)
      let g (cl: 'c  list) ((al: 'a list) , (b: 'b)) = (
        (*f: fabrique un 'c *)
        let f (a: 'a) = makeitem a b in 
          List.append cl (List.map f al) 
      ) in 
        (*on folde g sur inlist*)
        List.fold_left g [] inlist
    )

let _ = assert (
  (flat_flagged_list 
     [ (["a1";"a2";"a3"], "b1") ; (["a4";"a5"], "b2") ] 
     (fun a b -> a ^ "-" ^ b))
  = 
    ["a1-b1"; "a2-b1"; "a3-b1"; "a4-b2"; "a5-b2"]
  )

(*------------------------------------------------------
flat_twiced_flagged_list
--------------------------------------------------------
mme principe mais avec deux niveaux de flags :

let mk a b c = (a,b,c)

let toto =
[
([ ([1;2;3], "a"); ([4;5], "b") ], "X") ;
([ ([6], "c"); ([7;8], "d"); ([9], "e")  ], "Y") ;
( [ ([10], "f") ]   , "Z")
]

  let l = flat_twice_flagged_list toto mk
  ------------------------------------------------------*)
let flat_twice_flagged_list 
    (inlist:   (('a list * 'b) list * 'c) list )
    (makeitem: 'a -> 'b -> 'c -> 'd ) 
    = (
      let g (dl: 'd list) ((albl: ('a list * 'b) list), (c: 'c)) = (
        let h (dl: 'd list) ((al: 'a list), (b: 'b)) = (
          let f (a: 'a) = makeitem a b c in
            List.append dl (List.map f al)
        ) in
          List.fold_left h dl albl
      ) in
        List.fold_left g [] inlist
    )

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

(** Utilitaries to build [val_exp]  *)

let leafexp lxm op = CallByPos({src = lxm ; it = op }, Oper [])

let unexp lxm op e1 = CallByPos( {src = lxm ; it = op }, Oper [e1] )    
let unexp_predef lxm op e1 = CallByPos( {src = lxm ; it = Predef_n (op,[]) }, Oper [e1] )

let binexp lxm op e1 e2 = CallByPos( {src = lxm ; it = op }, Oper [e1 ; e2] ) 
let binexp_predef lxm op e1 e2 = CallByPos( {src = lxm ; it = Predef_n (op,[]) }, 
                                            Oper [e1 ; e2] ) 

let ternexp lxm op e1 e2 e3 = CallByPos( {src = lxm ; it = op }, Oper [e1 ; e2; e3] )
let ternexp_predef lxm op e1 e2 e3 = CallByPos( {src = lxm ; it = Predef_n (op,[]) }, 
                                                Oper [e1 ; e2; e3] )

let naryexp lxm op elst = CallByPos( {src = lxm ; it = op }, Oper elst )        
let naryexp_predef lxm op elst = CallByPos( {src = lxm ; it = Predef_n (op,[]) }, 
                                            Oper elst )


let bynameexp lxm op nelst = CallByName( {src = lxm ; it = op } , nelst )

open Ident


(**********************************************************************************)
(* Interface avec SyntaxTree *)
let idref_of_lxm lxm =
  try Lxm.flagit (Ident.idref_of_string (Lxm.str lxm)) lxm
  with _ ->
    print_string  ("Parser.idref_of_lxm" ^(Lxm.str lxm));
    assert false


(**********************************************************************************)
(** add_info
-----------------------------------------------------------------------
Rle :
        proc gnrique pour mettre une info 'a dans
         une table (Ident.t, 'a srcflagged).

Effets de bord :
        erreur de compil si dj utilis
*)
let (add_info : (Ident.t, 'a srcflagged) Hashtbl.t -> 
      string -> (* une string en cas d'erreur   *)
      Lxm.t ->  (* le lexeme en question        *)
      'a ->     (* l'info en question           *)
      unit) = 
  fun htbl kindof lxm info -> 
    try
      let x  = Hashtbl.find htbl (Lxm.id lxm) in 
        raise (
          Errors.Compile_error ( 
            lxm, 
            Printf.sprintf "bad %s declaration, ident already linked at %s" kindof 
              (Lxm.position x.src)
          )
        )
    with Not_found ->
      Hashtbl.add htbl (Lxm.id lxm) { src = lxm ; it  = info }
        

(**********************************************************************************)
(* local tables used to store (via [add_info], see above) intermediary results 

   Most of the function below (treat_<something>) returns unit but modifies
   one or several of those tables.
*)

let (const_table:(Ident.t, const_info srcflagged) Hashtbl.t) = Hashtbl.create 50 
let (type_table :(Ident.t, type_info  srcflagged) Hashtbl.t) = Hashtbl.create 50
let (node_table :(Ident.t, node_info  srcflagged) Hashtbl.t) = Hashtbl.create 50
let (def_list : item_ident list ref) = ref []

  
(**********************************************************************************)
(** Traitement des listes d'idents avec valeur ventuelle
    (constantes, champs de struct etc...)
*)

let (lexeme_to_ident_flagged: Lxm.t -> Ident.t Lxm.srcflagged) = 
  fun x -> {it = (Lxm.id x); src = x }

let (lexeme_to_pack_name_flagged:Lxm.t -> Ident.pack_name  Lxm.srcflagged) = 
  fun x -> {it = (Ident.pack_name_of_string (Lxm.str x)); src = x }


(* Listes d'idents typs et (ventuellement) valus *)
type id_valopt = (Lxm.t * type_exp * val_exp option)

(* Pas de valeur : le type distribue sur une liste d'ident *)
let id_valopt_list_of_id_list (idlist : Lxm.t list) (texp : type_exp) = 
  let treat_id (id : Lxm.t) = (id, texp, None) in 
    List.map treat_id idlist

(* Avec valeur : il ne doit y avoir qu'un seul ident *) 
let id_valopt_of_id_val (id : Lxm.t) (texp : type_exp) (vexp : val_exp) = (* -> unit *)
  (id, texp, Some vexp)

let treat_external_const_list lst typ = (* -> unit *)
  let f = function lxm ->
    add_info const_table "constant" lxm (ExternalConst ((Lxm.id lxm), typ, None));
    def_list := (ConstItem (Lxm.id lxm)) :: !def_list
  in 
    List.iter f lst


let treat_defined_const lxm typ exp = (* -> unit *)
  add_info const_table "constant" lxm (DefinedConst ((Lxm.id lxm) , typ, exp));
  def_list := (ConstItem (Lxm.id lxm)) :: !def_list

let treat_external_type_list lxmlst = (* -> unit *)
  let f = function lxm ->
    add_info type_table "type" lxm (ExternalType (Lxm.id lxm)) ;
    def_list := (TypeItem (Lxm.id lxm)) :: !def_list
  in
    List.iter f lxmlst 


let treat_aliased_type lxm typexp = (*  -> unit *)
  add_info type_table "type" lxm (AliasedType ((Lxm.id lxm), typexp));
  def_list := (TypeItem (Lxm.id lxm)) :: !def_list


(**********************************************************************************)
(* Traitement d'un type numr   *)
let (treat_enum_type : Lxm.t -> Lxm.t list -> unit) =
  fun 
    typlxm (* le lexeme du type *) 
    cstlxmlst (* liste des lexemes des valeurs *) 
    -> 
    let cstnamelist = List.map lexeme_to_ident_flagged cstlxmlst in 
      (* Enfin, on introduit la dfinition du type *)
    let typstr = Lxm.id typlxm in
      add_info type_table "type" typlxm (EnumType (typstr, cstnamelist));
      def_list := (TypeItem typstr) :: !def_list

(**********************************************************************************)
(* Traitement d'un type structure *)
let (make_struct_type_info :  Lxm.t -> id_valopt list (* la liste des champs *) -> 
      struct_type_info) =
  fun typlxm flexlist -> 
    (* On anticipe la construction de la table de champs *)
    let ftab = Hashtbl.create 50 in
    let (put_in_ftab : (Lxm.t * type_exp * val_exp option) -> Ident.t) =
      (* Traitement d'un champ lmentaire *)
      fun (lx, ty, va) -> 
        (* fabrique le field_info *)
        let lxstr = Lxm.id lx in
        let fi = { fd_name = lxstr ; fd_type = ty ; fd_value = va } in
          (* le range dans ftab *)
          add_info ftab "field" lx fi;
          lxstr (* renvoie juste le nom du champs *)
    in
    let flst = List.map put_in_ftab flexlist in
      { st_name = Lxm.id typlxm ; st_flist = flst ; st_ftable = ftab }


(**********************************************************************************)
let treat_struct_type
    (typlxm :  Lxm.t) (* le lexeme du nom de type *)
    (flexlist: id_valopt list) (* la liste des champs *)
    =  (* sortie: unit *)
  let typstr = Lxm.id typlxm in
  let typinfo = StructType 
    (make_struct_type_info typlxm flexlist)
  in
    (* met l'info dans la table des types *)
    add_info type_table "type" typlxm typinfo ;
    def_list := (TypeItem typstr) :: !def_list
  

(**********************************************************************************)
(********************************************)
(* Dclarations de vars et params de noeuds *)
(********************************************)
(*
Un peu coton  cause des types, clocks,
et de la syntaxe laxiste sur la distribution
de ces flags dans les dclarations de variables !
On utilise un artifice local pour
homogniser le traitements de listes de vars :
- clocked_ids list
*) 
type typed_ids = (Lxm.t list * type_exp)    
type clocked_ids = (typed_ids list * clock_exp)

let (clocked_ids_to_var_infos : var_nature -> 
      (((Lxm.t list) * type_exp) list * SyntaxTreeCore.clock_exp) list -> 
      var_info srcflagged list) =
  fun vnat vdefs ->
    let i = ref 0 in
    let makevar lxm te ce =
      let res =
        Lxm.flagit 
          {
            var_nature = vnat;
            var_name = (Lxm.id lxm);
            var_number = !i;
            var_type = te;
            var_clock = ce;
          }
          lxm
      in
        incr i;
        res
    in
      flat_twice_flagged_list vdefs makevar


(**********************************************************************************)
let (treat_node_decl : bool -> Lxm.t -> static_param srcflagged list -> 
      clocked_ids list (* entres *) -> 
      clocked_ids list (* sorties *) -> 
      clocked_ids list (* locales *) -> 
      (val_exp srcflagged) list (* assserts *) -> 
      (eq_info srcflagged) list (* liste des equations *) -> 
      unit
    ) =
  fun has_memory nlxm statics indefs outdefs locdefs asserts eqs -> 
    let vtable = Hashtbl.create 50 in
    let rec (treat_vars : clocked_ids list -> var_nature -> var_info srcflagged list) =
      (* Procedure de traitement des in, out ou loc, paramtre par la [var_nature] *)
      fun vdefs nat -> 
        let i = ref 0 in
          match vdefs with
            | [] -> []
            | (tids, ck)::reste ->
                let put_var_in_table (lxm: Lxm.t) (ty: type_exp) =
                  let vinfo = {
                    var_nature = nat; var_name = (Lxm.id lxm); 
                    var_type = ty; var_clock = ck; var_number = !i
                  }
                  in
                    incr i;
                    add_info vtable "variable" lxm vinfo;
                    Lxm.flagit vinfo lxm 
                in
                  (flat_flagged_list tids put_var_in_table) 
                  @ (treat_vars reste nat)
    in
    let invars  = treat_vars indefs  VarInput 
    and outvars = treat_vars outdefs VarOutput 
    and locvars = treat_vars locdefs VarLocal 
    in 
    let vars = build_node_var invars outvars (Some locvars) in
    let nstr = Lxm.id nlxm in
    let ninfo = {
      name = nstr;
      static_params = statics;
      vars    = Some vars;
      def     = Body { asserts = asserts ; eqs  = eqs };
      has_mem = has_memory;
      is_safe = true;
    }
    in
      add_info node_table "node" nlxm ninfo;
      def_list := (NodeItem (nstr,statics)) :: !def_list


(**********************************************************************************)
let (treat_node_alias : bool -> Lxm.t -> static_param srcflagged list -> 
      (var_info srcflagged list * var_info srcflagged list) option -> 
      node_exp srcflagged -> unit) = 
  fun has_memory nlxm statics node_profile value -> 
    let nstr = Lxm.id nlxm in
    let vars = 
      match node_profile with
        | None -> None
        | Some (invars,outvars) -> Some (build_node_var invars outvars None)
    in
    let ninfo = {
      name = nstr;
      static_params = statics;
      vars    = vars;
      def     = Alias (flagit (CALL_n value) value.src);
      has_mem = has_memory;
      is_safe = true;
    }
    in
      add_info node_table "(alias) node" nlxm ninfo;
      def_list := (NodeItem (nstr,statics)) :: !def_list
 
  

(**********************************************************************************)
(* Traitement d'un noeud abstrait *)

let treat_abstract_or_extern_node_do (* cf the profile of [treat_abstract_node] *)
    has_memory lxm inpars outpars is_abstract =
  let (invars, outvars : var_info srcflagged list * var_info srcflagged list) = 
    clocked_ids_to_var_infos VarInput  inpars,
    clocked_ids_to_var_infos VarOutput outpars 
  in
  let vars = build_node_var invars outvars None in
  let xn = {
    name = Lxm.id lxm;
    static_params = [];
    vars    = Some vars;
    def     = if is_abstract then Abstract else Extern;
    has_mem = has_memory;
    is_safe = true;
  }
  in
    xn

let (treat_abstract_node : bool -> Lxm.t -> 
      (((Lxm.t list) * type_exp) list * SyntaxTreeCore.clock_exp) list -> 
      (((Lxm.t list) * type_exp) list * SyntaxTreeCore.clock_exp) list -> 
      item_info Lxm.srcflagged) =
  fun has_memory lxm inpars outpars ->
    Lxm.flagit 
      (NodeInfo (treat_abstract_or_extern_node_do has_memory lxm inpars outpars true))
      lxm

  
(**********************************************************************************)
let (treat_external_node : bool -> Lxm.t -> 
      (((Lxm.t list) * type_exp) list  * SyntaxTreeCore.clock_exp) list -> 
      (((Lxm.t list) * type_exp) list  * SyntaxTreeCore.clock_exp) list -> 
      unit
    ) =
  fun has_memory ext_nodelxm inpars outpars -> 
    let ninfo = 
      treat_abstract_or_extern_node_do (* external nodes look like abstract nodes indeed *)
        has_memory ext_nodelxm inpars outpars false
    in
    let statics = [] in (* no static args for external node (for now at least) *)
      add_info node_table "(extern) node" ext_nodelxm ninfo ;
      def_list := (NodeItem (Lxm.id (ext_nodelxm),statics)) :: !def_list
  
(**********************************************************************************)
let (threat_slice_start : Lxm.t -> val_exp -> val_exp option -> slice_info srcflagged) =
  fun lxm last step ->
    let str = Lxm.str lxm in
    let int_to_val_exp  istr =
      try 
        ignore (int_of_string istr);
        CallByPos(flagit (Predef_n(ICONST_n (Ident.of_string(istr)),[])) lxm,
                  Oper [])
      with _ ->
        CallByPos(flagit (IDENT_n (Ident.idref_of_string(istr))) lxm,
                  Oper [])
    in
      match Str.split (Str.regexp (Str.quote "..")) str with
        | [first] ->
            let slice_info = 
              { 
                si_first = int_to_val_exp first; 
                si_last = last; 
                si_step = step
              }
            in 
              flagit slice_info lxm
        | _ -> assert false


let (make_ident : Lxm.t -> pragma list -> Lxm.t) =
  fun lxm pl -> 
    if pl = [] then lxm else Lxm.add_pragma lxm pl