Merge pull request #72 from yallop/check-errno-in-foreign

Remove returning_checking_errno; pass a flag to foreign instead.

examples/date/date.ml

@@ -23,8 +23,8 @@ let tm_yday  = int -: "tm_yday"  (* day in the year *)
 let tm_isdst = int -: "tm_isdst" (* daylight saving time *)
 let () = seal (tm : tm structure typ)
 
-let time = foreign "time" (ptr time_t @-> returning_checking_errno time_t)
-  
+let time = foreign "time" ~check_errno:true (ptr time_t @-> returning time_t)
+
 let asctime = foreign "asctime" (ptr tm @-> returning string)
 
 let localtime = foreign "localtime" (ptr time_t @-> returning (ptr tm))

examples/fts/fts.ml

@@ -200,20 +200,20 @@ let _fts_open = Foreign.foreign "fts_open"
   (ptr string @-> int @-> Foreign.funptr_opt compar_type @-> returning (ptr fts))
 
 (* FTSENT *fts_read(FTS *ftsp); *)
-let _fts_read = Foreign.foreign "fts_read"
-  (ptr fts @-> returning_checking_errno (ptr ftsent))
+let _fts_read = Foreign.foreign "fts_read" ~check_errno:true
+  (ptr fts @-> returning (ptr ftsent))
 
 (* FTSENT *fts_children(FTS *ftsp, int options); *)
 let _fts_children = Foreign.foreign "fts_children"
   (ptr fts @-> int @-> returning (ptr ftsent))
 
 (* int fts_set(FTS *ftsp, FTSENT *f, int options); *)
-let _fts_set = Foreign.foreign "fts_set"
-  (ptr fts @-> ptr (ftsent) @-> int @-> returning_checking_errno int)
+let _fts_set = Foreign.foreign "fts_set" ~check_errno:true
+  (ptr fts @-> ptr (ftsent) @-> int @-> returning int)
 
 (* int fts_close(FTS *ftsp); *)
-let _fts_close = Foreign.foreign "fts_close"
-  (ptr fts @-> returning_checking_errno int)
+let _fts_close = Foreign.foreign "fts_close" ~check_errno:true
+  (ptr fts @-> returning int)
 
 let crush_options f : 'a list -> int = List.fold_left (fun i o -> i lor (f o)) 0
 

examples/sigset/sigset.ml

@@ -41,7 +41,8 @@ let full () =
 
    EINVAL The signum argument doesn't specify a valid signal. 
 *)
-let sigaddset = foreign "sigaddset" (ptr sigset_t @-> int @-> returning_checking_errno int)
+let sigaddset = foreign "sigaddset" ~check_errno:true
+  (ptr sigset_t @-> int @-> returning int)
 
 let add set signal = ignore (sigaddset set signal)
 
@@ -50,7 +51,8 @@ let add set signal = ignore (sigaddset set signal)
 
    The return value and error conditions are the same as for
    sigaddset.  *)
-let sigdelset = foreign "sigdelset" (ptr sigset_t @-> int @-> returning_checking_errno int)
+let sigdelset = foreign "sigdelset" ~check_errno:true
+  (ptr sigset_t @-> int @-> returning int)
 
 let del set signal = ignore (sigdelset set signal)
 
@@ -62,6 +64,7 @@ let del set signal = ignore (sigdelset set signal)
 
    EINVAL The signum argument doesn't specify a valid signal. 
 *)
-let sigismember = foreign "sigismember" (ptr sigset_t @-> int @-> returning_checking_errno int)
+let sigismember = foreign "sigismember" ~check_errno:true
+  (ptr sigset_t @-> int @-> returning int)
 
 let mem set signal = sigismember set signal <> 0

src/ctypes.mli

@@ -215,11 +215,6 @@ val returning : 'a typ -> 'a fn
     to be used together with {!(@->)}; see the documentation for {!(@->)} for an
     example. *)
 
-val returning_checking_errno : 'a typ -> 'a fn
-(** Give the return type of a C function.  This behaves like {!returning},
-    except that calls to functions bound using [returning_checking_errno] check
-    whether errno has been updated and raise {!Unix.Unix_error} if so. *)
-
 (** {3 Struct and union types} *)
 
 type ('a, 'kind) structured = ('a, 'kind) Static.structured

src/ffi.ml

@@ -101,7 +101,7 @@ let prep_callspec callspec ty =
 
 let rec box_function : type a. a fn -> Ffi_stubs.callspec -> a WeakRef.t -> Ffi_stubs.boxedfn
   = fun fn callspec -> match fn with
