/[svn]/typing/typer.ml
ViewVC logotype

Diff of /typing/typer.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1473 by abate, Tue Jul 10 18:52:59 2007 UTC revision 1474 by abate, Tue Jul 10 18:53:27 2007 UTC
# Line 58  Line 58 
58  let equal _ _ = failwith "Typer.equal"  let equal _ _ = failwith "Typer.equal"
59  let check _ = failwith "Typer.check"  let check _ = failwith "Typer.check"
60    
61    
62    let load_schema_fwd = ref (fun x uri -> assert false)
63    
64    let enter_schema x uri env =
65      !load_schema_fwd x uri;
66      { env with schemas = UEnv.add x uri env.schemas }
67    
68    
69  (* TODO: filter out builtin defs ? *)  (* TODO: filter out builtin defs ? *)
70  let serialize_item s = function  let serialize_item s = function
71    | Type t -> Serialize.Put.bits 1 s 0; Types.serialize s t    | Type t -> Serialize.Put.bits 1 s 0; Types.serialize s t
# Line 65  Line 73 
73    
74  let serialize s env =  let serialize s env =
75    Serialize.Put.env Id.serialize serialize_item Env.iter s env.ids;    Serialize.Put.env Id.serialize serialize_item Env.iter s env.ids;
76    Ns.serialize_table s env.ns    Ns.serialize_table s env.ns;
77    
78      let schs =
79        UEnv.fold (fun name uri accu -> (name,uri)::accu) env.schemas [] in
80      Serialize.Put.list (Serialize.Put.pair U.serialize Serialize.Put.string) s schs
81    
82  let deserialize_item s = match Serialize.Get.bits 1 s with  let deserialize_item s = match Serialize.Get.bits 1 s with
83    | 0 -> Type (Types.deserialize s)    | 0 -> Type (Types.deserialize s)
# Line 75  Line 87 
87  let deserialize s =  let deserialize s =
88    let ids = Serialize.Get.env Id.deserialize deserialize_item Env.add Env.empty s in    let ids = Serialize.Get.env Id.deserialize deserialize_item Env.add Env.empty s in
89    let ns = Ns.deserialize_table s in    let ns = Ns.deserialize_table s in
90    { ids = ids; ns = ns; cu = UEnv.empty; schemas = UEnv.empty }    let schs =
91        Serialize.Get.list
92          (Serialize.Get.pair U.deserialize Serialize.Get.string) s in
93      let env =
94        { ids = ids; ns = ns; cu = UEnv.empty; schemas = UEnv.empty } in
95      List.fold_left (fun env (name,uri) -> enter_schema name uri env) env schs
96    
97    
98  let empty_env = {  let empty_env = {
# Line 95  Line 112 
112    with Not_found -> Types.CompUnit.mk x    with Not_found -> Types.CompUnit.mk x
113    
114    
 let enter_schema x uri env =  
   { env with schemas = UEnv.add x uri env.schemas }  
115  let find_schema x env =  let find_schema x env =
116    try UEnv.find x env.schemas    try UEnv.find x env.schemas
117    with Not_found -> raise (Error (Printf.sprintf "%s: no such schema" (U.get_str x)))    with Not_found -> raise (Error (Printf.sprintf "%s: no such schema" (U.get_str x)))
# Line 219  Line 234 
234    State.ref "Typer.schema_model_groups" (Hashtbl.create 51)    State.ref "Typer.schema_model_groups" (Hashtbl.create 51)
235    
236    
237  let get_schema_fwd = ref (fun _ -> assert false)  (*
238    let get_schema uri =
239      try Hashtbl.find !schemas uri
240      with Not_found -> assert false
241    *)
242    
243  let find_schema_descr_uri kind uri (name : Ns.qname) =  let find_schema_descr_uri kind uri (name : Ns.qname) =
244    try    try
     ignore (!get_schema_fwd uri);  
245      let elt () = Hashtbl.find !schema_elements (uri, name) in      let elt () = Hashtbl.find !schema_elements (uri, name) in
246      let typ () = Hashtbl.find !schema_types (uri, name) in      let typ () = Hashtbl.find !schema_types (uri, name) in
247      let att () = Hashtbl.find !schema_attributes (uri, name) in      let att () = Hashtbl.find !schema_attributes (uri, name) in
# Line 853  Line 871 
871                function                function
872                    (Type _) -> Format.fprintf ppf " %a" Ident.print v                    (Type _) -> Format.fprintf ppf " %a" Ident.print v
873                  | _ -> ()) env.ids                  | _ -> ()) env.ids
 let dump_type ppf env name =  
   try  
     (match Env.find (Ident.ident name) env.ids with  
     | Type t -> Types.Print.print ppf t  
     | _ -> raise Not_found)  
   with Not_found ->  
     raise (Error (Printf.sprintf "Type %s not found" (U.get_str name)))  
   
 let dump_schema_type ppf env (k, s, n) =  
   let name = qname env noloc n in  
   let uri = find_schema s env in  
   let descr = find_schema_descr_uri k uri name in  
   Types.Print.print ppf descr  
