l4/pkg/ocaml/contrib/typing/env.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id: env.ml 9240 2009-04-28 05:11:54Z garrigue $ *)
  14
  15 (* Environment handling *)
  16
  17 open Config
  18 open Misc
  19 open Asttypes
  20 open Longident
  21 open Path
  22 open Types
  23
  24
  25 type error =
  26     Not_an_interface of string
  27   | Corrupted_interface of string
  28   | Illegal_renaming of string * string
  29   | Inconsistent_import of string * string * string
  30   | Need_recursive_types of string * string
  31
  32 exception Error of error
  33
  34 type summary =
  35     Env_empty
  36   | Env_value of summary * Ident.t * value_description
  37   | Env_type of summary * Ident.t * type_declaration
  38   | Env_exception of summary * Ident.t * exception_declaration
  39   | Env_module of summary * Ident.t * module_type
  40   | Env_modtype of summary * Ident.t * modtype_declaration
  41   | Env_class of summary * Ident.t * class_declaration
  42   | Env_cltype of summary * Ident.t * cltype_declaration
  43   | Env_open of summary * Path.t
  44
  45 type t = {
  46   values: (Path.t * value_description) Ident.tbl;
  47   annotations: (Path.t * Annot.ident) Ident.tbl;
  48   constrs: constructor_description Ident.tbl;
  49   labels: label_description Ident.tbl;
  50   types: (Path.t * type_declaration) Ident.tbl;
  51   modules: (Path.t * module_type) Ident.tbl;
  52   modtypes: (Path.t * modtype_declaration) Ident.tbl;
  53   components: (Path.t * module_components) Ident.tbl;
  54   classes: (Path.t * class_declaration) Ident.tbl;
  55   cltypes: (Path.t * cltype_declaration) Ident.tbl;
  56   summary: summary
  57 }
  58
  59 and module_components = module_components_repr Lazy.t
  60
  61 and module_components_repr =
  62     Structure_comps of structure_components
  63   | Functor_comps of functor_components
  64
  65 and structure_components = {
  66   mutable comp_values: (string, (value_description * int)) Tbl.t;
  67   mutable comp_annotations: (string, (Annot.ident * int)) Tbl.t;
  68   mutable comp_constrs: (string, (constructor_description * int)) Tbl.t;
  69   mutable comp_labels: (string, (label_description * int)) Tbl.t;
  70   mutable comp_types: (string, (type_declaration * int)) Tbl.t;
  71   mutable comp_modules: (string, (module_type Lazy.t * int)) Tbl.t;
  72   mutable comp_modtypes: (string, (modtype_declaration * int)) Tbl.t;
  73   mutable comp_components: (string, (module_components * int)) Tbl.t;
  74   mutable comp_classes: (string, (class_declaration * int)) Tbl.t;
  75   mutable comp_cltypes: (string, (cltype_declaration * int)) Tbl.t
  76 }
  77
  78 and functor_components = {
  79   fcomp_param: Ident.t;                 (* Formal parameter *)
  80   fcomp_arg: module_type;               (* Argument signature *)
  81   fcomp_res: module_type;               (* Result signature *)
  82   fcomp_env: t;     (* Environment in which the result signature makes sense *)
  83   fcomp_subst: Subst.t;  (* Prefixing substitution for the result signature *)
  84   fcomp_cache: (Path.t, module_components) Hashtbl.t  (* For memoization *)
  85 }
  86
  87 let empty = {
  88   values = Ident.empty; annotations = Ident.empty; constrs = Ident.empty;
  89   labels = Ident.empty; types = Ident.empty;
  90   modules = Ident.empty; modtypes = Ident.empty;
  91   components = Ident.empty; classes = Ident.empty;
  92   cltypes = Ident.empty;
  93   summary = Env_empty }
  94
  95 let diff_keys is_local tbl1 tbl2 =
  96   let keys2 = Ident.keys tbl2 in
  97   List.filter
  98     (fun id ->
  99       is_local (Ident.find_same id tbl2) &&
 100       try ignore (Ident.find_same id tbl1); false with Not_found -> true)
 101     keys2
 102
 103 let is_ident = function
 104     Pident _ -> true
 105   | Pdot _ | Papply _ -> false
 106
 107 let is_local (p, _) = is_ident p
 108
 109 let is_local_exn = function
 110     {cstr_tag = Cstr_exception p} -> is_ident p
 111   | _ -> false
 112
 113 let diff env1 env2 =
 114   diff_keys is_local env1.values env2.values @
 115   diff_keys is_local_exn env1.constrs env2.constrs @
 116   diff_keys is_local env1.modules env2.modules @
 117   diff_keys is_local env1.classes env2.classes
 118
 119 (* Forward declarations *)
 120
 121 let components_of_module' =
 122   ref ((fun env sub path mty -> assert false) :
 123           t -> Subst.t -> Path.t -> module_type -> module_components)
 124 let components_of_functor_appl' =
 125   ref ((fun f p1 p2 -> assert false) :
 126           functor_components -> Path.t -> Path.t -> module_components)
 127 let check_modtype_inclusion =
 128   (* to be filled with Includemod.check_modtype_inclusion *)
 129   ref ((fun env mty1 path1 mty2 -> assert false) :
 130           t -> module_type -> Path.t -> module_type -> unit)
 131
 132 (* The name of the compilation unit currently compiled.
 133    "" if outside a compilation unit. *)
 134
 135 let current_unit = ref ""
 136
 137 (* Persistent structure descriptions *)
 138
 139 type pers_flags = Rectypes
 140
 141 type pers_struct =
 142   { ps_name: string;
 143     ps_sig: signature;
 144     ps_comps: module_components;
 145     ps_crcs: (string * Digest.t) list;
 146     ps_filename: string;
 147     ps_flags: pers_flags list }
 148
 149 let persistent_structures =
 150   (Hashtbl.create 17 : (string, pers_struct) Hashtbl.t)
 151
 152 (* Consistency between persistent structures *)
 153
 154 let crc_units = Consistbl.create()
 155
 156 let check_consistency filename crcs =
 157   try
 158     List.iter
 159       (fun (name, crc) -> Consistbl.check crc_units name crc filename)
 160       crcs
 161   with Consistbl.Inconsistency(name, source, auth) ->
 162     raise(Error(Inconsistent_import(name, auth, source)))
 163
 164 (* Reading persistent structures from .cmi files *)
 165
 166 let read_pers_struct modname filename =
 167   let ic = open_in_bin filename in
 168   try
 169     let buffer = String.create (String.length cmi_magic_number) in
 170     really_input ic buffer 0 (String.length cmi_magic_number);
 171     if buffer <> cmi_magic_number then begin
 172       close_in ic;
 173       raise(Error(Not_an_interface filename))
 174     end;
 175     let (name, sign) = input_value ic in
 176     let crcs = input_value ic in
 177     let flags = input_value ic in
 178     close_in ic;
 179     let comps =
 180       !components_of_module' empty Subst.identity
 181                              (Pident(Ident.create_persistent name))
 182                              (Tmty_signature sign) in
 183     let ps = { ps_name = name;
 184                ps_sig = sign;
 185                ps_comps = comps;
 186                ps_crcs = crcs;
 187                ps_filename = filename;
 188                ps_flags = flags } in
 189     if ps.ps_name <> modname then
 190       raise(Error(Illegal_renaming(ps.ps_name, filename)));
 191     check_consistency filename ps.ps_crcs;
 192     List.iter
 193       (function Rectypes ->
 194         if not !Clflags.recursive_types then
 195           raise(Error(Need_recursive_types(ps.ps_name, !current_unit))))
 196       ps.ps_flags;
 197     Hashtbl.add persistent_structures modname ps;
 198     ps
 199   with End_of_file | Failure _ ->
 200     close_in ic;
 201     raise(Error(Corrupted_interface(filename)))
 202
 203 let find_pers_struct name =
 204   try
 205     Hashtbl.find persistent_structures name
 206   with Not_found ->
 207     read_pers_struct name (find_in_path_uncap !load_path (name ^ ".cmi"))
 208
 209 let reset_cache () =
 210   current_unit := "";
 211   Hashtbl.clear persistent_structures;
 212   Consistbl.clear crc_units
 213
 214 let set_unit_name name =
 215   current_unit := name
 216
 217 (* Lookup by identifier *)
 218
 219 let rec find_module_descr path env =
 220   match path with
 221     Pident id ->
 222       begin try
 223         let (p, desc) = Ident.find_same id env.components
 224         in desc
 225       with Not_found ->
 226         if Ident.persistent id
 227         then (find_pers_struct (Ident.name id)).ps_comps
 228         else raise Not_found
 229       end
 230   | Pdot(p, s, pos) ->
 231       begin match Lazy.force(find_module_descr p env) with
 232         Structure_comps c ->
 233           let (descr, pos) = Tbl.find s c.comp_components in
 234           descr
 235       | Functor_comps f ->
 236          raise Not_found
 237       end
 238   | Papply(p1, p2) ->
 239       begin match Lazy.force(find_module_descr p1 env) with
 240         Functor_comps f ->
 241           !components_of_functor_appl' f p1 p2
 242       | Structure_comps c ->
 243           raise Not_found
 244       end
 245
 246 let find proj1 proj2 path env =
 247   match path with
 248     Pident id ->
 249       let (p, data) = Ident.find_same id (proj1 env)
 250       in data
 251   | Pdot(p, s, pos) ->
 252       begin match Lazy.force(find_module_descr p env) with
 253         Structure_comps c ->
 254           let (data, pos) = Tbl.find s (proj2 c) in data
 255       | Functor_comps f ->
 256           raise Not_found
 257       end
 258   | Papply(p1, p2) ->
 259       raise Not_found
 260
 261 let find_value =
 262   find (fun env -> env.values) (fun sc -> sc.comp_values)
 263 and find_type =
 264   find (fun env -> env.types) (fun sc -> sc.comp_types)
 265 and find_modtype =
 266   find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
 267 and find_class =
 268   find (fun env -> env.classes) (fun sc -> sc.comp_classes)
 269 and find_cltype =
 270   find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
 271
 272 (* Find the manifest type associated to a type when appropriate:
 273    - the type should be public or should have a private row,
 274    - the type should have an associated manifest type. *)
 275 let find_type_expansion path env =
 276   let decl = find_type path env in
 277   match decl.type_manifest with
 278   | Some body when decl.type_private = Public
 279               || decl.type_kind <> Type_abstract
 280               || Btype.has_constr_row body -> (decl.type_params, body)
 281   (* The manifest type of Private abstract data types without
 282      private row are still considered unknown to the type system.
 283      Hence, this case is caught by the following clause that also handles
 284      purely abstract data types without manifest type definition. *)
 285   | _ -> raise Not_found
 286
 287 (* Find the manifest type information associated to a type, i.e.
 288    the necessary information for the compiler's type-based optimisations.
 289    In particular, the manifest type associated to a private abstract type
 290    is revealed for the sake of compiler's type-based optimisations. *)
 291 let find_type_expansion_opt path env =
 292   let decl = find_type path env in
 293   match decl.type_manifest with
 294   (* The manifest type of Private abstract data types can still get
 295      an approximation using their manifest type. *)
 296   | Some body -> (decl.type_params, body)
 297   | _ -> raise Not_found
 298
 299 let find_modtype_expansion path env =
 300   match find_modtype path env with
 301     Tmodtype_abstract     -> raise Not_found
 302   | Tmodtype_manifest mty -> mty
 303
 304 let find_module path env =
 305   match path with
 306     Pident id ->
 307       begin try
 308         let (p, data) = Ident.find_same id env.modules
 309         in data
 310       with Not_found ->
 311         if Ident.persistent id then
 312           let ps = find_pers_struct (Ident.name id) in
 313           Tmty_signature(ps.ps_sig)
 314         else raise Not_found
 315       end
 316   | Pdot(p, s, pos) ->
 317       begin match Lazy.force (find_module_descr p env) with
 318         Structure_comps c ->
 319           let (data, pos) = Tbl.find s c.comp_modules in Lazy.force data
 320       | Functor_comps f ->
 321           raise Not_found
 322       end
 323   | Papply(p1, p2) ->
 324       raise Not_found (* not right *)
 325
 326 (* Lookup by name *)
 327
 328 let rec lookup_module_descr lid env =
 329   match lid with
 330     Lident s ->
 331       begin try
 332         Ident.find_name s env.components
 333       with Not_found ->
 334         if s = !current_unit then raise Not_found;
 335         let ps = find_pers_struct s in
 336         (Pident(Ident.create_persistent s), ps.ps_comps)
 337       end
 338   | Ldot(l, s) ->
 339       let (p, descr) = lookup_module_descr l env in
 340       begin match Lazy.force descr with
 341         Structure_comps c ->
 342           let (descr, pos) = Tbl.find s c.comp_components in
 343           (Pdot(p, s, pos), descr)
 344       | Functor_comps f ->
 345           raise Not_found
 346       end
 347   | Lapply(l1, l2) ->
 348       let (p1, desc1) = lookup_module_descr l1 env in
 349       let (p2, mty2) = lookup_module l2 env in
 350       begin match Lazy.force desc1 with
 351         Functor_comps f ->
 352           !check_modtype_inclusion env mty2 p2 f.fcomp_arg;
 353           (Papply(p1, p2), !components_of_functor_appl' f p1 p2)
 354       | Structure_comps c ->
 355           raise Not_found
 356       end
 357
 358 and lookup_module lid env =
 359   match lid with
 360     Lident s ->
 361       begin try
 362         Ident.find_name s env.modules
 363       with Not_found ->
 364         if s = !current_unit then raise Not_found;
 365         let ps = find_pers_struct s in
 366         (Pident(Ident.create_persistent s), Tmty_signature ps.ps_sig)
 367       end
 368   | Ldot(l, s) ->
 369       let (p, descr) = lookup_module_descr l env in
 370       begin match Lazy.force descr with
 371         Structure_comps c ->
 372           let (data, pos) = Tbl.find s c.comp_modules in
 373           (Pdot(p, s, pos), Lazy.force data)
 374       | Functor_comps f ->
 375           raise Not_found
 376       end
 377   | Lapply(l1, l2) ->
 378       let (p1, desc1) = lookup_module_descr l1 env in
 379       let (p2, mty2) = lookup_module l2 env in
 380       let p = Papply(p1, p2) in
 381       begin match Lazy.force desc1 with
 382         Functor_comps f ->
 383           !check_modtype_inclusion env mty2 p2 f.fcomp_arg;
 384           (p, Subst.modtype (Subst.add_module f.fcomp_param p2 f.fcomp_subst)
 385                             f.fcomp_res)
 386       | Structure_comps c ->
 387           raise Not_found
 388       end
 389
 390 let lookup proj1 proj2 lid env =
 391   match lid with
 392     Lident s ->
 393       Ident.find_name s (proj1 env)
 394   | Ldot(l, s) ->
 395       let (p, desc) = lookup_module_descr l env in
 396       begin match Lazy.force desc with
 397         Structure_comps c ->
 398           let (data, pos) = Tbl.find s (proj2 c) in
 399           (Pdot(p, s, pos), data)
 400       | Functor_comps f ->
 401           raise Not_found
 402       end
 403   | Lapply(l1, l2) ->
 404       raise Not_found
 405
 406 let lookup_simple proj1 proj2 lid env =
 407   match lid with
 408     Lident s ->
 409       Ident.find_name s (proj1 env)
 410   | Ldot(l, s) ->
 411       let (p, desc) = lookup_module_descr l env in
 412       begin match Lazy.force desc with
 413         Structure_comps c ->
 414           let (data, pos) = Tbl.find s (proj2 c) in
 415           data
 416       | Functor_comps f ->
 417           raise Not_found
 418       end
 419   | Lapply(l1, l2) ->
 420       raise Not_found
 421
 422 let lookup_value =
 423   lookup (fun env -> env.values) (fun sc -> sc.comp_values)
 424 let lookup_annot id e =
 425   lookup (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e
 426 and lookup_constructor =
 427   lookup_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
 428 and lookup_label =
 429   lookup_simple (fun env -> env.labels) (fun sc -> sc.comp_labels)
 430 and lookup_type =
 431   lookup (fun env -> env.types) (fun sc -> sc.comp_types)
 432 and lookup_modtype =
 433   lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
 434 and lookup_class =
 435   lookup (fun env -> env.classes) (fun sc -> sc.comp_classes)
 436 and lookup_cltype =
 437   lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
 438
 439 (* Expand manifest module type names at the top of the given module type *)
 440
 441 let rec scrape_modtype mty env =
 442   match mty with
 443     Tmty_ident path ->
 444       begin try
 445         scrape_modtype (find_modtype_expansion path env) env
 446       with Not_found ->
 447         mty
 448       end
 449   | _ -> mty
 450
 451 (* Compute constructor descriptions *)
 452
 453 let constructors_of_type ty_path decl =
 454   match decl.type_kind with
 455     Type_variant cstrs ->
 456       Datarepr.constructor_descrs
 457         (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
 458         cstrs decl.type_private
 459   | Type_record _ | Type_abstract -> []
 460
 461 (* Compute label descriptions *)
 462
 463 let labels_of_type ty_path decl =
 464   match decl.type_kind with
 465     Type_record(labels, rep) ->
 466       Datarepr.label_descrs
 467         (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
 468         labels rep decl.type_private
 469   | Type_variant _ | Type_abstract -> []
 470
 471 (* Given a signature and a root path, prefix all idents in the signature
 472    by the root path and build the corresponding substitution. *)
 473
 474 let rec prefix_idents root pos sub = function
 475     [] -> ([], sub)
 476   | Tsig_value(id, decl) :: rem ->
 477       let p = Pdot(root, Ident.name id, pos) in
 478       let nextpos = match decl.val_kind with Val_prim _ -> pos | _ -> pos+1 in
 479       let (pl, final_sub) = prefix_idents root nextpos sub rem in
 480       (p::pl, final_sub)
 481   | Tsig_type(id, decl, _) :: rem ->
 482       let p = Pdot(root, Ident.name id, nopos) in
 483       let (pl, final_sub) =
 484         prefix_idents root pos (Subst.add_type id p sub) rem in
 485       (p::pl, final_sub)
 486   | Tsig_exception(id, decl) :: rem ->
 487       let p = Pdot(root, Ident.name id, pos) in
 488       let (pl, final_sub) = prefix_idents root (pos+1) sub rem in
 489       (p::pl, final_sub)
 490   | Tsig_module(id, mty, _) :: rem ->
 491       let p = Pdot(root, Ident.name id, pos) in
 492       let (pl, final_sub) =
 493         prefix_idents root (pos+1) (Subst.add_module id p sub) rem in
 494       (p::pl, final_sub)
 495   | Tsig_modtype(id, decl) :: rem ->
 496       let p = Pdot(root, Ident.name id, nopos) in
 497       let (pl, final_sub) =
 498         prefix_idents root pos
 499                       (Subst.add_modtype id (Tmty_ident p) sub) rem in
 500       (p::pl, final_sub)
 501   | Tsig_class(id, decl, _) :: rem ->
 502       let p = Pdot(root, Ident.name id, pos) in
 503       let (pl, final_sub) = prefix_idents root (pos + 1) sub rem in
 504       (p::pl, final_sub)
 505   | Tsig_cltype(id, decl, _) :: rem ->
 506       let p = Pdot(root, Ident.name id, nopos) in
 507       let (pl, final_sub) = prefix_idents root pos sub rem in
 508       (p::pl, final_sub)
 509
 510 (* Compute structure descriptions *)
 511
 512 let rec components_of_module env sub path mty =
 513   lazy(match scrape_modtype mty env with
 514     Tmty_signature sg ->
 515       let c =
 516         { comp_values = Tbl.empty; comp_annotations = Tbl.empty;
 517           comp_constrs = Tbl.empty;
 518           comp_labels = Tbl.empty; comp_types = Tbl.empty;
 519           comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
 520           comp_components = Tbl.empty; comp_classes = Tbl.empty;
 521           comp_cltypes = Tbl.empty } in
 522       let (pl, sub) = prefix_idents path 0 sub sg in
 523       let env = ref env in
 524       let pos = ref 0 in
 525       List.iter2 (fun item path ->
 526         match item with
 527           Tsig_value(id, decl) ->
 528             let decl' = Subst.value_description sub decl in
 529             c.comp_values <-
 530               Tbl.add (Ident.name id) (decl', !pos) c.comp_values;
 531             if !Clflags.annotations then begin
 532               c.comp_annotations <-
 533                 Tbl.add (Ident.name id) (Annot.Iref_external, !pos)
 534                         c.comp_annotations;
 535             end;
 536             begin match decl.val_kind with
 537               Val_prim _ -> () | _ -> incr pos
 538             end
 539         | Tsig_type(id, decl, _) ->
 540             let decl' = Subst.type_declaration sub decl in
 541             c.comp_types <-
 542               Tbl.add (Ident.name id) (decl', nopos) c.comp_types;
 543             List.iter
 544               (fun (name, descr) ->
 545                 c.comp_constrs <- Tbl.add name (descr, nopos) c.comp_constrs)
 546               (constructors_of_type path decl');
 547             List.iter
 548               (fun (name, descr) ->
 549                 c.comp_labels <- Tbl.add name (descr, nopos) c.comp_labels)
 550               (labels_of_type path decl');
 551             env := store_type_infos id path decl !env
 552         | Tsig_exception(id, decl) ->
 553             let decl' = Subst.exception_declaration sub decl in
 554             let cstr = Datarepr.exception_descr path decl' in
 555             c.comp_constrs <-
 556               Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs;
 557             incr pos
 558         | Tsig_module(id, mty, _) ->
 559             let mty' = lazy (Subst.modtype sub mty) in
 560             c.comp_modules <-
 561               Tbl.add (Ident.name id) (mty', !pos) c.comp_modules;
 562             let comps = components_of_module !env sub path mty in
 563             c.comp_components <-
 564               Tbl.add (Ident.name id) (comps, !pos) c.comp_components;
 565             env := store_module id path mty !env;
 566             incr pos
 567         | Tsig_modtype(id, decl) ->
 568             let decl' = Subst.modtype_declaration sub decl in
 569             c.comp_modtypes <-
 570               Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes;
 571             env := store_modtype id path decl !env
 572         | Tsig_class(id, decl, _) ->
 573             let decl' = Subst.class_declaration sub decl in
 574             c.comp_classes <-
 575               Tbl.add (Ident.name id) (decl', !pos) c.comp_classes;
 576             incr pos
 577         | Tsig_cltype(id, decl, _) ->
 578             let decl' = Subst.cltype_declaration sub decl in
 579             c.comp_cltypes <-
 580               Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes)
 581         sg pl;
 582         Structure_comps c
 583   | Tmty_functor(param, ty_arg, ty_res) ->
 584         Functor_comps {
 585           fcomp_param = param;
 586           (* fcomp_arg must be prefixed eagerly, because it is interpreted
 587              in the outer environment, not in env *)
 588           fcomp_arg = Subst.modtype sub ty_arg;
 589           (* fcomp_res is prefixed lazily, because it is interpreted in env *)
 590           fcomp_res = ty_res;
 591           fcomp_env = env;
 592           fcomp_subst = sub;
 593           fcomp_cache = Hashtbl.create 17 }
 594   | Tmty_ident p ->
 595         Structure_comps {
 596           comp_values = Tbl.empty; comp_annotations = Tbl.empty;
 597           comp_constrs = Tbl.empty;
 598           comp_labels = Tbl.empty; comp_types = Tbl.empty;
 599           comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
 600           comp_components = Tbl.empty; comp_classes = Tbl.empty;
 601           comp_cltypes = Tbl.empty })
 602
 603 (* Insertion of bindings by identifier + path *)
 604
 605 and store_value id path decl env =
 606   { env with
 607     values = Ident.add id (path, decl) env.values;
 608     summary = Env_value(env.summary, id, decl) }
 609
 610 and store_annot id path annot env =
 611   if !Clflags.annotations then
 612     { env with
 613       annotations = Ident.add id (path, annot) env.annotations }
 614   else env
 615
 616 and store_type id path info env =
 617   { env with
 618     constrs =
 619       List.fold_right
 620         (fun (name, descr) constrs ->
 621           Ident.add (Ident.create name) descr constrs)
 622         (constructors_of_type path info)
 623         env.constrs;
 624     labels =
 625       List.fold_right
 626         (fun (name, descr) labels ->
 627           Ident.add (Ident.create name) descr labels)
 628         (labels_of_type path info)
 629         env.labels;
 630     types = Ident.add id (path, info) env.types;
 631     summary = Env_type(env.summary, id, info) }
 632
 633 and store_type_infos id path info env =
 634   (* Simplified version of store_type that doesn't compute and store
 635      constructor and label infos, but simply record the arity and
 636      manifest-ness of the type.  Used in components_of_module to
 637      keep track of type abbreviations (e.g. type t = float) in the
 638      computation of label representations. *)
 639   { env with
 640     types = Ident.add id (path, info) env.types;
 641     summary = Env_type(env.summary, id, info) }
 642
 643 and store_exception id path decl env =
 644   { env with
 645     constrs = Ident.add id (Datarepr.exception_descr path decl) env.constrs;
 646     summary = Env_exception(env.summary, id, decl) }
 647
 648 and store_module id path mty env =
 649   { env with
 650     modules = Ident.add id (path, mty) env.modules;
 651     components =
 652       Ident.add id (path, components_of_module env Subst.identity path mty)
 653                    env.components;
 654     summary = Env_module(env.summary, id, mty) }
 655
 656 and store_modtype id path info env =
 657   { env with
 658     modtypes = Ident.add id (path, info) env.modtypes;
 659     summary = Env_modtype(env.summary, id, info) }
 660
 661 and store_class id path desc env =
 662   { env with
 663     classes = Ident.add id (path, desc) env.classes;
 664     summary = Env_class(env.summary, id, desc) }
 665
 666 and store_cltype id path desc env =
 667   { env with
 668     cltypes = Ident.add id (path, desc) env.cltypes;
 669     summary = Env_cltype(env.summary, id, desc) }
 670
 671 (* Compute the components of a functor application in a path. *)
 672
 673 let components_of_functor_appl f p1 p2 =
 674   try
 675     Hashtbl.find f.fcomp_cache p2
 676   with Not_found ->
 677     let p = Papply(p1, p2) in
 678     let mty =
 679       Subst.modtype (Subst.add_module f.fcomp_param p2 Subst.identity)
 680                     f.fcomp_res in
 681     let comps = components_of_module f.fcomp_env f.fcomp_subst p mty in
 682     Hashtbl.add f.fcomp_cache p2 comps;
 683     comps
 684
 685 (* Define forward functions *)
 686
 687 let _ =
 688   components_of_module' := components_of_module;
 689   components_of_functor_appl' := components_of_functor_appl
 690
 691 (* Insertion of bindings by identifier *)
 692
 693 let add_value id desc env =
 694   store_value id (Pident id) desc env
 695
 696 let add_annot id annot env =
 697   store_annot id (Pident id) annot env
 698
 699 and add_type id info env =
 700   store_type id (Pident id) info env
 701
 702 and add_exception id decl env =
 703   store_exception id (Pident id) decl env
 704
 705 and add_module id mty env =
 706   store_module id (Pident id) mty env
 707
 708 and add_modtype id info env =
 709   store_modtype id (Pident id) info env
 710
 711 and add_class id ty env =
 712   store_class id (Pident id) ty env
 713
 714 and add_cltype id ty env =
 715   store_cltype id (Pident id) ty env
 716
 717 (* Insertion of bindings by name *)
 718
 719 let enter store_fun name data env =
 720   let id = Ident.create name in (id, store_fun id (Pident id) data env)
 721
 722 let enter_value = enter store_value
 723 and enter_type = enter store_type
 724 and enter_exception = enter store_exception
 725 and enter_module = enter store_module
 726 and enter_modtype = enter store_modtype
 727 and enter_class = enter store_class
 728 and enter_cltype = enter store_cltype
 729
 730 (* Insertion of all components of a signature *)
 731
 732 let add_item comp env =
 733   match comp with
 734     Tsig_value(id, decl)     -> add_value id decl env
 735   | Tsig_type(id, decl, _)   -> add_type id decl env
 736   | Tsig_exception(id, decl) -> add_exception id decl env
 737   | Tsig_module(id, mty, _)  -> add_module id mty env
 738   | Tsig_modtype(id, decl)   -> add_modtype id decl env
 739   | Tsig_class(id, decl, _)  -> add_class id decl env
 740   | Tsig_cltype(id, decl, _) -> add_cltype id decl env
 741
 742 let rec add_signature sg env =
 743   match sg with
 744     [] -> env
 745   | comp :: rem -> add_signature rem (add_item comp env)
 746
 747 (* Open a signature path *)
 748
 749 let open_signature root sg env =
 750   (* First build the paths and substitution *)
 751   let (pl, sub) = prefix_idents root 0 Subst.identity sg in
 752   (* Then enter the components in the environment after substitution *)
 753   let newenv =
 754     List.fold_left2
 755       (fun env item p ->
 756         match item with
 757           Tsig_value(id, decl) ->
 758             let e1 = store_value (Ident.hide id) p
 759                         (Subst.value_description sub decl) env
 760             in store_annot (Ident.hide id) p (Annot.Iref_external) e1
 761         | Tsig_type(id, decl, _) ->
 762             store_type (Ident.hide id) p
 763                        (Subst.type_declaration sub decl) env
 764         | Tsig_exception(id, decl) ->
 765             store_exception (Ident.hide id) p
 766                             (Subst.exception_declaration sub decl) env
 767         | Tsig_module(id, mty, _) ->
 768             store_module (Ident.hide id) p (Subst.modtype sub mty) env
 769         | Tsig_modtype(id, decl) ->
 770             store_modtype (Ident.hide id) p
 771                           (Subst.modtype_declaration sub decl) env
 772         | Tsig_class(id, decl, _) ->
 773             store_class (Ident.hide id) p
 774                         (Subst.class_declaration sub decl) env
 775         | Tsig_cltype(id, decl, _) ->
 776             store_cltype (Ident.hide id) p
 777                          (Subst.cltype_declaration sub decl) env)
 778       env sg pl in
 779   { newenv with summary = Env_open(env.summary, root) }
 780
 781 (* Open a signature from a file *)
 782
 783 let open_pers_signature name env =
 784   let ps = find_pers_struct name in
 785   open_signature (Pident(Ident.create_persistent name)) ps.ps_sig env
 786
 787 (* Read a signature from a file *)
 788
 789 let read_signature modname filename =
 790   let ps = read_pers_struct modname filename in ps.ps_sig
 791
 792 (* Return the CRC of the interface of the given compilation unit *)
 793
 794 let crc_of_unit name =
 795   let ps = find_pers_struct name in
 796   try
 797     List.assoc name ps.ps_crcs
 798   with Not_found ->
 799     assert false
 800
 801 (* Return the list of imported interfaces with their CRCs *)
 802
 803 let imported_units() =
 804   Consistbl.extract crc_units
 805
 806 (* Save a signature to a file *)
 807
 808 let save_signature_with_imports sg modname filename imports =
 809   Btype.cleanup_abbrev ();
 810   Subst.reset_for_saving ();
 811   let sg = Subst.signature (Subst.for_saving Subst.identity) sg in
 812   let oc = open_out_bin filename in
 813   try
 814     output_string oc cmi_magic_number;
 815     output_value oc (modname, sg);
 816     flush oc;
 817     let crc = Digest.file filename in
 818     let crcs = (modname, crc) :: imports in
 819     output_value oc crcs;
 820     let flags = if !Clflags.recursive_types then [Rectypes] else [] in
 821     output_value oc flags;
 822     close_out oc;
 823     (* Enter signature in persistent table so that imported_unit()
 824        will also return its crc *)
 825     let comps =
 826       components_of_module empty Subst.identity
 827         (Pident(Ident.create_persistent modname)) (Tmty_signature sg) in
 828     let ps =
 829       { ps_name = modname;
 830         ps_sig = sg;
 831         ps_comps = comps;
 832         ps_crcs = crcs;
 833         ps_filename = filename;
 834         ps_flags = flags } in
 835     Hashtbl.add persistent_structures modname ps;
 836     Consistbl.set crc_units modname crc filename
 837   with exn ->
 838     close_out oc;
 839     remove_file filename;
 840     raise exn
 841
 842 let save_signature sg modname filename =
 843   save_signature_with_imports sg modname filename (imported_units())
 844
 845 (* Make the initial environment *)
 846
 847 let initial = Predef.build_initial_env add_type add_exception empty
 848
 849 (* Return the environment summary *)
 850
 851 let summary env = env.summary
 852
 853 (* Error report *)
 854
 855 open Format
 856
 857 let report_error ppf = function
 858   | Not_an_interface filename -> fprintf ppf
 859       "%s@ is not a compiled interface" filename
 860   | Corrupted_interface filename -> fprintf ppf
 861       "Corrupted compiled interface@ %s" filename
 862   | Illegal_renaming(modname, filename) -> fprintf ppf
 863       "Wrong file naming: %s@ contains the compiled interface for@ %s"
 864       filename modname
 865   | Inconsistent_import(name, source1, source2) -> fprintf ppf
 866       "@[<hov>The files %s@ and %s@ \
 867               make inconsistent assumptions@ over interface %s@]"
 868       source1 source2 name
 869   | Need_recursive_types(import, export) ->
 870       fprintf ppf
 871         "@[<hov>Unit %s imports from %s, which uses recursive types.@ %s@]"
 872         import export "The compilation flag -rectypes is required"