Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Print warnings on the warnings formatter in the couple of places that don't 

Except the OCAMLPARAM stuff, as that runs before the command line
warning settings are even parsed, so while they are reported using the
normal warnings code, they don't look like normal warnings.
master
Valentin Gatien-Baron 2018-07-15 15:00:47 -04:00
parent 47eeff4bac
commit 0444eac687
11 changed files with 48 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
bytecomp/bytelibrarian.ml
View File

@ -55,7 +55,7 @@ let add_ccobjs l =
lib_dllibs := !lib_dllibs @ l.lib_dllibs lib_dllibs := !lib_dllibs @ l.lib_dllibs
end end
let copy_object_file ppf oc name = let copy_object_file oc name =
let file_name = let file_name =
try try
find_in_path !load_path name find_in_path !load_path name
@ -68,7 +68,7 @@ let copy_object_file ppf oc name =
let compunit_pos = input_binary_int ic in let compunit_pos = input_binary_int ic in
seek_in ic compunit_pos; seek_in ic compunit_pos;
let compunit = (input_value ic : compilation_unit) in let compunit = (input_value ic : compilation_unit) in
Bytelink.check_consistency ppf file_name compunit; Bytelink.check_consistency file_name compunit;
copy_compunit ic oc compunit; copy_compunit ic oc compunit;
close_in ic; close_in ic;
[compunit] [compunit]
@ -77,7 +77,7 @@ let copy_object_file ppf oc name =
let toc_pos = input_binary_int ic in let toc_pos = input_binary_int ic in
seek_in ic toc_pos; seek_in ic toc_pos;
let toc = (input_value ic : library) in let toc = (input_value ic : library) in
List.iter (Bytelink.check_consistency ppf file_name) toc.lib_units; List.iter (Bytelink.check_consistency file_name) toc.lib_units;
add_ccobjs toc; add_ccobjs toc;
List.iter (copy_compunit ic oc) toc.lib_units; List.iter (copy_compunit ic oc) toc.lib_units;
close_in ic; close_in ic;
@ -88,14 +88,14 @@ let copy_object_file ppf oc name =
End_of_file -> close_in ic; raise(Error(Not_an_object_file file_name)) End_of_file -> close_in ic; raise(Error(Not_an_object_file file_name))
| x -> close_in ic; raise x | x -> close_in ic; raise x
let create_archive ppf file_list lib_name = let create_archive file_list lib_name =
let outchan = open_out_bin lib_name in let outchan = open_out_bin lib_name in
try try
output_string outchan cma_magic_number; output_string outchan cma_magic_number;
let ofs_pos_toc = pos_out outchan in let ofs_pos_toc = pos_out outchan in
output_binary_int outchan 0; output_binary_int outchan 0;
let units = let units =
List.flatten(List.map (copy_object_file ppf outchan) file_list) in List.flatten(List.map (copy_object_file outchan) file_list) in
let toc = let toc =
{ lib_units = units; { lib_units = units;
lib_custom = !Clflags.custom_runtime; lib_custom = !Clflags.custom_runtime;

2
bytecomp/bytelibrarian.mli
View File

@ -22,7 +22,7 @@
content table = list of compilation units content table = list of compilation units
*) *)
val create_archive: Format.formatter -> string list -> string -> unit val create_archive: string list -> string -> unit
type error = type error =
File_not_found of string File_not_found of string

38
bytecomp/bytelink.ml
View File

