syntaxTab.ml

(** Time-stamp: <modified the 09/12/2008 (at 17:36) by Erwan Jahier> *)

(** 
    Table des infos sources : une couche au dessus de SyntaxTree pour mieux
    ranger les packages et les modèles et faciliter la résolution des
    identificateurs.

    1) expansion des modèles

    2) pour chaque package instancié, 2 tables de symboles :

    - une pour la vision "exportée"
    - une pour la vision interne. Chaque table de symbole, 3 "espaces"
    de noms (par nature d'items, type/const/node)

    Ces tables sont destinées à résoudre les références simples, elle
    associent à une string :

    - la definition syntaxique de l'item associé s'il est local
    - l'identificateur absolu (package+nom) si il est externe
*)

open Lxm
open SyntaxTree
open SyntaxTreeCore
open Errors

(** Package manager

    Un package manager (pack_mng) contient les infos ``source'' du
    package + DEUX tables de symboles, correspondant aux deux contextes
    possibles de compilation :

    - compilation du provide
    - compilation du body

    En effet, un identificateur de type, de constante ou de noeud
    n'est pas interprété de la même manière suivant qu'il apparaît
    dans la partie provide ou body.

    Il contient aussi une table des items exportés pour faciliter le
    traitement des "use" du package. C'est une correspondance 

        nature + nom simple -> nom complet 

    (c.a.d. ??? + SyntaxTree.item_ident -> Ident.long)
*)

