symbolTab.ml

(** Time-stamp: <modified the 04/02/2009 (at 11:04) by Erwan Jahier> *)

(*
Sous-module pour SyntaxTab 
*)
open Lxm
open SyntaxTree
open SyntaxTreeCore
open Errors

type 'a elt =
  | Local of 'a
  | Imported of Ident.long * static_param srcflagged list

type t = {
  st_consts: (Ident.t , (Ident.pack_name * const_info srcflagged elt)) Hashtbl.t ;
  st_types : (Ident.t , (Ident.pack_name * type_info  srcflagged elt)) Hashtbl.t ;
  st_nodes : (Ident.t , (node_info  srcflagged) elt) Hashtbl.t ;
} 

(* Création/initialisation d'une symbol_tab *)
let create () = 
  let consts_tbl = Hashtbl.create 50
  and types_tbl  = Hashtbl.create 50
  and nodes_tbl  = Hashtbl.create 50
  in
    {
      st_consts = consts_tbl;
      st_types  = types_tbl;
      st_nodes  = nodes_tbl;
    }

let find_type (this: t) (id: Ident.t) lxm =
  try snd (Hashtbl.find (this.st_types) id)
  with Not_found -> 
    raise (Compile_error(lxm, "unknown type (" ^ (Ident.to_string id)^")"))

let find_pack_of_type (this: t) (id: Ident.t) lxm =
  try fst (Hashtbl.find (this.st_types) id)
  with Not_found -> 
    raise (Compile_error(lxm, "unknown type (" ^ (Ident.to_string id)^")"))

  
let find_const (this: t) (id: Ident.t) lxm = 
  try snd (Hashtbl.find (this.st_consts) id)
  with Not_found -> 
    raise (Compile_error(lxm, "unknown constant (" ^ (Ident.to_string id) ^")"))

let find_pack_of_const (this: t) (id: Ident.t) lxm = 
  try fst (Hashtbl.find (this.st_consts) id)
  with Not_found -> 
    raise (Compile_error(lxm, "unknown constant (" ^ (Ident.to_string id) ^")"))


let find_node (this: t) (id: Ident.t) lxm =
  try Hashtbl.find (this.st_nodes) id
  with Not_found -> 
    if Lxm.line lxm = 0 && Lxm.cend lxm = 0 then
      (* A hack to print a nicer error msg when the node asked in the 
	 command-line is not found in the input files*)
      raise (Global_error("Can not find node " ^ (Ident.to_string id)^
			    " in " ^ (Lxm.file lxm)))
    else
      let all_nodes = 
        Hashtbl.fold (fun n _ acc -> (Ident.to_string n)::acc) this.st_nodes [] 
      in
      let msg = "unknown node: " ^ (Ident.to_string id)^"\n" ^ 
        "*** known nodes are: " ^ (String.concat ", " all_nodes) ^ "\n"
      in
        raise (Compile_error(lxm, msg))


(* Manip de SymbolTab.t *)
let add_import_const (this: t) (pn:Ident.pack_name) (id: Ident.t) (aid: Ident.long) =
  Hashtbl.replace (this.st_consts) id (pn, Imported (aid, []))

let add_import_type (this: t) (id: Ident.t) (aid: Ident.long) =
  Hashtbl.replace (this.st_types) id (Ident.pack_of_long aid, Imported (aid, []))

let add_import_node (this: t) (id: Ident.t) (aid: Ident.long) 
    (params:static_param srcflagged list) =
  Hashtbl.replace (this.st_nodes) id (Imported (aid, params))

let add_const (this: t) (pn:Ident.pack_name) (n: Ident.t) 
    (cix: (const_info  srcflagged)) =
  Hashtbl.replace this.st_consts n (pn, Local cix)

let add_type (this: t) pn (n: Ident.t) (tix: type_info srcflagged) = (
  Hashtbl.replace this.st_types n (pn, Local tix) ;
  (* cas particulier des types enums *)
  match tix.it with
      EnumType (_, ecl) -> (
	let tname = Lxm.str tix.src in
	let treat_enum_const ec = (
	  let te = Named_type_exp { Ident.id_pack = None; Ident.id_id = tname} in
	  let tex = Lxm.flagit te tix.src in
	  let ci = EnumConst (ec.it, tex) in
	    add_const this pn ec.it (Lxm.flagit ci (ec.src));
	    add_const this pn ec.it (Lxm.flagit ci (ec.src))
	) in
	  List.iter treat_enum_const ecl
      )
    | _ -> ()
)

let add_node (this: t) (n: Ident.t) (oix: node_info  srcflagged) =
  Hashtbl.add this.st_nodes n (Local oix)
 

(* let iter_types  this f = Hashtbl.iter f this.st_types *)
let iter_types  this f = Hashtbl.iter (fun id (pn,ti) -> f id ti) this.st_types
let iter_consts this f = Hashtbl.iter (fun id (pn,ci) -> f id ci) this.st_consts
let iter_nodes  this f = Hashtbl.iter f this.st_nodes
(* let iter_consts2 this f = Hashtbl.iter f this.st_consts *)