[Pkg-ocaml-maint-commits] [ocaml-ctypes] 06/12: Imported Upstream version 0.6.2
Stéphane Glondu
glondu at moszumanska.debian.org
Tue Jun 14 09:46:36 UTC 2016
This is an automated email from the git hooks/post-receive script.
glondu pushed a commit to branch master
in repository ocaml-ctypes.
commit f9fefe6bc7c014d25346538547302d465096e805
Author: Stephane Glondu <steph at glondu.net>
Date: Tue Jun 14 11:24:16 2016 +0200
Imported Upstream version 0.6.2
---
CHANGES.md | 12 +++++
META | 14 +++---
src/configure/extract_from_c.ml | 4 +-
src/cstubs/cstubs_generate_c.ml | 54 ++++++++++++++++++++--
tests/clib/test_functions.c | 10 ++++
tests/clib/test_functions.h | 4 ++
tests/test-lwt-jobs/stubs/functions.ml | 6 +++
tests/test-lwt-jobs/test_lwt_jobs.ml | 28 +++++++++++
tests/test-returning-errno-lwt/stubs/functions.ml | 6 +++
.../test_returning_errno.ml | 28 +++++++++++
10 files changed, 153 insertions(+), 13 deletions(-)
diff --git a/CHANGES.md b/CHANGES.md
index 72d6f3c..c5272c9 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -1,3 +1,15 @@
+## ctypes 0.6.2
+
+### Bug fixes
+
+* Fix for argument quoting in the Windows build after new cross compilation support
+ https://github.com/ocamllabs/ocaml-ctypes/pull/399
+
+* Improve Lwt jobs support for functions with many or no arguments
+ https://github.com/ocamllabs/ocaml-ctypes/pull/400
+
+Thanks to Andreas Hauptmann (@fdopen) for contributing to this release.
+
## ctypes 0.6.1
### Bug fixes
diff --git a/META b/META
index e2dcf0f..48bf1ce 100644
--- a/META
+++ b/META
@@ -1,4 +1,4 @@
-version = "0.6.1"
+version = "0.6.2"
description = "Combinators for binding to C libraries without writing any C."
requires = "unix bigarray str bytes"
archive(byte) = "ctypes.cma"
@@ -8,7 +8,7 @@ archive(native, plugin) = "ctypes.cmxs"
exists_if = "ctypes.cma"
package "top" (
- version = "0.6.1"
+ version = "0.6.2"
description = "Toplevel printers for C types"
requires = "ctypes"
archive(byte) = "ctypes-top.cma"
@@ -19,7 +19,7 @@ package "top" (
)
package "stubs" (
- version = "0.6.1"
+ version = "0.6.2"
description = "Stub generation from C types"
requires = "ctypes"
archive(byte) = "cstubs.cma"
@@ -31,13 +31,13 @@ package "stubs" (
)
package "foreign" (
- version = "0.6.1"
+ version = "0.6.2"
description = "Dynamic linking of C functions"
requires(-mt) = "ctypes.foreign.unthreaded"
requires(mt) = "ctypes.foreign.threaded"
package "base" (
- version = "0.6.1"
+ version = "0.6.2"
description = "Dynamic linking of C functions (base package)"
requires = "ctypes"
archive(byte) = "ctypes-foreign-base.cma"
@@ -48,7 +48,7 @@ package "foreign" (
)
package "threaded" (
- version = "0.6.1"
+ version = "0.6.2"
description = "Dynamic linking of C functions (for use in threaded programs)"
requires = "threads ctypes ctypes.foreign.base"
archive(byte) = "ctypes-foreign-threaded.cma"
@@ -59,7 +59,7 @@ package "foreign" (
)
package "unthreaded" (
- version = "0.6.1"
+ version = "0.6.2"
description = "Dynamic linking of C functions (for use in unthreaded programs)"
requires = "ctypes ctypes.foreign.base"
archive(byte) = "ctypes-foreign-unthreaded.cma"
diff --git a/src/configure/extract_from_c.ml b/src/configure/extract_from_c.ml
index b69ec4a..6dfb913 100644
--- a/src/configure/extract_from_c.ml
+++ b/src/configure/extract_from_c.ml
@@ -23,9 +23,9 @@ let read_output program =
(getenv ~default:"ocamlfind" "OCAMLFIND")
((getenv ~default:"" "CFLAGS") |>
(nsplit " ") |>
- (List.map (fun s -> "-ccopt '"^s^"'")) |>
+ (List.map (fun s -> "-ccopt " ^ Filename.quote s)) |>
(String.concat " "))
- input_filename
+ (Filename.quote input_filename)
in
prerr_endline cmd;
Sys.chdir (Filename.dirname input_filename);
diff --git a/src/cstubs/cstubs_generate_c.ml b/src/cstubs/cstubs_generate_c.ml
index 877079b..9f49db4 100644
--- a/src/cstubs/cstubs_generate_c.ml
+++ b/src/cstubs/cstubs_generate_c.ml
@@ -418,14 +418,43 @@ struct
fprintf fmt "}@\n";
end
+ let rec camlxParam fmt args =
+ match args with
+ [] -> ()
+ | x1 :: [] ->
+ fprintf fmt "@[CAMLxparam1 (%s)@];@\n" x1
+ | x1 :: x2 :: [] ->
+ fprintf fmt "@[CAMLxparam2 (%s, %s)@];@\n" x1 x2
+ | x1 :: x2 :: x3 :: [] ->
+ fprintf fmt "@[CAMLxparam3 (%s, %s, %s)@];@\n" x1 x2 x3
+ | x1 :: x2 :: x3 :: x4 :: [] ->
+ fprintf fmt "@[CAMLxparam4 (%s, %s, %s, %s)@];@\n" x1 x2 x3 x4
+ | x1 :: x2 :: x3 :: x4 :: x5 :: rest ->
+ fprintf fmt "@[CAMLxparam5 (%s, %s, %s, %s, %s)@];@\n" x1 x2 x3 x4 x5;
+ camlxParam fmt rest
+
+ let camlParam fmt args =
+ match args with
+ [] ->
+ fprintf fmt "@[CAMLparam0 ()@];@\n"
+ | x1 :: [] ->
+ fprintf fmt "@[CAMLparam1 (%s)@];@\n" x1
+ | x1 :: x2 :: [] ->
+ fprintf fmt "@[CAMLparam2 (%s, %s)@];@\n" x1 x2
+ | x1 :: x2 :: x3 :: [] ->
+ fprintf fmt "@[CAMLparam3 (%s, %s, %s)@];@\n" x1 x2 x3
+ | x1 :: x2 :: x3 :: x4 :: [] ->
+ fprintf fmt "@[CAMLparam4 (%s, %s, %s, %s)@];@\n" x1 x2 x3 x4
+ | x1 :: x2 :: x3 :: x4 :: x5 :: rest ->
+ fprintf fmt "@[CAMLparam5 (%s, %s, %s, %s, %s)@];@\n" x1 x2 x3 x4 x5;
+ camlxParam fmt rest
+
let stub ~errno ~stub_name fmt fn args =
begin
fprintf fmt "@[value@ %s@;@[(%s)@]@]@;@[<2>{@\n"
stub_name
(String.concat ", " (List.map (fun (_, x) -> "value "^ x) args));
- fprintf fmt "@[CAMLparam%d (%s)@];@\n"
- (List.length args)
- (String.concat ", " (List.map (fun (_, x) -> x) args));
+ camlParam fmt (List.map snd args);
fprintf fmt "@[LWT_UNIX_INIT_JOB(job,@ %s,@ 0)@];@\n"
stub_name;
@@ -445,6 +474,20 @@ struct
fprintf fmt "}@\n";
end
+ let byte_stub ~errno ~stub_name fmt fn args =
+ begin
+ let nargs = List.length args in
+ fprintf fmt "@[value@ %s_byte%d@;@[(value *argv, int argc)@]@]@;@[<2>{@\n"
+ stub_name nargs;
+ fprintf fmt "@[<2>return@ @[%s(@[" stub_name;
+ ListLabels.iteri args
+ ~f:(fun i _ ->
+ if i = nargs - 1 then fprintf fmt "argv[%d]" i
+ else fprintf fmt "argv[%d],@ " i);
+ fprintf fmt ")@]@]@];@]@\n";
+ fprintf fmt "}@\n";
+ end
+
let fn_args_and_result fn =
let counter = ref 0 in
let var prefix =
@@ -453,7 +496,8 @@ struct
in
let rec aux : type a. a fn -> _ -> _ =
fun fn args -> match fn with
- Function (t, f) -> aux f ((BoxedType t, var "arg") :: args)
+ Function (Void, f) -> aux f args
+ | Function (t, f) -> aux f ((BoxedType t, var "arg") :: args)
| Returns t -> List.rev args, BoxedType t
in aux fn []
@@ -464,6 +508,8 @@ struct
worker ~errno ~cname ~stub_name fmt fn r args;
result ~errno ~stub_name fmt fn r;
stub ~errno ~stub_name fmt fn args;
+ if List.length args > max_byte_args then
+ byte_stub ~errno ~stub_name fmt fn args;
fprintf fmt "@\n";
end
end
diff --git a/tests/clib/test_functions.c b/tests/clib/test_functions.c
index 8da00c3..12501cb 100644
--- a/tests/clib/test_functions.c
+++ b/tests/clib/test_functions.c
@@ -627,3 +627,13 @@ void *retrieve_ocaml_value(void)
{
return global_ocaml_value;
}
+
+int sixargs(int x1, int x2, int x3, int x4, int x5, int x6)
+{
+ return x1 + x2 + x3 + x4 + x5 + x6;
+}
+
+int return_10(void)
+{
+ return 10;
+}
diff --git a/tests/clib/test_functions.h b/tests/clib/test_functions.h
index 26d38f1..7928acd 100644
--- a/tests/clib/test_functions.h
+++ b/tests/clib/test_functions.h
@@ -230,4 +230,8 @@ int32_t sum_int_array(int32_t *, size_t);
void save_ocaml_value(void *);
void *retrieve_ocaml_value(void);
+
+int sixargs(int, int, int, int, int, int);
+int return_10(void);
+
#endif /* TEST_FUNCTIONS_H */
diff --git a/tests/test-lwt-jobs/stubs/functions.ml b/tests/test-lwt-jobs/stubs/functions.ml
index fb53d2b..0821bf1 100644
--- a/tests/test-lwt-jobs/stubs/functions.ml
+++ b/tests/test-lwt-jobs/stubs/functions.ml
@@ -21,4 +21,10 @@ struct
let struct_stat : [`stat] structure typ = structure "stat"
let stat = foreign "stat"
(string @-> ptr struct_stat @-> returning int)
+
+ let sixargs = foreign "sixargs"
+ (int @-> int @-> int @-> int @-> int @-> int @-> returning int)
+
+ let return_10 = foreign "return_10"
+ (void @-> returning int)
end
diff --git a/tests/test-lwt-jobs/test_lwt_jobs.ml b/tests/test-lwt-jobs/test_lwt_jobs.ml
index 66cbfb8..ed05c27 100644
--- a/tests/test-lwt-jobs/test_lwt_jobs.ml
+++ b/tests/test-lwt-jobs/test_lwt_jobs.ml
@@ -67,6 +67,28 @@ let test_string_lifetime _ =
end
+(*
+ Test calling functions with many arguments.
+ *)
+let test_six_args _ =
+ let open Lwt.Infix in
+ Lwt_unix.run
+ ((Bindings.sixargs 1 2 3 4 5 6).Generated_bindings.lwt >>= fun i ->
+ assert_equal (1 + 2 + 3 + 4 + 5 + 6) i;
+ Lwt.return ())
+
+
+(*
+ Test calling functions with no arguments.
+ *)
+let test_no_args _ =
+ let open Lwt.Infix in
+ Lwt_unix.run
+ ((Bindings.return_10 ()).Generated_bindings.lwt >>= fun i ->
+ assert_equal 10 i;
+ Lwt.return ())
+
+
let suite = "Lwt job tests" >:::
["calling sqrt"
>:: test_sqrt;
@@ -76,6 +98,12 @@ let suite = "Lwt job tests" >:::
"string lifetime"
>:: test_string_lifetime;
+
+ "functions with many arguments"
+ >:: test_six_args;
+
+ "functions with no arguments"
+ >:: test_no_args;
]
diff --git a/tests/test-returning-errno-lwt/stubs/functions.ml b/tests/test-returning-errno-lwt/stubs/functions.ml
index 4d829b0..863a7b9 100644
--- a/tests/test-returning-errno-lwt/stubs/functions.ml
+++ b/tests/test-returning-errno-lwt/stubs/functions.ml
@@ -16,4 +16,10 @@ struct
let struct_stat : [`stat] structure typ = structure "stat"
let stat = foreign "stat"
(string @-> ptr struct_stat @-> returning int)
+
+ let sixargs = foreign "sixargs"
+ (int @-> int @-> int @-> int @-> int @-> int @-> returning int)
+
+ let return_10 = foreign "return_10"
+ (void @-> returning int)
end
diff --git a/tests/test-returning-errno-lwt/test_returning_errno.ml b/tests/test-returning-errno-lwt/test_returning_errno.ml
index 688d635..21ca36d 100644
--- a/tests/test-returning-errno-lwt/test_returning_errno.ml
+++ b/tests/test-returning-errno-lwt/test_returning_errno.ml
@@ -32,9 +32,37 @@ let test_stat _ =
end
+(*
+ Test calling functions with many arguments.
+ *)
+let test_six_args _ =
+ let open Lwt.Infix in
+ Lwt_unix.run
+ ((Bindings.sixargs 1 2 3 4 5 6).Generated_bindings.lwt >>= fun (i, errno) ->
+ assert_equal (1 + 2 + 3 + 4 + 5 + 6) i;
+ Lwt.return ())
+
+
+(*
+ Test calling functions with no arguments.
+ *)
+let test_no_args _ =
+ let open Lwt.Infix in
+ Lwt_unix.run
+ ((Bindings.return_10 ()).Generated_bindings.lwt >>= fun (i, errno) ->
+ assert_equal 10 i;
+ Lwt.return ())
+
+
let suite = "Errno tests" >:::
["calling stat"
>:: test_stat;
+
+ "functions with many arguments"
+ >:: test_six_args;
+
+ "functions with no arguments"
+ >:: test_no_args;
]
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-ocaml-maint/packages/ocaml-ctypes.git
More information about the Pkg-ocaml-maint-commits
mailing list