[OCaml] Expose the LLVM diagnostic handler

Differential Revision: http://reviews.llvm.org/D18891


git-svn-id: https://llvm.org/svn/llvm-project/llvm/trunk@265897 91177308-0d34-0410-b5e6-96231b3b80d8

4 files changed, 60 insertions, 1 deletions

diff --git a/test/Bindings/OCaml/bitreader.ml b/test/Bindings/OCaml/bitreader.ml
index 3fda34ab22e..87a165cddc8 100644
--- a/test/Bindings/OCaml/bitreader.ml
+++ b/test/Bindings/OCaml/bitreader.ml
@@ -12,9 +12,13 @@
 
 let context = Llvm.global_context ()
 
+let diagnostic_handler _ = ()
+
 let test x = if not x then exit 1 else ()
 
 let _ =
+  Llvm.set_diagnostic_handler context (Some diagnostic_handler);
+
   let fn = Sys.argv.(1) in
   let m = Llvm.create_module context "ocaml_test_module" in
 
diff --git a/test/Bindings/OCaml/diagnostic_handler.ml b/test/Bindings/OCaml/diagnostic_handler.ml
new file mode 100644
index 00000000000..a94ff220b7f
--- /dev/null
+++ b/test/Bindings/OCaml/diagnostic_handler.ml
@@ -0,0 +1,48 @@
+(* RUN: cp %s %T/diagnostic_handler.ml
+ * RUN: %ocamlc -g -w +A -package llvm.bitreader -linkpkg %T/diagnostic_handler.ml -o %t
+ * RUN: %t %t.bc | FileCheck %s
+ * RUN: %ocamlopt -g -w +A -package llvm.bitreader -linkpkg %T/diagnostic_handler.ml -o %t
+ * RUN: %t %t.bc | FileCheck %s
+ * XFAIL: vg_leak
+ *)
+
+let context = Llvm.global_context ()
+
+let diagnostic_handler d =
+  Printf.printf
+    "Diagnostic handler called: %s\n" (Llvm.Diagnostic.description d);
+  match Llvm.Diagnostic.severity d with
+  | Error -> Printf.printf "Diagnostic severity is Error\n"
+  | Warning -> Printf.printf "Diagnostic severity is Warning\n"
+  | Remark -> Printf.printf "Diagnostic severity is Remark\n"
+  | Note -> Printf.printf "Diagnostic severity is Note\n"
+
+let test x = if not x then exit 1 else ()
+
+let _ =
+  Llvm.set_diagnostic_handler context (Some diagnostic_handler);
+
+  (* corrupt the bitcode *)
+  let fn = Sys.argv.(1) ^ ".txt" in
+  begin let oc = open_out fn in
+    output_string oc "not a bitcode file\n";
+    close_out oc
+  end;
+
+  test begin
+    try
+      let mb = Llvm.MemoryBuffer.of_file fn in
+      let m = begin try
+        (* CHECK: Diagnostic handler called: Invalid bitcode signature
+         * CHECK: Diagnostic severity is Error
+         *)
+        Llvm_bitreader.get_module context mb
+      with x ->
+        Llvm.MemoryBuffer.dispose mb;
+        raise x
+      end in
+      Llvm.dispose_module m;
+      false
+    with Llvm_bitreader.Error _ ->
+      true
+  end
diff --git a/test/Bindings/OCaml/ext_exc.ml b/test/Bindings/OCaml/ext_exc.ml
index a24a28b1f52..5c9c8476cb9 100644
--- a/test/Bindings/OCaml/ext_exc.ml
+++ b/test/Bindings/OCaml/ext_exc.ml
@@ -8,9 +8,12 @@
 
 let context = Llvm.global_context ()
 
-(* this used to crash, we must not use 'external' in .mli files, but 'val' if we
+let diagnostic_handler _ = ()
+
+(* This used to crash, we must not use 'external' in .mli files, but 'val' if we
  * want the let _ bindings executed, see http://caml.inria.fr/mantis/view.php?id=4166 *)
 let _ =
+    Llvm.set_diagnostic_handler context (Some diagnostic_handler);
     try
         ignore (Llvm_bitreader.get_module context (Llvm.MemoryBuffer.of_stdin ()))
     with
diff --git a/test/Bindings/OCaml/linker.ml b/test/Bindings/OCaml/linker.ml
index 423905e489c..119ca4cfee9 100644
--- a/test/Bindings/OCaml/linker.ml
+++ b/test/Bindings/OCaml/linker.ml
@@ -16,6 +16,8 @@ open Llvm_linker
 let context = global_context ()
 let void_type = Llvm.void_type context
 
+let diagnostic_handler _ = ()
+
 (* Tiny unit test framework - really just to help find which line is busted *)
 let print_checkpoints = false
 
@@ -28,6 +30,8 @@ let suite name f =
 (*===-- Linker -----------------------------------------------------------===*)
 
 let test_linker () =
+  set_diagnostic_handler context (Some diagnostic_handler);
+
   let fty = function_type void_type [| |] in
 
   let make_module name =