srcTab.ml

(** Time-stamp: <modified the 16/11/2007 (at 11:52) by Erwan Jahier> *)

(** 
    Table des infos sources : une couche au dessus de Syntaxe 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/oper)

    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 CompUtils
open Syntaxe
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. Syntaxe.item_ident -> fullid)
*)

type pack_mng = {
  (* le lexeme de ref *)
  pm_lxm : Lxm.t;
  (* le source brut *)
  pm_raw_src : Syntaxe.pack_info;
  (* le source expansé *)
  pm_actual_src : Syntaxe.pack_given;
  (* table "brute" des items provided *)
  (* pour les "user" du pack *)
  pm_user_items : (Syntaxe.item_ident, fullid Lxm.srcflaged) 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 : Syntaxe.namespace list ;
  st_raw_mod_tab : (string , model_info srcflaged) Hashtbl.t ;
  st_raw_pack_tab : (string , pack_info srcflaged) Hashtbl.t ;
  (* table des managers de packs *)
  st_pack_mng_tab : (string , pack_mng)  Hashtbl.t; 
} 



let pack_list this = (
  let f n p l = ( n::l ) in
    Hashtbl.fold f this.st_pack_mng_tab []
)

(* accès aux infos *)
let pack_body_env this  p = (
  try
    (Hashtbl.find this.st_pack_mng_tab p).pm_body_stab
  with Not_found -> assert false
)

let pack_prov_env this  p = (
  try
    (Hashtbl.find this.st_pack_mng_tab p).pm_provide_stab
  with Not_found -> assert false
)


(****************************************************************************
init de la table des items provided (pour les users)
****************************************************************************)
let init_user_items (this: pack_mng) = (
  let pname = Lxm.str this.pm_lxm in
    (* EXPORTATION D'UNE const_info *)
  let export_const
      (s:string)
      (xci: Syntaxe.const_info srcflaged)
      = (
	Verbose.put "       export const %s\n" s;
	CompUtils.put_in_tab "const" this.pm_user_items
	  (ConstItem s)
	  (Lxm.flagit (make_fullid pname  s) xci.src)
      ) in
    (* EXPORTATION D'UN type_info *)
  let export_type
      (s: string)
      (xti: Syntaxe.type_info srcflaged)
      = (
	let _ = 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.put "       export enum const %s\n" s;
		  CompUtils.put_in_tab "const" this.pm_user_items
		    (ConstItem s)
		    (Lxm.flagit (make_fullid pname s) lxm)
	      ) in
		List.iter treat_enum_const ecl
	    ) | _ -> ()
	in
	  Verbose.put "       export type %s\n" s;
	  CompUtils.put_in_tab "type" this.pm_user_items
	    (TypeItem s)
	    (Lxm.flagit (make_fullid pname  s) xti.src)
      ) in
    (* EXPORTATION D'UN oper_info *)
  let export_oper
      (s: string)
      (xoi: Syntaxe.oper_info srcflaged)
      = (
	Verbose.put "       export oper %s\n" s;
	CompUtils.put_in_tab "oper" this.pm_user_items
	  (OperItem s)
	  (Lxm.flagit (make_fullid 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_oper  pg.pg_body.pk_oper_table ;
	) |
	    Some spflg -> (
	      (* ON EXPORTE LES PROVIDES *)
	      let treat_prov x = (
		let lxm = x.src in
		let s = Lxm.str lxm in
		  match (x.it) with
		      TypeInfo xti -> export_type s (Lxm.flagit xti lxm)
		    | ConstInfo xci -> export_const s (Lxm.flagit xci lxm)
		    | OperInfo xoi -> export_oper 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 : Syntaxe.pack_info srcflaged)
   (pgiven : Syntaxe.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 ExpandPack)
   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 (sl : Syntaxe.namespace list) = (
	(* 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.put "*** SrcTab.create pass 1\n";
	(* passe 1 *)
	init_raw_tabs res sl ;
	(* passe 2 *)
Verbose.put "*** SrcTab.create pass 2\n";
	let init_pack_mng pname pdata = (
Verbose.put "    init pack %s\n" pname;
		let pg = ExpandPack.doit 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.put "*** SrcTab.create pass 3\n";
	Hashtbl.iter (init_pack_mng_stabs res) res.st_pack_mng_tab ;
	(* resultat *)
Verbose.put "*** SrcTab.create done\n";
	res
)
and
(***** PASSE 1 *****)
(* init des tables string -> mod ou pack *)
init_raw_tabs (this : t) (sl : Syntaxe.namespace list) = (
	(* on itère pour chaque namespace : *)
	let treat_ns ns = (
		match ns with
		(* cas d'un package *)
		Syntaxe.NSPack  pi -> (
			let lxm = pi.Lxm.src in
			let nme = (Lxm.str lxm) in
			CompUtils.put_in_tab "package" this.st_raw_pack_tab nme pi
		) |
		(* cas d'un modele *)
		Syntaxe.NSModel mi -> (
			let lxm = mi.Lxm.src in
			let nme = (Lxm.str lxm) in
			CompUtils.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",
- puis les déclaration locales qui peuvent éventuellement
  masquer les précédentes (warning ?)
*)
init_pack_mng_stabs (this: t) (pname: string) (pm: pack_mng) = (
	let pg = pm.pm_actual_src in

Verbose.put "    symbol tables for pack %s\n" pname;
	(* ON COMMENCE PAR TRAITER LE PG_USES *)
	let treat_uses px = (
		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: Syntaxe.item_ident)
			(iks: fullid Lxm.srcflaged) =
		(
			match ii with
			ConstItem n -> (
				SymbolTab.add_import_const pm.pm_body_stab n iks.it;
				match pm.pm_provide_stab with
				  Some pt -> SymbolTab.add_import_const pt 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 -> ()
			)|
			OperItem n -> (
				SymbolTab.add_import_oper pm.pm_body_stab n iks.it;
				match pm.pm_provide_stab with
				  Some pt -> SymbolTab.add_import_oper pt n iks.it
				| 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)	
	  pg.pg_body.pk_type_table;
	Hashtbl.iter (SymbolTab.add_const pm.pm_body_stab)	
	  pg.pg_body.pk_const_table;
	Hashtbl.iter (SymbolTab.add_oper pm.pm_body_stab)	
	  pg.pg_body.pk_oper_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.str lxm) in
			match (x.it) with
			TypeInfo xti -> (
				SymbolTab.add_type pptab s (Lxm.flagit xti lxm) 
			) |
			ConstInfo xci -> (
				SymbolTab.add_const pptab s (Lxm.flagit xci lxm)
			) |
			OperInfo xoi -> (
				 SymbolTab.add_oper pptab s (Lxm.flagit xoi lxm)
			)
		) in
		List.iter treat_prov spflg
	) 
)

(****************************************************************************
Associations :
--------------
- Syntaxe.idref -> fullid * Syntaxe.xxxx_info

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

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



(*** dump ***)
let dump x = (
)