https://github.com/charguer/ocaml
Tip revision: 4548f1e68f99a1eead460251a20ebfe2b3e736f4 authored by Alain Frisch on 14 December 2010, 08:38:03 UTC
Allow implicit coercion on type with free variables (if subtyping does not unify variables).
Allow implicit coercion on type with free variables (if subtyping does not unify variables).
Tip revision: 4548f1e
compilenv.ml
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Compilation environments for compilation units *)
open Config
open Misc
open Clambda
open Cmx_format
type error =
Not_a_unit_info of string
| Corrupted_unit_info of string
| Illegal_renaming of string * string
exception Error of error
let global_infos_table =
(Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t)
let current_unit =
{ ui_name = "";
ui_symbol = "";
ui_defines = [];
ui_imports_cmi = [];
ui_imports_cmx = [];
ui_approx = Value_unknown;
ui_curry_fun = [];
ui_apply_fun = [];
ui_send_fun = [];
ui_force_link = false }
let symbolname_for_pack pack name =
match pack with
| None -> name
| Some p ->
let b = Buffer.create 64 in
for i = 0 to String.length p - 1 do
match p.[i] with
| '.' -> Buffer.add_string b "__"
| c -> Buffer.add_char b c
done;
Buffer.add_string b "__";
Buffer.add_string b name;
Buffer.contents b
let reset ?packname name =
Hashtbl.clear global_infos_table;
let symbol = symbolname_for_pack packname name in
current_unit.ui_name <- name;
current_unit.ui_symbol <- symbol;
current_unit.ui_defines <- [symbol];
current_unit.ui_imports_cmi <- [];
current_unit.ui_imports_cmx <- [];
current_unit.ui_curry_fun <- [];
current_unit.ui_apply_fun <- [];
current_unit.ui_send_fun <- [];
current_unit.ui_force_link <- false
let current_unit_infos () =
current_unit
let current_unit_name () =
current_unit.ui_name
let make_symbol ?(unitname = current_unit.ui_symbol) idopt =
let prefix = "caml" ^ unitname in
match idopt with
| None -> prefix
| Some id -> prefix ^ "__" ^ id
let read_unit_info filename =
let ic = open_in_bin filename in
try
let buffer = String.create (String.length cmx_magic_number) in
really_input ic buffer 0 (String.length cmx_magic_number);
if buffer <> cmx_magic_number then begin
close_in ic;
raise(Error(Not_a_unit_info filename))
end;
let ui = (input_value ic : unit_infos) in
let crc = Digest.input ic in
close_in ic;
(ui, crc)
with End_of_file | Failure _ ->
close_in ic;
raise(Error(Corrupted_unit_info(filename)))
let read_library_info filename =
let ic = open_in_bin filename in
let buffer = String.create (String.length cmxa_magic_number) in
really_input ic buffer 0 (String.length cmxa_magic_number);
if buffer <> cmxa_magic_number then
raise(Error(Not_a_unit_info filename));
let infos = (input_value ic : library_infos) in
close_in ic;
infos
(* Read and cache info on global identifiers *)
let cmx_not_found_crc =
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
let get_global_info global_ident =
let modname = Ident.name global_ident in
if modname = current_unit.ui_name then
Some current_unit
else begin
try
Hashtbl.find global_infos_table modname
with Not_found ->
let (infos, crc) =
try
let filename =
find_in_path_uncap !load_path (modname ^ ".cmx") in
let (ui, crc) = read_unit_info filename in
if ui.ui_name <> modname then
raise(Error(Illegal_renaming(ui.ui_name, filename)));
(Some ui, crc)
with Not_found ->
(None, cmx_not_found_crc) in
current_unit.ui_imports_cmx <-
(modname, crc) :: current_unit.ui_imports_cmx;
Hashtbl.add global_infos_table modname infos;
infos
end
let cache_unit_info ui =
Hashtbl.add global_infos_table ui.ui_name (Some ui)
(* Return the approximation of a global identifier *)
let toplevel_approx = Hashtbl.create 16
let record_global_approx_toplevel id =
Hashtbl.add toplevel_approx current_unit.ui_name current_unit.ui_approx
let global_approx id =
if Ident.is_predef_exn id then Value_unknown
else try Hashtbl.find toplevel_approx (Ident.name id)
with Not_found ->
match get_global_info id with
| None -> Value_unknown
| Some ui -> ui.ui_approx
(* Return the symbol used to refer to a global identifier *)
let symbol_for_global id =
if Ident.is_predef_exn id then
"caml_exn_" ^ Ident.name id
else begin
match get_global_info id with
| None -> make_symbol ~unitname:(Ident.name id) None
| Some ui -> make_symbol ~unitname:ui.ui_symbol None
end
(* Register the approximation of the module being compiled *)
let set_global_approx approx =
current_unit.ui_approx <- approx
(* Record that a currying function or application function is needed *)
let need_curry_fun n =
if not (List.mem n current_unit.ui_curry_fun) then
current_unit.ui_curry_fun <- n :: current_unit.ui_curry_fun
let need_apply_fun n =
if not (List.mem n current_unit.ui_apply_fun) then
current_unit.ui_apply_fun <- n :: current_unit.ui_apply_fun
let need_send_fun n =
if not (List.mem n current_unit.ui_send_fun) then
current_unit.ui_send_fun <- n :: current_unit.ui_send_fun
(* Write the description of the current unit *)
let write_unit_info info filename =
let oc = open_out_bin filename in
output_string oc cmx_magic_number;
output_value oc info;
flush oc;
let crc = Digest.file filename in
Digest.output oc crc;
close_out oc
let save_unit_info filename =
current_unit.ui_imports_cmi <- Env.imported_units();
write_unit_info current_unit filename
(* Error report *)
open Format
let report_error ppf = function
| Not_a_unit_info filename ->
fprintf ppf "%s@ is not a compilation unit description." filename
| Corrupted_unit_info filename ->
fprintf ppf "Corrupted compilation unit description@ %s" filename
| Illegal_renaming(modname, filename) ->
fprintf ppf "%s@ contains the description for unit@ %s" filename modname