-    | Returns (_, ty) ->
+    | Returns ty ->
       let () = prep_callspec callspec ty in
       let write_rv = Memory.write ty in
       fun f -> Ffi_stubs.Done (write_rv ~offset:0 (WeakRef.get f), callspec)
@@ -122,26 +122,27 @@ let rec box_function : type a. a fn -> Ffi_stubs.callspec -> a WeakRef.t -> Ffi_
   add_argument callspec argn
   prep_callspec callspec rettype
 *)
-let rec build_ccallspec : type a. a fn -> Ffi_stubs.callspec -> a ccallspec
-  = fun fn callspec -> match fn with
-    | Returns (check_errno, t) ->
+let rec build_ccallspec : type a. check_errno:bool -> a fn -> Ffi_stubs.callspec
+  -> a ccallspec
+  = fun ~check_errno fn callspec -> match fn with
+    | Returns t ->
       let () = prep_callspec callspec t in
       Call (check_errno, Memory.build t ~offset:0)
     | Function (p, f) ->
       let offset = add_argument callspec p in
-      let rest = build_ccallspec f callspec in
+      let rest = build_ccallspec ~check_errno f callspec in
       WriteArg (Memory.write p ~offset, rest)
 
-let build_function ?name fn =
+let build_function ?name ~check_errno fn =
   let c = Ffi_stubs.allocate_callspec () in
-  let e = build_ccallspec fn c in
+  let e = build_ccallspec ~check_errno fn c in
   invoke name e [] c
 
 let ptr_of_rawptr raw_ptr =
   { raw_ptr ; pbyte_offset = 0; reftype = void; pmanaged = None }
 
-let function_of_pointer ?name fn =
-  let f = build_function ?name fn in
+let function_of_pointer ?name ~check_errno fn =
+  let f = build_function ?name ~check_errno fn in
   fun {raw_ptr} -> f raw_ptr
 
 let pointer_of_function fn =

src/ffi.mli

@@ -9,7 +9,8 @@ open Static
 
 (** Dynamic function calls based on libffi *)
 
-val function_of_pointer : ?name:string -> ('a -> 'b) fn -> unit ptr -> ('a -> 'b)
+val function_of_pointer : ?name:string -> check_errno:bool -> ('a -> 'b) fn ->
+  unit ptr -> ('a -> 'b)
 (** Build an OCaml function from a type specification and a pointer to a C
     function. *)
 

src/foreign.ml

@@ -14,9 +14,9 @@ let format_function_pointer fn k fmt =
   Type_printing.format_fn' fn
     (fun fmt -> Format.fprintf fmt "(*%t)" k) fmt
 
-let funptr ?name fn =
+let funptr ?name ?(check_errno=false) fn =
   let open Ffi in
-  let read = function_of_pointer ?name fn
+  let read = function_of_pointer ~check_errno ?name fn
   and write = pointer_of_function fn
   and format_typ = format_function_pointer fn in
   Static.(view ~format_typ ~read ~write (ptr void))
@@ -44,10 +44,10 @@ let ptr_of_raw_ptr p =
 let foreign_value ?from symbol t =
   from_voidp t (ptr_of_raw_ptr (dlsym ?handle:from ~symbol))
 
-let foreign ?(stub = false) ?from symbol typ = let open Ctypes in
+let foreign ?from ?(stub=false) ?(check_errno=false) symbol typ =
   try
     let p = ptr_of_raw_ptr (dlsym ?handle:from ~symbol) in
     let pp = to_voidp (allocate (ptr void) p) in
-    !@ (from_voidp (funptr ~name:symbol typ) pp)
+    !@ (from_voidp (funptr ~name:symbol ~check_errno typ) pp)
   with 
   | exn -> if stub then fun _ -> raise exn else raise exn

src/foreign.mli

@@ -7,31 +7,49 @@
 
 (** High-level bindings for C functions and values *)
 
-val foreign : ?stub:bool -> ?from:Dl.library -> string -> 
-  ('a -> 'b) Ctypes.fn -> ('a -> 'b)
+val foreign :
+  ?from:Dl.library ->
+  ?stub:bool -> 
+  ?check_errno:bool ->
+  string ->
+  ('a -> 'b) Ctypes.fn ->
+  ('a -> 'b)
 (** [foreign name typ] exposes the C function of type [typ] named by [name] as
-    an OCaml value.  The argument [?from], if supplied, is a library handle
-    returned by {!Dl.dlopen}.  The argument [?stub], if [true] (defaults to 
-    [false]), indicates that the function should not raise an exception 
-    if [name] is not found but return an OCaml value that raises an 
-    exception when called. 
+    an OCaml value.
 
-    @raise Dl.DL_error if [name] is not found in [?from] and [?stub] is 
+    The argument [?from], if supplied, is a library handle returned by
+    {!Dl.dlopen}.
+
+    The argument [?stub], if [true] (defaults to [false]), indicates that the
+    function should not raise an exception if [name] is not found but return
+    an OCaml value that raises an exception when called.
+
+    The value [?check_errno], which defaults to [false], indicates whether
+    {!Unix.Unix_error} should be raised if the C function modifies [errno].
+
+    @raise Dl.DL_error if [name] is not found in [?from] and [?stub] is
     [false]. *)
 
 val foreign_value : ?from:Dl.library -> string -> 'a Ctypes.typ -> 'a Ctypes.ptr
 (** [foreign_value name typ] exposes the C value of type [typ] named by [name]
     as an OCaml value.  The argument [?from], if supplied, is a library handle
     returned by {!Dl.dlopen}.  *)
 
