symbolTab.ml

(** Time-stamp: <modified the 21/08/2008 (at 15:46) 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
      raise (Compile_error(lxm, "unknown node (" ^ (Ident.to_string id)^")"))


(* 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 *)


(* useful for debug *)
let (dump : t -> unit) =
  fun x ->
    let const_info_dump = function 
      | pn, Imported(l,_) -> print_string (Ident.long_to_string l)
      | pn, Local(x) -> (match x.it with
		       | ExternalConst (id,texp,vopt) -> print_string "extern"
		       | EnumConst (id,texp) -> print_string "enum"
		       | DefinedConst (id,texp,vexp) -> 
			   SyntaxTreeDump.dump_val_exp Format.std_formatter vexp;
			   Format.print_flush ()
		    )
    in
    let type_info_dump =  function 
      | pn, Imported(l,params) -> print_string (Ident.long_to_string l)
      | pn, Local ti -> 
	  match ti.it with
	    | ExternalType id -> print_string ("extern type ")
	    | AliasedType(id,texp)  -> 
		print_string "an alias on ";
		SyntaxTreeDump.dump_type_exp Format.std_formatter texp;
		Format.print_flush ()
	    | EnumType (id,_)  -> print_string ("an enum " ^ (Ident.to_string id))
	    | StructType   si  -> print_string ("a structure " )
	    | ArrayType(id,_,_)  -> print_string ("an array " ^ (Ident.to_string id))
    in
    let node_info_dump =  function 
      | Imported(l,params) -> print_string ((Ident.long_to_string l) ^ " (extern)")
      | Local ni -> print_string ((Ident.to_string ni.it.name) ^ " (local)")
    in
    let htbl_dump label i2s tbl =
      print_string label;
      Hashtbl.iter 
	(fun id info -> 
	   print_string ("\n  - " ^ Ident.to_string id ^" -> ");
	   i2s info)
	tbl
    in
      htbl_dump "\nconstants: " const_info_dump x.st_consts;
      htbl_dump "\ntypes: " type_info_dump x.st_types;
      htbl_dump "\nnodes: " node_info_dump x.st_nodes