Support for returning errno from generated stubs

Makefile.tests

@@ -494,12 +494,12 @@ tests/test-arrays/generated_stubs.c: $(BUILDDIR)/test-arrays-stub-generator.nati
 tests/test-arrays/generated_bindings.ml: $(BUILDDIR)/test-arrays-stub-generator.native
 	$< --ml-file $@
 
-test-errno.dir = tests/test-errno
-test-errno.threads = yes
-test-errno.deps = str bigarray oUnit bytes
-test-errno.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-threaded
-test-errno: PROJECT=test-errno
-test-errno: $$(NATIVE_TARGET)
+test-foreign-errno.dir = tests/test-foreign-errno
+test-foreign-errno.threads = yes
+test-foreign-errno.deps = str bigarray oUnit bytes
+test-foreign-errno.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-threaded
+test-foreign-errno: PROJECT=test-foreign-errno
+test-foreign-errno: $$(NATIVE_TARGET)
 
 test-passable.dir = tests/test-passable
 test-passable.threads = yes
@@ -875,6 +875,87 @@ $(BUILDDIR)/test-lwt-jobs-ml-stub-generator.native: $(BUILDDIR)/tests/test-lwt-j
 $(BUILDDIR)/tests/test-lwt-jobs/generated_struct_stubs.c: $(BUILDDIR)/test-lwt-jobs-stub-generator.native
 	$< --c-struct-file $@
 
