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