Merge branch 'ZackerySpytz-OCaml-exception-improvements'

* ZackerySpytz-OCaml-exception-improvements:
  [OCaml] Some exception improvements

Examples/test-suite/ocaml/catches_runme.ml

@@ -0,0 +1,39 @@
+open Swig
+open Catches
+
+let _  =
+  try
+    ignore (_test_catches '(1)); assert false
+  with Failure s ->
+    assert (s = "C++ int exception thrown, value: 1")
+
+  try
+    ignore (_test_catches '(2)); assert false
+  with Failure s ->
+    assert (s = "two")
+
+  try
+    ignore (_test_catches '(3)); assert false
+  with Failure s ->
+    assert (s = "C++ ThreeException const & exception thrown")
+
+  try
+    ignore (_test_exception_specification '(1)); assert false
+  with Failure s ->
+    assert (s = "C++ int exception thrown, value: 1")
+
+  try
+    ignore (_test_exception_specification '(2)); assert false
+  with Failure s ->
+    assert (s = "unknown exception")
+
+  try
+    ignore (_test_exception_specification '(3)); assert false
+  with Failure s ->
+    assert (s = "unknown exception")
+
+  try
+    ignore (_test_catches_all '(1)); assert false
+  with Failure s ->
+    assert (s = "unknown exception")
+;;

Examples/test-suite/ocaml/director_exception_runme.ml

@@ -0,0 +1,46 @@
+open Swig
+open Director_exception
+
+exception MyException of string * string
+
+let director_exception_MyFoo ob meth args =
+  match meth with
+      "ping" -> raise (Failure "MyFoo::ping() EXCEPTION")
+    | _ -> (invoke ob) meth args
+
+let director_exception_MyFoo2 ob meth args =
+  match meth with
+      "ping" -> (C_bool true)
+    | _ -> (invoke ob) meth args
+
+let director_exception_MyFoo3 ob meth args =
+  match meth with
+      "ping" -> raise (MyException ("foo", "bar"))
+    | _ -> (invoke ob) meth args
+
+(* Check that Failure is raised by MyFoo.ping() (via MyFoo.pong()). *)
+let a =
+  new_derived_object
+    new_Foo (director_exception_MyFoo) '()
+let a = _launder(a)
+try
+  let _ = a -> pong () in assert false
+with Failure s -> assert(s = "MyFoo::ping() EXCEPTION")
+
+let a =
+  new_derived_object
+    new_Foo (director_exception_MyFoo2) '()
+let a = _launder(a)
+try
+  let _ = a -> pong () in assert false
+with Failure s -> assert(s = "No appropriate conversion found.")
+
+let a =
+  new_derived_object
+    new_Foo (director_exception_MyFoo3) '()
+let a = _launder(a)
+try
+  let _ = a -> pong () in assert false
+with MyException (s1, s2) ->
+  assert (s1 = "foo");
+  assert (s2 = "bar");

Examples/test-suite/ocaml/exception_classname_runme.ml

@@ -0,0 +1,5 @@
+open Swig
+open Exception_classname
+
+let a = new_Exception '()
+assert (a -> testfunc () as int = 42)

Examples/test-suite/ocaml/exception_order_runme.ml

@@ -0,0 +1,17 @@
+open Swig
+open Exception_order
+
+let a = new_A '()
+
+let check meth args expected =
+  try
+    ignore ((invoke a) meth (C_list [ args ])); assert false
+  with Failure msg -> assert (msg = expected)
+
+let _ =
+  check "foo" '() "C++ E1 exception thrown";
+  check "bar" '() "C++ E2 exception thrown";
+  check "foobar" '() "postcatch unknown";
+  check "barfoo" (C_int 1) "C++ E1 exception thrown";
+  check "barfoo" (C_int 2) "C++ E2 * exception thrown";
+;;

Examples/test-suite/ocaml/li_std_except_runme.ml

@@ -0,0 +1,18 @@
+open Swig
+open Li_std_except
+
+let _ =
+  let t = new_Test '() in
+  try let _ = t -> throw_bad_cast () in assert false with Failure s -> ();
+  try let _ = t -> throw_bad_exception () in assert false with Failure s -> ();
+  try let _ = t -> throw_domain_error () in assert false with Failure s -> assert (s = "oops");
+  try let _ = t -> throw_exception () in assert false with Failure s -> ();
+  try let _ = t -> throw_invalid_argument () in assert false with Invalid_argument s -> assert (s = "oops");
+  try let _ = t -> throw_length_error () in assert false with Failure s -> assert (s = "oops");
+  try let _ = t -> throw_logic_error () in assert false with Failure s -> assert (s = "oops");
+  try let _ = t -> throw_out_of_range () in assert false with Failure s -> assert (s = "oops");
+  try let _ = t -> throw_overflow_error () in assert false with Failure s -> assert (s = "oops");
+  try let _ = t -> throw_range_error () in assert false with Failure s -> assert (s = "oops");
+  try let _ = t -> throw_runtime_error () in assert false with Failure s -> assert (s = "oops");
+  try let _ = t -> throw_underflow_error () in assert false with Failure s -> assert (s = "oops");
+;;

Examples/test-suite/ocaml/swig_exception_runme.ml

@@ -0,0 +1,13 @@
+open Swig
+open Swig_exception
+
+let _ =
+  let c = new_Circle '(10) and s = new_Square '(10) in
+  assert (_Shape_nshapes '() as int = 2);
+  try
+    ignore (c -> throwException ()); assert false
+  with Sys_error msg -> assert (msg = "OK");
+  let _ = c -> "~" () in
+  let _ = s -> "~" () in
+  assert (_Shape_nshapes '() as int = 0);
+;;

Examples/test-suite/ocaml/throw_exception_runme.ml

@@ -1,28 +1,25 @@
-(* Throw exception test *)
-
 open Swig
 open Throw_exception
 
-let x = new_Foo C_void ;;
-let _ =
-  try
-    (invoke x) "test_int" C_void 
-  with (Failure "Exception(37): Thrown exception from C++ (int)\n") ->
-  try 
-    (invoke x) "test_msg" C_void
-  with (Failure "Exception(0): Dead\n") ->
-  try
-    (invoke x) "test_cls" C_void 
-  with (Failure "Exception(0): Thrown exception from C++ (unknown)\n") ->
-  try
-    (invoke x) "test_multi" (C_int 1)
-  with (Failure "Exception(37): Thrown exception from C++ (int)\n") ->
-  try
-    (invoke x) "test_multi" (C_int 2)
-  with (Failure "Exception(0): Dead\n") ->
-  try
-    (invoke x) "test_multi" (C_int 3)
-  with (Failure "Exception(0): Thrown exception from C++ (unknown)\n") ->
-    exit 0
+let x = new_Foo '()
 
-let _ = exit 1
+let check meth args expected =
+  try
+    let _ = ((invoke x) meth (C_list [ args ])) in assert false
+  with Failure msg -> assert (msg = expected)
+
+let _ =
+  check "test_int" '() "C++ int exception thrown, value: 37";
+  check "test_msg" '() "Dead";
+  check "test_cls" '() "C++ CError exception thrown";
+  check "test_cls_ptr" '() "C++ CError * exception thrown";
+  check "test_cls_ref" '() "C++ CError & exception thrown";
+  check "test_cls_td" '() "C++ Namespace::ErrorTypedef exception thrown";
+  check "test_cls_ptr_td" '() "C++ Namespace::ErrorPtr exception thrown";
+  check "test_cls_ref_td" '() "C++ Namespace::ErrorRef exception thrown";
+  check "test_array" '() "C++ int [10] exception thrown";
+  check "test_enum" '() "C++ Namespace::EnumTest exception thrown";
+  check "test_multi" '(1) "C++ int exception thrown, value: 37";
+  check "test_multi" '(2) "Dead";
+  check "test_multi" '(3) "C++ CError exception thrown";
+;;

Lib/exception.i

@@ -127,13 +127,44 @@ SWIGINTERN void SWIG_JavaException(JNIEnv *jenv, int code, const char *msg) {
 
 #ifdef SWIGOCAML
 %{
-#define OCAML_MSG_BUF_LEN 1024
-SWIGINTERN void SWIG_exception_(int code, const char *msg) {
-  char msg_buf[OCAML_MSG_BUF_LEN];
-  sprintf( msg_buf, "Exception(%d): %s\n", code, msg );
-  caml_failwith( msg_buf );
+SWIGINTERN void SWIG_OCamlException(int code, const char *msg) {
+  CAMLparam0();
+
+  SWIG_OCamlExceptionCodes exception_code = SWIG_OCamlUnknownError;
+  switch (code) {
+  case SWIG_DivisionByZero:
+    exception_code = SWIG_OCamlArithmeticException;
+    break;
+  case SWIG_IndexError:
+    exception_code = SWIG_OCamlIndexOutOfBoundsException;
+    break;
+  case SWIG_IOError:
+  case SWIG_SystemError:
+    exception_code = SWIG_OCamlSystemException;
+    break;
+  case SWIG_MemoryError:
+    exception_code = SWIG_OCamlOutOfMemoryError;
+    break;
+  case SWIG_OverflowError:
+    exception_code = SWIG_OCamlOverflowException;
+    break;
+  case SWIG_RuntimeError:
+    exception_code = SWIG_OCamlRuntimeException;
+    break;
+  case SWIG_SyntaxError:
+  case SWIG_TypeError:
+  case SWIG_ValueError:
+    exception_code = SWIG_OCamlIllegalArgumentException;
+    break;
+  case SWIG_UnknownError:
+  default:
+    exception_code = SWIG_OCamlUnknownError;
+    break;
+  }
+  SWIG_OCamlThrowException(exception_code, msg);
+  CAMLreturn0;
 }
-#define SWIG_exception(a,b) SWIG_exception_((a),(b))
+#define SWIG_exception(code, msg) SWIG_OCamlException(code, msg)
 %}
 #endif
 

Lib/ocaml/ocamldec.swg

@@ -127,7 +127,44 @@ CAMLextern int64 Int64_val(caml_value_t v);
 #define SWIG_GetModule(clientdata) SWIG_Ocaml_GetModule(clientdata)
 #define SWIG_SetModule(clientdata, pointer) SWIG_Ocaml_SetModule(pointer)
 
-#define SWIG_contract_assert(expr, msg) if(!(expr)) {caml_failwith(msg);} else
+typedef enum {
+  SWIG_OCamlArithmeticException,
+  SWIG_OCamlDirectorPureVirtual,
+  SWIG_OCamlOutOfMemoryError,
+  SWIG_OCamlOverflowException,
+  SWIG_OCamlIllegalArgumentException,
+  SWIG_OCamlIndexOutOfBoundsException,
+  SWIG_OCamlRuntimeException,
+  SWIG_OCamlSystemException,
+  SWIG_OCamlUnknownError
+} SWIG_OCamlExceptionCodes;
+
+SWIGINTERN void SWIG_OCamlThrowException(SWIG_OCamlExceptionCodes code, const char *msg) {
+  CAMLparam0();
+  SWIG_CAMLlocal1(str);
+
+  switch (code) {
+  case SWIG_OCamlIllegalArgumentException:
+    caml_invalid_argument(msg);
+    break;
+  case SWIG_OCamlSystemException:
+    str = caml_copy_string(msg);
+    caml_raise_sys_error(str);
+    break;
+  case SWIG_OCamlArithmeticException:
+  case SWIG_OCamlIndexOutOfBoundsException:
+  case SWIG_OCamlOutOfMemoryError:
+  case SWIG_OCamlOverflowException:
+  case SWIG_OCamlRuntimeException:
+  case SWIG_OCamlUnknownError:
+  default:
+    caml_failwith(msg);
+    break;
+  }
+  CAMLreturn0;
+}
+
+#define SWIG_contract_assert(expr, msg) if(!(expr)) {SWIG_OCamlThrowException(SWIG_OCamlRuntimeException, msg);}
 
     SWIGINTERN int
     SWIG_GetPtr(void *source, void **result, swig_type_info *type, swig_type_info *result_type);

Lib/ocaml/std_except.i

@@ -0,0 +1,23 @@
+%{
+#include <typeinfo>
+#include <stdexcept>
+%}
+
+namespace std
+{
+  %ignore exception;
+  struct exception {};
+}
+
+%typemap(throws) std::bad_cast          "SWIG_OCamlThrowException(SWIG_OCamlRuntimeException, $1.what());"
+%typemap(throws) std::bad_exception     "SWIG_OCamlThrowException(SWIG_OCamlRuntimeException, $1.what());"
+%typemap(throws) std::domain_error      "SWIG_OCamlThrowException(SWIG_OCamlRuntimeException, $1.what());"
+%typemap(throws) std::exception         "SWIG_OCamlThrowException(SWIG_OCamlRuntimeException, $1.what());"
+%typemap(throws) std::invalid_argument  "SWIG_OCamlThrowException(SWIG_OCamlIllegalArgumentException, $1.what());"
+%typemap(throws) std::length_error      "SWIG_OCamlThrowException(SWIG_OCamlIndexOutOfBoundsException, $1.what());"
+%typemap(throws) std::logic_error       "SWIG_OCamlThrowException(SWIG_OCamlRuntimeException, $1.what());"
+%typemap(throws) std::out_of_range      "SWIG_OCamlThrowException(SWIG_OCamlIndexOutOfBoundsException, $1.what());"
+%typemap(throws) std::overflow_error    "SWIG_OCamlThrowException(SWIG_OCamlArithmeticException, $1.what());"
+%typemap(throws) std::range_error       "SWIG_OCamlThrowException(SWIG_OCamlIndexOutOfBoundsException, $1.what());"
+%typemap(throws) std::runtime_error     "SWIG_OCamlThrowException(SWIG_OCamlRuntimeException, $1.what());"
+%typemap(throws) std::underflow_error   "SWIG_OCamlThrowException(SWIG_OCamlArithmeticException, $1.what());"

Lib/ocaml/typecheck.i

@@ -163,19 +163,16 @@
                   unsigned int, 
                   unsigned long, 
                   unsigned short {
-  SWIG_exception($1,"Thrown exception from C++ (int)");
+  char error_msg[256];
+  sprintf(error_msg, "C++ $1_type exception thrown, value: %d", $1);
+  SWIG_OCamlThrowException(SWIG_OCamlRuntimeException, error_msg);
 }
 
-%typemap(throws) SWIGTYPE CLASS {
-  $&1_ltype temp = new $1_ltype($1);
-  SWIG_exception((int)temp,"Thrown exception from C++ (object)");
-}
-
-%typemap(throws) SWIGTYPE {
+%typemap(throws) SWIGTYPE, SWIGTYPE &, SWIGTYPE &&, SWIGTYPE *, SWIGTYPE [], SWIGTYPE [ANY] {
   (void)$1;
-  SWIG_exception(0,"Thrown exception from C++ (unknown)");
+  SWIG_OCamlThrowException(SWIG_OCamlRuntimeException, "C++ $1_type exception thrown");
 }
 
 %typemap(throws) char * {
-  SWIG_exception(0,$1);
+  SWIG_OCamlThrowException(SWIG_OCamlRuntimeException, $1);
 }

Lib/std_except.i

@@ -19,7 +19,7 @@
  * a new std_except.i file in the target library directory.
  * ----------------------------------------------------------------------------- */
 
-#if defined(SWIGJAVA) || defined(SWIGCSHARP) || defined(SWIGGUILE) || defined(SWIGUTL) || defined(SWIGD)
+#if defined(SWIGJAVA) || defined(SWIGCSHARP) || defined(SWIGGUILE) || defined(SWIGUTL) || defined(SWIGD) || defined(SWIGOCAML)
 #error "This version of std_except.i should not be used"
 #endif