expandPack.ml

(** Time-stamp: <modified the 11/03/2008 (at 15:48) by Erwan Jahier> *)

open Lxm
open SyntaxTree
open SyntaxTreeCore
open Errors
open SyntaxTabUtils

let (doit:
      (Ident.t, SyntaxTree.model_info Lxm.srcflagged) Hashtbl.t ->
      (SyntaxTree.pack_info  Lxm.srcflagged) ->
      SyntaxTree.pack_given) =
  fun mtab pdata -> (
    match (pdata.it.pa_def) with
	PackGiven pg -> pg
	  (* on garde tel-quel ... *)
	  
      | PackInstance pi -> (
	  (* recherche du modle *)
	  let mi = try Hashtbl.find mtab pi.pi_model 
	  with Not_found ->
	    let msg = Printf.sprintf "bad pack instance: model %s undeclared"
	      (Ident.to_string pi.pi_model)
	    in
	      raise ( Compile_error (pdata.src, msg))
	  in
	    (*-----------INIT-----------------------------------*)
	    (* On part du packbody du modle, dont on duplique les tables :*)
	  let ctab = Hashtbl.copy mi.it.mo_body.pk_const_table in
	  let ttab = Hashtbl.copy mi.it.mo_body.pk_type_table in
	  let otab = Hashtbl.copy mi.it.mo_body.pk_node_table in
	    (* liste des nouveaux define ... *)
	  let newdefs = ref [] in
	    (* liste des nouveaux provides ... *)
	  let newprov = ref [] in
	    (* On met en correspondance les pi_args avec les mo_needs *)
	  let args = pi.pi_args in
	  let pars = mi.it.mo_needs in
	    (*--------------------------------------------------*)
	    (* la fonction qui traite un couple ... *)
	  let check_arg p a = (
	    (* message d'erreur standard *)
	    let instance_error () = (
	      let msg = Printf.sprintf
		"bad pack instance: uncompatible arg passed to %s"
		(Lxm.details p.src)
	      in
		raise (Compile_error (a.src, msg))
	    ) in
	      (* on a soit un ident,  checker plus tard, 
		 soit une expression de la bonne nature *)
	      match (p.it) with
		| StaticParamType s -> (
		    let te = match (a.it) with
			StaticArgIdent idr -> (
			  Lxm.flagit (Named_type_exp idr) a.src
			) 
		      | StaticArgType x -> x
		      | _ -> instance_error ()
		    in
		    let ti = AliasedType (s, te) in
		    let x = Lxm.flagit (TypeInfo ti) p.src in
		      newprov := x::!newprov ;
		      let y = Lxm.flagit ti p.src in
			put_in_tab "type" ttab s y ;
			newdefs := (TypeItem s)::!newdefs
		  ) 
		| StaticParamConst (s,te) -> (
		    let ce = match (a.it) with
		      | StaticArgIdent idr -> 
			  SyntaxTreeCore.leafexp a.src (IDENT_n idr) 
		      | StaticArgConst x -> x
		      | _ -> instance_error ()
		    in
		    let ci = DefinedConst (s, Some te, ce) in
		    let x = Lxm.flagit (ConstInfo ci) p.src in
		      newprov := x::!newprov ;
		      let y = Lxm.flagit ci p.src in
			put_in_tab "const" ctab s y ;
			newdefs := (ConstItem s)::!newdefs
		  ) 
		| StaticParamNode (s, inl, outl, has_memory) -> (
		    let ne = match (a.it) with
		      | StaticArgIdent idr -> Lxm.flagit ((idr,[])) a.src
		      | StaticArgNode x -> Lxm.flagit x a.src
		      | _ -> instance_error () 
		    in
		    let ni = {
		      name = s;
		      static_params = None;
		      vars = Some (ParserUtils.build_node_var inl outl None);
		      def = Alias ne;
		      has_mem = has_memory;
		      is_safe = true;
		    } 
		    in
		    let x = Lxm.flagit (NodeInfo ni) p.src in
		      newprov := x::!newprov ;
		      let y = Lxm.flagit ni p.src in
			put_in_tab "node" otab s y ;
			newdefs := (NodeItem s)::!newdefs
		  ) 
	  ) in
	    try (
	      (*------------TRAITEMENT---------------------------------*)
	      List.iter2 check_arg pars args ;
	      (* on fabrique un pack_given valide avec les infos rcoltes *)	
	      let body = {
		pk_const_table = ctab ;
		pk_type_table = ttab ;
		pk_node_table = otab ;
		pk_def_list = List.append
		  (mi.it.mo_body.pk_def_list) 
		  (List.rev !newdefs)
	      } in
		(* les provides du modle + les nouveaux de newprov *)
		(* SAUF SI ON EXPORTE DEJA TOUT !                   *)
	      let prov = match (mi.it.mo_provides) with
		  Some l -> (
		    Some (List.append l (List.rev !newprov))
		  ) 
		|  None -> None
	      in
	      let pg = {
		(* les uses du modle ... *)
		pg_uses = mi.it.mo_uses ;
		pg_provides = prov ;
		pg_body = body ;
	      } in
		pg
	    ) with Invalid_argument _ -> (
	      let msg = Printf.sprintf
		"bad pack instance: %d args provided while model %s has %d params"
		(List.length args)
		(Ident.to_string pi.pi_model)
		(List.length pars)
	      in
		raise ( Compile_error (pdata.src, msg))
	    )
	)
  )