type pack_mng = {
  (* le lexeme associé au package? *)
  pm_lxm : Lxm.t;
  (* le source brut *)
  pm_raw_src : SyntaxTree.pack_info;
  (* le source expansé *)
  pm_actual_src : SyntaxTree.pack_given;
  (* table "brute" des items provided *)
  (* pour les "user" du pack *)
  pm_user_items : (SyntaxTreeCore.item_ident, Ident.long Lxm.srcflagged) Hashtbl.t;
  (* les tables de symboles pour compil ultérieure *)
  pm_body_stab : SymbolTab.t;
  (* la table pour provide n'est créée que si besoin ... *)
  pm_provide_stab : SymbolTab.t option;
}

(** TYPE PRINCIPAL : t

    Packages et modèles sont rangés dans des tables, ce qui permet
    notamment de traiter les erreurs de multi-déclarations
    (st_raw_mod_tab et st_raw_pack_tab)

    Les instances de modeles sont traitées pour n'avoir plus que des
    ``pack_given'' (i.e. pack avec provide + body)

    À chaque package (éventuellement expansé) est associé un manager
    pour faciliter l'accès à ses infos (pack_mng)
*)
type t = {
  (* liste + tables des sources bruts *)
  st_list : SyntaxTree.pack_or_model list ;
  st_raw_mod_tab  : (Ident.t , model_info srcflagged) Hashtbl.t ;
  st_raw_pack_tab : (Ident.pack_name , pack_info srcflagged) Hashtbl.t ;
  (* table des managers de packs *)
  st_pack_mng_tab : (Ident.pack_name , pack_mng)  Hashtbl.t; 
}

(* exported *)
let (pack_list:t -> Ident.pack_name list) =
  fun this -> 
    Hashtbl.fold (fun n p l -> n::l) this.st_pack_mng_tab []


(* exported *)
let (pack_body_env: t -> Ident.pack_name -> SymbolTab.t) =
  fun this p -> 
    try  (Hashtbl.find this.st_pack_mng_tab p).pm_body_stab
    with Not_found -> 
      print_string ("*** Can not find package '" ^ 
		      (Ident.pack_name_to_string p) ^ "' in the following packages: ");
      Hashtbl.iter 
	(fun pn pm -> print_string ("\n***\t '"^(Ident.pack_name_to_string pn)^ "'"))
	this.st_pack_mng_tab;
      print_string "\n";
      flush stdout;
      exit 2


(* exported *)
let (pack_prov_env: t -> Ident.pack_name -> Lxm.t -> SymbolTab.t option) =
  fun this p lxm -> 
    try (Hashtbl.find this.st_pack_mng_tab p).pm_provide_stab
    with Not_found -> 
(*       let msg =  *)
(*         ("\n*** Could not find package " ^(Ident.pack_name_to_string p) ^  *)
(*            " in the package table" ) *)
(*       in *)
	None  
(*         raise(Compile_error(lxm, msg))   *)
      



(****************************************************************************
init de la table des items provided (pour les users)
****************************************************************************)
let init_user_items (this: pack_mng) = (
  let pname = Ident.pack_name_of_string (Lxm.str this.pm_lxm) in

  (** Exportation D'une const_info *)
  let export_const (s:Ident.t) (xci: SyntaxTreeCore.const_info srcflagged) =
	Verbose.printf ~level:3 "       export const %s\n" (Ident.to_string s);
	SyntaxTabUtils.put_in_tab "const" this.pm_user_items
	  (ConstItem s)
	  (Lxm.flagit (Ident.make_long pname s) xci.src)
  in
    
  (** Exportation D'un type_info *)
  let export_type (s: Ident.t) (xti: SyntaxTreeCore.type_info srcflagged) = 
    ( match (xti.it) with
	| EnumType (_, ecl) -> (
	    (* Cas particulier des types enums *)
	    (* on exporte les constantes ... *)
	    let treat_enum_const ec = 
	      let s = ec.it in
	      let lxm = ec.src in
		Verbose.printf ~level:3 "       export enum const %s\n" (Ident.to_string s);
		SyntaxTabUtils.put_in_tab "const" this.pm_user_items
		  (ConstItem s)
		  (Lxm.flagit (Ident.make_long pname s) lxm)
	    in
	      List.iter treat_enum_const ecl
	  )
	| ExternalType _
	| AliasedType _ 
	| StructType _ 
	| ArrayType _ 
	  -> ()
    );
    Verbose.printf ~level:3 "       export type %s\n" (Ident.to_string s);
    SyntaxTabUtils.put_in_tab "type" this.pm_user_items
      (TypeItem s)
      (Lxm.flagit (Ident.make_long pname  s) xti.src)
  in

  (** Exportation D'un node_info *)
  let export_node (s: Ident.t) (xoi: SyntaxTreeCore.node_info srcflagged) = 
    Verbose.printf ~level:3 "       export node %s\n" (Ident.to_string s);
    SyntaxTabUtils.put_in_tab "node" this.pm_user_items
      (NodeItem (s,xoi.it.static_params))
      (Lxm.flagit (Ident.make_long pname s) xoi.src)
  in

  let pg = this.pm_actual_src in
    match pg.pg_provides with
      | None ->
	  (* On Exporte Tout Tel Quel *)
	  Hashtbl.iter export_type  pg.pg_body.pk_type_table ;
	  Hashtbl.iter export_const pg.pg_body.pk_const_table ;
	  Hashtbl.iter export_node  pg.pg_body.pk_node_table ;
      | Some spflg ->
	  (* On Exporte Les Provides *)
	  let treat_prov x = 
	    let lxm = x.src in
	    let s = Lxm.id lxm in
	      match (x.it) with
		  TypeInfo xti -> export_type s (Lxm.flagit xti lxm)
		| ConstInfo xci -> export_const s (Lxm.flagit xci lxm)
		| NodeInfo xoi -> export_node s (Lxm.flagit xoi lxm)
	  in
	    List.iter treat_prov spflg
)

(*
Création/initialisation d'un pack_mng :
On prépare juste la table des items provided
pour pouvoir traiter les éventuels "use" des autres pack.
Les tables de symboles sont créées plus tard.
*)
let create_pack_mng 
    (pdata : SyntaxTree.pack_info srcflagged)
    (pgiven : SyntaxTree.pack_given)
    = (
      (* la table pm_provide_stab n'est créée que si besoin *)
      let ppstab = match pgiven.pg_provides with
	  None -> None 
	| Some _ -> Some (SymbolTab.create ())
      in
      let res =
	{
	  pm_lxm = pdata.src ;
	  pm_raw_src = pdata.it;
	  pm_actual_src = pgiven;
	  pm_user_items = Hashtbl.create 50;
	  pm_provide_stab = ppstab;
	  pm_body_stab = SymbolTab.create ();
	} 
      in
	init_user_items res;
	res
    )



(****************************************************************************
CREATION
-----------------------------------------------------------------------------
Se fait en plusieurs passes :

1) mise en place des tables "raw" mod et pack (string -> source pack/mod)
2) instanciations éventuelle des packs (voir InstanciateModel)
   et initialisation des pack_mng (en particulier des infos pour les users)
3) pour chaque pack, création des symbol_table contextuelles
   (pour la partie provide et pour la partie body)
****************************************************************************)

let rec (create  : SyntaxTree.pack_or_model list -> t) =
  fun sl -> 
    (* liste + tables des sources bruts *)
    let res = {
      st_list = sl ;
      st_raw_mod_tab = Hashtbl.create 50;
      st_raw_pack_tab = Hashtbl.create 50; 
      st_pack_mng_tab = Hashtbl.create 50; 
    } 
    in
      Verbose.printf ~level:3 "*** SyntaxTab.create pass 1\n";
      (* passe 1 *)
      init_raw_tabs res sl ;
      (* passe 2 *)
      Verbose.printf ~level:3 "*** SyntaxTab.create pass 2\n";
      let init_pack_mng pname pdata = (
	Verbose.printf ~level:3 "    init pack %s\n" (Ident.pack_name_to_string pname);
	let pg = InstanciateModel.f res.st_raw_mod_tab pdata in
	  Hashtbl.add res.st_pack_mng_tab 
	    pname
	    (create_pack_mng pdata pg)
      ) in
	Hashtbl.iter init_pack_mng res.st_raw_pack_tab ;
	(* passe 3 *)
	Verbose.printf ~level:3 "*** SyntaxTab.create pass 3\n";
	Hashtbl.iter (init_pack_mng_stabs res) res.st_pack_mng_tab ;
	(* resultat *)
	Verbose.printf ~level:3 "*** SyntaxTab.create done\n";
	res
 and
(***** PASSE 1 *****)
(* init des tables string -> mod ou pack *)
    init_raw_tabs (this : t) (sl : SyntaxTree.pack_or_model list) =
    (* on itère pour chaque pack_or_model : *)
  let treat_ns ns = 
      match ns with
	  (* cas d'un package *)
	| SyntaxTree.NSPack  pi ->
	    let lxm = pi.Lxm.src in
	    let nme = (Ident.pack_name_of_string (Lxm.str lxm)) in
	      SyntaxTabUtils.put_in_tab "package" this.st_raw_pack_tab nme pi
	   	
	| SyntaxTree.NSModel mi -> (* cas d'un modele *)
	    let lxm = mi.Lxm.src in
	    let nme = (Lxm.id lxm) in
	      SyntaxTabUtils.put_in_tab "model" this.st_raw_mod_tab nme mi
    in
      List.iter treat_ns sl
 and
(***** PASSE 3 *****)
(* Essentiellement le remplissage des champs de pack_mng : 

   pm_provide_stab : SymbolTab.t
   table qui permettra de résoudre les refs simples
   à l'intérieur de la partie provides.

   pm_body_stab : SymbolTab.t ;
   table qui permettra de résoudre les refs simples
   à l'intérieur de la partie body.

   N.B. s'il n'y a pas de provides explicite, on construit
   une unique table qui sert pour les deux !

   Comment ça marche :
   - on traite en premier les éventuels "use", (= open de ocaml)
   - puis les déclarations locales qui peuvent éventuellement
   masquer les précédentes (warning ?)
*)
init_pack_mng_stabs (this: t) (pname: Ident.pack_name) (pm: pack_mng) = (
  let pg = pm.pm_actual_src in

    Verbose.printf ~level:3 "   init symbol tables for pack %s\n"
      (Ident.pack_name_to_string pname);
    (* ON COMMENCE PAR TRAITER LE PG_USES *)
    let treat_uses (px:Ident.pack_name srcflagged) = (
      let pname = px.it in
      let lxm = px.src in
      let pum = 
	try Hashtbl.find this.st_pack_mng_tab pname
	with Not_found -> raise(Compile_error(lxm, "unknown package"))
      in
      let fill_used_item
	  (ii: SyntaxTreeCore.item_ident)
	  (iks: Ident.long Lxm.srcflagged) =
	(match ii with
	   | ConstItem n -> (
	       SymbolTab.add_import_const pm.pm_body_stab px.it n iks.it;
	       match pm.pm_provide_stab with
		   Some pt -> SymbolTab.add_import_const pt px.it n iks.it
		 | None -> ()
	     )
	   | TypeItem n -> (
	       SymbolTab.add_import_type pm.pm_body_stab n iks.it;
	       match pm.pm_provide_stab with
		   Some pt -> SymbolTab.add_import_type pt n iks.it
		 | None -> ()
	     )
	   | NodeItem (n,sparams) -> (
	       SymbolTab.add_import_node pm.pm_body_stab n iks.it sparams;
	       match pm.pm_provide_stab with
		   Some pt -> SymbolTab.add_import_node pt n iks.it sparams
		 | None -> ()
	     )
	) 
      in
	Hashtbl.iter fill_used_item pum.pm_user_items
    )
    in
      List.iter treat_uses pg.pg_uses ;

      (* PUIS LES DECLARATION LOCALES *)
      (* ... dans le body : *)
      Hashtbl.iter (SymbolTab.add_type pm.pm_body_stab pname) pg.pg_body.pk_type_table;
      Hashtbl.iter (SymbolTab.add_const pm.pm_body_stab pname) pg.pg_body.pk_const_table;
      Hashtbl.iter (SymbolTab.add_node pm.pm_body_stab)	 pg.pg_body.pk_node_table;
      (* ... dans le provide : *)
      match pg.pg_provides with
	| None -> () 
	| Some spflg -> (
	    let pptab = match pm.pm_provide_stab with
		Some pt -> pt
	      | None -> assert false
	    in
	    let treat_prov x = 
	      let lxm = x.src in
	      let s = Lxm.id lxm in
		match (x.it) with
		  | TypeInfo xti  -> SymbolTab.add_type pptab pname s (Lxm.flagit xti lxm) 
		  | ConstInfo xci -> SymbolTab.add_const pptab pname s (Lxm.flagit xci lxm)
		  | NodeInfo xoi  -> SymbolTab.add_node pptab s (Lxm.flagit xoi lxm)
	    in
	      List.iter treat_prov spflg
	  )
)

(****************************************************************************
Associations :
--------------
- Ident.t -> Ident.long * SyntaxTreeCore.xxxx_info

****************************************************************************)

(* associations idref -> Ident.long *)
let find_type (genv: t) (pck: string) (idr: Ident.t) = 
  print_string "*** not implemented.\n";
  assert false

let find_const (genv: t) (pck: string) (idr: Ident.t) = 
  print_string "*** not implemented.\n";
  assert false

let find_node (genv: t) (pck: string) (idr: Ident.t) =
  print_string "*** not implemented.\n";
  assert false



(* exported *)
let (dump : t -> unit) =
  fun x -> 
    let p = Verbose.print_string ~level:3 in
      p "*** « Syntax table dump:\n";
    
      p " \t - Package or model list:\n\t\t";
      (* st_list : SyntaxTree.pack_or_model list ; *)
      List.iter 
	(fun pm -> p (SyntaxTree.pack_or_model_to_string pm); p "\n\t\t") 
	x.st_list ;
      
      p "\n\t - Raw model table: ";
      (* st_raw_mod_tab  : (Ident.t , model_info srcflagged) Hashtbl.t ; *)
      Hashtbl.iter 
	(fun id _mi -> p ((Ident.to_string id) ^ " "))
	x.st_raw_mod_tab;
      
      p "\n\t - Raw Package table: ";
      (* st_raw_pack_tab : (Ident.pack_name , pack_info srcflagged) Hashtbl.t ; *)
      Hashtbl.iter 
	(fun pn pi -> p ((Ident.pack_name_to_string pn) ^ " ")) 
	x.st_raw_pack_tab;
      
      p "\n\t - Package manager table: ";
      (* st_pack_mng_tab : (Ident.pack_name , pack_mng)  Hashtbl.t;  *)
      Hashtbl.iter 
	(fun pn pm -> p ((Ident.pack_name_to_string pn) ^ " ")) 
	x.st_pack_mng_tab;
      
      p "\nEnd of Syntax table dump. »\n"