+test-returning-errno-lwt-stubs.dir  = tests/test-returning-errno-lwt/stubs
+test-returning-errno-lwt-stubs.threads = yes
+test-returning-errno-lwt-stubs.subproject_deps = ctypes cstubs \
+   ctypes-foreign-base ctypes-foreign-threaded tests-common
+test-returning-errno-lwt-stubs: PROJECT=test-returning-errno-lwt-stubs
+test-returning-errno-lwt-stubs: $$(LIB_TARGETS)
+
+test-returning-errno-lwt-stub-generator.dir = tests/test-returning-errno-lwt/stub-generator
+test-returning-errno-lwt-stub-generator.threads = yes
+test-returning-errno-lwt-stub-generator.subproject_deps = ctypes cstubs \
+     ctypes-foreign-base ctypes-foreign-threaded test-returning-errno-lwt-stubs tests-common
+test-returning-errno-lwt-stub-generator.deps = str bigarray bytes
+test-returning-errno-lwt-stub-generator: PROJECT=test-returning-errno-lwt-stub-generator
+test-returning-errno-lwt-stub-generator: $$(NATIVE_TARGET)
+
+test-returning-errno-lwt.dir = tests/test-returning-errno-lwt
+test-returning-errno-lwt.threads = yes
+test-returning-errno-lwt.deps = str bigarray oUnit bytes lwt.unix
+test-returning-errno-lwt.subproject_deps = ctypes ctypes-foreign-base \
+   ctypes-foreign-threaded cstubs tests-common test-returning-errno-lwt-stubs
+test-returning-errno-lwt.link_flags = -L$(BUILDDIR)/clib -ltest_functions
+test-returning-errno-lwt: PROJECT=test-returning-errno-lwt
+test-returning-errno-lwt: $$(NATIVE_TARGET)
+
+test-returning-errno-lwt-generated: \
+  tests/test-returning-errno-lwt/generated_bindings.ml \
+  tests/test-returning-errno-lwt/generated_struct_bindings.ml \
+  tests/test-returning-errno-lwt/generated_stubs.c
+
+tests/test-returning-errno-lwt/generated_stubs.c: $(BUILDDIR)/test-returning-errno-lwt-stub-generator.native
+	$< --c-file $@
+tests/test-returning-errno-lwt/generated_bindings.ml: $(BUILDDIR)/test-returning-errno-lwt-stub-generator.native
+	$< --ml-file $@
+tests/test-returning-errno-lwt/generated_struct_bindings.ml: $(BUILDDIR)/test-returning-errno-lwt-ml-stub-generator.native
+	$< > $@
+$(BUILDDIR)/test-returning-errno-lwt-ml-stub-generator.native: $(BUILDDIR)/tests/test-returning-errno-lwt/generated_struct_stubs.c
+	$(CC) -I `$(OCAMLFIND) ocamlc -where | sed 's|\r$$||'` $(CFLAGS) $(LDFLAGS) $(WINLDFLAGS) -o $@ $^
+$(BUILDDIR)/tests/test-returning-errno-lwt/generated_struct_stubs.c: $(BUILDDIR)/test-returning-errno-lwt-stub-generator.native
+	$< --c-struct-file $@
+
+test-returning-errno-stubs.dir  = tests/test-returning-errno/stubs
+test-returning-errno-stubs.threads = yes
+test-returning-errno-stubs.subproject_deps = ctypes cstubs \
+   ctypes-foreign-base ctypes-foreign-threaded tests-common
+test-returning-errno-stubs: PROJECT=test-returning-errno-stubs
+test-returning-errno-stubs: $$(LIB_TARGETS)
+
+test-returning-errno-stub-generator.dir = tests/test-returning-errno/stub-generator
+test-returning-errno-stub-generator.threads = yes
+test-returning-errno-stub-generator.subproject_deps = ctypes cstubs \
+     ctypes-foreign-base ctypes-foreign-threaded test-returning-errno-stubs tests-common
+test-returning-errno-stub-generator.deps = str bigarray bytes
+test-returning-errno-stub-generator: PROJECT=test-returning-errno-stub-generator
+test-returning-errno-stub-generator: $$(NATIVE_TARGET)
+
+test-returning-errno.dir = tests/test-returning-errno
+test-returning-errno.threads = yes
+test-returning-errno.deps = str bigarray oUnit bytes lwt.unix
+test-returning-errno.subproject_deps = ctypes ctypes-foreign-base \
+   ctypes-foreign-threaded cstubs tests-common test-returning-errno-stubs
+test-returning-errno.link_flags = -L$(BUILDDIR)/clib -ltest_functions
+test-returning-errno: PROJECT=test-returning-errno
+test-returning-errno: $$(NATIVE_TARGET)
+
+test-returning-errno-generated: \
+  tests/test-returning-errno/generated_bindings.ml \
+  tests/test-returning-errno/generated_struct_bindings.ml \
+  tests/test-returning-errno/generated_stubs.c
+
+tests/test-returning-errno/generated_stubs.c: $(BUILDDIR)/test-returning-errno-stub-generator.native
+	$< --c-file $@
+tests/test-returning-errno/generated_bindings.ml: $(BUILDDIR)/test-returning-errno-stub-generator.native
+	$< --ml-file $@
+tests/test-returning-errno/generated_struct_bindings.ml: $(BUILDDIR)/test-returning-errno-ml-stub-generator.native
+	$< > $@
+$(BUILDDIR)/test-returning-errno-ml-stub-generator.native: $(BUILDDIR)/tests/test-returning-errno/generated_struct_stubs.c
+	$(CC) -I `$(OCAMLFIND) ocamlc -where | sed 's|\r$$||'` $(CFLAGS) $(LDFLAGS) $(WINLDFLAGS) -o $@ $^
+$(BUILDDIR)/tests/test-returning-errno/generated_struct_stubs.c: $(BUILDDIR)/test-returning-errno-stub-generator.native
+	$< --c-struct-file $@
+
+
 test-threads-stubs.dir  = tests/test-threads/stubs
 test-threads-stubs.threads = yes
 test-threads-stubs.subproject_deps = ctypes cstubs \
@@ -908,7 +989,7 @@ TESTS += test-foreign_values-stubs test-foreign_values-stub-generator test-forei
 TESTS += test-unions-stubs test-unions-stub-generator test-unions-generated test-unions
 TESTS += test-custom_ops
 TESTS += test-arrays-stubs test-arrays-stub-generator test-arrays-generated test-arrays
-TESTS += test-errno
+TESTS += test-foreign-errno
 TESTS += test-passable
 TESTS += test-alignment
 TESTS += test-views-stubs test-views-stub-generator test-views-generated test-views
@@ -924,6 +1005,8 @@ TESTS += test-coercions-stubs test-coercions-stub-generator test-coercions-gener
 TESTS += test-roots
 TESTS += test-passing-ocaml-values-stubs test-passing-ocaml-values-stub-generator test-passing-ocaml-values-generated test-passing-ocaml-values
 TESTS += test-lwt-jobs-stubs test-lwt-jobs-stub-generator test-lwt-jobs-generated test-lwt-jobs
+TESTS += test-returning-errno-lwt-stubs test-returning-errno-lwt-stub-generator test-returning-errno-lwt-generated test-returning-errno-lwt
+TESTS += test-returning-errno-stubs test-returning-errno-stub-generator test-returning-errno-generated test-returning-errno
 TESTS += test-threads-stubs test-threads
 
 

src/cstubs/cstubs.ml