@ -169,7 +169,7 @@ let crc_interfaces = Consistbl.create ()
let interfaces = ref ([] : string list) let interfaces = ref ([] : string list)
let implementations_defined = ref ([] : (string * string) list) let implementations_defined = ref ([] : (string * string) list)
let check_consistency ppf file_name cu = let check_consistency file_name cu =
begin try begin try
List.iter List.iter
(fun (name, crco) -> (fun (name, crco) ->
@ -186,7 +186,7 @@ let check_consistency ppf file_name cu =
end; end;
begin try begin try
let source = List.assoc cu.cu_name !implementations_defined in let source = List.assoc cu.cu_name !implementations_defined in
Location.print_warning (Location.in_file file_name) ppf Location.prerr_warning (Location.in_file file_name)
(Warnings.Multiple_definition(cu.cu_name, (Warnings.Multiple_definition(cu.cu_name,
Location.show_filename file_name, Location.show_filename file_name,
Location.show_filename source)) Location.show_filename source))
@ -208,8 +208,8 @@ let debug_info = ref ([] : (int * Instruct.debug_event list * string list) list)
(* Link in a compilation unit *) (* Link in a compilation unit *)
let link_compunit ppf output_fun currpos_fun inchan file_name compunit = let link_compunit output_fun currpos_fun inchan file_name compunit =
check_consistency ppf file_name compunit; check_consistency file_name compunit;
seek_in inchan compunit.cu_pos; seek_in inchan compunit.cu_pos;
let code_block = LongString.input_bytes inchan compunit.cu_codesize in let code_block = LongString.input_bytes inchan compunit.cu_codesize in
Symtable.patch_object code_block compunit.cu_reloc; Symtable.patch_object code_block compunit.cu_reloc;
@ -230,10 +230,10 @@ let link_compunit ppf output_fun currpos_fun inchan file_name compunit =
(* Link in a .cmo file *) (* Link in a .cmo file *)
let link_object ppf output_fun currpos_fun file_name compunit = let link_object output_fun currpos_fun file_name compunit =
let inchan = open_in_bin file_name in let inchan = open_in_bin file_name in
try try
link_compunit ppf output_fun currpos_fun inchan file_name compunit; link_compunit output_fun currpos_fun inchan file_name compunit;
close_in inchan close_in inchan
with with
Symtable.Error msg -> Symtable.Error msg ->
@ -243,14 +243,14 @@ let link_object ppf output_fun currpos_fun file_name compunit =
(* Link in a .cma file *) (* Link in a .cma file *)
let link_archive ppf output_fun currpos_fun file_name units_required = let link_archive output_fun currpos_fun file_name units_required =
let inchan = open_in_bin file_name in let inchan = open_in_bin file_name in
try try
List.iter List.iter
(fun cu -> (fun cu ->
let name = file_name ^ "(" ^ cu.cu_name ^ ")" in let name = file_name ^ "(" ^ cu.cu_name ^ ")" in
try try
link_compunit ppf output_fun currpos_fun inchan name cu link_compunit output_fun currpos_fun inchan name cu
with Symtable.Error msg -> with Symtable.Error msg ->
raise(Error(Symbol_error(name, msg)))) raise(Error(Symbol_error(name, msg))))
units_required; units_required;
@ -259,11 +259,11 @@ let link_archive ppf output_fun currpos_fun file_name units_required =
(* Link in a .cmo or .cma file *) (* Link in a .cmo or .cma file *)
let link_file ppf output_fun currpos_fun = function let link_file output_fun currpos_fun = function
Link_object(file_name, unit) -> Link_object(file_name, unit) ->
link_object ppf output_fun currpos_fun file_name unit link_object output_fun currpos_fun file_name unit
| Link_archive(file_name, units) -> | Link_archive(file_name, units) ->
link_archive ppf output_fun currpos_fun file_name units link_archive output_fun currpos_fun file_name units
(* Output the debugging information *) (* Output the debugging information *)
(* Format is: (* Format is:
@ -298,7 +298,7 @@ let make_absolute file =
(* Create a bytecode executable file *) (* Create a bytecode executable file *)
let link_bytecode ppf tolink exec_name standalone = let link_bytecode tolink exec_name standalone =
(* Avoid the case where the specified exec output file is the same as (* Avoid the case where the specified exec output file is the same as
one of the objects to be linked *) one of the objects to be linked *)
List.iter (function List.iter (function
@ -343,7 +343,7 @@ let link_bytecode ppf tolink exec_name standalone =
end; end;
let output_fun = output_bytes outchan let output_fun = output_bytes outchan
and currpos_fun () = pos_out outchan - start_code in and currpos_fun () = pos_out outchan - start_code in
List.iter (link_file ppf output_fun currpos_fun) tolink; List.iter (link_file output_fun currpos_fun) tolink;
if check_dlls then Dll.close_all_dlls(); if check_dlls then Dll.close_all_dlls();
(* The final STOP instruction *) (* The final STOP instruction *)
output_byte outchan Opcodes.opSTOP; output_byte outchan Opcodes.opSTOP;
@ -444,7 +444,7 @@ let output_cds_file outfile =
(* Output a bytecode executable as a C file *) (* Output a bytecode executable as a C file *)
let link_bytecode_as_c ppf tolink outfile = let link_bytecode_as_c tolink outfile =
let outchan = open_out outfile in let outchan = open_out outfile in
begin try begin try
(* The bytecode *) (* The bytecode *)
@ -464,7 +464,7 @@ let link_bytecode_as_c ppf tolink outfile =
output_code_string outchan code; output_code_string outchan code;
currpos := !currpos + Bytes.length code currpos := !currpos + Bytes.length code
and currpos_fun () = !currpos in and currpos_fun () = !currpos in
List.iter (link_file ppf output_fun currpos_fun) tolink; List.iter (link_file output_fun currpos_fun) tolink;
(* The final STOP instruction *) (* The final STOP instruction *)
Printf.fprintf outchan "\n0x%x};\n\n" Opcodes.opSTOP; Printf.fprintf outchan "\n0x%x};\n\n" Opcodes.opSTOP;
(* The table of global data *) (* The table of global data *)
@ -565,7 +565,7 @@ let fix_exec_name name =
(* Main entry point (build a custom runtime if needed) *) (* Main entry point (build a custom runtime if needed) *)
let link ppf objfiles output_name = let link objfiles output_name =
let objfiles = let objfiles =
if !Clflags.nopervasives then objfiles if !Clflags.nopervasives then objfiles
else if !Clflags.output_c_object then "stdlib.cma" :: objfiles else if !Clflags.output_c_object then "stdlib.cma" :: objfiles
@ -584,7 +584,7 @@ let link ppf objfiles output_name =
(* put user's opts first *) (* put user's opts first *)
Clflags.dllibs := !lib_dllibs @ !Clflags.dllibs; (* put user's DLLs first *) Clflags.dllibs := !lib_dllibs @ !Clflags.dllibs; (* put user's DLLs first *)
if not !Clflags.custom_runtime then if not !Clflags.custom_runtime then
link_bytecode ppf tolink output_name true link_bytecode tolink output_name true
else if not !Clflags.output_c_object then begin else if not !Clflags.output_c_object then begin
let bytecode_name = Filename.temp_file "camlcode" "" in let bytecode_name = Filename.temp_file "camlcode" "" in
let prim_name = let prim_name =
@ -593,7 +593,7 @@ let link ppf objfiles output_name =
else else
Filename.temp_file "camlprim" ".c" in Filename.temp_file "camlprim" ".c" in
try try
link_bytecode ppf tolink bytecode_name false; link_bytecode tolink bytecode_name false;
let poc = open_out prim_name in let poc = open_out prim_name in
(* note: builds will not be reproducible if the C code contains macros (* note: builds will not be reproducible if the C code contains macros
such as __FILE__. *) such as __FILE__. *)
@ -646,7 +646,7 @@ let link ppf objfiles output_name =
else basename ^ Config.ext_obj else basename ^ Config.ext_obj
in in
try try
link_bytecode_as_c ppf tolink c_file; link_bytecode_as_c tolink c_file;
if not (Filename.check_suffix output_name ".c") then begin if not (Filename.check_suffix output_name ".c") then begin
temps := c_file :: !temps; temps := c_file :: !temps;
if Ccomp.compile_file ~output:obj_file ?stable_name c_file <> 0 then if Ccomp.compile_file ~output:obj_file ?stable_name c_file <> 0 then

5
bytecomp/bytelink.mli
View File

@ -15,11 +15,10 @@
(* Link .cmo files and produce a bytecode executable. *) (* Link .cmo files and produce a bytecode executable. *)
val link : Format.formatter -> string list -> string -> unit val link : string list -> string -> unit
val reset : unit -> unit val reset : unit -> unit
val check_consistency: val check_consistency: string -> Cmo_format.compilation_unit -> unit
Format.formatter -> string -> Cmo_format.compilation_unit -> unit
val extract_crc_interfaces: unit -> (string * Digest.t option) list val extract_crc_interfaces: unit -> (string * Digest.t option) list

20
bytecomp/bytepackager.ml
View File

@ -132,11 +132,11 @@ let read_member_info file = (
Accumulate relocs, debug info, etc. Accumulate relocs, debug info, etc.
Return size of bytecode. *) Return size of bytecode. *)
let rename_append_bytecode ppf packagename oc mapping defined ofs prefix subst let rename_append_bytecode packagename oc mapping defined ofs prefix subst
objfile compunit = objfile compunit =
let ic = open_in_bin objfile in let ic = open_in_bin objfile in
try try
Bytelink.check_consistency ppf objfile compunit; Bytelink.check_consistency objfile compunit;
List.iter List.iter
(rename_relocation packagename objfile mapping defined ofs) (rename_relocation packagename objfile mapping defined ofs)
compunit.cu_reloc; compunit.cu_reloc;
@ -161,7 +161,7 @@ let rename_append_bytecode ppf packagename oc mapping defined ofs prefix subst
(* Same, for a list of .cmo and .cmi files. (* Same, for a list of .cmo and .cmi files.
Return total size of bytecode. *) Return total size of bytecode. *)
let rec rename_append_bytecode_list ppf packagename oc mapping defined ofs let rec rename_append_bytecode_list packagename oc mapping defined ofs
prefix subst = prefix subst =
function function
[] -> [] ->
@ -169,15 +169,15 @@ let rec rename_append_bytecode_list ppf packagename oc mapping defined ofs
| m :: rem -> | m :: rem ->
match m.pm_kind with match m.pm_kind with
| PM_intf -> | PM_intf ->
rename_append_bytecode_list ppf packagename oc mapping defined ofs rename_append_bytecode_list packagename oc mapping defined ofs
prefix subst rem prefix subst rem
| PM_impl compunit -> | PM_impl compunit ->
let size = let size =
rename_append_bytecode ppf packagename oc mapping defined ofs rename_append_bytecode packagename oc mapping defined ofs
prefix subst m.pm_file compunit in prefix subst m.pm_file compunit in
let id = Ident.create_persistent m.pm_name in let id = Ident.create_persistent m.pm_name in
let root = Path.Pident (Ident.create_persistent prefix) in let root = Path.Pident (Ident.create_persistent prefix) in
rename_append_bytecode_list ppf packagename oc mapping (id :: defined) rename_append_bytecode_list packagename oc mapping (id :: defined)
(ofs + size) prefix (ofs + size) prefix
(Subst.add_module id (Path.Pdot (root, Ident.name id, Path.nopos)) (Subst.add_module id (Path.Pdot (root, Ident.name id, Path.nopos))
subst) subst)
@ -206,7 +206,7 @@ let build_global_target oc target_name members mapping pos coercion =
(* Build the .cmo file obtained by packaging the given .cmo files. *) (* Build the .cmo file obtained by packaging the given .cmo files. *)
let package_object_files ppf files targetfile targetname coercion = let package_object_files files targetfile targetname coercion =
let members = let members =
map_left_right read_member_info files in map_left_right read_member_info files in
let required_globals = let required_globals =
@ -241,7 +241,7 @@ let package_object_files ppf files targetfile targetname coercion =
let pos_depl = pos_out oc in let pos_depl = pos_out oc in
output_binary_int oc 0; output_binary_int oc 0;
let pos_code = pos_out oc in let pos_code = pos_out oc in
let ofs = rename_append_bytecode_list ppf targetname oc mapping [] 0 let ofs = rename_append_bytecode_list targetname oc mapping [] 0
targetname Subst.identity members in targetname Subst.identity members in
build_global_target oc targetname members mapping ofs coercion; build_global_target oc targetname members mapping ofs coercion;
let pos_debug = pos_out oc in let pos_debug = pos_out oc in
@ -278,7 +278,7 @@ let package_object_files ppf files targetfile targetname coercion =
(* The entry point *) (* The entry point *)
let package_files ppf initial_env files targetfile = let package_files initial_env files targetfile =
let files = let files =
List.map List.map
(fun f -> (fun f ->
@ -291,7 +291,7 @@ let package_files ppf initial_env files targetfile =
try try
let coercion = let coercion =
Typemod.package_units initial_env files targetcmi targetname in Typemod.package_units initial_env files targetcmi targetname in
package_object_files ppf files targetfile targetname coercion package_object_files files targetfile targetname coercion
with x -> with x ->
remove_file targetfile; raise x remove_file targetfile; raise x

2
bytecomp/bytepackager.mli
View File

@ -16,7 +16,7 @@
(* "Package" a set of .cmo files into one .cmo file having the (* "Package" a set of .cmo files into one .cmo file having the
original compilation units as sub-modules. *) original compilation units as sub-modules. *)
val package_files: Format.formatter -> Env.t -> string list -> string -> unit val package_files: Env.t -> string list -> string -> unit
type error = type error =
Forward_reference of string * Ident.t Forward_reference of string * Ident.t

4
driver/compmisc.ml
View File

@ -57,11 +57,11 @@ let initial_env () =
~initially_opened_module ~initially_opened_module
~open_implicit_modules:(List.rev !Clflags.open_modules) ~open_implicit_modules:(List.rev !Clflags.open_modules)
let read_color_env ppf = let read_color_env () =
try try
match Clflags.parse_color_setting (Sys.getenv "OCAML_COLOR") with match Clflags.parse_color_setting (Sys.getenv "OCAML_COLOR") with
| None -> | None ->
Location.print_warning Location.none ppf Location.prerr_warning Location.none
(Warnings.Bad_env_variable (Warnings.Bad_env_variable
("OCAML_COLOR", ("OCAML_COLOR",
"expected \"auto\", \"always\" or \"never\"")); "expected \"auto\", \"always\" or \"never\""));

2
driver/compmisc.mli
View File

@ -16,4 +16,4 @@
val init_path : ?dir:string -> bool -> unit val init_path : ?dir:string -> bool -> unit
val initial_env : unit -> Env.t val initial_env : unit -> Env.t
val read_color_env : Format.formatter -> unit val read_color_env : unit -> unit

9
driver/main.ml
View File

@ -134,7 +134,7 @@ let main () =
try try
readenv ppf Before_args; readenv ppf Before_args;
Clflags.parse_arguments anonymous usage; Clflags.parse_arguments anonymous usage;
Compmisc.read_color_env ppf; Compmisc.read_color_env ();
begin try begin try
Compenv.process_deferred_actions Compenv.process_deferred_actions
(ppf, (ppf,
@ -162,8 +162,7 @@ let main () =
if !make_archive then begin if !make_archive then begin
Compmisc.init_path false; Compmisc.init_path false;
Bytelibrarian.create_archive ppf Bytelibrarian.create_archive (Compenv.get_objfiles ~with_ocamlparam:false)
(Compenv.get_objfiles ~with_ocamlparam:false)
(extract_output !output_name); (extract_output !output_name);
Warnings.check_fatal (); Warnings.check_fatal ();
end end
@ -171,7 +170,7 @@ let main () =
Compmisc.init_path false; Compmisc.init_path false;
let extracted_output = extract_output !output_name in let extracted_output = extract_output !output_name in
let revd = get_objfiles ~with_ocamlparam:false in let revd = get_objfiles ~with_ocamlparam:false in
Bytepackager.package_files ppf (Compmisc.initial_env ()) Bytepackager.package_files (Compmisc.initial_env ())
revd (extracted_output); revd (extracted_output);
Warnings.check_fatal (); Warnings.check_fatal ();
end end
@ -193,7 +192,7 @@ let main () =
default_output !output_name default_output !output_name
in in
Compmisc.init_path false; Compmisc.init_path false;
Bytelink.link ppf (get_objfiles ~with_ocamlparam:true) target; Bytelink.link (get_objfiles ~with_ocamlparam:true) target;
Warnings.check_fatal (); Warnings.check_fatal ();
end; end;
with x -> with x ->

2
driver/optmain.ml
View File

@ -247,7 +247,7 @@ let main () =
"<options> Compute dependencies \ "<options> Compute dependencies \
(use 'ocamlopt -depend -help' for details)"]; (use 'ocamlopt -depend -help' for details)"];
Clflags.parse_arguments anonymous usage; Clflags.parse_arguments anonymous usage;
Compmisc.read_color_env ppf; Compmisc.read_color_env ();
if !gprofile && not Config.profiling then if !gprofile && not Config.profiling then
fatal "Profiling with \"gprof\" is not supported on this platform."; fatal "Profiling with \"gprof\" is not supported on this platform.";
begin try begin try

4
middle_end/middle_end.ml
View File

@ -45,11 +45,11 @@ let middle_end ppf ~prefixname ~backend
end) end)
in in
let warning_set = ref WarningSet.empty in let warning_set = ref WarningSet.empty in
let flambda_warning_printer loc _fmt w = let flambda_warning_printer loc ppf w =
let elt = loc, w in let elt = loc, w in
if not (WarningSet.mem elt !warning_set) then begin if not (WarningSet.mem elt !warning_set) then begin
warning_set := WarningSet.add elt !warning_set; warning_set := WarningSet.add elt !warning_set;
previous_warning_printer loc !Location.formatter_for_warnings w previous_warning_printer loc ppf w
end; end;
in in
Misc.protect_refs Misc.protect_refs