From 828ce477c8e7791f718cb01616e0bf80c2773e02 Mon Sep 17 00:00:00 2001
From: Zackery Spytz <zspytz@gmail.com>
Date: Tue, 5 Feb 2019 13:35:43 -0700
Subject: [PATCH] [OCaml] Fix a bug in the ctors of director classes

If a class was given the director feature, it was not possible
to use ctors with multiple parameters.

Add director_default_runme.ml (it is based on
director_default_runme.java).
---
 .../ocaml/director_default_runme.ml           | 25 +++++++++++++++++++
 Lib/ocaml/std_string.i                        |  5 ++++
 Lib/ocaml/swig.ml                             |  7 ++++++
 Lib/ocaml/swig.mli                            |  1 +
 Source/Modules/ocaml.cxx                      | 13 +++++-----
 5 files changed, 45 insertions(+), 6 deletions(-)
 create mode 100644 Examples/test-suite/ocaml/director_default_runme.ml

diff --git a/Examples/test-suite/ocaml/director_default_runme.ml b/Examples/test-suite/ocaml/director_default_runme.ml
new file mode 100644
index 000000000..4fd655a00
--- /dev/null
+++ b/Examples/test-suite/ocaml/director_default_runme.ml
@@ -0,0 +1,25 @@
+open Swig
+open Director_default
+
+let director_default_MyFoo ob meth args =
+  match meth with
+      "Msg" -> (match args with
+                  | C_list [ msg ] -> C_string ("director_default_MyFoo-" ^ (msg as string))
+                  | _ -> raise (Failure "director_default_MyFoo::Msg()"))
+    | _ -> (invoke ob) meth args
+
+let _ =
+  let a = new_derived_object new_Foo (director_default_MyFoo) '(10) in
+  assert (a -> GetMsg () as string = "director_default_MyFoo-default");
+  assert (a -> GetMsg ("boo") as string = "director_default_MyFoo-boo");
+  let f = new_Foo '(10) in
+  assert (f -> GetMsg () as string = "Foo-default");
+  assert (f -> GetMsg ("boo") as string = "Foo-boo");
+
+  let b = new_Bar '(1) in
+  assert (b -> GetMsg () as string = "Bar-default");
+  assert (b -> GetMsg ("boo") as string = "Bar-boo");
+  let b2 = new_Bar '() in
+  assert (b2 -> GetMsg () as string = "Bar-default");
+  assert (b2 -> GetMsg ("boo") as string = "Bar-boo");
+;;
diff --git a/Lib/ocaml/std_string.i b/Lib/ocaml/std_string.i
index 770353052..0ea9b4e2d 100644
--- a/Lib/ocaml/std_string.i
+++ b/Lib/ocaml/std_string.i
@@ -70,6 +70,11 @@ class wstring;
   swig_result =	caml_list_append(swig_result,caml_val_string_len((*$1).c_str(), (*$1).size()));
 }
 
+%typemap(directorin) string {
+    swig_result = caml_val_string_len($1.c_str(), $1.size());
+    args = caml_list_append(args, swig_result);
+}
+
 %typemap(directorout) string {
 	$result.assign((char *)caml_ptr_val($input,0), caml_string_len($input));
 }
diff --git a/Lib/ocaml/swig.ml b/Lib/ocaml/swig.ml
index 8ac301dc6..58a93347b 100644
--- a/Lib/ocaml/swig.ml
+++ b/Lib/ocaml/swig.ml
@@ -44,6 +44,13 @@ let _ = Callback.register "swig_runmethod" invoke
 let fnhelper arg =
   match arg with C_list l -> l | C_void -> [] | _ -> [ arg ]
 
+let director_core_helper fnargs =
+  try
+    match List.hd fnargs with
+      | C_director_core (o,r) -> fnargs
+      | _ -> C_void :: fnargs
+  with Failure _ -> C_void :: fnargs
+
 let rec get_int x = 
   match x with
       C_bool b -> if b then 1 else 0
diff --git a/Lib/ocaml/swig.mli b/Lib/ocaml/swig.mli
index 3207b9e73..c5ffadb15 100644
--- a/Lib/ocaml/swig.mli
+++ b/Lib/ocaml/swig.mli
@@ -30,6 +30,7 @@ exception NoSuchClass of string
 
 val invoke : ('a c_obj_t) -> (string -> 'a c_obj_t -> 'a c_obj_t)
 val fnhelper : 'a c_obj_t -> 'a c_obj_t list
+val director_core_helper : 'a c_obj_t list -> 'a c_obj_t list
 
 val get_int : 'a c_obj_t -> int
 val get_float : 'a c_obj_t -> float
diff --git a/Source/Modules/ocaml.cxx b/Source/Modules/ocaml.cxx
index 99f2a98d7..752e6231f 100644
--- a/Source/Modules/ocaml.cxx
+++ b/Source/Modules/ocaml.cxx
@@ -752,14 +752,15 @@ public:
       }
     }
 
-    if (expose_func)
-      Printf(f_mlbody,
-	     "external %s_f : c_obj list -> c_obj list = \"%s\" ;;\n"
-	     "let %s arg = match %s_f (fnhelper arg) with\n"
-	     "  [] -> C_void\n"
+    if (expose_func) {
+      Printf(f_mlbody, "external %s_f : c_obj list -> c_obj list = \"%s\" ;;\n", mangled_name, wname);
+      Printf(f_mlbody, "let %s arg = match %s_f (%s(fnhelper arg)) with\n", mangled_name, mangled_name,
+	     in_constructor && Swig_directorclass(getCurrentClass()) ? "director_core_helper " : "");
+      Printf(f_mlbody, "  [] -> C_void\n"
 	     "| [x] -> (if %s then Gc.finalise \n"
 	     "  (fun x -> ignore ((invoke x) \"~\" C_void)) x) ; x\n"
-	     "| lst -> C_list lst ;;\n", mangled_name, wname, mangled_name, mangled_name, newobj ? "true" : "false");
+	     "| lst -> C_list lst ;;\n", newobj ? "true" : "false");
+    }
 
     if ((!classmode || in_constructor || in_destructor || static_member_function) && expose_func)
       Printf(f_mlibody, "val %s : c_obj -> c_obj\n", mangled_name);