@@ -25,7 +25,9 @@ module type BINDINGS = functor (F : FOREIGN') -> sig end
 
 type concurrency_policy = [ `Sequential | `Lwt_jobs ]
 
-let gen_c ~concurrency prefix fmt : (module FOREIGN') =
+type errno_policy = [ `Ignore_errno | `Return_errno ]
+
+let gen_c ~concurrency ~errno prefix fmt : (module FOREIGN') =
   (module
    struct
      let counter = ref 0
@@ -35,7 +37,7 @@ let gen_c ~concurrency prefix fmt : (module FOREIGN') =
      type 'a return = 'a
      type 'a result = unit
      let foreign cname fn =
-       Cstubs_generate_c.fn ~concurrency
+       Cstubs_generate_c.fn ~concurrency ~errno
          ~cname ~stub_name:(var prefix cname) fmt fn
      let foreign_value cname typ =
        Cstubs_generate_c.value ~cname ~stub_name:(var prefix cname) fmt typ
@@ -46,56 +48,58 @@ let gen_c ~concurrency prefix fmt : (module FOREIGN') =
 type bind = Bind : string * string * ('a -> 'b) Ctypes.fn -> bind
 type val_bind = Val_bind : string * string * 'a Ctypes.typ -> val_bind
 
-let write_return : concurrency:concurrency_policy -> Format.formatter -> unit =
-  fun ~concurrency fmt -> match concurrency with
-      `Sequential -> Format.fprintf fmt "type 'a return = 'a@\n"
-    | `Lwt_jobs ->
+let write_return :
+  concurrency:concurrency_policy -> errno:errno_policy ->
+  Format.formatter -> unit =
+  fun ~concurrency ~errno fmt -> match concurrency, errno with
+      `Sequential, `Ignore_errno -> Format.fprintf fmt "type 'a return = 'a@\n"
+    | `Sequential, `Return_errno -> Format.fprintf fmt "type 'a return = 'a * int@\n"
+    | `Lwt_jobs, `Ignore_errno ->
       begin
         Format.fprintf fmt "type 'a return = { lwt: 'a Lwt.t }@\n";
         Format.fprintf fmt "let box_lwt lwt = {lwt}@\n";
       end
-
-let write_fn : concurrency:concurrency_policy -> Format.formatter -> unit =
-  fun ~concurrency fmt -> match concurrency with
-      `Sequential ->
+    | `Lwt_jobs, `Return_errno ->
       begin
-        Format.fprintf fmt
-          "type 'a fn = 'a CI.fn = @\n";
-        Format.fprintf fmt
-          " | Returns  : 'a CI.typ   -> 'a return fn@\n";
-        Format.fprintf fmt
-          " | Function : 'a CI.typ * 'b fn  -> ('a -> 'b) fn@\n";
-        Format.fprintf fmt
-          "let returning t = CI.Returns t@\n";
-        Format.fprintf fmt
-          "let (@@->) f p = CI.Function (f, p)@\n";
-      end
-    | `Lwt_jobs ->
-      begin
-        Format.fprintf fmt
-          "type 'a fn = @\n";
-        Format.fprintf fmt
-          " | Returns  : 'a CI.typ   -> 'a return fn@\n";
-        Format.fprintf fmt
-          " | Function : 'a CI.typ * 'b fn  -> ('a -> 'b) fn@\n";
-        Format.fprintf fmt
-          "let returning t = Returns t@\n";
-        Format.fprintf fmt
-          "let (@@->) f p = Function (f, p)@\n";
+        Format.fprintf fmt "type 'a return = { lwt: ('a * int) Lwt.t }@\n";
+        Format.fprintf fmt "let box_lwt lwt = {lwt}@\n";
       end
 
-let write_foreign ~concurrency fmt bindings val_bindings =
+let write_fn ~concurrency ~errno fmt =
+  begin
+    Format.fprintf fmt "type 'a fn =@\n";
+    Format.fprintf fmt " | Returns  : 'a CI.typ   -> 'a return fn@\n";
+    Format.fprintf fmt " | Function : 'a CI.typ * 'b fn  -> ('a -> 'b) fn@\n"
+  end
+
+let write_map_result ~concurrency ~errno fmt =
+  match concurrency, errno with
+    `Sequential, `Ignore_errno ->
+    Format.fprintf fmt "let map_result f x = f x@\n"
+  | `Sequential, `Return_errno ->
+    Format.fprintf fmt "let map_result f (x, y) = (f x, y)@\n"
+  | `Lwt_jobs, `Ignore_errno ->
+    Format.fprintf fmt "let map_result f x = Lwt.map f x@\n"
+  | `Lwt_jobs, `Return_errno ->
+    Format.fprintf fmt "let map_result f v = Lwt.map (fun (x, y) -> (f x, y)) v@\n"
+
+let write_foreign ~concurrency ~errno fmt bindings val_bindings =
   Format.fprintf fmt
     "type 'a result = 'a@\n";
-  write_return ~concurrency fmt;
-  write_fn ~concurrency fmt;
+  write_return ~concurrency ~errno fmt;
+  write_fn ~concurrency ~errno fmt;
+  write_map_result ~concurrency ~errno fmt;
+  Format.fprintf fmt
+    "let returning t = Returns t@\n";
+  Format.fprintf fmt
+    "let (@@->) f p = Function (f, p)@\n";
   Format.fprintf fmt
     "let foreign : type a b. string -> (a -> b) fn -> (a -> b) =@\n";
   Format.fprintf fmt
     "  fun name t -> match t, name with@\n@[<v>";
   ListLabels.iter bindings
     ~f:(fun (Bind (stub_name, external_name, fn)) ->
-      Cstubs_generate_ml.case ~concurrency ~stub_name ~external_name fmt fn);
+      Cstubs_generate_ml.case ~concurrency ~errno ~stub_name ~external_name fmt fn);
   Format.fprintf fmt "@[<hov 2>@[|@ _,@ s@ ->@]@ ";
   Format.fprintf fmt
     " @[Printf.ksprintf@ failwith@ \"No match for %%s\" s@]@]@]@.@\n";
@@ -112,7 +116,7 @@ let write_foreign ~concurrency fmt bindings val_bindings =
   Format.fprintf fmt
     " @[Printf.ksprintf@ failwith@ \"No match for %%s\" s@]@]@]@.@\n"
 
-let gen_ml ~concurrency prefix fmt : (module FOREIGN') * (unit -> unit) =
+let gen_ml ~concurrency ~errno prefix fmt : (module FOREIGN') * (unit -> unit) =
   let bindings = ref []
   and val_bindings = ref []
   and counter = ref 0 in
@@ -129,36 +133,47 @@ let gen_ml ~concurrency prefix fmt : (module FOREIGN') * (unit -> unit) =
      let foreign cname fn =
        let name = var prefix cname in
        bindings := Bind (cname, name, fn) :: !bindings;
-       Cstubs_generate_ml.extern ~concurrency
+       Cstubs_generate_ml.extern ~concurrency ~errno
          ~stub_name:name ~external_name:name fmt fn
      let foreign_value cname typ =
        let name = var prefix cname in
-       Cstubs_generate_ml.extern ~concurrency:`Sequential
+       Cstubs_generate_ml.extern ~concurrency:`Sequential ~errno:`Ignore_errno
          ~stub_name:name ~external_name:name fmt
          Ctypes.(void @-> returning (ptr void));
        val_bindings := Val_bind (cname, name, typ) :: !val_bindings
      let returning = Ctypes.returning
      let (@->) = Ctypes.(@->)
    end),
   fun () ->
-    write_foreign ~concurrency fmt !bindings !val_bindings
+    write_foreign ~concurrency ~errno fmt !bindings !val_bindings
 
 let sequential = `Sequential
 let lwt_jobs = `Lwt_jobs
-
-let headers : concurrency_policy -> string list = function
-    `Sequential -> ["\"ctypes_cstubs_internals.h\""]
-  | `Lwt_jobs ->   ["\"ctypes_cstubs_internals.h\"";
-                    "\"lwt_unix.h\"";
-                    "<errno.h>";
-                    "<caml/memory.h>"]
-
-let write_c ?(concurrency=`Sequential) fmt ~prefix (module B : BINDINGS) =
-  List.iter (Format.fprintf fmt "#include %s@\n") (headers concurrency);
-  let module M = B((val gen_c ~concurrency prefix fmt)) in ()
-
-let write_ml ?(concurrency=`Sequential) fmt ~prefix (module B : BINDINGS) =
-  let foreign, finally = gen_ml ~concurrency prefix fmt in
+let ignore_errno = `Ignore_errno
+let return_errno = `Return_errno
+
+let concurrency_headers = function
+    `Sequential -> []
+  | `Lwt_jobs ->   ["\"lwt_unix.h\"";  "<caml/memory.h>"]
+
+let errno_headers = function
+    `Ignore_errno -> []
+  | `Return_errno -> ["<errno.h>"]
+
+let headers : concurrency_policy -> errno_policy -> string list =
+  fun concurrency errno ->
+    ["\"ctypes_cstubs_internals.h\""] @
+    errno_headers errno @
+    concurrency_headers concurrency
+
+let write_c ?(concurrency=`Sequential) ?(errno=`Ignore_errno)
+    fmt ~prefix (module B : BINDINGS) =
+  List.iter (Format.fprintf fmt "#include %s@\n") (headers concurrency errno);
+  let module M = B((val gen_c ~concurrency ~errno prefix fmt)) in ()
+
+let write_ml ?(concurrency=`Sequential) ?(errno=`Ignore_errno)
+    fmt ~prefix (module B : BINDINGS) =
+  let foreign, finally = gen_ml ~concurrency ~errno prefix fmt in
   let () = Format.fprintf fmt "module CI = Cstubs_internals@\n@\n" in
   let module M = B((val foreign)) in
   finally ()

src/cstubs/cstubs.mli

@@ -83,6 +83,38 @@ end
 
 module type BINDINGS = functor (F : FOREIGN with type 'a result = unit) -> sig end
 
+type errno_policy
+(** Values of the [errno_policy] type specify the errno support provided by
+    the generated code.  See {!ignore_errno} for the available option.
+*)
+
+val ignore_errno : errno_policy
+(** Generate code with no special support for errno.  This is the default. *)
+
+val return_errno : errno_policy
+(** Generate code that returns errno in addition to the return value of each function.
+
+    Passing [return_errno] as the [errno] argument to {!Cstubs.write_c} and
+    {!Cstubs.write_ml} changes the return type of bound functions from a
+    single value to a pair of values.  For example, the binding
+    specification 
+
+       [let realpath = foreign "reaplath" (string @-> string @-> returning string)]
+
+    generates a value of the following type by default:
+
+       [val realpath : string -> string -> stirng]
+
+    but when using [return_errno] the generated type is as follows:
+
+       [val realpath : string -> string -> stirng * int]
+
+    and when using both [return_errno] and [lwt_jobs] the generated type is as
+    follows:
+
+       [val realpath : string -> string -> (stirng * int) Lwt.t]
+*)
+
 type concurrency_policy
 (** Values of the [concurrency_policy] type specify the concurrency support
     provided by the generated code.  See {!sequential} and {!lwt_jobs} for the
@@ -114,7 +146,7 @@ val lwt_jobs : concurrency_policy
        [val unlink : string -> int Lwt.t]
 *)
 
-val write_c : ?concurrency:concurrency_policy ->
+val write_c : ?concurrency:concurrency_policy -> ?errno:errno_policy ->
   Format.formatter -> prefix:string -> (module BINDINGS) -> unit
 (** [write_c fmt ~prefix bindings] generates C stubs for the functions bound
     with [foreign] in [bindings].  The stubs are intended to be used in
@@ -127,7 +159,7 @@ val write_c : ?concurrency:concurrency_policy ->
     [ctypes_cstubs_internals.h].
 *)
 
-val write_ml : ?concurrency:concurrency_policy ->
+val write_ml : ?concurrency:concurrency_policy -> ?errno:errno_policy ->
   Format.formatter -> prefix:string -> (module BINDINGS) -> unit
 (** [write_ml fmt ~prefix bindings] generates ML bindings for the functions
     bound with [foreign] in [bindings].  The generated code conforms to the

src/cstubs/cstubs_c_language.ml

@@ -41,7 +41,7 @@ type cexp = [ cconst
             | clocal
             | `Cast of ty * cexp
             | `Addr of cvar ]
-type clvalue = [ clocal
+type clvalue = [ cvar
                | `Index of clvalue * cexp
                | `Field of clvalue * fieldname 
                | `PointerField of clvalue * fieldname ]

src/cstubs/cstubs_emit_c.ml

@@ -48,7 +48,7 @@ let rec cexp fmt : cexp -> unit = function
   | `Addr (`Local (name, _)) -> fprintf fmt "@[&@[%s@]@]" name
 
 let rec clvalue fmt : clvalue -> unit = function
-  | `Local _ as x -> cvar fmt x
+  | #cvar as x -> cvar fmt x
   | `Index (lv, i) ->
     fprintf fmt "@[@[%a@]@[[%a]@]@]" clvalue lv cexp i
   | `Field (lv, f) ->