116 lines
4.5 KiB
OCaml
116 lines
4.5 KiB
OCaml
(**************************************************************************)
|
|
(* *)
|
|
(* OCaml *)
|
|
(* *)
|
|
(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
|
|
(* OCaml port by John Malecki and Xavier Leroy *)
|
|
(* *)
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique. *)
|
|
(* *)
|
|
(* All rights reserved. This file is distributed under the terms of *)
|
|
(* the GNU Lesser General Public License version 2.1, with the *)
|
|
(* special exception on linking described in the file LICENSE. *)
|
|
(* *)
|
|
(**************************************************************************)
|
|
|
|
open Env
|
|
|
|
type error =
|
|
Module_not_found of Path.t
|
|
|
|
exception Error of error
|
|
|
|
let env_cache =
|
|
(Hashtbl.create 59 : ((Env.summary * Subst.t), Env.t) Hashtbl.t)
|
|
|
|
let reset_cache () =
|
|
Hashtbl.clear env_cache;
|
|
Env.reset_cache()
|
|
|
|
let rec env_from_summary sum subst =
|
|
try
|
|
Hashtbl.find env_cache (sum, subst)
|
|
with Not_found ->
|
|
let env =
|
|
match sum with
|
|
Env_empty ->
|
|
Env.empty
|
|
| Env_value(s, id, desc) ->
|
|
Env.add_value id (Subst.value_description subst desc)
|
|
(env_from_summary s subst)
|
|
| Env_type(s, id, desc) ->
|
|
Env.add_type ~check:false id
|
|
(Subst.type_declaration subst desc)
|
|
(env_from_summary s subst)
|
|
| Env_extension(s, id, desc) ->
|
|
Env.add_extension ~check:false ~rebind:false id
|
|
(Subst.extension_constructor subst desc)
|
|
(env_from_summary s subst)
|
|
| Env_module(s, id, pres, desc) ->
|
|
Env.add_module_declaration ~check:false id pres
|
|
(Subst.module_declaration Keep subst desc)
|
|
(env_from_summary s subst)
|
|
| Env_modtype(s, id, desc) ->
|
|
Env.add_modtype id (Subst.modtype_declaration Keep subst desc)
|
|
(env_from_summary s subst)
|
|
| Env_class(s, id, desc) ->
|
|
Env.add_class id (Subst.class_declaration subst desc)
|
|
(env_from_summary s subst)
|
|
| Env_cltype (s, id, desc) ->
|
|
Env.add_cltype id (Subst.cltype_declaration subst desc)
|
|
(env_from_summary s subst)
|
|
| Env_open(s, path) ->
|
|
let env = env_from_summary s subst in
|
|
let path' = Subst.module_path subst path in
|
|
begin match Env.open_signature Asttypes.Override path' env with
|
|
| Ok env -> env
|
|
| Error `Functor -> assert false
|
|
| Error `Not_found -> raise (Error (Module_not_found path'))
|
|
end
|
|
| Env_functor_arg(Env_module(s, id, pres, desc), id')
|
|
when Ident.same id id' ->
|
|
Env.add_module_declaration ~check:false
|
|
id pres (Subst.module_declaration Keep subst desc)
|
|
~arg:true (env_from_summary s subst)
|
|
| Env_functor_arg _ -> assert false
|
|
| Env_constraints(s, map) ->
|
|
Path.Map.fold
|
|
(fun path info ->
|
|
Env.add_local_type (Subst.type_path subst path)
|
|
(Subst.type_declaration subst info))
|
|
map (env_from_summary s subst)
|
|
| Env_copy_types s ->
|
|
let env = env_from_summary s subst in
|
|
Env.make_copy_of_types env env
|
|
| Env_persistent (s, id) ->
|
|
let env = env_from_summary s subst in
|
|
Env.add_persistent_structure id env
|
|
| Env_value_unbound (s, str, reason) ->
|
|
let env = env_from_summary s subst in
|
|
Env.enter_unbound_value str reason env
|
|
| Env_module_unbound (s, str, reason) ->
|
|
let env = env_from_summary s subst in
|
|
Env.enter_unbound_module str reason env
|
|
in
|
|
Hashtbl.add env_cache (sum, subst) env;
|
|
env
|
|
|
|
let env_of_only_summary env =
|
|
Env.env_of_only_summary env_from_summary env
|
|
|
|
(* Error report *)
|
|
|
|
open Format
|
|
|
|
let report_error ppf = function
|
|
| Module_not_found p ->
|
|
fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p
|
|
|
|
let () =
|
|
Location.register_error_of_exn
|
|
(function
|
|
| Error err -> Some (Location.error_of_printer_file report_error err)
|
|
| _ -> None
|
|
)
|