874    
875  let dump_ns ppf env =  let dump_ns ppf env =
876    Ns.dump_table ppf env.ns    Ns.dump_table ppf env.ns
# Line 1716  Line 1721 
1721    
1722    
1723  open Schema_types  open Schema_types
1724    
1725    
1726  let get_schema uri =  let get_schema uri =
1727    try Hashtbl.find !schemas uri    Hashtbl.find !schemas uri
1728    with Not_found ->  
1729    let load_schema schema_name uri =
1730      if Hashtbl.mem !schemas uri then ()
1731      else (
1732      let schema = Schema_parser.schema_of_uri uri in      let schema = Schema_parser.schema_of_uri uri in
1733      let log_schema_component kind uri name cd_type =      let log_schema_component kind uri name cd_type =
1734        if not (Schema_builtin.is_builtin name) then begin        if not (Schema_builtin.is_builtin name) then begin
1735          Format.fprintf Format.std_formatter        let n = U.to_string schema_name ^ "#" ^ (Ns.QName.to_string name) in
1736            "Registering schema %s: %s # %s"        Types.Print.register_global (U.mk_latin1 n) cd_type;
1737            kind uri (Ns.QName.to_string name);  
1738          Format.fprintf Format.std_formatter "Registering schema %s: %s" kind n;
1739  (*        if debug_schema then  (*        if debug_schema then
1740            Types.Print.print Format.std_formatter cd_type; *)            Types.Print.print Format.std_formatter cd_type; *)
1741          Format.fprintf Format.std_formatter "@."          Format.fprintf Format.std_formatter "@."
# Line 1761  Line 1772 
1772        schema.Schema_types.attribute_groups;        schema.Schema_types.attribute_groups;
1773      List.iter (* Schema model groups -> CDuce types *)      List.iter (* Schema model groups -> CDuce types *)
1774        (fun mg ->        (fun mg ->
1775           let cd_type = Schema_converter.cd_type_of_model_group ~schema mg.mg_def         in         let cd_type =
1776             Schema_converter.cd_type_of_model_group ~schema mg.mg_def in
1777           log_schema_component "model group" uri mg.mg_name cd_type;           log_schema_component "model group" uri mg.mg_name cd_type;
1778           Hashtbl.add !schema_model_groups (uri, mg.mg_name) cd_type)           Hashtbl.add !schema_model_groups (uri, mg.mg_name) cd_type)
1779        schema.Schema_types.model_groups;        schema.Schema_types.model_groups;
1780      schema    )
   
   
1781    
 let () = get_schema_fwd := get_schema  
1782    
1783    let () = load_schema_fwd := load_schema
Legend:
Removed from v.1473  
changed lines
  Added in v.1474
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5