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 <st...@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 _______________________________________________ Pkg-ocaml-maint-commits mailing list Pkg-ocaml-maint-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-ocaml-maint-commits