Lwt return void

src/cstubs/cstubs_generate_c.ml

@@ -359,11 +359,14 @@ struct
   let structure_type stub_name = 
     structure (sprintf "job_%s" stub_name)
 
-  let structure ~errno ~stub_name fmt fn args result =
+  let structure (type r) ~errno ~stub_name fmt fn args (result : r typ) =
     let open Ctypes in
     let s = structure_type stub_name in
     let (_ : (_,_) field) = field s "job" lwt_unix_job in
-    let (_ : (_,_) field) = field s "result" result in
+    let () = match result with
+        Void -> let (_ : (_,_) field) = field s "result" int in ()
+      | result -> let (_ : (_,_) field) = field s "result" result in ()
+    in
     let () = match errno with
         `Ignore_errno -> ()
       | `Return_errno -> ignore (field s "error_status" sint)
@@ -373,19 +376,21 @@ struct
     let () = seal s in
     fprintf fmt "@[%a@];@\n" (fun t -> format_typ t) s
 
-  let worker ~errno ~cname ~stub_name fmt f result args =
+  let worker (type r) ~errno ~cname ~stub_name fmt f (result : r typ) args =
     let fn' = { fname = cname;
                allocates = false;
                reads_ocaml_heap = false;
                fn = Fn f }
     and j = "j", Ty (ptr (structure_type stub_name)) in
     let rec body args : _ -> ccomp = function
         [] ->
-        let r c =
-          Generate_C.cast ~from:(Ty result) ~into:(Ty Void)
-            (`LetAssign (`PointerField (`Local j, "result"),
-                         `App (fn', List.rev args),
-                         c))
+        let r c = match result with
+          | Void -> Generate_C.(`App (fn', List.rev args) >> c)
+          | result ->
+            Generate_C.cast ~from:(Ty result) ~into:(Ty Void)
+              (`LetAssign (`PointerField (`Local j, "result"),
+                           `App (fn', List.rev args),
+                           c))
         in
         begin match errno with
             `Ignore_errno -> r (`Return (Ty Void, (`Int Signed.SInt.zero)))