-val funptr : ?name:string -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) Ctypes.typ
+val funptr :
+  ?name:string ->
+  ?check_errno:bool ->
+  ('a -> 'b) Ctypes.fn ->
+  ('a -> 'b) Ctypes.typ
 (** Construct a function pointer type from a function type.
 
     The ctypes library, like C itself, distinguishes functions and function
     pointers.  Functions are not first class: it is not possible to use them
     as arguments or return values of calls, or store them in addressable
     memory.  Function pointers are first class, and so have none of these
-    restrictions. *)
+    restrictions.
+
+    The value [?check_errno], which defaults to [false], indicates whether
+    {!Unix.Unix_error} should be raised if the C function modifies [errno]. *)
 
 val funptr_opt : ('a -> 'b) Ctypes.fn -> ('a -> 'b) option Ctypes.typ
 (** Construct a function pointer type from a function type.

src/static.ml

@@ -69,8 +69,7 @@ and 'a union_type = {
 and 's boxed_field = BoxedField : ('a, 's) field -> 's boxed_field
 
 type _ fn =
-  (* The flag indicates whether we should check errno *)
-  | Returns  : bool * 'a typ   -> 'a fn
+  | Returns  : 'a typ   -> 'a fn
   | Function : 'a typ * 'b fn  -> ('a -> 'b) fn
 
 type boxed_typ = BoxedType : 'a typ -> boxed_typ
@@ -155,8 +154,7 @@ let returning v =
   if not (passable v) then
     raise (Unsupported "Unsupported return type")
   else
-    Returns (false, v)
-let returning_checking_errno v = Returns (true, v)
+    Returns v
 
 let structure tag =
   Struct { spec = Incomplete { isize = 0 }; tag; fields = [] }

src/type_printing.ml

@@ -92,7 +92,7 @@ and format_fn' : 'a. 'a fn ->
   (Format.formatter -> unit) =
   let rec gather : type a. a fn -> boxed_typ list * boxed_typ =
     function
-      | Returns (_, ty) -> [], BoxedType ty
+      | Returns ty -> [], BoxedType ty
       | Function (Void, fn) -> gather fn
       | Function (p, fn) -> let ps, r = gather fn in BoxedType p :: ps, r in
   fun fn k fmt ->

tests/test_errno.ml

@@ -14,8 +14,8 @@ open Ctypes
    is raised.
 *)
 let test_errno_exception_raised () =
-  let fdopendir = Foreign.foreign "fdopendir"
-    (int @-> returning_checking_errno (ptr void)) in
+  let fdopendir = Foreign.foreign "fdopendir" ~check_errno:true
+    (int @-> returning (ptr void)) in
   assert_raises (Unix.Unix_error(Unix.EBADF, "fdopendir", ""))
     (fun () -> fdopendir (-300))
 
@@ -24,8 +24,8 @@ let test_errno_exception_raised () =
   Call chdir() with a valid directory path and check that zero is returned. 
 *)
 let test_int_return_errno_exception_raised () =
-  let chdir = Foreign.foreign "chdir"
-    (string @-> returning_checking_errno int) in
+  let chdir = Foreign.foreign "chdir" ~check_errno:true
+    (string @-> returning int) in
   assert_raises (Unix.Unix_error(Unix.ENOENT, "chdir", ""))
     (fun () -> chdir "/unlikely_to_exist")
 
@@ -34,8 +34,8 @@ let test_int_return_errno_exception_raised () =
   Call chdir() with a valid directory path and check that zero is returned. 
 *)
 let test_errno_no_exception_raised () =
-  let chdir = Foreign.foreign "chdir"
-    (string @-> returning_checking_errno int) in
+  let chdir = Foreign.foreign "chdir" ~check_errno:true
+    (string @-> returning int) in
   assert_equal 0 (chdir (Sys.getcwd ()))