@@ -407,7 +412,7 @@ struct
                   body [] args,
                   `Static))
 
-  let result ~errno ~stub_name fmt fn result =
+  let result (type r) ~errno ~stub_name fmt fn (result : r typ) =
     begin
       fprintf fmt "@[static@ value@ result_%s@;@[(struct@ job_%s@ *j)@]@]@;@[<2>{@\n"
         stub_name stub_name;
@@ -421,12 +426,17 @@ struct
           fprintf fmt "@[Store_field(rv,@ 1,@ ctypes_copy_sint(j->error_status));@]@\n";
           fprintf fmt "@[Store_field(rv,@ 0,@ ";
       in
-          fprintf fmt "%a);@]@\n"
-            (fun fmt ty ->
-               Cstubs_emit_c.ceff fmt
-                 (Generate_C.inj ty
-                    (`Local ("j->result", Cstubs_c_language.(Ty ty)))))
-            result;
+      fprintf fmt "%a);@]@\n"
+        (let f (type r) fmt : r typ -> _ = function
+             Void ->
+             Cstubs_emit_c.ceff fmt Generate_C.val_unit
+           | ty ->
+             Cstubs_emit_c.ceff fmt
+               (Generate_C.inj ty
+                  (`Local ("j->result", Cstubs_c_language.(Ty ty))))
+         in f
+        )
+        result;
       fprintf fmt "@[lwt_unix_free_job(&j->job)@];@\n";
       fprintf fmt "@[CAMLreturn@ (rv)@];@]@\n";
       fprintf fmt "}@\n";

tests/clib/test_functions.c

@@ -669,6 +669,12 @@ int return_10(void)
   return 10;
 }
 
+void return_void(int *x)
+{
+  *x = 10;
+  return;
+}
+
 int callback_returns_char_a(char (*f)(void))
 {
   return f() == 'a' ? 1 : 0;

tests/clib/test_functions.h

@@ -233,6 +233,7 @@ void *retrieve_ocaml_value(void);
 
 int sixargs(int, int, int, int, int, int);
 int return_10(void);
+void return_void(int *);
 
 int callback_returns_char_a(char (*)(void));
 

tests/test-lwt-jobs/stubs/functions.ml

@@ -27,4 +27,7 @@ struct
 
   let return_10 = foreign "return_10"
       (void @-> returning int)
+
+  let return_void = foreign "return_void"
+      (ptr int @-> returning void)
 end

tests/test-lwt-jobs/test_lwt_jobs.ml

@@ -88,6 +88,16 @@ let test_no_args _ =
      assert_equal 10 i;
      Lwt.return ())
 
+(*
+  Test calling functions that return void.
+ *)
+let test_return_void _ =
+  let open Lwt.Infix in
+  Lwt_unix.run
+    (let x_p = allocate_n ~count:1 int in
+     (Bindings.return_void x_p).Generated_bindings.lwt >>= fun () ->
+     assert_equal 10 (!@ x_p);
+     Lwt.return ())
 
 let suite = "Lwt job tests" >:::
   ["calling sqrt"
@@ -104,6 +114,9 @@ let suite = "Lwt job tests" >:::
 
    "functions with no arguments"
     >:: test_no_args;
+
+   "functions that return void"
+    >:: test_return_void;
   ]
 
 

tests/test-lwt-preemptive/stubs/functions.ml

@@ -27,4 +27,7 @@ struct
 
   let return_10 = foreign "return_10"
       (void @-> returning int)
+
+  let return_void = foreign "return_void"
+      (ptr int @-> returning void)
 end

tests/test-lwt-preemptive/test_lwt_jobs.ml

@@ -88,6 +88,17 @@ let test_no_args _ =
      assert_equal 10 i;
      Lwt.return ())
 
+(*
+  Test calling functions that return void.
+ *)
+let test_return_void _ =
+  let open Lwt.Infix in
+  Lwt_unix.run
+    (let x_p = allocate_n ~count:1 int in
+     (Bindings.return_void x_p).Generated_bindings.lwt >>= fun () ->
+     assert_equal 10 (!@ x_p);
+     Lwt.return ())
+
 
 let suite = "Lwt job tests" >:::
   ["calling sqrt"
@@ -104,6 +115,9 @@ let suite = "Lwt job tests" >:::
 
    "functions with no arguments"
     >:: test_no_args;
+
+   "functions that return void"
+    >:: test_return_void;
   ]
 
 

tests/test-returning-errno-lwt-jobs/stubs/functions.ml

@@ -22,4 +22,7 @@ struct
 
   let return_10 = foreign "return_10"
       (void @-> returning int)
+
+  let return_void = foreign "return_void"
+      (ptr int @-> returning void)
 end

tests/test-returning-errno-lwt-jobs/test_returning_errno.ml

@@ -53,6 +53,17 @@ let test_no_args _ =
      assert_equal 10 i;
      Lwt.return ())
 
+(*
+  Test calling functions that return void.
+ *)
+let test_return_void _ =
+  let open Lwt.Infix in
+  Lwt_unix.run
+    (let x_p = allocate_n ~count:1 int in
+     (Bindings.return_void x_p).Generated_bindings.lwt >>= fun ((), errno) ->
+     assert_equal 10 (!@ x_p);
+     Lwt.return ())
+
 
 let suite = "Errno tests" >:::
   ["calling stat"
@@ -63,6 +74,9 @@ let suite = "Errno tests" >:::
 
    "functions with no arguments"
     >:: test_no_args;
+
+   "functions that return void"
+    >:: test_return_void;
   ]
 
 

tests/test-returning-errno-lwt-preemptive/stubs/functions.ml

@@ -22,4 +22,7 @@ struct
 
   let return_10 = foreign "return_10"
       (void @-> returning int)
+
+  let return_void = foreign "return_void"
+      (ptr int @-> returning void)
 end

tests/test-returning-errno-lwt-preemptive/test_returning_errno.ml

@@ -53,6 +53,17 @@ let test_no_args _ =
      assert_equal 10 i;
      Lwt.return ())
 
+(*
+  Test calling functions that return void.
+ *)
+let test_return_void _ =
+  let open Lwt.Infix in
+  Lwt_unix.run
+    (let x_p = allocate_n ~count:1 int in
+     (Bindings.return_void x_p).Generated_bindings.lwt >>= fun ((), errno) ->
+     assert_equal 10 (!@ x_p);
+     Lwt.return ())
+
 
 let suite = "Errno tests" >:::
   ["calling stat"
@@ -63,6 +74,9 @@ let suite = "Errno tests" >:::
 
    "functions with no arguments"
     >:: test_no_args;
+
+   "functions that return void"
+    >:: test_return_void;
   ]