├── .github └── workflows │ └── test.yml ├── .gitignore ├── CHANGES.md ├── LICENSE ├── Makefile ├── README.md ├── ctypes-foreign.opam ├── ctypes.opam ├── dune ├── dune-project ├── examples ├── cstubs_structs │ ├── Makefile │ ├── README.md │ ├── bindings.ml │ ├── bindings_c_gen.ml │ ├── main.ml │ └── myocamlbuild.ml ├── date │ ├── foreign │ │ ├── date.ml │ │ ├── date.mli │ │ └── dune │ └── stub-generation │ │ ├── bindings │ │ ├── date_stubs.ml │ │ └── dune │ │ ├── date_cmd.ml │ │ ├── dune │ │ └── stub-generator │ │ ├── date_stub_generator.ml │ │ └── dune ├── fts │ ├── foreign │ │ ├── dune │ │ ├── fts.ml │ │ ├── fts.mli │ │ └── fts_cmd.ml │ └── stub-generation │ │ ├── bindings │ │ ├── dune │ │ ├── fts.mli │ │ ├── fts_bindings.ml │ │ └── fts_types.ml │ │ ├── config │ │ ├── discover.ml │ │ ├── discover.mli │ │ └── dune │ │ ├── dune │ │ ├── fts_cmd.ml │ │ ├── fts_if.ml │ │ └── stub-generator │ │ ├── dune │ │ └── fts_stub_generator.ml ├── ncurses │ ├── foreign │ │ ├── dune │ │ ├── ncurses.ml │ │ ├── ncurses.mli │ │ └── ncurses_cmd.ml │ └── stub-generation │ │ ├── bindings │ │ ├── dune │ │ └── ncurses_bindings.ml │ │ ├── dune │ │ ├── ncurses_stub_cmd.ml │ │ └── stub-generator │ │ ├── dune │ │ └── ncurses_stub_generator.ml └── sigset │ ├── sigset.ml │ └── sigset.mli ├── src ├── configure │ ├── dune │ └── gen_c_primitives.ml ├── cstubs │ ├── cstubs.ml │ ├── cstubs.mli │ ├── cstubs_analysis.ml │ ├── cstubs_analysis.mli │ ├── cstubs_c_language.ml │ ├── cstubs_emit_c.ml │ ├── cstubs_errors.ml │ ├── cstubs_errors.mli │ ├── cstubs_generate_c.ml │ ├── cstubs_generate_c.mli │ ├── cstubs_generate_ml.ml │ ├── cstubs_generate_ml.mli │ ├── cstubs_inverted.ml │ ├── cstubs_inverted.mli │ ├── cstubs_public_name.ml │ ├── cstubs_public_name.mli │ ├── cstubs_structs.ml │ ├── cstubs_structs.mli │ ├── ctypes_path.ml │ ├── ctypes_path.mli │ └── dune ├── ctypes-foreign │ ├── config │ │ ├── discover.ml │ │ ├── dune │ │ └── gen_libffi_abi.ml │ ├── ctypes_closure_properties.ml │ ├── ctypes_closure_properties.mli │ ├── ctypes_ffi.ml │ ├── ctypes_ffi.mli │ ├── ctypes_ffi_stubs.ml │ ├── ctypes_foreign_basis.ml │ ├── ctypes_foreign_threaded_stubs.ml │ ├── ctypes_weak_ref.ml │ ├── ctypes_weak_ref.mli │ ├── dl.ml.unix │ ├── dl.ml.win │ ├── dl.mli │ ├── dl_stubs.c.unix │ ├── dl_stubs.c.win │ ├── dune │ ├── ffi_call_stubs.c │ ├── ffi_type_stubs.c │ ├── foreign.ml │ ├── foreign.mli │ ├── foreign_threaded_stubs.c │ └── libffi_abi.mli ├── ctypes-top │ ├── dune │ └── install_ctypes_printers.ml └── ctypes │ ├── complexL.ml │ ├── complexL.mli │ ├── complex_stubs.c │ ├── cstubs_internals.h │ ├── cstubs_internals.ml │ ├── cstubs_internals.mli │ ├── ctypes.ml │ ├── ctypes.mli │ ├── ctypes_bigarray.ml │ ├── ctypes_bigarray.mli │ ├── ctypes_bigarray_stubs.ml │ ├── ctypes_bigarrays.c │ ├── ctypes_coerce.ml │ ├── ctypes_coerce.mli │ ├── ctypes_complex_compatibility.h │ ├── ctypes_complex_stubs.h │ ├── ctypes_cstubs_internals.h │ ├── ctypes_ldouble_stubs.h │ ├── ctypes_managed_buffer_stubs.h │ ├── ctypes_memory.ml │ ├── ctypes_memory_stubs.ml │ ├── ctypes_primitive_types.ml │ ├── ctypes_primitive_types.mli │ ├── ctypes_primitives.h │ ├── ctypes_ptr.ml │ ├── ctypes_raw_pointer.h │ ├── ctypes_roots.c │ ├── ctypes_roots_stubs.ml │ ├── ctypes_static.ml │ ├── ctypes_static.mli │ ├── ctypes_std_view_stubs.ml │ ├── ctypes_std_views.ml │ ├── ctypes_structs.ml │ ├── ctypes_structs.mli │ ├── ctypes_structs_computed.ml │ ├── ctypes_structs_computed.mli │ ├── ctypes_type_info_stubs.h │ ├── ctypes_type_printing.ml │ ├── ctypes_type_printing.mli │ ├── ctypes_types.mli │ ├── ctypes_value_printing.ml │ ├── ctypes_value_printing_stubs.ml │ ├── dune │ ├── lDouble.ml │ ├── lDouble.mli │ ├── ldouble_stubs.c │ ├── managed_buffer_stubs.c │ ├── posixTypes.ml │ ├── posixTypes.mli │ ├── posix_types_stubs.c │ ├── raw_pointer_stubs.c │ └── type_info_stubs.c └── tests ├── bench-micro ├── Makefile ├── bench_micro.gnuplot ├── bench_micro.ml ├── bench_micro_bindings.ml ├── bench_micro_gen.ml ├── bench_micro_interpreted.gnuplot ├── bench_micro_lib.c ├── bench_micro_stubs.c ├── bench_micro_stubs.h └── process_summary.ml ├── clib ├── dune ├── test_functions.c └── test_functions.h ├── config ├── dune └── test_config.ml ├── flags ├── dune ├── gen.ml └── gen.mli ├── test-alignment ├── dune └── test_alignment.ml ├── test-arrays ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_array.ml ├── test-bigarrays ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_bigarrays.ml ├── test-bools ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_bools.ml ├── test-builtins ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_builtins.ml ├── test-callback_lifetime ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_callback_lifetime.ml ├── test-closure-type-promotion ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_closure_type_promotion.ml ├── test-coercions ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_coercions.ml ├── test-complex ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_complex.ml ├── test-constants ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── types.ml └── test_constants.ml ├── test-cstdlib ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_cstdlib.ml ├── test-custom_ops ├── dune └── test_custom_ops.ml ├── test-enums ├── dune ├── struct-stub-generator │ ├── driver.ml │ └── dune ├── struct-stubs │ ├── dune │ └── types.ml ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_enums.ml ├── test-finalisers ├── dune └── test_finalisers.ml ├── test-foreign-errno ├── dune └── test_errno.ml ├── test-foreign_values ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_foreign_values.ml ├── test-funptrs ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_funptrs.ml ├── test-higher_order ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_higher_order.ml ├── test-integers ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_integers.ml ├── test-ldouble ├── dune └── test_ldouble.ml ├── test-lifetime ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_lifetime.ml ├── test-lwt-jobs ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ ├── functions.ml │ └── types.ml └── test_lwt_jobs.ml ├── test-lwt-preemptive ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ ├── functions.ml │ └── types.ml └── test_lwt_jobs.ml ├── test-macros ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_macros.ml ├── test-marshal ├── dune └── test_marshal.ml ├── test-oo_style ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_oo_style.ml ├── test-passable ├── dune └── test_passable.ml ├── test-passing-ocaml-values ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_passing_ocaml_values.ml ├── test-pointers ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_pointers.ml ├── test-raw ├── dune └── test_raw.ml ├── test-returning-errno-lwt-jobs ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ ├── functions.ml │ └── types.ml └── test_returning_errno.ml ├── test-returning-errno-lwt-preemptive ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ ├── functions.ml │ └── types.ml └── test_returning_errno.ml ├── test-returning-errno ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ ├── functions.ml │ └── types.ml └── test_returning_errno.ml ├── test-roots ├── dune └── test_roots.ml ├── test-sizeof ├── dune └── test_sizeof.ml ├── test-structs ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ ├── functions.ml │ └── types.ml └── test_structs.ml ├── test-stubs ├── dune └── test_stubs.ml ├── test-threads ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_threads.ml ├── test-type_printing ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── types.ml └── test_type_printing.ml ├── test-unions ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ ├── functions.ml │ └── types.ml └── test_unions.ml ├── test-value_printing ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_value_printing.ml ├── test-variadic ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_variadic.ml ├── test-views ├── dune ├── stub-generator │ ├── driver.ml │ └── dune ├── stubs │ ├── dune │ └── functions.ml └── test_views.ml └── tests-common ├── dune └── tests_common.ml /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: Ctypes 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | pull_request: 8 | workflow_dispatch: 9 | 10 | jobs: 11 | tests: 12 | name: Tests 13 | 14 | strategy: 15 | fail-fast: false 16 | matrix: 17 | include: 18 | - os: ubuntu-latest 19 | ocaml-compiler: 4.07.0 20 | - os: ubuntu-latest 21 | ocaml-compiler: 4.08.0 22 | - os: ubuntu-latest 23 | ocaml-compiler: 4.09.0 24 | - os: ubuntu-latest 25 | ocaml-compiler: ocaml-variants.4.11.2+fp+flambda 26 | - os: ubuntu-latest 27 | ocaml-compiler: 4.11.1 28 | - os: ubuntu-latest 29 | ocaml-compiler: 4.12.0 30 | - os: ubuntu-latest 31 | ocaml-compiler: 4.13.1 32 | - os: ubuntu-latest 33 | ocaml-compiler: 4.14.0 34 | - os: ubuntu-latest 35 | ocaml-compiler: 5.0.0 36 | - os: ubuntu-latest 37 | ocaml-compiler: 5.1.0 38 | - os: ubuntu-latest 39 | ocaml-compiler: 5.2.0 40 | - os: ubuntu-latest 41 | ocaml-compiler: 5.3.0 42 | - os: ubuntu-24.04-arm 43 | ocaml-compiler: 5.3.0 44 | - os: windows-latest 45 | ocaml-compiler: 4.13.1 46 | - os: macos-latest 47 | ocaml-compiler: 4.13.1 48 | 49 | runs-on: ${{ matrix.os }} 50 | 51 | steps: 52 | - name: Checkout code 53 | uses: actions/checkout@v4 54 | 55 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 56 | uses: ocaml/setup-ocaml@v3 57 | with: 58 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 59 | 60 | - name: Deps 61 | run: | 62 | opam pin add -n ctypes.dev . 63 | opam pin add -n ctypes-foreign.dev . 64 | opam depext -ty ctypes ctypes-foreign 65 | opam install -t --deps-only . 66 | 67 | - name: Build 68 | run: opam exec -- dune build 69 | 70 | - name: Test 71 | run: opam exec -- dune runtest 72 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .*.swp 2 | _build 3 | _opam 4 | *.install 5 | .merlin 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013 Jeremy Yallop 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build clean test 2 | 3 | build: 4 | dune build 5 | 6 | test: 7 | dune runtest 8 | 9 | clean: 10 | dune clean 11 | -------------------------------------------------------------------------------- /ctypes-foreign.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Dynamic access to foreign C libraries using Ctypes" 4 | description: """ 5 | 6 | This installs the `ctypes-foreign` interface which 7 | uses `libffi` to provide dynamic access to foreign libraries.""" 8 | maintainer: ["Jeremy Yallop "] 9 | authors: ["Jeremy Yallop"] 10 | license: "MIT" 11 | tags: ["org:mirage" "org:ocamllabs"] 12 | homepage: "https://github.com/yallop/ocaml-ctypes" 13 | doc: "https://yallop.github.io/ocaml-ctypes/" 14 | bug-reports: "https://github.com/yallop/ocaml-ctypes/issues" 15 | depends: [ 16 | "dune" {>= "3.9"} 17 | "ocaml" {>= "4.07.0"} 18 | "integers" {with-test & >= "0.2.2"} 19 | "ctypes" {= version} 20 | "dune-configurator" 21 | "conf-pkg-config" 22 | "lwt" {with-test & >= "2.4.7"} 23 | "ounit2" {with-test} 24 | "conf-ncurses" {with-test} 25 | "conf-fts" {with-test & os != "win32"} 26 | "conf-libffi" {>= "2.0.0"} 27 | "odoc" {with-doc} 28 | ] 29 | build: [ 30 | ["dune" "subst"] {dev} 31 | [ 32 | "dune" 33 | "build" 34 | "-p" 35 | name 36 | "-j" 37 | jobs 38 | "@install" 39 | "@runtest" {with-test} 40 | "@doc" {with-doc} 41 | ] 42 | ] 43 | dev-repo: "git+https://github.com/yallop/ocaml-ctypes.git" 44 | x-maintenance-intent: ["(any).(any).(latest)"] 45 | -------------------------------------------------------------------------------- /ctypes.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Combinators for binding to C libraries without writing any C" 4 | description: """ 5 | 6 | ctypes is a library for binding to C libraries using pure OCaml. The primary 7 | aim is to make writing C extensions as straightforward as possible. 8 | The core of ctypes is a set of combinators for describing the structure of C 9 | types -- numeric types, arrays, pointers, structs, unions and functions. You 10 | can use these combinators to describe the types of the functions that you want 11 | to call, then bind directly to those functions -- all without writing or 12 | generating any C! 13 | 14 | To install the optional `ctypes-foreign` interface (which uses `libffi` to 15 | provide dynamic access to foreign libraries), you will need to also install 16 | the `ctypes-foreign` package. 17 | 18 | opam install ctypes-foreign 19 | 20 | This will make the `ctypes-foreign` ocamlfind subpackage available.""" 21 | maintainer: ["Jeremy Yallop "] 22 | authors: ["Jeremy Yallop"] 23 | license: "MIT" 24 | tags: ["org:mirage" "org:ocamllabs"] 25 | homepage: "https://github.com/yallop/ocaml-ctypes" 26 | doc: "https://yallop.github.io/ocaml-ctypes/" 27 | bug-reports: "https://github.com/yallop/ocaml-ctypes/issues" 28 | depends: [ 29 | "dune" {>= "3.9"} 30 | "ocaml" {>= "4.07.0"} 31 | "integers" 32 | "dune-configurator" 33 | "ounit2" {with-test} 34 | "conf-fts" {with-test & os != "win32"} 35 | "conf-pkg-config" {with-test} 36 | "odoc" {with-doc} 37 | ] 38 | build: [ 39 | ["dune" "subst"] {dev} 40 | [ 41 | "dune" 42 | "build" 43 | "-p" 44 | name 45 | "-j" 46 | jobs 47 | "@install" 48 | "@runtest" {with-test} 49 | "@doc" {with-doc} 50 | ] 51 | ] 52 | dev-repo: "git+https://github.com/yallop/ocaml-ctypes.git" 53 | x-maintenance-intent: ["(any).(any).(latest)"] 54 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (env 2 | (dev 3 | (flags 4 | (:standard -principal -w -67-69)))) 5 | 6 | (deprecated_library_name 7 | (old_public_name "ctypes.foreign") 8 | (new_public_name "ctypes-foreign")) 9 | -------------------------------------------------------------------------------- /examples/cstubs_structs/Makefile: -------------------------------------------------------------------------------- 1 | all: main 2 | 3 | # Step 1 4 | bindings.cmx: bindings.ml 5 | ocamlfind ocamlopt -w '@f@p@u@s@40' -package ctypes,ctypes.foreign,ctypes.stubs -c bindings.ml 6 | 7 | # Step 2 8 | bindings_c_gen.cmx: bindings_c_gen.ml bindings.cmx 9 | ocamlfind ocamlopt -w '@f@p@u@s@40' -package ctypes,ctypes.foreign,ctypes.stubs -c bindings_c_gen.ml bindings.cmx 10 | 11 | # Step 3 compiling 12 | bindings_c_gen: bindings_c_gen.cmx bindings.cmx 13 | ocamlfind ocamlopt -w '@f@p@u@s@40' -package ctypes,ctypes.foreign,ctypes.stubs -linkpkg -o bindings_c_gen bindings.cmx bindings_c_gen.cmx 14 | 15 | # Step 3 executing 16 | bindings_stubs_gen.c: bindings_c_gen 17 | ./bindings_c_gen 18 | 19 | # Step 4 compiling 20 | bindings_stubs_gen.o: bindings_stubs_gen.c 21 | ocamlfind ocamlc -w '@f@p@u@s@40' -package ctypes,ctypes.foreign -c bindings_stubs_gen.c 22 | 23 | # Step 4 compiling 24 | bindings_stubs_gen: bindings_stubs_gen.o 25 | cc -o bindings_stubs_gen bindings_stubs_gen.o 26 | 27 | # Step 5 28 | bindings_stubs.ml: bindings_stubs_gen 29 | ./bindings_stubs_gen > bindings_stubs.ml 30 | 31 | # Step 6 32 | bindings_stubs.cmx: bindings_stubs.ml 33 | ocamlfind ocamlopt -w '@f@p@u@s@40' -package ctypes,ctypes.foreign,ctypes.stubs -c bindings_stubs.ml 34 | 35 | # Use in the main program 36 | main.cmx: bindings_stubs.cmx main.ml 37 | ocamlfind ocamlopt -w '@f@p@u@s@40' -package ctypes,ctypes.foreign,ctypes.stubs -c main.ml bindings_stubs.cmx 38 | 39 | main: main.cmx 40 | ocamlfind ocamlopt -w '@f@p@u@s@40' -package ctypes,ctypes.foreign,ctypes.stubs -linkpkg -o main bindings.cmx bindings_stubs.cmx main.cmx 41 | 42 | clean: 43 | -rm *.cmx *.cmi *.c *.o bindings_c_gen bindings_stubs_gen bindings_stubs.ml main 44 | 45 | with_ocamlbuild: 46 | ocamlbuild -use-ocamlfind -package ctypes,ctypes.foreign,ctypes.stubs main.native 47 | 48 | ocamlbuild_clean: 49 | ocamlbuild -clean 50 | -------------------------------------------------------------------------------- /examples/cstubs_structs/bindings.ml: -------------------------------------------------------------------------------- 1 | module Stubs = functor (S : Cstubs_structs.TYPE) -> struct 2 | module Tm = struct 3 | type tm 4 | type t = tm Ctypes.structure 5 | let t : t S.typ = S.structure "tm" 6 | let tm_hour = S.(field t "tm_hour" int) 7 | let tm_year = S.(field t "tm_year" int) 8 | 9 | let () = S.seal t 10 | end 11 | 12 | module Limits = struct 13 | let shrt_max = S.(constant "SHRT_MAX" short) 14 | end 15 | end 16 | -------------------------------------------------------------------------------- /examples/cstubs_structs/bindings_c_gen.ml: -------------------------------------------------------------------------------- 1 | let c_headers = "#include \n#include " 2 | 3 | let main () = 4 | let stubs_out = open_out "bindings_stubs_gen.c" in 5 | let stubs_fmt = Format.formatter_of_out_channel stubs_out in 6 | Format.fprintf stubs_fmt "%s@\n" c_headers; 7 | Cstubs_structs.write_c stubs_fmt (module Bindings.Stubs); 8 | Format.pp_print_flush stubs_fmt (); 9 | close_out stubs_out 10 | 11 | let () = main () 12 | 13 | -------------------------------------------------------------------------------- /examples/cstubs_structs/main.ml: -------------------------------------------------------------------------------- 1 | module Stubs = Bindings.Stubs(Bindings_stubs) 2 | 3 | let time = 4 | Foreign.foreign 5 | "time" 6 | Ctypes.(ptr PosixTypes.time_t @-> returning PosixTypes.time_t) 7 | 8 | let gmtime = 9 | Foreign.foreign 10 | "gmtime" 11 | Ctypes.(ptr PosixTypes.time_t @-> returning (ptr Stubs.Tm.t)) 12 | 13 | let main () = 14 | let tme = Ctypes.allocate PosixTypes.time_t (time Ctypes.(from_voidp PosixTypes.time_t null)) in 15 | let tm = gmtime tme in 16 | Printf.printf "tm_hour = %d\n" Ctypes.(getf (!@ tm) Stubs.Tm.tm_hour); 17 | Printf.printf "tm_year = %d\n" Ctypes.(getf (!@ tm) Stubs.Tm.tm_year); 18 | Printf.printf "SHRT_MAX = %d\n" Stubs.Limits.shrt_max 19 | 20 | let () = main () 21 | -------------------------------------------------------------------------------- /examples/cstubs_structs/myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | (* This example relies on Ocamlbuild version 0.9.0 (specifically on PR#6794). 2 | Otherwise compiling bindings_stubs_gen.c, Step 4, will fail because the 3 | package information isn't passed to "ocamlfind ocamlc". *) 4 | open Ocamlbuild_plugin 5 | 6 | let () = 7 | let additional_rules = function 8 | | Before_hygiene -> () 9 | | After_hygiene -> () 10 | | Before_options -> () 11 | | After_options -> () 12 | | Before_rules -> () 13 | | After_rules -> 14 | 15 | (* Generate stubs. Steps 1, 2, & 3 of Makefile (1 & 2 via built-in rules). 16 | ML -> C *) 17 | rule "cstubs: x_c_gen.native -> x_stubs_gen.c" 18 | ~dep:"%_c_gen.native" 19 | ~prod:"%_stubs_gen.c" 20 | (fun env _build -> Cmd (A (env "./%_c_gen.native"))); 21 | 22 | (* Step 4. OCamlbuild (nor ocamlc/ocamlopt) has a built in rule for 23 | linking executables from C. Call out to 'cc'. *) 24 | rule "stub_gen 1: x_stubs_gen.o -> x_stubs_gen" 25 | ~dep:"%_stubs_gen.o" 26 | ~prod:"%_stubs_gen" 27 | (fun env _build -> 28 | Cmd (S [ A "cc"; A "-o"; A (env "%_stubs_gen"); A (env "%_stubs_gen.o") ])); 29 | 30 | (* Step 5. Generate ml stubs. C -> ML *) 31 | rule "stubs_gen 2: x_stubs_gen -> x_stubs.ml" 32 | ~dep:"%_stubs_gen" 33 | ~prod:"%_stubs.ml" 34 | (fun env _build -> Cmd (S[A (env "./%_stubs_gen"); Sh">"; A (env "%_stubs.ml")])); 35 | 36 | in 37 | dispatch additional_rules 38 | -------------------------------------------------------------------------------- /examples/date/foreign/date.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes 9 | open PosixTypes 10 | open Foreign 11 | 12 | type tm 13 | let tm = structure "tm" 14 | let (-:) ty label = field tm label ty 15 | let tm_sec = int -: "tm_sec" (* seconds *) 16 | let tm_min = int -: "tm_min" (* minutes *) 17 | let tm_hour = int -: "tm_hour" (* hours *) 18 | let tm_mday = int -: "tm_mday" (* day of the month *) 19 | let tm_mon = int -: "tm_mon" (* month *) 20 | let tm_year = int -: "tm_year" (* year *) 21 | let tm_wday = int -: "tm_wday" (* day of the week *) 22 | let tm_yday = int -: "tm_yday" (* day in the year *) 23 | let tm_isdst = int -: "tm_isdst" (* daylight saving time *) 24 | let () = seal (tm : tm structure typ) 25 | 26 | let time = foreign "time" ~check_errno:true (ptr time_t @-> returning time_t) 27 | 28 | let asctime = foreign "asctime" (ptr tm @-> returning string) 29 | 30 | let localtime = foreign "localtime" (ptr time_t @-> returning (ptr tm)) 31 | 32 | let () = begin 33 | let timep = allocate_n ~count:1 time_t in 34 | let time = time timep in 35 | assert (time = !@timep); 36 | let tm = localtime timep in 37 | Printf.printf "tm.tm_mon = %d\n" (getf !@tm tm_mon); 38 | Printf.printf "tm.tm_year = %d\n" (getf !@tm tm_year); 39 | print_endline (asctime tm) 40 | end 41 | -------------------------------------------------------------------------------- /examples/date/foreign/date.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes 9 | open PosixTypes 10 | 11 | type tm 12 | val tm_sec : (int, tm structure) field 13 | val tm_min : (int, tm structure) field 14 | val tm_hour : (int, tm structure) field 15 | val tm_mday : (int, tm structure) field 16 | val tm_mon : (int, tm structure) field 17 | val tm_year : (int, tm structure) field 18 | val tm_wday : (int, tm structure) field 19 | val tm_yday : (int, tm structure) field 20 | val tm_isdst : (int, tm structure) field 21 | 22 | val time : time_t ptr -> time_t 23 | val asctime : tm structure ptr -> string 24 | val localtime : time_t ptr -> tm structure ptr 25 | -------------------------------------------------------------------------------- /examples/date/foreign/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names date) 3 | (libraries ctypes-foreign)) 4 | -------------------------------------------------------------------------------- /examples/date/stub-generation/bindings/date_stubs.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes 9 | open PosixTypes 10 | 11 | type tm 12 | let tm = structure "tm" 13 | let (-:) ty label = field tm label ty 14 | let tm_sec = int -: "tm_sec" (* seconds *) 15 | let tm_min = int -: "tm_min" (* minutes *) 16 | let tm_hour = int -: "tm_hour" (* hours *) 17 | let tm_mday = int -: "tm_mday" (* day of the month *) 18 | let tm_mon = int -: "tm_mon" (* month *) 19 | let tm_year = int -: "tm_year" (* year *) 20 | let tm_wday = int -: "tm_wday" (* day of the week *) 21 | let tm_yday = int -: "tm_yday" (* day in the year *) 22 | let tm_isdst = int -: "tm_isdst" (* daylight saving time *) 23 | let () = seal (tm : tm structure typ) 24 | 25 | module Bindings 26 | (F : Ctypes.FOREIGN) = 27 | struct 28 | open F 29 | 30 | let time = foreign "time" (ptr time_t @-> returning time_t) 31 | 32 | let asctime = foreign "asctime" (ptr tm @-> returning string) 33 | 34 | let localtime = foreign "localtime" (ptr time_t @-> returning (ptr tm)) 35 | end 36 | -------------------------------------------------------------------------------- /examples/date/stub-generation/bindings/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name date_stubs) 3 | (libraries ctypes)) 4 | -------------------------------------------------------------------------------- /examples/date/stub-generation/date_cmd.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes 9 | open PosixTypes 10 | open Date_stubs 11 | module D = Bindings(Date_generated) 12 | open D 13 | 14 | let () = begin 15 | let timep = allocate_n ~count:1 time_t in 16 | let time = time timep in 17 | assert (time = !@timep); 18 | let tm = localtime timep in 19 | Printf.printf "tm.tm_mon = %d\n" (getf !@tm tm_mon); 20 | Printf.printf "tm.tm_year = %d\n" (getf !@tm tm_year); 21 | print_endline (asctime tm) 22 | end 23 | -------------------------------------------------------------------------------- /examples/date/stub-generation/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name date_cmd) 3 | (libraries date_stubs date_generated)) 4 | -------------------------------------------------------------------------------- /examples/date/stub-generation/stub-generator/date_stub_generator.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | let c_headers = "#include " 9 | 10 | let main () = 11 | let ml_out = open_out "date_generated.ml" 12 | and c_out = open_out "date_stubs.c" in 13 | let ml_fmt = Format.formatter_of_out_channel ml_out 14 | and c_fmt = Format.formatter_of_out_channel c_out in 15 | Format.fprintf c_fmt "%s@\n" c_headers; 16 | Cstubs.write_c c_fmt ~prefix:"date_stub_" (module Date_stubs.Bindings); 17 | Cstubs.write_ml ml_fmt ~prefix:"date_stub_" (module Date_stubs.Bindings); 18 | Format.pp_print_flush ml_fmt (); 19 | Format.pp_print_flush c_fmt (); 20 | close_out ml_out; 21 | close_out c_out 22 | 23 | let () = main () 24 | -------------------------------------------------------------------------------- /examples/date/stub-generation/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name date_stub_generator) 3 | (modules date_stub_generator) 4 | (libraries date_stubs ctypes.stubs ctypes)) 5 | 6 | (rule 7 | (targets date_stubs.c date_generated.ml) 8 | (deps date_stub_generator.exe) 9 | (action 10 | (run %{deps}))) 11 | 12 | (library 13 | (name date_generated) 14 | (modules date_generated) 15 | (foreign_stubs 16 | (language c) 17 | (names date_stubs)) 18 | (libraries ctypes.stubs)) 19 | -------------------------------------------------------------------------------- /examples/fts/foreign/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name fts_cmd) 3 | (enabled_if 4 | (= %{os_type} Unix)) 5 | (libraries ctypes-foreign) 6 | (package ctypes-foreign) 7 | (action (progn))) 8 | -------------------------------------------------------------------------------- /examples/fts/foreign/fts_cmd.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Fts 9 | 10 | let usage = "fts_cmd path [ path .. ]" 11 | 12 | let sort_by_name lp rp = 13 | let open Ctypes in 14 | let open FTSENT in 15 | String.compare (name !@lp) (name !@rp) 16 | 17 | let rec iter ~gen ~f = 18 | match gen () with 19 | | None -> () 20 | | Some x -> 21 | begin 22 | f x; 23 | iter ~gen ~f 24 | end 25 | 26 | let ents ?compar path_argv = 27 | let fts : FTS.t = fts_open ~path_argv ?compar ~options:[] () in 28 | (fun _ -> fts_read fts) 29 | 30 | let main paths = 31 | let indent = ref 0 in 32 | let show_path ent = 33 | Printf.printf "%*s%s\n" !indent "" (FTSENT.path ent); 34 | in 35 | iter 36 | ~f:FTSENT.(fun ent -> 37 | match info ent with 38 | | FTS_D -> begin 39 | show_path ent; 40 | incr indent 41 | end 42 | | FTS_F 43 | | FTS_SL 44 | | FTS_SLNONE -> show_path ent 45 | | FTS_DP -> decr indent 46 | | _ -> ()) 47 | ~gen:(ents ~compar:sort_by_name paths) 48 | 49 | let () = 50 | match List.tl (Array.to_list Sys.argv) with 51 | | [] -> prerr_endline usage 52 | | l -> main l 53 | -------------------------------------------------------------------------------- /examples/fts/stub-generation/bindings/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name fts_stubs) 3 | (wrapped false) 4 | (modules_without_implementation fts) 5 | (libraries ctypes ctypes-foreign)) 6 | -------------------------------------------------------------------------------- /examples/fts/stub-generation/bindings/fts_bindings.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes 9 | open Fts_types 10 | 11 | open FTSENT 12 | open FTS 13 | 14 | module Bindings (F : Ctypes.FOREIGN) = 15 | struct 16 | open F 17 | 18 | (* FTS *fts_open(char * const *path_argv, int options, 19 | int ( *compar)(const FTSENT **, const FTSENT ** )); 20 | *) 21 | let _fts_open = foreign "fts_open" 22 | (ptr (const (ptr char)) @-> int @-> compar_typ_opt @-> returning (ptr fts)) 23 | 24 | (* FTSENT *fts_read(FTS *ftsp); *) 25 | let _fts_read = foreign "fts_read" (* ~check_errno:true *) 26 | (ptr fts @-> returning (ptr ftsent)) 27 | 28 | (* FTSENT *fts_children(FTS *ftsp, int options); *) 29 | let _fts_children = foreign "fts_children" 30 | (ptr fts @-> int @-> returning (ptr ftsent)) 31 | 32 | (* int fts_set(FTS *ftsp, FTSENT *f, int options); *) 33 | let _fts_set = foreign "fts_set" (* ~check_errno:true *) 34 | (ptr fts @-> ptr (ftsent) @-> int @-> returning int) 35 | 36 | (* int fts_close(FTS *ftsp); *) 37 | let _fts_close = foreign "fts_close" (* ~check_errno:true *) 38 | (ptr fts @-> returning int) 39 | 40 | let _strdup = foreign "strdup" 41 | (string @-> returning (ptr char)) 42 | 43 | let _free = foreign "free" 44 | (ptr char @-> returning void) 45 | end 46 | -------------------------------------------------------------------------------- /examples/fts/stub-generation/config/discover.ml: -------------------------------------------------------------------------------- 1 | module C = Configurator.V1 2 | 3 | let prepend opt flags = 4 | if flags = [] then 5 | [] 6 | else 7 | opt :: flags 8 | 9 | let () = 10 | C.main ~name:"fts_example" (fun c -> 11 | let default : C.Pkg_config.package_conf = { 12 | libs = []; 13 | cflags = [] 14 | } in 15 | let conf = 16 | match C.Pkg_config.get c with 17 | | None -> default 18 | | Some pc -> 19 | (match C.Pkg_config.query pc ~package:"libfts" with 20 | | None -> default 21 | | Some v -> v) 22 | in 23 | C.Flags.write_sexp "c_flags.sexp" (prepend "-ccopt" conf.cflags); 24 | C.Flags.write_sexp "c_library_flags.sexp" (prepend "-cclib" conf.libs) 25 | ) 26 | -------------------------------------------------------------------------------- /examples/fts/stub-generation/config/discover.mli: -------------------------------------------------------------------------------- 1 | (* empty *) 2 | -------------------------------------------------------------------------------- /examples/fts/stub-generation/config/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name discover) 3 | (libraries dune-configurator)) 4 | 5 | (rule 6 | (targets c_flags.sexp c_library_flags.sexp) 7 | (action 8 | (run ./discover.exe))) 9 | -------------------------------------------------------------------------------- /examples/fts/stub-generation/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name fts_cmd) 3 | (build_if 4 | (= %{os_type} Unix)) 5 | (libraries fts_stubs fts_generated) 6 | (package ctypes) 7 | (action (progn)) 8 | (link_flags 9 | :standard 10 | (:include config/c_library_flags.sexp))) 11 | -------------------------------------------------------------------------------- /examples/fts/stub-generation/fts_cmd.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Fts_types 9 | open Fts_if 10 | 11 | let usage = "fts_cmd path [ path .. ]" 12 | 13 | let sort_by_name lp rp = 14 | let open Ctypes in 15 | let open FTSENT in 16 | String.compare (name !@lp) (name !@rp) 17 | 18 | let rec iter ~gen ~f = 19 | match gen () with 20 | | None -> () 21 | | Some x -> 22 | begin 23 | f x; 24 | iter ~gen ~f 25 | end 26 | 27 | let ents ?compar path_argv = 28 | let fts : FTS.t = fts_open ~path_argv ?compar ~options:[] () in 29 | (fun _ -> fts_read fts) 30 | 31 | let main paths = 32 | let indent = ref 0 in 33 | let show_path ent = 34 | Printf.printf "%*s%s\n" !indent "" (FTSENT.path ent); 35 | in 36 | iter 37 | ~f:FTSENT.(fun ent -> 38 | match info ent with 39 | | FTS_D -> begin 40 | show_path ent; 41 | incr indent 42 | end 43 | | FTS_F 44 | | FTS_SL 45 | | FTS_SLNONE -> show_path ent 46 | | FTS_DP -> decr indent 47 | | _ -> ()) 48 | ~gen:(ents ~compar:sort_by_name paths) 49 | 50 | let () = 51 | match List.tl (Array.to_list Sys.argv) with 52 | | [] -> prerr_endline usage 53 | | l -> main l 54 | -------------------------------------------------------------------------------- /examples/fts/stub-generation/fts_if.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes 9 | open Fts_types 10 | open FTS 11 | 12 | module N = Fts_bindings.Bindings(Fts_generated) 13 | open N 14 | 15 | let crush_options f : 'a list -> int = List.fold_left (fun i o -> i lor (f o)) 0 16 | 17 | let fts_read fts = 18 | let p = _fts_read fts.ptr in 19 | if to_voidp p = null then None 20 | else Some p 21 | 22 | let fts_close ftsp = 23 | ignore (_fts_close ftsp.ptr) 24 | 25 | let fts_set ~ftsp ~f ~options = 26 | ignore (_fts_set ftsp.ptr f (crush_options fts_set_option_value options)) 27 | 28 | let fts_children ~ftsp ~name_only = 29 | _fts_children ftsp.ptr (fts_children_option_of_bool name_only) 30 | 31 | let null_terminated_array_of_ptr_list typ list = 32 | let nitems = List.length list in 33 | let arr = CArray.make typ (1 + nitems) in 34 | List.iteri (CArray.set arr) list; 35 | (coerce (ptr typ) (ptr (ptr void)) (CArray.start arr +@ nitems)) <-@ null; 36 | arr 37 | 38 | let fts_open ~path_argv ?compar ~options () = 39 | let path_argv_cpointers = List.map _strdup path_argv in 40 | let paths = null_terminated_array_of_ptr_list (ptr char) path_argv_cpointers in 41 | let options = crush_options fts_open_option_value options in 42 | let r = { ptr = _fts_open (CArray.start paths) options compar; compar } in 43 | List.iter _free path_argv_cpointers; 44 | r 45 | -------------------------------------------------------------------------------- /examples/fts/stub-generation/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name fts_stub_generator) 3 | (enabled_if 4 | (= %{os_type} "Unix")) 5 | (modules fts_stub_generator) 6 | (libraries fts_stubs ctypes.stubs ctypes)) 7 | 8 | (rule 9 | (targets fts_stubs.c fts_generated.ml) 10 | (deps fts_stub_generator.exe) 11 | (enabled_if 12 | (= %{os_type} "Unix")) 13 | (action 14 | (run %{deps}))) 15 | 16 | (library 17 | (name fts_generated) 18 | (enabled_if 19 | (= %{os_type} "Unix")) 20 | (modules fts_generated) 21 | (foreign_stubs 22 | (language c) 23 | (names fts_stubs) 24 | (flags 25 | :standard 26 | (:include ../config/c_flags.sexp))) 27 | (libraries ctypes.stubs)) 28 | -------------------------------------------------------------------------------- /examples/fts/stub-generation/stub-generator/fts_stub_generator.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | let c_headers = " 9 | #include 10 | #include 11 | #include 12 | #include 13 | " 14 | 15 | let main () = 16 | let ml_out = open_out "fts_generated.ml" 17 | and c_out = open_out "fts_stubs.c" in 18 | let ml_fmt = Format.formatter_of_out_channel ml_out 19 | and c_fmt = Format.formatter_of_out_channel c_out in 20 | Format.fprintf c_fmt "%s@\n" c_headers; 21 | Cstubs.write_c c_fmt ~prefix:"fts_stub_" (module Fts_bindings.Bindings); 22 | Cstubs.write_ml ml_fmt ~prefix:"fts_stub_" (module Fts_bindings.Bindings); 23 | Format.pp_print_flush ml_fmt (); 24 | Format.pp_print_flush c_fmt (); 25 | close_out ml_out; 26 | close_out c_out 27 | 28 | let () = main () 29 | -------------------------------------------------------------------------------- /examples/ncurses/foreign/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ncurses) 3 | (modules ncurses) 4 | (libraries ctypes-foreign)) 5 | 6 | (executables 7 | (names ncurses_cmd) 8 | (modules ncurses_cmd) 9 | (link_flags 10 | (:standard -cclib -lncurses)) 11 | (libraries ncurses)) 12 | -------------------------------------------------------------------------------- /examples/ncurses/foreign/ncurses.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes 9 | open Foreign 10 | 11 | type window = unit ptr 12 | let window : window typ = ptr void 13 | 14 | let initscr = 15 | foreign "initscr" (void @-> (returning window)) 16 | 17 | let endwin = 18 | foreign "endwin" (void @-> (returning void)) 19 | 20 | let refresh = 21 | foreign "refresh" (void @-> (returning void)) 22 | 23 | let wrefresh = 24 | foreign "wrefresh" (window @-> (returning void)) 25 | 26 | let newwin = 27 | foreign "newwin" (int @-> int @-> int @-> int @-> (returning window)) 28 | 29 | let addch = 30 | foreign "addch" (char @-> (returning void)) 31 | 32 | let mvwaddch = 33 | foreign "mvwaddch" (window @-> int @-> int @-> char @-> (returning void)) 34 | 35 | let addstr = 36 | foreign "addstr" (string @-> (returning void)) 37 | 38 | let mvwaddstr = 39 | foreign "mvwaddstr" (window @-> int @-> int @-> string @-> (returning void)) 40 | 41 | let box = 42 | foreign "box" (window @-> int @-> int @-> (returning void)) 43 | 44 | let cbreak = 45 | foreign "cbreak" (void @-> (returning void)) 46 | -------------------------------------------------------------------------------- /examples/ncurses/foreign/ncurses_cmd.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ncurses 9 | 10 | let () = 11 | let main_window = initscr () in 12 | cbreak (); 13 | let small_window = newwin 10 10 5 5 in 14 | mvwaddstr main_window 1 2 "Hello"; 15 | mvwaddstr small_window 2 2 "World"; 16 | box small_window 0 0; 17 | refresh (); 18 | Unix.sleep 1; 19 | wrefresh small_window; 20 | Unix.sleep 5; 21 | endwin() 22 | -------------------------------------------------------------------------------- /examples/ncurses/stub-generation/bindings/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ncurses_bindings) 3 | (libraries ctypes)) 4 | -------------------------------------------------------------------------------- /examples/ncurses/stub-generation/bindings/ncurses_bindings.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes 9 | 10 | type window = unit ptr 11 | let window : window typ = ptr void 12 | 13 | module Bindings (F : Ctypes.FOREIGN) = 14 | struct 15 | open F 16 | 17 | let initscr = 18 | foreign "initscr" (void @-> (returning window)) 19 | 20 | let endwin = 21 | foreign "endwin" (void @-> (returning void)) 22 | 23 | let refresh = 24 | foreign "refresh" (void @-> (returning void)) 25 | 26 | let wrefresh = 27 | foreign "wrefresh" (window @-> (returning void)) 28 | 29 | let newwin = 30 | foreign "newwin" (int @-> int @-> int @-> int @-> (returning window)) 31 | 32 | let addch = 33 | foreign "addch" (char @-> (returning void)) 34 | 35 | let mvwaddch = 36 | foreign "mvwaddch" (window @-> int @-> int @-> char @-> (returning void)) 37 | 38 | let addstr = 39 | foreign "addstr" (string @-> (returning void)) 40 | 41 | let mvwaddstr = 42 | foreign "mvwaddstr" (window @-> int @-> int @-> string @-> (returning void)) 43 | 44 | let box = 45 | foreign "box" (window @-> int @-> int @-> (returning void)) 46 | 47 | let cbreak = 48 | foreign "cbreak" (void @-> (returning void)) 49 | end 50 | -------------------------------------------------------------------------------- /examples/ncurses/stub-generation/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name ncurses_stub_cmd) 3 | (libraries ncurses_bindings ncurses_generated unix)) 4 | -------------------------------------------------------------------------------- /examples/ncurses/stub-generation/ncurses_stub_cmd.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | module N = Ncurses_bindings.Bindings(Ncurses_generated) 9 | open N 10 | 11 | let () = 12 | let main_window = initscr () in 13 | cbreak (); 14 | let small_window = newwin 10 10 5 5 in 15 | mvwaddstr main_window 1 2 "Hello"; 16 | mvwaddstr small_window 2 2 "World"; 17 | box small_window 0 0; 18 | refresh (); 19 | Unix.sleep 1; 20 | wrefresh small_window; 21 | Unix.sleep 5; 22 | endwin() 23 | -------------------------------------------------------------------------------- /examples/ncurses/stub-generation/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name ncurses_stub_generator) 3 | (modules ncurses_stub_generator) 4 | (libraries ncurses_bindings ctypes.stubs ctypes)) 5 | 6 | (rule 7 | (targets ncurses_stubs.c ncurses_generated.ml) 8 | (deps ncurses_stub_generator.exe) 9 | (action 10 | (run %{deps}))) 11 | 12 | (library 13 | (name ncurses_generated) 14 | (modules ncurses_generated) 15 | (c_library_flags -lncurses) 16 | (foreign_stubs 17 | (language c) 18 | (names ncurses_stubs)) 19 | (libraries ctypes.stubs)) 20 | -------------------------------------------------------------------------------- /examples/ncurses/stub-generation/stub-generator/ncurses_stub_generator.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2017 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | let c_headers = "#include " 9 | 10 | let main () = 11 | let ml_out = open_out "ncurses_generated.ml" in 12 | let c_out = open_out "ncurses_stubs.c" in 13 | let c_fmt = Format.formatter_of_out_channel c_out in 14 | let ml_fmt = Format.formatter_of_out_channel ml_out in 15 | Format.fprintf c_fmt "%s@\n" c_headers; 16 | Cstubs.write_c c_fmt ~prefix:"ncurses_stub_" (module Ncurses_bindings.Bindings); 17 | Cstubs.write_ml ml_fmt ~prefix:"ncurses_stub_" (module Ncurses_bindings.Bindings); 18 | Format.pp_print_flush ml_fmt (); 19 | Format.pp_print_flush c_fmt (); 20 | close_out ml_out; 21 | close_out c_out 22 | 23 | let () = main () 24 | -------------------------------------------------------------------------------- /examples/sigset/sigset.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open PosixTypes 9 | open Ctypes 10 | 11 | type t = sigset_t ptr 12 | 13 | val t : sigset_t ptr typ 14 | 15 | val empty : unit -> t 16 | 17 | val full : unit -> t 18 | 19 | val add : t -> int -> unit 20 | 21 | val del : t -> int -> unit 22 | 23 | val mem : t -> int -> bool 24 | -------------------------------------------------------------------------------- /src/configure/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name gen_c_primitives) 3 | (libraries dune-configurator) 4 | (modules gen_c_primitives)) 5 | -------------------------------------------------------------------------------- /src/cstubs/cstubs_analysis.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Analysis for stub generation *) 9 | 10 | val float : 'a Ctypes_static.fn -> bool 11 | val may_allocate : 'a Ctypes_static.fn -> bool 12 | -------------------------------------------------------------------------------- /src/cstubs/cstubs_errors.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Exception definitions *) 9 | 10 | exception Cstubs_internal_error of string 11 | 12 | let internal_error fmt = 13 | Format.ksprintf (fun s -> raise (Cstubs_internal_error s)) fmt 14 | -------------------------------------------------------------------------------- /src/cstubs/cstubs_errors.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Exception definitions *) 9 | 10 | exception Cstubs_internal_error of string 11 | 12 | val internal_error : ('a, unit, string, 'b) format4 -> 'a 13 | -------------------------------------------------------------------------------- /src/cstubs/cstubs_generate_c.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* C stub generation *) 9 | 10 | val fn : concurrency:[ `Sequential | `Lwt_jobs | `Lwt_preemptive | `Unlocked ] -> 11 | errno:[ `Ignore_errno | `Return_errno ] -> 12 | cname:string -> stub_name:string -> 13 | Format.formatter -> 'a Ctypes.fn -> unit 14 | 15 | val value : cname:string -> stub_name:string -> Format.formatter -> 16 | 'a Ctypes.typ -> unit 17 | 18 | val inverse_fn : stub_name:string -> runtime_lock:bool -> 19 | Format.formatter -> 'a Ctypes.fn -> unit 20 | 21 | val inverse_fn_decl : stub_name:string -> Format.formatter -> 22 | 'a Ctypes.fn -> unit 23 | -------------------------------------------------------------------------------- /src/cstubs/cstubs_generate_ml.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* ML stub generation *) 9 | 10 | val extern : concurrency:[ `Sequential | `Lwt_jobs | `Lwt_preemptive | `Unlocked ] -> 11 | errno:[ `Ignore_errno | `Return_errno ] -> 12 | stub_name:string -> external_name:string -> Format.formatter -> 13 | ('a -> 'b) Ctypes.fn -> unit 14 | 15 | val case : concurrency:[ `Sequential | `Lwt_jobs | `Lwt_preemptive | `Unlocked ] -> 16 | errno:[ `Ignore_errno | `Return_errno ] -> 17 | stub_name:string -> external_name:string -> Format.formatter -> 18 | ('a -> 'b) Ctypes.fn -> unit 19 | 20 | val val_case : stub_name:string -> external_name:string -> Format.formatter -> 21 | 'a Ctypes.typ -> unit 22 | 23 | val constructor_decl : concurrency:[ `Sequential | `Lwt_jobs | `Lwt_preemptive | `Unlocked ] -> 24 | errno:[ `Ignore_errno | `Return_errno ] -> 25 | string -> 'a Ctypes.fn -> Format.formatter -> unit 26 | 27 | val inverse_case : register_name:string -> constructor:string -> string -> 28 | Format.formatter -> ('a -> 'b) Ctypes.fn -> unit 29 | -------------------------------------------------------------------------------- /src/cstubs/cstubs_inverted.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (** Operations for exposing OCaml code as C libraries. *) 9 | 10 | module type INTERNAL = 11 | sig 12 | (* Expose type definitions to C. 13 | 14 | The types are printed to the header file generated by [write_c_header]. *) 15 | val enum : (string * int64) list -> 'a Ctypes.typ -> unit 16 | val structure : _ Ctypes.structure Ctypes.typ -> unit 17 | val union : _ Ctypes.union Ctypes.typ -> unit 18 | val typedef : _ Ctypes.typ -> string -> unit 19 | 20 | val internal : ?runtime_lock:bool -> string -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) -> unit 21 | end 22 | 23 | module type BINDINGS = functor (F : INTERNAL) -> sig end 24 | 25 | val write_c : Format.formatter -> prefix:string -> (module BINDINGS) -> unit 26 | (** [write_c fmt ~prefix bindings] generates C stubs for the functions bound 27 | with [internal] in [bindings]. The stubs are intended to be used in 28 | conjunction with the ML code generated by {!write_ml}. 29 | 30 | The generated code uses definitions exposed in the header file 31 | [cstubs_internals.h]. 32 | *) 33 | 34 | val write_c_header : Format.formatter -> prefix:string -> (module BINDINGS) -> unit 35 | (** [write_c_header fmt ~prefix bindings] generates a C header file 36 | for the functions bound with [internal] in [bindings]. The stubs 37 | are intended to be used in conjunction with the C code generated 38 | by {!write_c}. 39 | *) 40 | 41 | val write_ml : Format.formatter -> prefix:string -> (module BINDINGS) -> unit 42 | (** [write_ml fmt ~prefix bindings] generates ML bindings for the functions 43 | bound with [internal] in [bindings]. The generated code conforms to the 44 | {!INTERNAL} interface. 45 | 46 | The generated code uses definitions exposed in the module 47 | [Cstubs_internals]. *) 48 | -------------------------------------------------------------------------------- /src/cstubs/cstubs_public_name.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Publicly visible names for type values *) 9 | 10 | val ident_of_ml_prim : 'a Ctypes_primitive_types.ml_prim -> Ctypes_path.path 11 | (* The type that should appear in the extern signature *) 12 | 13 | val constructor_ident_of_prim : 'a Ctypes_primitive_types.prim -> Ctypes_path.path 14 | (* The path to a value that represents the primitive type *) 15 | 16 | val constructor_cident_of_prim : 17 | ?module_name:string -> 'a Ctypes_primitive_types.prim -> Ctypes_path.path 18 | (* The path to a constructor that represents the primitive type *) 19 | -------------------------------------------------------------------------------- /src/cstubs/cstubs_structs.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | module type TYPE = 9 | sig 10 | include Ctypes_types.TYPE 11 | 12 | type 'a const 13 | val constant : string -> 'a typ -> 'a const 14 | 15 | val enum : string -> ?typedef:bool -> ?unexpected:(int64 -> 'a) -> ('a * int64 const) list -> 'a typ 16 | end 17 | 18 | module type BINDINGS = functor (F : TYPE) -> sig end 19 | 20 | val write_c : Format.formatter -> (module BINDINGS) -> unit 21 | -------------------------------------------------------------------------------- /src/cstubs/ctypes_path.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Paths (long identifiers) *) 9 | 10 | type path = string list 11 | 12 | let is_uident s = 13 | Str.(string_match (regexp "[A-Z][a-zA-Z0-9_]*") s 0);; 14 | 15 | let is_ident s = 16 | Str.(string_match (regexp "[A-Za-z_][a-zA-Z0-9_]*") s 0);; 17 | 18 | let rec is_valid_path = function 19 | | [] -> false 20 | | [l] -> is_ident l 21 | | u :: p -> is_uident u && is_valid_path p 22 | 23 | let path_of_string s = 24 | let p = Str.(split (regexp_string ".") s) in 25 | if is_valid_path p then p 26 | else invalid_arg "Ctypes_ident.path_of_string" 27 | 28 | let format_path fmt p = 29 | Format.pp_print_string fmt (String.concat "." p) 30 | -------------------------------------------------------------------------------- /src/cstubs/ctypes_path.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Value paths (long identifiers) *) 9 | 10 | type path 11 | 12 | val path_of_string : string -> path 13 | val format_path : Format.formatter -> path -> unit 14 | -------------------------------------------------------------------------------- /src/cstubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ctypes_stubs) 3 | (public_name ctypes.stubs) 4 | (instrumentation 5 | (backend bisect_ppx)) 6 | (wrapped false) 7 | (libraries 8 | (re_export ctypes) 9 | str)) 10 | -------------------------------------------------------------------------------- /src/ctypes-foreign/config/discover.ml: -------------------------------------------------------------------------------- 1 | module C = Configurator.V1 2 | 3 | let () = 4 | C.main ~name:"ffi" (fun c -> 5 | let default : C.Pkg_config.package_conf = { 6 | libs = ["-lffi"]; 7 | cflags = [] 8 | } in 9 | let conf = 10 | match C.Pkg_config.get c with 11 | | None -> default 12 | | Some pc -> 13 | (match C.Pkg_config.query pc ~package:"libffi" with 14 | | None -> default 15 | | Some v -> v) 16 | in 17 | let backend = 18 | match Sys.os_type with 19 | | "Win32" | "Cygwin" -> "win" 20 | | _ -> "unix" in 21 | 22 | let f = "as_needed_test" in 23 | let ml = f ^ ".ml" in 24 | open_out ml |> close_out; 25 | let extra_ldflags = 26 | match backend with 27 | |"win" -> ["-lpsapi"] 28 | |_ -> 29 | let res = C.Process.run_ok c "ocamlopt" 30 | ["-shared"; "-cclib"; "-Wl,--no-as-needed"; ml; "-o"; f^".cmxs"] in 31 | if res then ["-Wl,--no-as-needed"] else [] 32 | in 33 | C.Flags.write_sexp "c_flags.sexp" conf.cflags; 34 | C.Flags.write_lines "c_flags" conf.cflags; 35 | C.Flags.write_sexp "c_library_flags.sexp" (conf.libs @ extra_ldflags); 36 | C.Flags.write_lines "backend.sexp" [backend] 37 | ) 38 | -------------------------------------------------------------------------------- /src/ctypes-foreign/config/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name discover) 3 | (modules discover) 4 | (libraries dune-configurator)) 5 | 6 | (executable 7 | (name gen_libffi_abi) 8 | (modules gen_libffi_abi) 9 | (libraries dune-configurator)) 10 | -------------------------------------------------------------------------------- /src/ctypes-foreign/ctypes_closure_properties.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | module type MUTEX = 9 | sig 10 | type t 11 | val create : unit -> t 12 | val lock : t -> unit 13 | val try_lock : t -> bool 14 | val unlock : t -> unit 15 | end 16 | 17 | module Make (Mutex : MUTEX) : 18 | sig 19 | val record : Obj.t -> Obj.t -> int 20 | (** [record c v] links the lifetimes of [c] and [v], ensuring that [v] is not 21 | collected while [c] is still live. The return value is a key 22 | that can be used to retrieve [v] while [v] is still live. *) 23 | 24 | val retrieve : int -> Obj.t 25 | (** [retrieve v] retrieves a value using a key returned by [record], or raises 26 | [Not_found] if [v] is no longer live. *) 27 | end 28 | -------------------------------------------------------------------------------- /src/ctypes-foreign/ctypes_ffi.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | module type CLOSURE_PROPERTIES = 9 | sig 10 | val record : Obj.t -> Obj.t -> int 11 | (** [record c v] links the lifetimes of [c] and [v], ensuring that [v] is not 12 | collected while [c] is still live. The return value is a key 13 | that can be used to retrieve [v] while [v] is still live. *) 14 | 15 | val retrieve : int -> Obj.t 16 | (** [retrieve v] retrieves a value using a key returned by [record], or raises 17 | [Not_found] if [v] is no longer live. *) 18 | end 19 | 20 | module Make(Closure_properties : CLOSURE_PROPERTIES) : 21 | sig 22 | open Ctypes_static 23 | open Libffi_abi 24 | 25 | (** Dynamic function calls based on libffi *) 26 | 27 | val function_of_pointer : ?name:string -> abi:abi -> check_errno:bool -> 28 | release_runtime_lock:bool -> ('a -> 'b) fn -> ('a -> 'b) static_funptr -> 29 | ('a -> 'b) 30 | (** Build an OCaml function from a type specification and a pointer to a C 31 | function. *) 32 | 33 | val pointer_of_function : abi:abi -> acquire_runtime_lock:bool -> 34 | thread_registration:bool -> 35 | ('a -> 'b) fn -> ('a -> 'b) -> ('a -> 'b) static_funptr 36 | (** Build an C function from a type specification and an OCaml function. 37 | 38 | The C function pointer returned is callable as long as the OCaml function 39 | value is live. *) 40 | 41 | type 'a funptr 42 | 43 | val free_funptr : _ funptr -> unit 44 | 45 | val funptr_of_fun : abi:abi -> acquire_runtime_lock:bool -> 46 | thread_registration:bool -> 47 | ('a -> 'b) fn -> ('a -> 'b) -> ('a -> 'b) funptr 48 | 49 | val funptr_of_static_funptr : ('a -> 'b) static_funptr -> ('a -> 'b) funptr 50 | 51 | val funptr_to_static_funptr : ('a -> 'b) funptr -> ('a -> 'b) static_funptr 52 | 53 | val report_leaked_funptr : (string -> unit) ref 54 | end 55 | -------------------------------------------------------------------------------- /src/ctypes-foreign/ctypes_foreign_threaded_stubs.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | external setup_thread_registration : unit -> unit 9 | = "ctypes_setup_thread_registration" 10 | -------------------------------------------------------------------------------- /src/ctypes-foreign/ctypes_weak_ref.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | exception EmptyWeakReference 9 | 10 | type 'a t = 'a Weak.t 11 | 12 | let empty () = raise EmptyWeakReference 13 | let make v = Weak.(let a = create 1 in set a 0 (Some v); a) 14 | let set r v = Weak.set r 0 (Some v) 15 | let get r = match Weak.get r 0 with Some v -> v | None -> empty () 16 | let is_empty r = Weak.check r 0 17 | -------------------------------------------------------------------------------- /src/ctypes-foreign/ctypes_weak_ref.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (** A single-cell variant of the weak arrays in the standard library. *) 9 | 10 | exception EmptyWeakReference 11 | (** An expired weak reference was accessed. *) 12 | 13 | type 'a t 14 | (** The type of weak references.. *) 15 | 16 | val make : 'a -> 'a t 17 | (** Obtain a weak reference from a strong reference. *) 18 | 19 | val set : 'a t -> 'a -> unit 20 | (** Update a weak reference. *) 21 | 22 | val get : 'a t -> 'a 23 | (** Obtain a strong reference from a weak reference. *) 24 | 25 | val is_empty : 'a t -> bool 26 | (** Whether a weak reference is still live. *) 27 | -------------------------------------------------------------------------------- /src/ctypes-foreign/dl.ml.unix: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | [@@@ocaml.warning "-16"] 9 | 10 | type library 11 | 12 | type flag = 13 | RTLD_LAZY 14 | | RTLD_NOW 15 | | RTLD_GLOBAL 16 | | RTLD_LOCAL 17 | | RTLD_NODELETE 18 | | RTLD_NOLOAD 19 | | RTLD_DEEPBIND 20 | 21 | exception DL_error of string 22 | 23 | (* void *dlopen(const char *filename, int flag); *) 24 | external _dlopen : ?filename:string -> flags:int -> library option 25 | = "ctypes_dlopen" 26 | 27 | (* void *dlsym(void *handle, const char *symbol); *) 28 | external _dlsym : ?handle:library -> symbol:string -> nativeint option 29 | = "ctypes_dlsym" 30 | 31 | (* int dlclose(void *handle); *) 32 | external _dlclose : handle:library -> int 33 | = "ctypes_dlclose" 34 | 35 | (* char *dlerror(void); *) 36 | external _dlerror : unit -> string option 37 | = "ctypes_dlerror" 38 | 39 | external resolve_flag : flag -> int 40 | = "ctypes_resolve_dl_flag" 41 | 42 | let _report_dl_error noload = 43 | match _dlerror () with 44 | | Some error -> raise (DL_error (error)) 45 | | None -> 46 | if noload then 47 | raise (DL_error "library not loaded") 48 | else 49 | failwith "dl_error: expected error, but no error reported" 50 | 51 | let crush_flags f : 'a list -> int = List.fold_left (fun i o -> i lor (f o)) 0 52 | 53 | [@@@warning "-16"] 54 | let dlopen ?filename ~flags = 55 | match _dlopen ?filename ~flags:(crush_flags resolve_flag flags) with 56 | | Some library -> library 57 | | None -> _report_dl_error (List.mem RTLD_NOLOAD flags) 58 | 59 | let dlclose ~handle = 60 | match _dlclose ~handle with 61 | | 0 -> () 62 | | _ -> _report_dl_error false 63 | 64 | let dlsym ?handle ~symbol = 65 | match _dlsym ?handle ~symbol with 66 | | Some symbol -> symbol 67 | | None -> _report_dl_error false 68 | -------------------------------------------------------------------------------- /src/ctypes-foreign/dl.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (** Bindings to the dlopen / dlsym interface. *) 9 | 10 | type library 11 | (** The type of dynamic libraries, as returned by {!dlopen}. *) 12 | 13 | exception DL_error of string 14 | (** An error condition occurred when calling {!dlopen}, {!dlclose} or 15 | {!dlsym}. The argument is the string returned by the [dlerror] 16 | function. *) 17 | 18 | (** Flags for {!dlopen} 19 | 20 | Note for windows users: Only [RTLD_NOLOAD] and [RTLD_NODELETE] are supported. 21 | Passing no or any other flags to {!dlopen} will result in standard behaviour: 22 | just LoadLibrary is called. If [RTLD_NOLOAD] is specified and the module is 23 | not already loaded, a {!DL_error} with the string "library not loaded" is 24 | thrown; there is however no test, if such a library exists at all (like under 25 | linux). 26 | *) 27 | type flag = 28 | RTLD_LAZY 29 | | RTLD_NOW 30 | | RTLD_GLOBAL 31 | | RTLD_LOCAL 32 | | RTLD_NODELETE 33 | | RTLD_NOLOAD 34 | | RTLD_DEEPBIND 35 | 36 | val dlopen : ?filename:string -> flags:flag list -> library 37 | (** Open a dynamic library. 38 | 39 | Note for windows users: the filename must be encoded in UTF-8 *) 40 | 41 | val dlclose : handle:library -> unit 42 | (** Close a dynamic library. *) 43 | 44 | val dlsym : ?handle:library -> symbol:string -> nativeint 45 | (** Look up a symbol in a dynamic library. *) 46 | -------------------------------------------------------------------------------- /src/ctypes-foreign/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (copy# "dl_stubs.c.%{read-lines:backend.sexp}" dl_stubs.c)) 3 | 4 | (rule 5 | (copy# "dl.ml.%{read-lines:backend.sexp}" dl.ml)) 6 | 7 | (rule 8 | (with-stdout-to 9 | libffi_abi.ml 10 | (run ./config/gen_libffi_abi.exe -cflags "%{read-lines:c_flags}"))) 11 | 12 | (library 13 | (name ctypes_foreign) 14 | (public_name ctypes-foreign) 15 | (instrumentation 16 | (backend bisect_ppx)) 17 | (wrapped false) 18 | (private_modules ctypes_foreign_threaded_stubs) 19 | (libraries ctypes threads) 20 | (c_library_flags 21 | :standard 22 | (:include c_library_flags.sexp)) 23 | (foreign_stubs 24 | (language c) 25 | (names dl_stubs ffi_call_stubs ffi_type_stubs foreign_threaded_stubs) 26 | (flags 27 | :standard 28 | (:include c_flags.sexp)))) 29 | 30 | (rule 31 | (targets c_flags c_flags.sexp c_library_flags.sexp backend.sexp) 32 | (action 33 | (run ./config/discover.exe))) 34 | -------------------------------------------------------------------------------- /src/ctypes-foreign/foreign.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | include Ctypes_foreign_basis.Make(Ctypes_closure_properties.Make(Mutex)) 9 | 10 | let () = begin 11 | (* Initialize the Thread library and set up the hook for registering C 12 | threads with the OCaml runtime *) 13 | let _ : Thread.t = Thread.self () in 14 | Ctypes_foreign_threaded_stubs.setup_thread_registration () 15 | end 16 | -------------------------------------------------------------------------------- /src/ctypes-foreign/libffi_abi.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (** Support for various ABIs. *) 9 | 10 | type abi 11 | 12 | val aix : abi 13 | val darwin : abi 14 | val eabi : abi 15 | val fastcall : abi 16 | val gcc_sysv : abi 17 | val linux : abi 18 | val linux64 : abi 19 | val linux_soft_float : abi 20 | val ms_cdecl : abi 21 | val n32 : abi 22 | val n32_soft_float : abi 23 | val n64 : abi 24 | val n64_soft_float : abi 25 | val o32 : abi 26 | val o32_soft_float : abi 27 | val osf : abi 28 | val pa32 : abi 29 | val stdcall : abi 30 | val sysv : abi 31 | val thiscall : abi 32 | val unix : abi 33 | val unix64 : abi 34 | val v8 : abi 35 | val v8plus : abi 36 | val v9 : abi 37 | val vfp : abi 38 | 39 | val default_abi : abi 40 | 41 | val abi_code : abi -> int 42 | -------------------------------------------------------------------------------- /src/ctypes-top/dune: -------------------------------------------------------------------------------- 1 | ;; see https://github.com/ocaml/dune/issues/688 2 | 3 | (library 4 | (name ctypes_top) 5 | (public_name ctypes.top) 6 | (libraries ctypes compiler-libs)) 7 | -------------------------------------------------------------------------------- /src/ctypes/complexL.ml: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | external make : LDouble.t -> LDouble.t -> t = "ctypes_ldouble_complex_make" 4 | 5 | external re : t -> LDouble.t = "ctypes_ldouble_complex_real" 6 | external im : t -> LDouble.t = "ctypes_ldouble_complex_imag" 7 | 8 | let of_complex x = make (LDouble.of_float x.Complex.re) (LDouble.of_float x.Complex.im) 9 | let to_complex x = { Complex.re = LDouble.to_float (re x); im = LDouble.to_float (im x) } 10 | 11 | let norm2 x = 12 | let r, i = re x, im x in 13 | LDouble.(add (mul r r) (mul i i)) 14 | 15 | let norm x = 16 | let open LDouble in 17 | let r = abs (re x) and i = abs (im x) in 18 | if r = zero then i 19 | else if i = zero then r 20 | else if r >= i then 21 | let q = div i r in mul r (sqrt (add one (mul q q))) 22 | else 23 | let q = div r i in mul i (sqrt (add one (mul q q))) 24 | 25 | let polar n a = make LDouble.(mul (cos a) n) LDouble.(mul (sin a) n) 26 | 27 | let zero = make LDouble.zero LDouble.zero 28 | let one = make LDouble.one LDouble.zero 29 | let i = make LDouble.zero LDouble.one 30 | 31 | external neg : t -> t = "ctypes_ldouble_complex_neg" 32 | external conj : t -> t = "ctypes_ldouble_complex_conjl" 33 | external add : t -> t -> t = "ctypes_ldouble_complex_add" 34 | external sub : t -> t -> t = "ctypes_ldouble_complex_sub" 35 | external mul : t -> t -> t = "ctypes_ldouble_complex_mul" 36 | external div : t -> t -> t = "ctypes_ldouble_complex_div" 37 | let inv x = div one x 38 | external sqrt : t -> t = "ctypes_ldouble_complex_csqrtl" 39 | external arg : t -> LDouble.t = "ctypes_ldouble_complex_cargl" 40 | external exp : t -> t = "ctypes_ldouble_complex_cexpl" 41 | external log : t -> t = "ctypes_ldouble_complex_clogl" 42 | external pow : t -> t -> t = "ctypes_ldouble_complex_cpowl" 43 | 44 | -------------------------------------------------------------------------------- /src/ctypes/complexL.mli: -------------------------------------------------------------------------------- 1 | type t 2 | (** The type of long double complex values *) 3 | 4 | val make : LDouble.t -> LDouble.t -> t 5 | (** [make x y] creates the long double complex value [x + y * i] *) 6 | 7 | val of_complex : Complex.t -> t 8 | (** create a long double complex from a Complex.t *) 9 | 10 | val to_complex : t -> Complex.t 11 | (** Convert a long double complex to a Complex.t. The real and imaginary components 12 | are converted by calling [LDouble.to_float] which can produce unspecified results. *) 13 | 14 | val zero : t 15 | (** [0 + i0] *) 16 | 17 | val one : t 18 | (** [1 + i0] *) 19 | 20 | val i : t 21 | (** [0 + i] *) 22 | 23 | val re : t -> LDouble.t 24 | (** return the real part of the long double complex *) 25 | 26 | val im : t -> LDouble.t 27 | (** return the imaginary part of the long double complex *) 28 | 29 | val neg : t -> t 30 | (** Unary negation *) 31 | 32 | val conj : t -> t 33 | (** Conjugate: given the complex [x + i.y], returns [x - i.y]. *) 34 | 35 | val add : t -> t -> t 36 | (** Addition *) 37 | 38 | val sub : t -> t -> t 39 | (** Subtraction *) 40 | 41 | val mul : t -> t -> t 42 | (** Multiplication *) 43 | 44 | val div : t -> t -> t 45 | (** Division *) 46 | 47 | val inv : t -> t 48 | (** Multiplicative inverse ([1/z]). *) 49 | 50 | val sqrt : t -> t 51 | (** Square root. *) 52 | 53 | val norm2 : t -> LDouble.t 54 | (** Norm squared: given [x + i.y], returns [x^2 + y^2]. *) 55 | 56 | val norm : t -> LDouble.t 57 | (** Norm: given [x + i.y], returns [sqrt(x^2 + y^2)]. *) 58 | 59 | val polar : LDouble.t -> LDouble.t -> t 60 | (** [polar norm arg] returns the complex having norm [norm] and argument [arg]. *) 61 | 62 | val arg : t -> LDouble.t 63 | (** Argument. The argument of a complex number is the angle 64 | in the complex plane between the positive real axis and a line 65 | passing through zero and the number. *) 66 | 67 | val exp : t -> t 68 | (** Exponentiation. [exp z] returns [e] to the [z] power. *) 69 | 70 | val log : t -> t 71 | (** Natural logarithm (in base [e]). *) 72 | 73 | val pow : t -> t -> t 74 | (** Power function. [pow z1 z2] returns [z1] to the [z2] power. *) 75 | 76 | -------------------------------------------------------------------------------- /src/ctypes/complex_stubs.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | */ 7 | 8 | #include 9 | #include 10 | 11 | #include "ctypes_complex_compatibility.h" 12 | #include "ctypes_complex_stubs.h" 13 | 14 | static value allocate_complex_value(double r, double i) 15 | { 16 | value v = caml_alloc(2 * Double_wosize, Double_array_tag); 17 | Store_double_field(v, 0, r); 18 | Store_double_field(v, 1, i); 19 | return v; 20 | } 21 | 22 | /* ctypes_copy_float_complex : float _Complex -> Complex.t */ 23 | value ctypes_copy_float_complex(float _Complex c) 24 | { 25 | return allocate_complex_value(ctypes_compat_crealf(c), ctypes_compat_cimagf(c)); 26 | } 27 | 28 | /* ctypes_copy_double_complex : double _Complex -> Complex.t */ 29 | value ctypes_copy_double_complex(double _Complex c) 30 | { 31 | return allocate_complex_value(ctypes_compat_creal(c), ctypes_compat_cimag(c)); 32 | } 33 | 34 | /* ctypes_float_complex_val : Complex.t -> float _Complex */ 35 | float _Complex ctypes_float_complex_val(value v) 36 | { 37 | return ctypes_compat_make_complexf(Double_field(v, 0), Double_field(v, 1)); 38 | } 39 | 40 | /* ctypes_double_complex_val : Complex.t -> double _Complex */ 41 | double _Complex ctypes_double_complex_val(value v) 42 | { 43 | return ctypes_compat_make_complex(Double_field(v, 0), Double_field(v, 1)); 44 | } 45 | -------------------------------------------------------------------------------- /src/ctypes/cstubs_internals.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | */ 7 | 8 | #ifndef CSTUBS_INTERNALS_H 9 | #define CSTUBS_INTERNALS_H 10 | 11 | /* This is just here for backwards compatibility and will eventually be 12 | removed. */ 13 | 14 | /* Include the real header. */ 15 | #include "ctypes_cstubs_internals.h" 16 | 17 | #endif /* CSTUBS_INTERNALS_H */ 18 | -------------------------------------------------------------------------------- /src/ctypes/ctypes.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | include Ctypes_static 9 | 10 | include Ctypes_structs_computed 11 | 12 | include Ctypes_type_printing 13 | 14 | include Ctypes_memory 15 | 16 | include Ctypes_std_views 17 | 18 | include Ctypes_value_printing 19 | 20 | include Ctypes_coerce 21 | 22 | let lift_typ x = x 23 | 24 | module type FOREIGN = 25 | sig 26 | type 'a fn 27 | type 'a return 28 | val (@->) : 'a typ -> 'b fn -> ('a -> 'b) fn 29 | val returning : 'a typ -> 'a return fn 30 | 31 | type 'a result 32 | val foreign : string -> ('a -> 'b) fn -> ('a -> 'b) result 33 | val foreign_value : string -> 'a typ -> 'a ptr result 34 | end 35 | 36 | module type TYPE = 37 | sig 38 | include Ctypes_types.TYPE 39 | 40 | type 'a const 41 | val constant : string -> 'a typ -> 'a const 42 | val enum : string -> ?typedef:bool -> 43 | ?unexpected:(int64 -> 'a) -> ('a * int64 const) list -> 'a typ 44 | end 45 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_bigarray_stubs.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | type _ kind = 9 | Kind_float32 : float kind 10 | | Kind_float64 : float kind 11 | | Kind_int8_signed : int kind 12 | | Kind_int8_unsigned : int kind 13 | | Kind_int16_signed : int kind 14 | | Kind_int16_unsigned : int kind 15 | | Kind_int32 : int32 kind 16 | | Kind_int64 : int64 kind 17 | | Kind_int : int kind 18 | | Kind_nativeint : nativeint kind 19 | | Kind_complex32 : Complex.t kind 20 | | Kind_complex64 : Complex.t kind 21 | | Kind_char : char kind 22 | 23 | let kind : type a b. (a, b) Bigarray.kind -> a kind = function 24 | | Bigarray.Float32 -> Kind_float32 25 | | Bigarray.Float64 -> Kind_float64 26 | | Bigarray.Int8_signed -> Kind_int8_signed 27 | | Bigarray.Int8_unsigned -> Kind_int8_unsigned 28 | | Bigarray.Int16_signed -> Kind_int16_signed 29 | | Bigarray.Int16_unsigned -> Kind_int16_unsigned 30 | | Bigarray.Int32 -> Kind_int32 31 | | Bigarray.Int64 -> Kind_int64 32 | | Bigarray.Int -> Kind_int 33 | | Bigarray.Nativeint -> Kind_nativeint 34 | | Bigarray.Complex32 -> Kind_complex32 35 | | Bigarray.Complex64 -> Kind_complex64 36 | | Bigarray.Char -> Kind_char 37 | | _ -> failwith "Unsupported bigarray kind" [@@ocaml.warning "-11"] 38 | 39 | external address : 'b -> Ctypes_ptr.voidp 40 | = "ctypes_bigarray_address" 41 | 42 | external view : 'a kind -> dims:int array -> _ Ctypes_ptr.Fat.t -> 43 | 'l Bigarray.layout -> ('a, 'b, 'l) Bigarray.Genarray.t 44 | = "ctypes_bigarray_view" 45 | 46 | external view1 : 'a kind -> dims:int array -> _ Ctypes_ptr.Fat.t -> 47 | 'l Bigarray.layout -> ('a, 'b, 'l) Bigarray.Array1.t 48 | = "ctypes_bigarray_view" 49 | 50 | external view2 : 'a kind -> dims:int array -> _ Ctypes_ptr.Fat.t -> 51 | 'l Bigarray.layout -> ('a, 'b, 'l) Bigarray.Array2.t 52 | = "ctypes_bigarray_view" 53 | 54 | external view3 : 'a kind -> dims:int array -> _ Ctypes_ptr.Fat.t -> 55 | 'l Bigarray.layout -> ('a, 'b, 'l) Bigarray.Array3.t 56 | = "ctypes_bigarray_view" 57 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_bigarrays.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | */ 7 | 8 | #include 9 | #include 10 | 11 | #include "ctypes_raw_pointer.h" 12 | 13 | #ifndef Caml_ba_layout_val 14 | /* Caml_ba_layout_val was introduced when the representation of layout 15 | values changed from an integer to a GADT. Up to that point the 16 | OCaml values c_layout and fortran_layout had the same values as 17 | the C constants CAML_BA_C_LAYOUT and CAML_BA_FORTRAN_LAYOUT */ 18 | #define Caml_ba_layout_val(v) (Int_val(v)) 19 | #endif 20 | 21 | /* address : 'b -> pointer */ 22 | value ctypes_bigarray_address(value ba) 23 | { 24 | return CTYPES_FROM_PTR(Caml_ba_data_val(ba)); 25 | } 26 | 27 | /* _view : ('a, 'b) kind -> dims:int array -> fatptr -> 'l layout -> 28 | ('a, 'b, 'l) Bigarray.Genarray.t */ 29 | value ctypes_bigarray_view(value kind_, value dims_, value ptr_, value layout_) 30 | { 31 | int kind = Int_val(kind_); 32 | int layout = Caml_ba_layout_val(layout_); 33 | int ndims = Wosize_val(dims_); 34 | intnat dims[CAML_BA_MAX_NUM_DIMS]; 35 | int i; 36 | for (i = 0; i < ndims; i++) { 37 | dims[i] = Long_val(Field(dims_, i)); 38 | } 39 | int flags = kind | layout | CAML_BA_EXTERNAL; 40 | void *data = CTYPES_ADDR_OF_FATPTR(ptr_); 41 | return caml_ba_alloc(flags, ndims, data, dims); 42 | } 43 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_coerce.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | type uncoercible_info 9 | 10 | exception Uncoercible of uncoercible_info 11 | 12 | val coerce : 'a Ctypes_static.typ -> 'b Ctypes_static.typ -> 'a -> 'b 13 | 14 | val coerce_fn : 'a Ctypes_static.fn -> 'b Ctypes_static.fn -> 'a -> 'b 15 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_complex_stubs.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | */ 7 | 8 | #ifndef CTYPES_COMPLEX_STUBS_H 9 | #define CTYPES_COMPLEX_STUBS_H 10 | 11 | #include 12 | 13 | /* ctypes_copy_float_complex : float _Complex -> Complex.t */ 14 | value ctypes_copy_float_complex(float _Complex); 15 | 16 | /* ctypes_copy_double_complex : double _Complex -> Complex.t */ 17 | value ctypes_copy_double_complex(double _Complex); 18 | 19 | /* ctypes_float_complex_val : Complex.t -> float _Complex */ 20 | float _Complex ctypes_float_complex_val(value); 21 | 22 | /* ctypes_double_complex_val : Complex.t -> double _Complex */ 23 | double _Complex ctypes_double_complex_val(value); 24 | 25 | #endif /* CTYPES_COMPLEX_STUBS_H */ 26 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_cstubs_internals.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | */ 7 | 8 | #ifndef CTYPES_CSTUBS_INTERNALS_H 9 | #define CTYPES_CSTUBS_INTERNALS_H 10 | 11 | /* Types and functions used by generated C code. */ 12 | 13 | #include "ctypes_primitives.h" 14 | #include "ctypes_complex_stubs.h" 15 | #include "ctypes_ldouble_stubs.h" 16 | #include "ctypes_raw_pointer.h" 17 | #include "ctypes_managed_buffer_stubs.h" 18 | #include 19 | /* The cast here removes the 'const' qualifier in recent 20 | versions of OCaml because ctypes doesn't yet support const. 21 | 22 | TODO: when ctypes supports cv-qualifiers, remove the cast. */ 23 | #define CTYPES_PTR_OF_OCAML_STRING(s) \ 24 | ((char *)String_val(Field(s, 1)) + Long_val(Field(s, 0))) 25 | 26 | #ifdef Bytes_val 27 | #define CTYPES_PTR_OF_OCAML_BYTES(s) \ 28 | (Bytes_val(Field(s, 1)) + Long_val(Field(s, 0))) 29 | #else 30 | #define CTYPES_PTR_OF_OCAML_BYTES(s) CTYPES_PTR_OF_OCAML_STRING(s) 31 | #endif 32 | 33 | #define Ctypes_val_char(c) \ 34 | (Val_int((c + 256) % 256)) 35 | #define CTYPES_PAIR_WITH_ERRNO(v) 36 | 37 | #include 38 | #include 39 | static inline value ctypes_pair_with_errno(value p) 40 | { 41 | CAMLparam1 (p); 42 | CAMLlocal1 (v); 43 | v = caml_alloc_tuple(2); 44 | Store_field (v, 0, p); 45 | Store_field (v, 1, ctypes_copy_sint(errno)); 46 | CAMLreturn (v); 47 | } 48 | 49 | #if defined(__MINGW32__) || defined(__MINGW64__) 50 | #define ctypes_printf __mingw_printf 51 | #else 52 | #define ctypes_printf printf 53 | #endif 54 | 55 | #endif /* CTYPES_CSTUBS_INTERNALS_H */ 56 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_ldouble_stubs.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2016 Andy Ray. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | */ 7 | 8 | #ifndef CTYPES_LDOUBLE_STUBS_H 9 | #define CTYPES_LDOUBLE_STUBS_H 10 | 11 | #include 12 | 13 | extern value ctypes_copy_ldouble(long double u); 14 | extern long double ctypes_ldouble_val(value); 15 | extern value ctypes_ldouble_of_float(value a); 16 | extern value ctypes_ldouble_to_float(value a); 17 | 18 | extern value ctypes_copy_ldouble_complex(long double _Complex u); 19 | extern long double _Complex ctypes_ldouble_complex_val(value); 20 | extern value ctypes_ldouble_complex_make(value r, value i); 21 | extern value ctypes_ldouble_complex_real(value v); 22 | extern value ctypes_ldouble_complex_imag(value v); 23 | 24 | #endif /* CTYPES_LDOUBLE_STUBS_H */ 25 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_managed_buffer_stubs.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | */ 7 | 8 | #ifndef CTYPES_MANAGED_BUFFER_STUBS_H 9 | #define CTYPES_MANAGED_BUFFER_STUBS_H 10 | 11 | #include 12 | 13 | /* copy_bytes : void * -> size_t -> managed_buffer */ 14 | extern value ctypes_copy_bytes(void *, size_t); 15 | 16 | /* allocate : int -> int -> managed_buffer */ 17 | extern value ctypes_allocate(value count, value size); 18 | 19 | /* block_address : managed_buffer -> immediate_pointer */ 20 | extern value ctypes_block_address(value managed_buffer); 21 | 22 | /* CTYPES_FROM_FAT_PTR : _ Ctypes_ptr.Fat.t -> void * */ 23 | 24 | 25 | #endif /* CTYPES_MANAGED_BUFFER_STUBS_H */ 26 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_memory_stubs.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stubs for reading and writing memory. *) 9 | 10 | open Ctypes_ptr 11 | 12 | (* A reference, managed by the garbage collector, to a region of memory in the 13 | C heap. *) 14 | type managed_buffer 15 | 16 | (* Allocate a region of stable, zeroed memory managed by a custom block. *) 17 | external allocate : int -> int -> managed_buffer 18 | = "ctypes_allocate" 19 | 20 | (* Obtain the address of the managed block. *) 21 | external block_address : managed_buffer -> voidp 22 | = "ctypes_block_address" 23 | 24 | (* Read a C value from a block of memory *) 25 | external read : 'a Ctypes_primitive_types.prim -> _ Fat.t -> 'a 26 | = "ctypes_read" 27 | 28 | (* Write a C value to a block of memory *) 29 | external write : 'a Ctypes_primitive_types.prim -> 'a -> _ Fat.t -> unit 30 | = "ctypes_write" [@@noalloc] 31 | 32 | module Pointer = 33 | struct 34 | external read : _ Fat.t -> voidp 35 | = "ctypes_read_pointer" 36 | 37 | external write : _ Fat.t -> _ Fat.t -> unit 38 | = "ctypes_write_pointer" 39 | end 40 | 41 | (* Copy [size] bytes from [src] to [dst]. *) 42 | external memcpy : dst:_ Fat.t -> src:_ Fat.t -> size:int -> unit 43 | = "ctypes_memcpy" 44 | 45 | (* Read a fixed length OCaml string from memory *) 46 | external string_of_array : _ Fat.t -> len:int -> string 47 | = "ctypes_string_of_array" 48 | 49 | (* Do nothing, concealing from the optimizer that nothing is being done. *) 50 | external use_value : 'a -> unit 51 | = "ctypes_use" [@@noalloc] 52 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_primitive_types.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Representation of primitive C types. 9 | 10 | Internal representation, not for public use. *) 11 | 12 | open Unsigned 13 | open Signed 14 | 15 | type _ prim = 16 | | Char : char prim 17 | | Schar : int prim 18 | | Uchar : uchar prim 19 | | Bool : bool prim 20 | | Short : int prim 21 | | Int : int prim 22 | | Long : long prim 23 | | Llong : llong prim 24 | | Ushort : ushort prim 25 | | Sint : sint prim 26 | | Uint : uint prim 27 | | Ulong : ulong prim 28 | | Ullong : ullong prim 29 | | Size_t : size_t prim 30 | | Int8_t : int prim 31 | | Int16_t : int prim 32 | | Int32_t : int32 prim 33 | | Int64_t : int64 prim 34 | | Uint8_t : uint8 prim 35 | | Uint16_t : uint16 prim 36 | | Uint32_t : uint32 prim 37 | | Uint64_t : uint64 prim 38 | | Camlint : int prim 39 | | Nativeint : nativeint prim 40 | | Float : float prim 41 | | Double : float prim 42 | | LDouble : LDouble.t prim 43 | | Complex32 : Complex.t prim 44 | | Complex64 : Complex.t prim 45 | | Complexld : ComplexL.t prim 46 | 47 | type _ ml_prim = 48 | | ML_char : char ml_prim 49 | | ML_complex : Complex.t ml_prim 50 | | ML_complexld : ComplexL.t ml_prim 51 | | ML_float : float ml_prim 52 | | ML_ldouble : LDouble.t ml_prim 53 | | ML_int : int ml_prim 54 | | ML_int32 : int32 ml_prim 55 | | ML_int64 : int64 ml_prim 56 | | ML_llong : llong ml_prim 57 | | ML_long : long ml_prim 58 | | ML_sint : sint ml_prim 59 | | ML_nativeint : nativeint ml_prim 60 | | ML_size_t : size_t ml_prim 61 | | ML_uchar : uchar ml_prim 62 | | ML_bool : bool ml_prim 63 | | ML_uint : uint ml_prim 64 | | ML_uint16 : uint16 ml_prim 65 | | ML_uint32 : uint32 ml_prim 66 | | ML_uint64 : uint64 ml_prim 67 | | ML_uint8 : uint8 ml_prim 68 | | ML_ullong : ullong ml_prim 69 | | ML_ulong : ulong ml_prim 70 | | ML_ushort : ushort ml_prim 71 | 72 | val ml_prim : 'a prim -> 'a ml_prim 73 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_raw_pointer.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | */ 7 | 8 | #ifndef CTYPES_RAW_POINTER_STUBS_H 9 | #define CTYPES_RAW_POINTER_STUBS_H 10 | 11 | #include 12 | #include 13 | #include 14 | 15 | #define CTYPES_FROM_PTR(P) caml_copy_nativeint((intptr_t)P) 16 | #define CTYPES_TO_PTR(I) ((void *)Nativeint_val(I)) 17 | 18 | /* CTYPES_ADDR_OF_FATPTR : _ Ctypes_ptr.Fat.t -> void * */ 19 | #define CTYPES_ADDR_OF_FATPTR(P) CTYPES_TO_PTR(Field(P, 1)) 20 | 21 | #endif /* CTYPES_RAW_POINTER_STUBS_H */ 22 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_roots.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "ctypes_raw_pointer.h" 4 | 5 | /* 'a -> voidp */ 6 | value ctypes_caml_roots_create(value v) 7 | { 8 | value *p = caml_stat_alloc(sizeof *p); 9 | *p = v; 10 | caml_register_generational_global_root(p); 11 | return CTYPES_FROM_PTR(p); 12 | } 13 | 14 | /* voidp -> 'a -> unit */ 15 | value ctypes_caml_roots_set(value p_, value v) 16 | { 17 | value *p = CTYPES_TO_PTR(p_); 18 | caml_modify_generational_global_root(p, v); 19 | return Val_unit; 20 | } 21 | 22 | /* voidp -> 'a */ 23 | value ctypes_caml_roots_get(value p_) 24 | { 25 | value *p = CTYPES_TO_PTR(p_); 26 | return *p; 27 | } 28 | 29 | /* voidp -> unit */ 30 | value ctypes_caml_roots_release(value p_) 31 | { 32 | value *p = CTYPES_TO_PTR(p_); 33 | caml_remove_generational_global_root(p); 34 | caml_stat_free(p); 35 | return Val_unit; 36 | } 37 | 38 | /* 'a -> unit */ 39 | value ctypes_use(value v) 40 | { 41 | return Val_unit; 42 | } 43 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_roots_stubs.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | external root : 'a -> Ctypes_ptr.voidp = 9 | "ctypes_caml_roots_create" 10 | 11 | external set : Ctypes_ptr.voidp -> 'a -> unit = 12 | "ctypes_caml_roots_set" 13 | 14 | external get : Ctypes_ptr.voidp -> 'a = 15 | "ctypes_caml_roots_get" 16 | 17 | external release : Ctypes_ptr.voidp -> unit = 18 | "ctypes_caml_roots_release" 19 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_std_view_stubs.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stubs for standard views. *) 9 | 10 | (* Convert a C string to an OCaml string *) 11 | external string_of_cstring : (_, char Ctypes_static.typ) Ctypes_ptr.Fat.t -> string 12 | = "ctypes_string_of_cstring" 13 | 14 | (* Convert an OCaml string to a C string *) 15 | external cstring_of_string : string -> Ctypes_memory_stubs.managed_buffer 16 | = "ctypes_cstring_of_string" 17 | 18 | (* Size information for uintptr_t *) 19 | external uintptr_t_size : unit -> int = "integers_uintptr_t_size" 20 | 21 | (* Size information for uintptr_t *) 22 | external intptr_t_size : unit -> int = "integers_intptr_t_size" 23 | 24 | (* Size information for ptrdiff_t *) 25 | external ptrdiff_t_size : unit -> int = "integers_ptrdiff_t_size" 26 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_structs.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes_static 9 | 10 | module type S = 11 | sig 12 | type (_, _) field 13 | val field : 't typ -> string -> 'a typ -> 14 | ('a, (('s, [<`Struct | `Union]) structured as 't)) field 15 | val seal : (_, [< `Struct | `Union]) Ctypes_static.structured Ctypes_static.typ -> unit 16 | end 17 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_structs.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes_static 9 | 10 | module type S = 11 | sig 12 | type (_, _) field 13 | val field : 't typ -> string -> 'a typ -> 14 | ('a, (('s, [<`Struct | `Union]) structured as 't)) field 15 | val seal : (_, [< `Struct | `Union]) Ctypes_static.structured Ctypes_static.typ -> unit 16 | end 17 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_structs_computed.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (** Structs and unions whose layouts are computed from the sizes and alignment 9 | requirements of the constituent field types. *) 10 | 11 | include Ctypes_structs.S 12 | with type ('a, 's) field := ('a, 's) Ctypes_static.field 13 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_type_info_stubs.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | */ 7 | 8 | #ifndef CTYPES_TYPE_INFO_STUBS_H 9 | #define CTYPES_TYPE_INFO_STUBS_H 10 | 11 | #include 12 | 13 | /* Read a C value from a block of memory */ 14 | /* read : 'a prim -> raw_pointer -> 'a */ 15 | extern value ctypes_read(value ctype, value buffer); 16 | 17 | /* Write a C value to a block of memory */ 18 | /* write : 'a prim -> 'a -> raw_pointer -> unit */ 19 | extern value ctypes_write(value ctype, value v, value buffer); 20 | 21 | #endif /* CTYPES_TYPE_INFO_STUBS_H */ 22 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_type_printing.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes_static 9 | 10 | (* The format context affects the formatting of pointer, struct and union 11 | types. There are three printing contexts: *) 12 | type format_context = [ 13 | (* In the top-level context struct and union types are printed in full, with 14 | member lists. Pointer types are unparenthesized; for example, 15 | pointer-to-void is printed as "void *", not as "void ( * )". *) 16 | | `toplevel 17 | (* In the array context, struct and union types are printed in abbreviated 18 | form, which consists of just a keyword and the tag name. Pointer types are 19 | parenthesized; for example, pointer-to-array-of-int is printed as 20 | "int ( * )[]", not as "int *[]". *) 21 | | `array 22 | (* In the non-array context, struct and union types are printed in abbreviated 23 | form and pointer types are unparenthesized. *) 24 | | `nonarray] 25 | 26 | val format_name : ?name:string -> Format.formatter -> unit 27 | 28 | val format_typ' : 'a Ctypes_static.typ -> (format_context -> Format.formatter -> unit) -> 29 | format_context -> Format.formatter -> unit 30 | 31 | val format_typ : ?name:string -> Format.formatter -> 'a typ -> unit 32 | 33 | val format_fn' : 'a fn -> (Format.formatter -> unit) -> Format.formatter -> unit 34 | 35 | val format_fn : ?name:string -> Format.formatter -> 'a fn -> unit 36 | 37 | val string_of_typ : ?name:string -> 'a typ -> string 38 | 39 | val string_of_fn : ?name:string -> 'a fn -> string 40 | -------------------------------------------------------------------------------- /src/ctypes/ctypes_value_printing_stubs.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stubs for formatting C values. *) 9 | 10 | (* Return a string representation of a C value *) 11 | external string_of_prim : 'a Ctypes_primitive_types.prim -> 'a -> string 12 | = "ctypes_string_of_prim" 13 | 14 | external string_of_pointer : _ Ctypes_ptr.Fat.t -> string 15 | = "ctypes_string_of_pointer" 16 | -------------------------------------------------------------------------------- /src/ctypes/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (with-stdout-to 3 | ctypes_primitives.ml 4 | (run ../configure/gen_c_primitives.exe))) 5 | 6 | (rule 7 | (deps 8 | (:header %{lib:integers:ocaml_integers.h})) 9 | (target ocaml_integers.h) 10 | (action 11 | (copy %{header} %{target}))) 12 | 13 | (library 14 | (name ctypes) 15 | (public_name ctypes) 16 | (wrapped false) 17 | (libraries integers bigarray) 18 | (modules_without_implementation ctypes_types) 19 | (instrumentation 20 | (backend bisect_ppx)) 21 | (install_c_headers 22 | ctypes_raw_pointer 23 | ctypes_primitives 24 | ctypes_cstubs_internals 25 | ctypes_managed_buffer_stubs 26 | ctypes_complex_compatibility 27 | cstubs_internals 28 | ctypes_ldouble_stubs 29 | ctypes_complex_stubs 30 | ctypes_type_info_stubs 31 | ocaml_integers) 32 | (foreign_stubs 33 | (language c) 34 | (names 35 | complex_stubs 36 | ctypes_bigarrays 37 | ctypes_roots 38 | ldouble_stubs 39 | managed_buffer_stubs 40 | posix_types_stubs 41 | raw_pointer_stubs 42 | type_info_stubs))) 43 | -------------------------------------------------------------------------------- /src/ctypes/posixTypes.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes 9 | 10 | (** Some POSIX types. *) 11 | 12 | (* arithmetic types from *) 13 | (** {2 POSIX arithmetic types} *) 14 | 15 | module Dev : Unsigned.S 16 | module Ino : Unsigned.S 17 | module Mode : Unsigned.S 18 | module Nlink : Unsigned.S 19 | module Off : Signed.S 20 | module Pid : Signed.S 21 | module Ssize : Signed.S 22 | module Time : Unsigned.S 23 | 24 | type clock_t 25 | type dev_t = Dev.t 26 | type ino_t = Ino.t 27 | type mode_t = Mode.t 28 | type nlink_t = Nlink.t 29 | type off_t = Off.t 30 | type pid_t = Pid.t 31 | type size_t = Unsigned.size_t 32 | type ssize_t = Ssize.t 33 | type time_t = Time.t 34 | type useconds_t 35 | 36 | (** {3 Values representing POSIX arithmetic types} *) 37 | 38 | val clock_t : clock_t typ 39 | val dev_t : dev_t typ 40 | val ino_t : ino_t typ 41 | val mode_t : mode_t typ 42 | val nlink_t : nlink_t typ 43 | val off_t : off_t typ 44 | val pid_t : pid_t typ 45 | val size_t : size_t typ 46 | val ssize_t : ssize_t typ 47 | val time_t : time_t typ 48 | val useconds_t : useconds_t typ 49 | 50 | (* non-arithmetic types from *) 51 | (** {2 POSIX non-arithmetic types} *) 52 | 53 | type sigset_t 54 | 55 | (** {3 Values representing POSIX non-arithmetic types} *) 56 | 57 | val sigset_t : sigset_t typ 58 | -------------------------------------------------------------------------------- /src/ctypes/raw_pointer_stubs.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | */ 7 | 8 | #include 9 | 10 | #include 11 | #include 12 | 13 | #include "ctypes_managed_buffer_stubs.h" 14 | #include "ctypes_type_info_stubs.h" 15 | #include "ctypes_raw_pointer.h" 16 | 17 | /* memcpy : dst:fat_pointer -> src:fat_pointer -> size:int -> unit */ 18 | value ctypes_memcpy(value dst, value src, value size) 19 | { 20 | CAMLparam3(dst, src, size); 21 | memcpy(CTYPES_ADDR_OF_FATPTR(dst), CTYPES_ADDR_OF_FATPTR(src), Long_val(size)); 22 | CAMLreturn(Val_unit); 23 | } 24 | 25 | 26 | /* string_of_cstring : raw_ptr -> int -> string */ 27 | value ctypes_string_of_cstring(value p) 28 | { 29 | return caml_copy_string(CTYPES_ADDR_OF_FATPTR(p)); 30 | } 31 | 32 | 33 | /* string_of_array : fat_ptr -> len:int -> string */ 34 | value ctypes_string_of_array(value p, value vlen) 35 | { 36 | CAMLparam2(p, vlen); 37 | CAMLlocal1(dst); 38 | intnat len = Long_val(vlen); 39 | if (len < 0) 40 | caml_invalid_argument("ctypes_string_of_array"); 41 | dst = caml_alloc_string(len); 42 | memcpy((char *)String_val(dst), CTYPES_ADDR_OF_FATPTR(p), len); 43 | CAMLreturn(dst); 44 | } 45 | 46 | 47 | /* cstring_of_string : string -> managed_buffer */ 48 | value ctypes_cstring_of_string(value s) 49 | { 50 | CAMLparam1(s); 51 | CAMLlocal1(buffer); 52 | size_t len = caml_string_length(s); 53 | buffer = ctypes_allocate(Val_int(1), Val_long(len + 1)); 54 | char *dst = CTYPES_TO_PTR(ctypes_block_address(buffer)); 55 | const char *ss = String_val(s); 56 | memcpy(dst, ss, len); 57 | dst[len] = '\0'; 58 | CAMLreturn(buffer); 59 | } 60 | -------------------------------------------------------------------------------- /tests/bench-micro/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build bench clean 2 | 3 | CFLAGS=-Wall -O2 4 | 5 | CTYPES_INCLUDE=`ocamlfind query ctypes`/.. 6 | 7 | BENCH_MICRO_STUBS=bench_micro_stubs.h bench_micro_lib.c bench_micro_stubs.c 8 | BENCH_MICRO_GENERATED=bench_micro_generated_stubs.c bench_micro_generated.ml 9 | 10 | build: bench_micro 11 | 12 | bench: build 13 | LD_LIBRARY_PATH=. ./bench_micro -ascii -q 10 +time +cycles \ 14 | -clear-columns -no-compactions -v -ci-absolute -all-values \ 15 | -overheads -save > summary.txt 16 | ocaml process_summary.ml summary.txt 17 | gnuplot bench_micro.gnuplot 18 | gnuplot bench_micro_interpreted.gnuplot 19 | 20 | libbench_micro.so: $(BENCH_MICRO_STUBS) 21 | gcc -o libbench_micro.so -shared -fPIC $(CFLAGS) bench_micro_stubs.c 22 | 23 | bench_micro_gen: $(BENCH_MICRO_STUBS) bench_micro_bindings.ml bench_micro_gen.ml 24 | ocamlfind opt -o bench_micro_gen \ 25 | -linkpkg -package ctypes.foreign,ctypes.stubs \ 26 | bench_micro_lib.c bench_micro_stubs.c \ 27 | bench_micro_bindings.ml bench_micro_gen.ml 28 | 29 | bench_micro_generated.ml bench_micro_generated_stubs.c: bench_micro_gen 30 | ./bench_micro_gen 31 | 32 | bench_micro: $(BENCH_MICRO_STUBS) $(BENCH_MICRO_GENERATED) libbench_micro.so bench_micro_bindings.ml bench_micro.ml 33 | ocamlfind opt -o bench_micro $(patsubst %,-ccopt %,$(CFLAGS)) \ 34 | -cclib -lbench_micro -cclib -L. \ 35 | -thread -linkpkg -I $(CTYPES_INCLUDE) \ 36 | -package ctypes.foreign,ctypes.stubs,core,core_bench \ 37 | bench_micro_lib.c bench_micro_stubs.c \ 38 | bench_micro_generated_stubs.c \ 39 | bench_micro_bindings.ml bench_micro_generated.ml bench_micro.ml 40 | 41 | clean: 42 | rm -f bench_micro bench_micro_gen libbench_micro.so 43 | rm -f bench_micro_generated.ml bench_micro_generated_stubs.c 44 | rm -f bench_micro.eps bench_micro_interpreted.eps 45 | rm -f *.o *.cmo *.cmx *.cmi 46 | -------------------------------------------------------------------------------- /tests/bench-micro/bench_micro.gnuplot: -------------------------------------------------------------------------------- 1 | set terminal eps 2 | set output 'bench_micro.eps' 3 | 4 | set key left top 5 | 6 | set xlabel "Arity" 7 | 8 | set autoscale 9 | set yrange [0:] 10 | 11 | set ylabel "Time (ns)" 12 | 13 | #set title "Mean FFI Call Latency by Arity" 14 | 15 | set style data linespoints 16 | 17 | plot "staged_functor.txt" using 1:2 title "Cmeleon Staged", \ 18 | "traditional.txt" using 1:2 title "OCaml Manual", \ 19 | "cowboy.txt" using 1:2 title "OCaml Expert" 20 | -------------------------------------------------------------------------------- /tests/bench-micro/bench_micro_gen.ml: -------------------------------------------------------------------------------- 1 | let with_formatter ~path f = 2 | let chan = open_out path in 3 | f Format.(formatter_of_out_channel chan); 4 | close_out chan 5 | ;; 6 | 7 | with_formatter 8 | ~path:"bench_micro_generated_stubs.c" 9 | (fun fmt -> 10 | Format.fprintf fmt "#include \"bench_micro_stubs.h\"\n\n"; 11 | Cstubs.write_c fmt ~prefix:"bench_micro" (module Bench_micro_bindings.Make)); 12 | 13 | with_formatter 14 | ~path:"bench_micro_generated.ml" 15 | (fun fmt -> 16 | Cstubs.write_ml fmt ~prefix:"bench_micro" (module Bench_micro_bindings.Make)) 17 | -------------------------------------------------------------------------------- /tests/bench-micro/bench_micro_interpreted.gnuplot: -------------------------------------------------------------------------------- 1 | set terminal eps 2 | set output 'bench_micro_interpreted.eps' 3 | 4 | set key left top 5 | 6 | set xlabel "Arity" 7 | 8 | set autoscale 9 | set yrange [0:] 10 | 11 | set ylabel "Time (ns)" 12 | 13 | # set title "Mean FFI Call Latency by Arity" 14 | 15 | set style data linespoints 16 | 17 | plot "interpreted_shared.txt" using 1:2 title "Cmeleon libffi Interpreted", \ 18 | "traditional.txt" using 1:2 title "OCaml Manual" 19 | -------------------------------------------------------------------------------- /tests/bench-micro/bench_micro_lib.c: -------------------------------------------------------------------------------- 1 | #include "bench_micro_stubs.h" 2 | 3 | int f_i0() { return 0; } 4 | int f_i1(int i0) { return i0; } 5 | int f_i2(int i0, int i1) { return i1; } 6 | int f_i3(int i0, int i1, int i2) { return i2; } 7 | int f_i4(int i0, int i1, int i2, int i3) { return i3; } 8 | int f_i5(int i0, int i1, int i2, int i3, int i4) { return i4; } 9 | int f_i6(int i0, int i1, int i2, int i3, int i4, int i5) { return i5; } 10 | int f_i7(int i0, int i1, int i2, int i3, int i4, int i5, int i6) { return i6; } 11 | int f_i8(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7) { 12 | return i7; 13 | } 14 | int f_i9(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8) 15 | { 16 | return i8; 17 | } 18 | int f_i10(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9) 19 | { 20 | return i9; 21 | } 22 | int f_i11(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10) 23 | { 24 | return i10; 25 | } 26 | int f_i12(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10, int i11) 27 | { 28 | return i11; 29 | } 30 | int f_i13(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10, int i11, int i12) 31 | { 32 | return i12; 33 | } 34 | int f_i14(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10, int i11, int i12, int i13) 35 | { 36 | return i13; 37 | } 38 | int f_i15(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10, int i11, int i12, int i13, int i14) 39 | { 40 | return i14; 41 | } 42 | -------------------------------------------------------------------------------- /tests/bench-micro/bench_micro_stubs.h: -------------------------------------------------------------------------------- 1 | 2 | int f_i0 (); 3 | int f_i1 (int i0); 4 | int f_i2 (int i0, int i1); 5 | int f_i3 (int i0, int i1, int i2); 6 | int f_i4 (int i0, int i1, int i2, int i3); 7 | int f_i5 (int i0, int i1, int i2, int i3, int i4); 8 | int f_i6 (int i0, int i1, int i2, int i3, int i4, int i5); 9 | int f_i7 (int i0, int i1, int i2, int i3, int i4, int i5, int i6); 10 | int f_i8 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7); 11 | int f_i9 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8); 12 | int f_i10 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9); 13 | int f_i11 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10); 14 | int f_i12 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10, int i11); 15 | int f_i13 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10, int i11, int i12); 16 | int f_i14 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10, int i11, int i12, int i13); 17 | int f_i15 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10, int i11, int i12, int i13, int i14); 18 | 19 | -------------------------------------------------------------------------------- /tests/clib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_functions) 3 | (install_c_headers test_functions) 4 | (foreign_stubs 5 | (language c) 6 | (names test_functions)) 7 | (c_library_flags -pthread) 8 | (libraries ctypes)) 9 | 10 | (rule 11 | (target clib%{ext_dll}) 12 | (deps 13 | (source_tree ../../src/ctypes) 14 | test_functions.h) 15 | (action 16 | (run 17 | %{cc} 18 | -I 19 | ../../src/ctypes 20 | -I 21 | %{ocaml_where} 22 | -o 23 | %{target} 24 | -shared 25 | %{dep:test_functions.c}))) 26 | -------------------------------------------------------------------------------- /tests/config/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test_config) 3 | (libraries dune.configurator)) 4 | 5 | (rule 6 | (targets test-cflags) 7 | (deps 8 | test_config.exe 9 | %{lib:ctypes:cstubs_internals.h} 10 | %{lib:ctypes:ctypes_complex_compatibility.h} 11 | %{lib:ctypes:ctypes_complex_stubs.h} 12 | %{lib:ctypes:ctypes_cstubs_internals.h} 13 | %{lib:ctypes:ctypes_ldouble_stubs.h} 14 | %{lib:ctypes:ctypes_managed_buffer_stubs.h} 15 | %{lib:ctypes:ctypes_primitives.h} 16 | %{lib:ctypes:ctypes_raw_pointer.h} 17 | %{lib:ctypes:ctypes_type_info_stubs.h}) 18 | (action 19 | (run 20 | %{exe:test_config.exe} 21 | -integers-dir 22 | %{lib:integers:ocaml_integers.h} 23 | -ctypes-dir 24 | %{lib:ctypes:ctypes_cstubs_internals.h}))) 25 | -------------------------------------------------------------------------------- /tests/config/test_config.ml: -------------------------------------------------------------------------------- 1 | module C = Configurator.V1 2 | 3 | let () = 4 | let ifile = ref "" in 5 | let cfile = ref "" in 6 | let args = [ 7 | "-integers-dir", Arg.Set_string ifile, "location of ocaml_integers.h"; 8 | "-ctypes-dir", Arg.Set_string cfile, "location of ctypes_cstubs_internals.h"] in 9 | C.main ~args ~name:"ctypes-tests" (fun _c -> 10 | let idir = ["-I";Filename.dirname !ifile] in 11 | let cdir = ["-I";Filename.dirname !cfile] in 12 | C.Flags.write_lines "test-cflags" (idir @ cdir) 13 | ) 14 | -------------------------------------------------------------------------------- /tests/flags/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (with-stdout-to 3 | link-flags.sexp 4 | (run ./gen.exe))) 5 | 6 | (executable 7 | (name gen)) 8 | -------------------------------------------------------------------------------- /tests/flags/gen.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | let ocaml_version_str = Sys.ocaml_version in 3 | let ocaml_version = 4 | Scanf.sscanf ocaml_version_str "%u.%u" (fun a b -> (a, b)) 5 | in 6 | if ocaml_version >= (4, 6) then 7 | print_endline ":standard" 8 | else 9 | print_endline "(:standard -ccopt -Wl,-E)" 10 | -------------------------------------------------------------------------------- /tests/flags/gen.mli: -------------------------------------------------------------------------------- 1 | (* empty *) 2 | -------------------------------------------------------------------------------- /tests/test-alignment/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (package ctypes-foreign) 3 | (name test_alignment) 4 | (libraries ounit2 ctypes ctypes-foreign)) 5 | -------------------------------------------------------------------------------- /tests/test-arrays/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_array) 3 | (package ctypes-foreign) 4 | (deps ../clib/clib%{ext_dll}) 5 | (link_flags 6 | (:include ../flags/link-flags.sexp)) 7 | (libraries 8 | ounit2 9 | ctypes 10 | ctypes.stubs 11 | ctypes-foreign 12 | test_arrays_stubs 13 | test_arrays_bindings 14 | tests_common)) 15 | -------------------------------------------------------------------------------- /tests/test-arrays/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the arrays tests. *) 9 | 10 | let () = Tests_common.run Sys.argv (module Functions.Stubs) 11 | -------------------------------------------------------------------------------- /tests/test-arrays/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_arrays_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_arrays_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-arrays/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_arrays_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-arrays/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the arrays tests. *) 9 | 10 | open Ctypes 11 | 12 | module Stubs (F: Ctypes.FOREIGN) = 13 | struct 14 | open F 15 | 16 | (* union u { 17 | int i; 18 | double d; 19 | } 20 | *) 21 | type number 22 | let u : number union typ = union "number" 23 | let (-:) ty label = field u label ty 24 | let i = int -: "i" 25 | let d = double -: "d" 26 | let () = seal u 27 | 28 | (* struct s { 29 | char tag; 30 | union u data; 31 | } 32 | *) 33 | type tagged 34 | let s : tagged structure typ = structure "tagged" 35 | let (-:) ty label = field s label ty 36 | let tag = char -: "tag" 37 | let data = u -: "num" 38 | let () = seal s 39 | 40 | let accepts_pointer_to_array_of_structs = 41 | foreign "accepts_pointer_to_array_of_structs" 42 | (ptr (array 5 s) @-> returning double) 43 | end 44 | -------------------------------------------------------------------------------- /tests/test-bigarrays/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_bigarrays) 3 | (package ctypes-foreign) 4 | (deps ../clib/clib%{ext_dll}) 5 | (link_flags 6 | (:include ../flags/link-flags.sexp)) 7 | (libraries 8 | ounit2 9 | ctypes 10 | ctypes.stubs 11 | ctypes-foreign 12 | test_bigarrays_stubs 13 | test_bigarrays_bindings 14 | tests_common)) 15 | -------------------------------------------------------------------------------- /tests/test-bigarrays/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the bigarrays tests. *) 9 | 10 | let () = Tests_common.run Sys.argv (module Functions.Stubs) 11 | -------------------------------------------------------------------------------- /tests/test-bigarrays/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_bigarrays_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_bigarrays_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-bigarrays/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_bigarrays_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-bigarrays/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the bigarrays tests. *) 9 | 10 | open Ctypes 11 | 12 | module Stubs (F: Ctypes.FOREIGN) = 13 | struct 14 | open F 15 | 16 | let matrix_mul = foreign "matrix_mul" 17 | (int @-> int @-> int @-> 18 | ptr double @-> ptr double @-> ptr double @-> 19 | returning void) 20 | 21 | let matrix_transpose = foreign "matrix_transpose" 22 | (int @-> int @-> ptr double @-> returning (ptr double)) 23 | end 24 | -------------------------------------------------------------------------------- /tests/test-bools/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_bools) 3 | (package ctypes-foreign) 4 | (deps ../clib/clib%{ext_dll}) 5 | (link_flags 6 | (:include ../flags/link-flags.sexp)) 7 | (libraries 8 | ounit2 9 | ctypes 10 | ctypes.stubs 11 | ctypes-foreign 12 | test_bools_stubs 13 | test_bools_bindings 14 | tests_common)) 15 | -------------------------------------------------------------------------------- /tests/test-bools/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the bool number tests. *) 9 | 10 | let () = Tests_common.run Sys.argv (module Functions.Common) 11 | -------------------------------------------------------------------------------- /tests/test-bools/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_bools_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_bools_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-bools/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_bools_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-bools/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the bool tests. *) 9 | 10 | open Ctypes 11 | 12 | (* These functions can be bound either dynamically using Foreign or statically 13 | using stub generation. *) 14 | module Common(F : Ctypes.FOREIGN) = 15 | struct 16 | let bool_and = F.(foreign "bool_and" (bool @-> bool @-> returning bool)) 17 | end 18 | -------------------------------------------------------------------------------- /tests/test-bools/test_bools.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open OUnit2 9 | 10 | let _ = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) 11 | 12 | module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a 13 | and type 'a return = 'a) = 14 | struct 15 | module M = Functions.Common(S) 16 | 17 | (* 18 | Test passing bool values. 19 | *) 20 | let test_passing_bools _ = 21 | begin 22 | assert_equal false (M.bool_and false false); 23 | assert_equal false (M.bool_and false true); 24 | assert_equal false (M.bool_and true false); 25 | assert_equal true (M.bool_and true true); 26 | end 27 | end 28 | 29 | 30 | module Foreign_tests = Common_tests(Tests_common.Foreign_binder) 31 | module Stub_tests = Common_tests(Generated_bindings) 32 | 33 | 34 | let suite = "Bool tests" >::: 35 | ["passing bools (foreign)" 36 | >:: Foreign_tests.test_passing_bools; 37 | 38 | "passing bools (stubs)" 39 | >:: Stub_tests.test_passing_bools; 40 | ] 41 | 42 | 43 | let _ = 44 | run_test_tt_main suite 45 | -------------------------------------------------------------------------------- /tests/test-builtins/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_builtins) 3 | (package ctypes-foreign) 4 | (libraries 5 | ounit2 6 | ctypes 7 | ctypes.stubs 8 | ctypes-foreign 9 | test_builtins_stubs 10 | test_builtins_bindings 11 | tests_common)) 12 | -------------------------------------------------------------------------------- /tests/test-builtins/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the builtins tests. *) 9 | 10 | let () = Tests_common.run Sys.argv (module Functions.Stubs) 11 | -------------------------------------------------------------------------------- /tests/test-builtins/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_builtins_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_builtins_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-builtins/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_builtins_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-builtins/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the builtins tests. *) 9 | 10 | open Ctypes 11 | 12 | module Stubs (F: Ctypes.FOREIGN) = 13 | struct 14 | open F 15 | 16 | (* *ptr |= value; return *ptr; *) 17 | let __sync_or_and_fetch = foreign "__sync_or_and_fetch" 18 | (ptr uint8_t @-> uint8_t @-> returning uint8_t) 19 | 20 | (* tmp = *ptr; *ptr &= value; return tmp; *) 21 | let __sync_fetch_and_and = foreign "__sync_fetch_and_and" 22 | (ptr uint8_t @-> uint8_t @-> returning uint8_t) 23 | end 24 | -------------------------------------------------------------------------------- /tests/test-builtins/test_builtins.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open OUnit2 9 | open Ctypes 10 | 11 | module Bindings = Functions.Stubs(Generated_bindings) 12 | 13 | (* 14 | Test calling builtins. 15 | *) 16 | let test_calling_builtins _ = 17 | let open Unsigned.UInt8 in 18 | let open Bindings in 19 | let u1 = of_int 0x77 20 | and u2 = of_int 0x8 in 21 | let expected = Infix.(u1 lor u2) in 22 | 23 | let p = allocate uint8_t u1 in 24 | assert (__sync_or_and_fetch p u2 = expected); 25 | assert (!@p = expected); 26 | 27 | p <-@ u1; 28 | assert (__sync_fetch_and_and p u2 = u1); 29 | assert (!@p = Infix.(u1 land u2)) 30 | 31 | let suite = "Builtin tests" >::: 32 | ["calling builtins" 33 | >:: test_calling_builtins; 34 | ] 35 | 36 | 37 | 38 | let _ = 39 | run_test_tt_main suite 40 | -------------------------------------------------------------------------------- /tests/test-callback_lifetime/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_callback_lifetime) 3 | (package ctypes-foreign) 4 | (deps ../clib/clib%{ext_dll}) 5 | (link_flags 6 | (:include ../flags/link-flags.sexp)) 7 | (libraries 8 | ounit2 9 | ctypes 10 | ctypes.stubs 11 | ctypes-foreign 12 | test_callback_lifetimes_stubs 13 | test_callback_lifetimes_bindings 14 | tests_common)) 15 | -------------------------------------------------------------------------------- /tests/test-callback_lifetime/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the callback lifetime tests. *) 9 | 10 | let () = Tests_common.run Sys.argv (module Functions.Stubs) 11 | -------------------------------------------------------------------------------- /tests/test-callback_lifetime/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_callback_lifetimes_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_callback_lifetimes_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-callback_lifetime/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_callback_lifetimes_stubs) 3 | (wrapped false) 4 | (libraries ctypes ctypes-foreign)) 5 | -------------------------------------------------------------------------------- /tests/test-callback_lifetime/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the callback lifetime tests. *) 9 | 10 | open Ctypes 11 | open Foreign 12 | 13 | module Stubs (F: Ctypes.FOREIGN) = 14 | struct 15 | open F 16 | 17 | let callback_type_ptr = funptr Ctypes.(int @-> returning int) 18 | 19 | let store_callback = foreign "store_callback" 20 | (callback_type_ptr @-> returning void) 21 | 22 | let invoke_stored_callback = foreign "invoke_stored_callback" 23 | (int @-> returning int) 24 | 25 | let return_callback = foreign "return_callback" 26 | (callback_type_ptr @-> returning callback_type_ptr) 27 | end 28 | -------------------------------------------------------------------------------- /tests/test-closure-type-promotion/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_closure_type_promotion) 3 | (package ctypes-foreign) 4 | (deps ../clib/clib%{ext_dll}) 5 | (link_flags 6 | (:include ../flags/link-flags.sexp)) 7 | (libraries 8 | ounit2 9 | ctypes 10 | ctypes.stubs 11 | ctypes-foreign 12 | test_closure_type_promotions_stubs 13 | test_closure_type_promotions_bindings 14 | tests_common)) 15 | -------------------------------------------------------------------------------- /tests/test-closure-type-promotion/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the higher order tests. *) 9 | 10 | let () = Tests_common.run Sys.argv (module Functions.Stubs) 11 | -------------------------------------------------------------------------------- /tests/test-closure-type-promotion/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_closure_type_promotions_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_closure_type_promotions_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-closure-type-promotion/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_closure_type_promotions_stubs) 3 | (wrapped false) 4 | (libraries ctypes ctypes-foreign)) 5 | -------------------------------------------------------------------------------- /tests/test-closure-type-promotion/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * This file is distributed under the terms of the MIT License. 3 | * See the file LICENSE for details. 4 | *) 5 | 6 | open Ctypes 7 | open Foreign 8 | 9 | module Stubs (F: Ctypes.FOREIGN) = 10 | struct 11 | open F 12 | let callback_returns_int8_t = foreign "callback_returns_int8_t" 13 | (funptr Ctypes.(void @-> returning int8_t) @-> returning int8_t) 14 | 15 | let callback_returns_int16_t = foreign "callback_returns_int16_t" 16 | (funptr Ctypes.(void @-> returning int16_t) @-> returning int16_t) 17 | 18 | let callback_returns_int32_t = foreign "callback_returns_int32_t" 19 | (funptr Ctypes.(void @-> returning int32_t) @-> returning int32_t) 20 | 21 | let callback_returns_int64_t = foreign "callback_returns_int64_t" 22 | (funptr Ctypes.(void @-> returning int64_t) @-> returning int64_t) 23 | 24 | let callback_returns_uint8_t = foreign "callback_returns_uint8_t" 25 | (funptr Ctypes.(void @-> returning uint8_t) @-> returning uint8_t) 26 | 27 | let callback_returns_uint16_t = foreign "callback_returns_uint16_t" 28 | (funptr Ctypes.(void @-> returning uint16_t) @-> returning uint16_t) 29 | 30 | let callback_returns_uint32_t = foreign "callback_returns_uint32_t" 31 | (funptr Ctypes.(void @-> returning uint32_t) @-> returning uint32_t) 32 | 33 | let callback_returns_uint64_t = foreign "callback_returns_uint64_t" 34 | (funptr Ctypes.(void @-> returning uint64_t) @-> returning uint64_t) 35 | 36 | let callback_returns_float = foreign "callback_returns_float" 37 | (funptr Ctypes.(void @-> returning float) @-> returning float) 38 | 39 | let callback_returns_double = foreign "callback_returns_double" 40 | (funptr Ctypes.(void @-> returning double) @-> returning double) 41 | 42 | let callback_returns_bool = foreign "callback_returns_bool" 43 | (funptr Ctypes.(void @-> returning bool) @-> returning bool) 44 | 45 | end 46 | -------------------------------------------------------------------------------- /tests/test-coercions/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_coercions) 3 | (package ctypes-foreign) 4 | (libraries 5 | ounit2 6 | ctypes 7 | ctypes.stubs 8 | ctypes-foreign 9 | test_coercionss_stubs 10 | test_coercionss_bindings 11 | tests_common)) 12 | -------------------------------------------------------------------------------- /tests/test-coercions/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the coercions tests. *) 9 | 10 | let cheader = "#include " 11 | 12 | let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) 13 | -------------------------------------------------------------------------------- /tests/test-coercions/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_coercionss_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_coercionss_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-coercions/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_coercionss_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-coercions/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the coercion tests. *) 9 | 10 | open Ctypes 11 | 12 | module Stubs (F: Ctypes.FOREIGN) = 13 | struct 14 | open F 15 | 16 | let memchr = foreign "memchr" 17 | (ptr void @-> int @-> size_t @-> returning (ptr void)) 18 | end 19 | -------------------------------------------------------------------------------- /tests/test-complex/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_complex) 3 | (package ctypes-foreign) 4 | (deps ../clib/clib%{ext_dll}) 5 | (link_flags 6 | (:include ../flags/link-flags.sexp)) 7 | (libraries 8 | ounit2 9 | ctypes 10 | ctypes.stubs 11 | ctypes-foreign 12 | test_complexs_stubs 13 | test_complexs_bindings 14 | tests_common)) 15 | -------------------------------------------------------------------------------- /tests/test-complex/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the complex number tests. *) 9 | 10 | let () = Tests_common.run Sys.argv (module Functions.Stubs) 11 | -------------------------------------------------------------------------------- /tests/test-complex/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_complexs_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_complexs_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-complex/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_complexs_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-constants/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets generated_stubs.c) 3 | (action 4 | (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) 5 | 6 | (rule 7 | (targets generated_bindings.ml) 8 | (action 9 | (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_struct_stubs.c) 13 | (action 14 | (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) 15 | 16 | (rule 17 | (targets ml-stub-generator.exe) 18 | (deps 19 | generated_struct_stubs.c 20 | ../clib/test_functions.h 21 | ../config/test-cflags) 22 | (action 23 | (run 24 | %{cc} 25 | %{read-lines:../config/test-cflags} 26 | -I 27 | ../clib 28 | -I 29 | %{ocaml-config:standard_library} 30 | -o 31 | %{targets} 32 | generated_struct_stubs.c))) 33 | 34 | (rule 35 | (targets generated_struct_bindings.ml) 36 | (deps ml-stub-generator.exe) 37 | (action 38 | (with-stdout-to 39 | %{targets} 40 | (run %{deps})))) 41 | 42 | (library 43 | (name test_constants_bindings) 44 | (wrapped false) 45 | (foreign_stubs 46 | (language c) 47 | (names generated_stubs)) 48 | (modules generated_bindings generated_struct_bindings) 49 | (libraries ctypes test_functions)) 50 | 51 | (test 52 | (name test_constants) 53 | (package ctypes-foreign) 54 | (deps ../clib/clib%{ext_dll}) 55 | (modules test_constants) 56 | (libraries 57 | ounit2 58 | ctypes 59 | ctypes.stubs 60 | ctypes-foreign 61 | test_constants_stubs 62 | test_functions 63 | test_constants_bindings 64 | tests_common)) 65 | -------------------------------------------------------------------------------- /tests/test-constants/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the constants tests. *) 9 | 10 | let cheader = "#include \n#include " 11 | 12 | let () = Tests_common.run Sys.argv 13 | ~cheader 14 | ~structs:(module Types.Struct_stubs) 15 | (module functor (S: Cstubs.FOREIGN) -> struct end) 16 | -------------------------------------------------------------------------------- /tests/test-constants/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_constants_stubs tests_common)) 5 | -------------------------------------------------------------------------------- /tests/test-constants/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_constants_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-constants/stubs/types.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | module Struct_stubs(S : Ctypes.TYPE) = 9 | struct 10 | open S 11 | 12 | let _SCHAR_MIN = constant "SCHAR_MIN" schar 13 | let _SCHAR_MAX = constant "SCHAR_MAX" schar 14 | let _UCHAR_MAX = constant "UCHAR_MAX" uchar 15 | let _CHAR_MIN = constant "CHAR_MIN" char 16 | let _CHAR_MAX = constant "CHAR_MAX" char 17 | let _SHRT_MIN = constant "SHRT_MIN" short 18 | let _SHRT_MAX = constant "SHRT_MAX" short 19 | let _USHRT_MAX = constant "USHRT_MAX" ushort 20 | let _INT_MIN = constant "INT_MIN" sint 21 | let _INT_MAX = constant "INT_MAX" sint 22 | let _UINT_MAX = constant "UINT_MAX" uint 23 | let _LONG_MAX = constant "LONG_MAX" long 24 | let _LONG_MIN = constant "LONG_MIN" long 25 | let _ULONG_MAX = constant "ULONG_MAX" ulong 26 | let _LLONG_MAX = constant "LLONG_MAX" llong 27 | let _LLONG_MIN = constant "LLONG_MIN" llong 28 | let _ULLONG_MAX = constant "ULLONG_MAX" ullong 29 | let _INT8_MIN = constant "INT8_MIN" int8_t 30 | let _INT16_MIN = constant "INT16_MIN" int16_t 31 | let _INT32_MIN = constant "INT32_MIN" int32_t 32 | let _INT64_MIN = constant "INT64_MIN" int64_t 33 | let _INT8_MAX = constant "INT8_MAX" int8_t 34 | let _INT16_MAX = constant "INT16_MAX" int16_t 35 | let _INT32_MAX = constant "INT32_MAX" int32_t 36 | let _INT64_MAX = constant "INT64_MAX" int64_t 37 | let _UINT8_MAX = constant "UINT8_MAX" uint8_t 38 | let _UINT16_MAX = constant "UINT16_MAX" uint16_t 39 | let _UINT32_MAX = constant "UINT32_MAX" uint32_t 40 | let _UINT64_MAX = constant "UINT64_MAX" uint64_t 41 | let _SIZE_MAX = constant "SIZE_MAX" size_t 42 | let _true = constant "true" bool 43 | let _false = constant "false" bool 44 | 45 | let i32_inverted = view int32_t 46 | ~read:Int32.neg ~write:Int32.neg 47 | let neg_INT16_MAX = constant "INT16_MAX" i32_inverted 48 | let neg_INT16_MIN = constant "INT16_MIN" i32_inverted 49 | 50 | let _A = constant "A" int 51 | let _B = constant "B" int 52 | let _C = constant "C" int 53 | let _D = constant "D" int 54 | end 55 | -------------------------------------------------------------------------------- /tests/test-cstdlib/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_cstdlib) 3 | (package ctypes-foreign) 4 | (libraries 5 | ounit2 6 | ctypes 7 | ctypes.stubs 8 | ctypes-foreign 9 | test_cstdlib_stubs 10 | test_cstdlib_bindings 11 | tests_common)) 12 | -------------------------------------------------------------------------------- /tests/test-cstdlib/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the C standard library tests. *) 9 | 10 | let cheader = " 11 | #include 12 | #include 13 | #include 14 | " 15 | 16 | let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) 17 | -------------------------------------------------------------------------------- /tests/test-cstdlib/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_cstdlib_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_cstdlib_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-cstdlib/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_cstdlib_stubs) 3 | (wrapped false) 4 | (libraries ctypes ctypes-foreign)) 5 | -------------------------------------------------------------------------------- /tests/test-custom_ops/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_custom_ops) 3 | (libraries ounit2 ctypes)) 4 | -------------------------------------------------------------------------------- /tests/test-enums/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets generated_struct_stubs.c) 3 | (action 4 | (run %{exe:struct-stub-generator/driver.exe} --c-struct-file %{targets}))) 5 | 6 | (rule 7 | (targets struct-stub-generator.exe) 8 | (deps 9 | generated_struct_stubs.c 10 | ../clib/test_functions.h 11 | ../config/test-cflags) 12 | (action 13 | (run 14 | %{cc} 15 | %{read-lines:../config/test-cflags} 16 | -I 17 | ../clib 18 | -I 19 | %{ocaml-config:standard_library} 20 | -o 21 | %{targets} 22 | generated_struct_stubs.c))) 23 | 24 | (rule 25 | (targets generated_stubs.c) 26 | (action 27 | (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) 28 | 29 | (rule 30 | (targets generated_bindings.ml) 31 | (action 32 | (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) 33 | 34 | (library 35 | (name test_enums_generated) 36 | (modules generated_bindings) 37 | (foreign_stubs 38 | (language c) 39 | (names generated_stubs)) 40 | (libraries test_functions) 41 | (wrapped false)) 42 | 43 | (test 44 | (name test_enums) 45 | (modules test_enums) 46 | (package ctypes-foreign) 47 | (libraries ounit2 ctypes test_enums_generated test_enums_stubs)) 48 | -------------------------------------------------------------------------------- /tests/test-enums/struct-stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Struct stub generation driver for the enum tests. *) 9 | 10 | let () = Tests_common.run Sys.argv 11 | ~structs:(module Types.Struct_stubs) 12 | (module functor (X: Cstubs.FOREIGN) -> struct end) 13 | -------------------------------------------------------------------------------- /tests/test-enums/struct-stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_enums_struct_stubs tests_common)) 5 | -------------------------------------------------------------------------------- /tests/test-enums/struct-stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_enums_struct_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-enums/struct-stubs/types.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes 9 | 10 | type fruit = Orange | Apple | Banana | Pear 11 | 12 | module Struct_stubs(S : Ctypes.TYPE) = 13 | struct 14 | open S 15 | 16 | let orange = constant "Orange" int64_t 17 | let apple = constant "Apple" int64_t 18 | let pear = constant "Pear" int64_t 19 | let banana = constant "Banana" int64_t 20 | 21 | let fruit = enum "fruit" [ 22 | Orange , orange ; 23 | Apple , apple ; 24 | Pear , pear ; 25 | Banana , banana ; 26 | ] 27 | 28 | let minus_one = constant "minus_one" int64_t 29 | let plus_one = constant "plus_one" int64_t 30 | 31 | let signed = enum "signed_enum" ~unexpected:(fun _ -> 0) [ 32 | -1, minus_one ; 33 | 1 , plus_one ; 34 | ] 35 | 36 | let fruit_cell : [`fruit_cell] structure typ = structure "fruit_cell" 37 | let frt = field fruit_cell "frt" fruit 38 | let next = field fruit_cell "next" (ptr_opt fruit_cell) 39 | let () = seal fruit_cell 40 | 41 | 42 | let edward = constant "Edward" int64_t 43 | let winnie = constant "Winnie" int64_t 44 | let paddington = constant "Paddington" int64_t 45 | 46 | let bears : [`Edward|`Winnie|`Paddington] typ = enum "bears" [ 47 | `Edward , edward ; 48 | `Winnie , winnie ; 49 | `Paddington , paddington ; 50 | ] 51 | end 52 | -------------------------------------------------------------------------------- /tests/test-enums/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the enum tests. *) 9 | 10 | let () = Tests_common.run Sys.argv (module Functions.Stubs) 11 | -------------------------------------------------------------------------------- /tests/test-enums/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_enums_stubs tests_common)) 5 | -------------------------------------------------------------------------------- /tests/test-enums/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_enums_stubs) 3 | (wrapped false) 4 | (libraries ctypes.stubs test_enums_struct_stubs)) 5 | 6 | (rule 7 | (targets generated_struct_bindings.ml) 8 | (action 9 | (with-stdout-to 10 | %{targets} 11 | (run %{exe:../struct-stub-generator.exe})))) 12 | -------------------------------------------------------------------------------- /tests/test-enums/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the enum tests. *) 9 | 10 | open Ctypes 11 | 12 | (* These functions can only be bound using stub generation, since Foreign 13 | doesn't support passing enums. *) 14 | module Stubs(F : Ctypes.FOREIGN) = 15 | struct 16 | open F 17 | 18 | module T = Types.Struct_stubs(Generated_struct_bindings) 19 | 20 | let classify_integer = foreign "classify_integer" 21 | (int @-> returning T.signed) 22 | 23 | let out_of_range = foreign "out_of_range" 24 | (void @-> returning T.signed) 25 | 26 | let next_fruit = foreign "next_fruit" 27 | (T.fruit @-> returning T.fruit) 28 | end 29 | -------------------------------------------------------------------------------- /tests/test-finalisers/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_finalisers) 3 | (libraries ctypes ounit2)) 4 | -------------------------------------------------------------------------------- /tests/test-foreign-errno/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_errno) 3 | (package ctypes-foreign) 4 | (libraries ounit2 ctypes ctypes-foreign)) 5 | -------------------------------------------------------------------------------- /tests/test-foreign_values/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_foreign_values) 3 | (package ctypes-foreign) 4 | (deps ../clib/clib%{ext_dll}) 5 | (link_flags 6 | (:include ../flags/link-flags.sexp)) 7 | (libraries 8 | ounit2 9 | ctypes 10 | ctypes.stubs 11 | ctypes-foreign 12 | test_foreign_values_stubs 13 | test_foreign_values_bindings 14 | tests_common)) 15 | -------------------------------------------------------------------------------- /tests/test-foreign_values/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the foreign value tests. *) 9 | 10 | let cheader = "extern char **environ;" 11 | 12 | let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) 13 | -------------------------------------------------------------------------------- /tests/test-foreign_values/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_foreign_values_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_foreign_values_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-foreign_values/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_foreign_values_stubs) 3 | (wrapped false) 4 | (libraries ctypes ctypes-foreign)) 5 | -------------------------------------------------------------------------------- /tests/test-foreign_values/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Bindings for the foreign value tests. *) 9 | 10 | open Ctypes 11 | 12 | module Common (F: Ctypes.FOREIGN) = 13 | struct 14 | let s : [`global_struct] structure typ = structure "global_struct" 15 | let (-:) ty label = field s label ty 16 | let len = size_t -: "len" 17 | let str = array 1 char -: "str" 18 | let () = seal s 19 | 20 | let global_struct = F.foreign_value "global_struct" s 21 | 22 | let plus = 23 | F.(foreign_value "plus_callback" 24 | (Foreign.funptr_opt Ctypes.(int @-> int @-> returning int))) 25 | 26 | let sum = F.(foreign "sum_range_with_plus_callback" 27 | (int @-> int @-> returning int)) 28 | 29 | let string_array = F.(foreign_value "string_array" (array 2 string)) 30 | let int_array = F.(foreign_value "int_array" (bigarray array1 5 Bigarray.int32)) 31 | end 32 | 33 | 34 | module Stubs (F: Ctypes.FOREIGN) = 35 | struct 36 | include Common(F) 37 | let environ = F.(foreign_value "environ" (ptr string_opt)) 38 | end 39 | -------------------------------------------------------------------------------- /tests/test-funptrs/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_funptrs) 3 | (package ctypes-foreign) 4 | (link_flags 5 | (:include ../flags/link-flags.sexp)) 6 | (libraries 7 | ounit2 8 | ctypes 9 | ctypes-foreign 10 | test_funptrs_stubs 11 | ctypes.stubs 12 | tests_common 13 | test_funptrs_bindings)) 14 | -------------------------------------------------------------------------------- /tests/test-funptrs/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the foreign value tests. *) 9 | 10 | let cheader = "extern char **environ;" 11 | 12 | let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) 13 | -------------------------------------------------------------------------------- /tests/test-funptrs/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries test_funptrs_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_funptrs_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (flags :standard -w -11) 24 | (libraries ctypes test_functions)) 25 | -------------------------------------------------------------------------------- /tests/test-funptrs/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_funptrs_stubs) 3 | (wrapped false) 4 | (libraries ctypes ctypes-foreign)) 5 | -------------------------------------------------------------------------------- /tests/test-funptrs/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | open Ctypes 2 | 3 | module Callback = (val Foreign.dynamic_funptr (int @-> returning int)) 4 | 5 | module Stubs (F: Ctypes.FOREIGN) = 6 | struct 7 | open F 8 | 9 | let call_dynamic_funptr = foreign "call_dynamic_funptr" 10 | (Callback.t @-> int @-> returning int) 11 | let save_dynamic_funptr = foreign "save_dynamic_funptr" 12 | (Callback.t @-> returning void) 13 | let call_saved_dynamic_funptr = foreign "call_saved_dynamic_funptr" 14 | (int @-> returning int) 15 | let call_dynamic_funptr_opt = foreign "call_dynamic_funptr" 16 | (Callback.t_opt @-> int @-> returning int) 17 | let save_dynamic_funptr_opt = foreign "save_dynamic_funptr" 18 | (Callback.t_opt @-> returning void) 19 | 20 | type simple_closure 21 | let simple_closure : simple_closure structure typ = structure "simple_closure" 22 | let simple_closure_f = field simple_closure "f" Callback.t 23 | let simple_closure_n = field simple_closure "n" int 24 | let () = seal simple_closure 25 | 26 | let call_dynamic_funptr_struct = foreign "call_dynamic_funptr_struct" 27 | (simple_closure @-> returning int) 28 | let call_dynamic_funptr_struct_ptr = foreign "call_dynamic_funptr_struct_ptr" 29 | (ptr simple_closure @-> returning int) 30 | end 31 | -------------------------------------------------------------------------------- /tests/test-higher_order/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_higher_order) 3 | (package ctypes-foreign) 4 | (deps ../clib/clib%{ext_dll}) 5 | (link_flags 6 | (:include ../flags/link-flags.sexp)) 7 | (libraries 8 | ounit2 9 | ctypes 10 | ctypes.stubs 11 | ctypes-foreign 12 | test_higher_order_stubs 13 | test_higher_order_bindings 14 | tests_common)) 15 | -------------------------------------------------------------------------------- /tests/test-higher_order/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the higher order tests. *) 9 | 10 | let () = Tests_common.run Sys.argv (module Functions.Stubs) 11 | -------------------------------------------------------------------------------- /tests/test-higher_order/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_higher_order_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_higher_order_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-higher_order/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_higher_order_stubs) 3 | (wrapped false) 4 | (libraries ctypes ctypes-foreign)) 5 | -------------------------------------------------------------------------------- /tests/test-higher_order/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the higher order tests. *) 9 | 10 | open Ctypes 11 | open Foreign 12 | 13 | module Stubs (F: Ctypes.FOREIGN) = 14 | struct 15 | open F 16 | let higher_order_1 = foreign "higher_order_1" 17 | (funptr Ctypes.(int @-> int @-> returning int) @-> int @-> int @-> 18 | returning int) 19 | 20 | let higher_order_1_static = foreign "higher_order_1" 21 | (static_funptr Ctypes.(int @-> int @-> returning int) @-> int @-> int @-> 22 | returning int) 23 | 24 | let higher_order_3 = foreign "higher_order_3" 25 | (funptr Ctypes.(funptr (int @-> int @-> returning int) @-> 26 | int @-> int @-> returning int) @-> 27 | funptr Ctypes.(int @-> int @-> returning int) @-> 28 | int @-> int @-> returning int) 29 | 30 | let callback_returns_char_a = foreign "callback_returns_char_a" 31 | (funptr Ctypes.(void @-> returning char) @-> returning int) 32 | 33 | let returning_funptr = foreign "returning_funptr" 34 | (int @-> returning (funptr Ctypes.(int @-> int @-> returning int))) 35 | 36 | let returning_funptr_static = foreign "returning_funptr" 37 | (int @-> returning (static_funptr Ctypes.(int @-> int @-> returning int))) 38 | 39 | let callback_returns_funptr = foreign "callback_returns_funptr" 40 | (funptr Ctypes.(int @-> returning (funptr (int @-> returning int))) @-> 41 | int @-> returning int) 42 | 43 | let register_callback = foreign "register_callback" 44 | (funptr Ctypes.(void @-> returning int) @-> returning void) 45 | 46 | let call_registered_callback = foreign "call_registered_callback" 47 | (int @-> int @-> returning void) 48 | end 49 | -------------------------------------------------------------------------------- /tests/test-integers/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_integers) 3 | (package ctypes-foreign) 4 | (deps ../clib/clib%{ext_dll}) 5 | (link_flags 6 | (:include ../flags/link-flags.sexp)) 7 | (libraries 8 | ounit2 9 | ctypes 10 | ctypes.stubs 11 | ctypes-foreign 12 | test_integers_stubs 13 | test_integers_bindings 14 | tests_common)) 15 | -------------------------------------------------------------------------------- /tests/test-integers/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the integer tests. *) 9 | 10 | let () = Tests_common.run Sys.argv (module Functions.Stubs) 11 | -------------------------------------------------------------------------------- /tests/test-integers/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_integers_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_integers_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-integers/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_integers_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-integers/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the integer tests. *) 9 | 10 | open Ctypes 11 | 12 | module Stubs (F: Ctypes.FOREIGN) = 13 | struct 14 | open F 15 | 16 | let max_caml_int = foreign "max_caml_int" 17 | (void @-> returning camlint) 18 | end 19 | -------------------------------------------------------------------------------- /tests/test-integers/test_integers.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open OUnit2 9 | open Ctypes 10 | open Unsigned 11 | 12 | let _ = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) 13 | 14 | module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a 15 | and type 'a return = 'a) = 16 | struct 17 | module M = Functions.Stubs(S) 18 | open M 19 | 20 | (* 21 | Test retrieving max caml ints from C. 22 | *) 23 | let test_max_caml_int _ = 24 | assert_equal max_int (max_caml_int ()) 25 | ~printer:string_of_int 26 | end 27 | 28 | (* 29 | Test UInt64.of_int. 30 | *) 31 | let test_uint64_of_int _ = 32 | begin 33 | assert_equal max_int (UInt64.to_int (UInt64.of_int max_int)) 34 | ~printer:string_of_int 35 | end 36 | 37 | (* 38 | Test storing and reading camlints. 39 | *) 40 | let test_store_caml_int _ = 41 | begin 42 | let p = allocate camlint max_int in 43 | assert_equal max_int !@p 44 | ~printer:string_of_int 45 | end 46 | 47 | 48 | module Foreign_tests = Common_tests(Tests_common.Foreign_binder) 49 | module Stub_tests = Common_tests(Generated_bindings) 50 | 51 | 52 | let suite = "Integer tests" >::: 53 | ["UInt64.of_int" 54 | >:: test_uint64_of_int; 55 | 56 | "max_caml_int (foreign)" 57 | >:: Foreign_tests.test_max_caml_int; 58 | 59 | "max_caml_int (stubs)" 60 | >:: Stub_tests.test_max_caml_int; 61 | 62 | "storing camlint" 63 | >:: test_store_caml_int; 64 | ] 65 | 66 | 67 | 68 | let _ = 69 | run_test_tt_main suite 70 | -------------------------------------------------------------------------------- /tests/test-ldouble/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_ldouble) 3 | (libraries ctypes ounit2)) 4 | -------------------------------------------------------------------------------- /tests/test-lifetime/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_lifetime) 3 | (package ctypes-foreign) 4 | (deps ../clib/clib%{ext_dll}) 5 | (link_flags 6 | (:include ../flags/link-flags.sexp)) 7 | (libraries 8 | ounit2 9 | ctypes 10 | ctypes.stubs 11 | ctypes-foreign 12 | test_lifetime_stubs 13 | test_lifetime_bindings 14 | tests_common)) 15 | -------------------------------------------------------------------------------- /tests/test-lifetime/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the lifetime tests. *) 9 | 10 | let () = Tests_common.run Sys.argv (module Functions.Stubs) 11 | ~concurrency:Cstubs.unlocked 12 | -------------------------------------------------------------------------------- /tests/test-lifetime/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_lifetime_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_lifetime_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-lifetime/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_lifetime_stubs) 3 | (wrapped false) 4 | (libraries ctypes ctypes-foreign)) 5 | -------------------------------------------------------------------------------- /tests/test-lifetime/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the lifetime tests. *) 9 | 10 | open Ctypes 11 | 12 | module Stubs (F: Ctypes.FOREIGN) = 13 | struct 14 | open F 15 | 16 | let check_ones = foreign "check_ones" 17 | (ptr int @-> size_t @-> returning void) 18 | end 19 | -------------------------------------------------------------------------------- /tests/test-lifetime/test_lifetime.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | [@@@warning "-35"] 9 | open OUnit2 10 | open Ctypes 11 | 12 | let _ = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) 13 | 14 | module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a 15 | and type 'a return = 'a) = 16 | struct 17 | module M = Functions.Stubs(S) 18 | open M 19 | 20 | let test_object_lifetime _ = 21 | let iters = 20000 in 22 | let l = [(); (); (); (); (); (); (); (); (); ()] in 23 | let alloc = (fun () -> 24 | for i = 0 to iters do 25 | for i = 0 to 200; do ignore (Array.make 10 ()) done; 26 | ignore (Array.make 1000 ()); 27 | if i mod 1000 = 0 then (Gc.compact ()); 28 | done) in 29 | let allocators = 30 | List.map (Thread.create alloc) l 31 | in 32 | let size = 100 in 33 | let mutate () = 34 | for i = 0 to iters do 35 | check_ones 36 | (CArray.start (CArray.make int ~initial:1 size)) 37 | (Unsigned.Size_t.of_int size); 38 | for i = 0 to 200; do 39 | ignore (Array.make 10 ()) 40 | done; 41 | done 42 | in 43 | let mutators = 44 | List.map (Thread.create mutate) l 45 | in 46 | List.iter Thread.join allocators; 47 | List.iter Thread.join mutators 48 | 49 | end 50 | 51 | module Foreign_tests = Common_tests(Tests_common.Foreign_binder) 52 | module Stub_tests = Common_tests(Generated_bindings) 53 | 54 | let suite = "Lifetime tests" >::: 55 | ["objects persist throughout C calls (foreign)" 56 | >:: Foreign_tests.test_object_lifetime; 57 | 58 | "objects persist throughout C calls (stubs)" 59 | >:: Stub_tests.test_object_lifetime; 60 | ] 61 | 62 | let _ = 63 | run_test_tt_main suite 64 | -------------------------------------------------------------------------------- /tests/test-lwt-jobs/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets generated_stubs.c) 3 | (action 4 | (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) 5 | 6 | (rule 7 | (targets generated_bindings.ml) 8 | (action 9 | (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_struct_stubs.c) 13 | (action 14 | (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) 15 | 16 | (rule 17 | (targets ml-stub-generator.exe) 18 | (deps 19 | generated_struct_stubs.c 20 | ../clib/test_functions.h 21 | ../config/test-cflags) 22 | (action 23 | (run 24 | %{cc} 25 | %{read-lines:../config/test-cflags} 26 | -I 27 | ../clib 28 | -I 29 | %{ocaml-config:standard_library} 30 | -o 31 | %{targets} 32 | generated_struct_stubs.c))) 33 | 34 | (rule 35 | (targets generated_struct_bindings.ml) 36 | (deps ml-stub-generator.exe) 37 | (action 38 | (with-stdout-to 39 | %{targets} 40 | (run %{deps})))) 41 | 42 | (library 43 | (name test_lwt_jobs_bindings) 44 | (wrapped false) 45 | (foreign_stubs 46 | (language c) 47 | (names generated_stubs)) 48 | (modules generated_bindings generated_struct_bindings) 49 | (libraries ctypes test_functions lwt.unix)) 50 | 51 | (test 52 | (name test_lwt_jobs) 53 | (package ctypes-foreign) 54 | (modules test_lwt_jobs) 55 | (action 56 | (run %{test} -runner sequential)) 57 | (libraries 58 | ounit2 59 | ctypes 60 | ctypes.stubs 61 | ctypes-foreign 62 | test_lwt_jobs_stubs 63 | test_functions 64 | test_lwt_jobs_bindings 65 | tests_common)) 66 | -------------------------------------------------------------------------------- /tests/test-lwt-jobs/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the Lwt jobs tests. *) 9 | 10 | let cheader = "#include 11 | #include 12 | #include 13 | #include 14 | " 15 | 16 | let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) 17 | ~structs:(module Types.Struct_stubs) 18 | ~concurrency:Cstubs.lwt_jobs 19 | -------------------------------------------------------------------------------- /tests/test-lwt-jobs/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_lwt_jobs_stubs tests_common)) 5 | -------------------------------------------------------------------------------- /tests/test-lwt-jobs/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_lwt_jobs_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-lwt-jobs/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the Lwt jobs tests. *) 9 | 10 | open Ctypes 11 | 12 | module Stubs (F: Ctypes.FOREIGN) = 13 | struct 14 | open F 15 | 16 | let sqrt = foreign "sqrt" (double @-> returning double) 17 | 18 | let sum_int_array = foreign "sum_int_array" 19 | (ptr int32_t @-> size_t @-> returning int32_t) 20 | 21 | let struct_stat : [`stat] structure typ = structure "stat" 22 | let stat = foreign "stat" 23 | (string @-> ptr struct_stat @-> returning int) 24 | 25 | let sixargs = foreign "sixargs" 26 | (int @-> int @-> int @-> int @-> int @-> int @-> returning int) 27 | 28 | let return_10 = foreign "return_10" 29 | (void @-> returning int) 30 | 31 | let return_void = foreign "return_void" 32 | (ptr int @-> returning void) 33 | end 34 | -------------------------------------------------------------------------------- /tests/test-lwt-jobs/stubs/types.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes 9 | open PosixTypes 10 | 11 | module Struct_stubs(S : Ctypes.TYPE) = 12 | struct 13 | open S 14 | 15 | let ifdir = constant "S_IFDIR" (lift_typ mode_t) 16 | let ifmt = constant "S_IFMT" (lift_typ mode_t) 17 | 18 | let stat : [`stat] structure typ = structure "stat" 19 | let st_mode = field stat "st_mode" (lift_typ mode_t) 20 | let () = seal stat 21 | end 22 | 23 | -------------------------------------------------------------------------------- /tests/test-lwt-preemptive/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets generated_stubs.c) 3 | (action 4 | (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) 5 | 6 | (rule 7 | (targets generated_bindings.ml) 8 | (action 9 | (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_struct_stubs.c) 13 | (action 14 | (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) 15 | 16 | (rule 17 | (targets ml-stub-generator.exe) 18 | (deps 19 | generated_struct_stubs.c 20 | ../clib/test_functions.h 21 | ../config/test-cflags) 22 | (action 23 | (run 24 | %{cc} 25 | %{read-lines:../config/test-cflags} 26 | -I 27 | ../clib 28 | -I 29 | %{ocaml-config:standard_library} 30 | -o 31 | %{targets} 32 | generated_struct_stubs.c))) 33 | 34 | (rule 35 | (targets generated_struct_bindings.ml) 36 | (deps ml-stub-generator.exe) 37 | (action 38 | (with-stdout-to 39 | %{targets} 40 | (run %{deps})))) 41 | 42 | (library 43 | (name test_lwt_preemptive_bindings) 44 | (wrapped false) 45 | (foreign_stubs 46 | (language c) 47 | (names generated_stubs)) 48 | (modules generated_bindings generated_struct_bindings) 49 | (libraries ctypes test_functions lwt.unix)) 50 | 51 | (test 52 | (name test_lwt_jobs) 53 | (modules test_lwt_jobs) 54 | (package ctypes-foreign) 55 | (action 56 | (run %{test} -runner sequential)) 57 | (libraries 58 | ounit2 59 | ctypes 60 | ctypes.stubs 61 | ctypes-foreign 62 | test_lwt_preemptive_stubs 63 | test_functions 64 | test_lwt_preemptive_bindings 65 | tests_common)) 66 | -------------------------------------------------------------------------------- /tests/test-lwt-preemptive/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the Lwt preemptive tests. *) 9 | 10 | let cheader = "#include 11 | #include 12 | #include 13 | #include 14 | " 15 | 16 | let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) 17 | ~structs:(module Types.Struct_stubs) 18 | ~concurrency:Cstubs.lwt_preemptive 19 | -------------------------------------------------------------------------------- /tests/test-lwt-preemptive/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_lwt_preemptive_stubs tests_common)) 5 | -------------------------------------------------------------------------------- /tests/test-lwt-preemptive/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_lwt_preemptive_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-lwt-preemptive/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the Lwt preemptive tests. *) 9 | 10 | open Ctypes 11 | 12 | module Stubs (F: Ctypes.FOREIGN) = 13 | struct 14 | open F 15 | 16 | let sqrt = foreign "sqrt" (double @-> returning double) 17 | 18 | let sum_int_array = foreign "sum_int_array" 19 | (ptr int32_t @-> size_t @-> returning int32_t) 20 | 21 | let struct_stat : [`stat] structure typ = structure "stat" 22 | let stat = foreign "stat" 23 | (string @-> ptr struct_stat @-> returning int) 24 | 25 | let sixargs = foreign "sixargs" 26 | (int @-> int @-> int @-> int @-> int @-> int @-> returning int) 27 | 28 | let return_10 = foreign "return_10" 29 | (void @-> returning int) 30 | 31 | let return_void = foreign "return_void" 32 | (ptr int @-> returning void) 33 | end 34 | -------------------------------------------------------------------------------- /tests/test-lwt-preemptive/stubs/types.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes 9 | open PosixTypes 10 | 11 | module Struct_stubs(S : Ctypes.TYPE) = 12 | struct 13 | open S 14 | 15 | let ifdir = constant "S_IFDIR" (lift_typ mode_t) 16 | let ifmt = constant "S_IFMT" (lift_typ mode_t) 17 | 18 | let stat : [`stat] structure typ = structure "stat" 19 | let st_mode = field stat "st_mode" (lift_typ mode_t) 20 | let () = seal stat 21 | end 22 | 23 | -------------------------------------------------------------------------------- /tests/test-macros/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_macros) 3 | (package ctypes-foreign) 4 | (libraries 5 | ounit2 6 | ctypes 7 | ctypes.stubs 8 | ctypes-foreign 9 | test_macros_stubs 10 | test_macros_bindings 11 | tests_common)) 12 | -------------------------------------------------------------------------------- /tests/test-macros/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the macro tests. *) 9 | 10 | let cheader = " 11 | #include 12 | " 13 | 14 | let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) 15 | -------------------------------------------------------------------------------- /tests/test-macros/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_macros_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_macros_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-macros/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_macros_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-macros/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the macro tests. *) 9 | 10 | open Ctypes 11 | 12 | module Stubs (F: Ctypes.FOREIGN) = 13 | struct 14 | open F 15 | 16 | let exp_double = foreign "exp" (double @-> returning double) 17 | 18 | let exp_float = foreign "exp" (float @-> returning float) 19 | end 20 | -------------------------------------------------------------------------------- /tests/test-macros/test_macros.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open OUnit2 9 | 10 | module Bindings = Functions.Stubs(Generated_bindings) 11 | 12 | (* 13 | Test calling type-generic macros. 14 | *) 15 | let test_tg_macros _ = 16 | let open Bindings in 17 | assert_bool "calling double version of type-generic exp" 18 | (exp_double 1.0 = exp 1.0); 19 | assert_bool "calling float version of type-generic exp" 20 | (abs_float (exp_float 1.0 -. exp 1.0) <= 0.001) 21 | 22 | 23 | let suite = "Macro tests" >::: 24 | ["Calling type-generic macros" 25 | >:: test_tg_macros; 26 | ] 27 | 28 | 29 | let _ = 30 | run_test_tt_main suite 31 | -------------------------------------------------------------------------------- /tests/test-marshal/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_marshal) 3 | (libraries ctypes ounit2)) 4 | -------------------------------------------------------------------------------- /tests/test-marshal/test_marshal.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open OUnit2 9 | open Unsigned 10 | 11 | 12 | (* 13 | Test marshalling and unmarshalling custom integers 14 | *) 15 | let test_integer_marshalling _ = 16 | let v = ( 17 | UInt8.zero, UInt16.zero, UInt32.zero, UInt64.zero, 18 | UInt8.one, UInt16.one, UInt32.one, UInt64.one, 19 | UInt8.of_string "100", UInt16.of_string "1000", 20 | UInt32.of_string "10000", UInt64.of_string "100000", 21 | UInt8.max_int, UInt16.max_int, UInt32.max_int, UInt64.max_int 22 | ) in 23 | assert_equal v Marshal.(from_string (to_string v []) 0) 24 | 25 | 26 | let suite = "Marshal tests" >::: 27 | ["integer marshalling" 28 | >:: test_integer_marshalling; 29 | ] 30 | 31 | 32 | let _ = 33 | run_test_tt_main suite 34 | -------------------------------------------------------------------------------- /tests/test-oo_style/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_oo_style) 3 | (package ctypes-foreign) 4 | (deps ../clib/clib%{ext_dll}) 5 | (link_flags 6 | (:include ../flags/link-flags.sexp)) 7 | (libraries 8 | ounit2 9 | ctypes 10 | ctypes.stubs 11 | ctypes-foreign 12 | test_oo_style_stubs 13 | test_oo_style_bindings 14 | tests_common)) 15 | -------------------------------------------------------------------------------- /tests/test-oo_style/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the OO-style tests. *) 9 | 10 | let () = Tests_common.run Sys.argv (module Functions.Stubs) 11 | -------------------------------------------------------------------------------- /tests/test-oo_style/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_oo_style_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_oo_style_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-oo_style/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_oo_style_stubs) 3 | (wrapped false) 4 | (libraries ctypes ctypes-foreign)) 5 | -------------------------------------------------------------------------------- /tests/test-passable/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_passable) 3 | (package ctypes-foreign) 4 | (libraries ctypes ctypes.stubs ctypes-foreign ounit2)) 5 | -------------------------------------------------------------------------------- /tests/test-passing-ocaml-values/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_passing_ocaml_values) 3 | (package ctypes-foreign) 4 | (libraries 5 | ounit2 6 | ctypes 7 | ctypes.stubs 8 | ctypes-foreign 9 | test_passing_ocaml_values_stubs 10 | test_passing_ocaml_values_bindings 11 | tests_common)) 12 | -------------------------------------------------------------------------------- /tests/test-passing-ocaml-values/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the OCaml-value-passing tests. *) 9 | 10 | let cheader = "#include " 11 | 12 | let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) 13 | -------------------------------------------------------------------------------- /tests/test-passing-ocaml-values/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_passing_ocaml_values_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_passing_ocaml_values_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-passing-ocaml-values/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_passing_ocaml_values_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-passing-ocaml-values/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the OCaml-value-passing tests. *) 9 | 10 | open Ctypes 11 | 12 | let name_strdup = 13 | match Sys.os_type with 14 | | "Win32" -> "_strdup" 15 | | _ -> "strdup" 16 | 17 | module Stubs (F: Ctypes.FOREIGN) = 18 | struct 19 | open F 20 | 21 | let memcpy_string_string = foreign "memcpy" 22 | (ocaml_string @-> ocaml_string @-> size_t @-> returning (ptr void)) 23 | 24 | let memcpy_bytes_bytes = foreign "memcpy" 25 | (ocaml_bytes @-> ocaml_bytes @-> size_t @-> returning (ptr void)) 26 | 27 | let memcpy_string_ptr = foreign "memcpy" 28 | (ocaml_string @-> ptr void @-> size_t @-> returning (ptr void)) 29 | 30 | let strdup = foreign name_strdup 31 | (ocaml_string @-> returning string) 32 | end 33 | -------------------------------------------------------------------------------- /tests/test-pointers/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_pointers) 3 | (package ctypes-foreign) 4 | (deps ../clib/clib%{ext_dll}) 5 | (link_flags 6 | (:include ../flags/link-flags.sexp)) 7 | (libraries 8 | ounit2 9 | ctypes 10 | ctypes.stubs 11 | ctypes-foreign 12 | test_pointers_stubs 13 | test_pointers_bindings 14 | tests_common)) 15 | -------------------------------------------------------------------------------- /tests/test-pointers/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the pointer tests. *) 9 | 10 | let () = Tests_common.run Sys.argv (module Functions.Stubs) 11 | -------------------------------------------------------------------------------- /tests/test-pointers/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_pointers_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_pointers_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-pointers/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_pointers_stubs) 3 | (wrapped false) 4 | (libraries ctypes ctypes-foreign)) 5 | -------------------------------------------------------------------------------- /tests/test-raw/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_raw) 3 | (package ctypes-foreign) 4 | (libraries ctypes ctypes-foreign ounit2)) 5 | -------------------------------------------------------------------------------- /tests/test-returning-errno-lwt-jobs/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets generated_stubs.c) 3 | (action 4 | (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) 5 | 6 | (rule 7 | (targets generated_bindings.ml) 8 | (action 9 | (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_struct_stubs.c) 13 | (action 14 | (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) 15 | 16 | (rule 17 | (targets ml-stub-generator.exe) 18 | (deps 19 | generated_struct_stubs.c 20 | ../clib/test_functions.h 21 | ../config/test-cflags) 22 | (action 23 | (run 24 | %{cc} 25 | %{read-lines:../config/test-cflags} 26 | -I 27 | ../clib 28 | -I 29 | %{ocaml-config:standard_library} 30 | -o 31 | %{targets} 32 | generated_struct_stubs.c))) 33 | 34 | (rule 35 | (targets generated_struct_bindings.ml) 36 | (deps ml-stub-generator.exe) 37 | (action 38 | (with-stdout-to 39 | %{targets} 40 | (run %{deps})))) 41 | 42 | (library 43 | (name test_returning_errno_lwt_jobs_bindings) 44 | (wrapped false) 45 | (foreign_stubs 46 | (language c) 47 | (names generated_stubs)) 48 | (modules generated_bindings generated_struct_bindings) 49 | (libraries ctypes test_functions lwt.unix)) 50 | 51 | (test 52 | (name test_returning_errno) 53 | (package ctypes-foreign) 54 | (modules test_returning_errno) 55 | (action 56 | (run %{test} -runner sequential)) 57 | (libraries 58 | ounit2 59 | ctypes 60 | ctypes.stubs 61 | ctypes-foreign 62 | test_returning_errno_lwt_jobs_stubs 63 | test_functions 64 | test_returning_errno_lwt_jobs_bindings 65 | tests_common)) 66 | -------------------------------------------------------------------------------- /tests/test-returning-errno-lwt-jobs/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the errno tests. *) 9 | 10 | let cheader = "#include 11 | #include 12 | #include 13 | #include 14 | #include 15 | " 16 | 17 | let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) 18 | ~structs:(module Types.Struct_stubs) 19 | ~concurrency:Cstubs.lwt_jobs 20 | ~errno:Cstubs.return_errno 21 | -------------------------------------------------------------------------------- /tests/test-returning-errno-lwt-jobs/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_returning_errno_lwt_jobs_stubs tests_common)) 5 | -------------------------------------------------------------------------------- /tests/test-returning-errno-lwt-jobs/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_returning_errno_lwt_jobs_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-returning-errno-lwt-jobs/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the Errno tests. *) 9 | 10 | open Ctypes 11 | 12 | module Stubs (F: Ctypes.FOREIGN) = 13 | struct 14 | open F 15 | 16 | let struct_stat : [`stat] structure typ = structure "stat" 17 | let stat = foreign "stat" 18 | (string @-> ptr struct_stat @-> returning int) 19 | 20 | let sixargs = foreign "sixargs" 21 | (int @-> int @-> int @-> int @-> int @-> int @-> returning int) 22 | 23 | let return_10 = foreign "return_10" 24 | (void @-> returning int) 25 | 26 | let return_void = foreign "return_void" 27 | (ptr int @-> returning void) 28 | end 29 | -------------------------------------------------------------------------------- /tests/test-returning-errno-lwt-jobs/stubs/types.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes 9 | open PosixTypes 10 | 11 | module Struct_stubs(S : Ctypes.TYPE) = 12 | struct 13 | open S 14 | 15 | let _ENOENT = constant "ENOENT" sint 16 | 17 | let ifdir = constant "S_IFDIR" (lift_typ mode_t) 18 | let ifmt = constant "S_IFMT" (lift_typ mode_t) 19 | 20 | let stat : [`stat] structure typ = structure "stat" 21 | let st_mode = field stat "st_mode" (lift_typ mode_t) 22 | let () = seal stat 23 | end 24 | -------------------------------------------------------------------------------- /tests/test-returning-errno-lwt-preemptive/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets generated_stubs.c) 3 | (action 4 | (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) 5 | 6 | (rule 7 | (targets generated_bindings.ml) 8 | (action 9 | (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_struct_stubs.c) 13 | (action 14 | (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) 15 | 16 | (rule 17 | (targets ml-stub-generator.exe) 18 | (deps 19 | generated_struct_stubs.c 20 | ../clib/test_functions.h 21 | ../config/test-cflags) 22 | (action 23 | (run 24 | %{cc} 25 | %{read-lines:../config/test-cflags} 26 | -I 27 | ../clib 28 | -I 29 | %{ocaml-config:standard_library} 30 | -o 31 | %{targets} 32 | generated_struct_stubs.c))) 33 | 34 | (rule 35 | (targets generated_struct_bindings.ml) 36 | (deps ml-stub-generator.exe) 37 | (action 38 | (with-stdout-to 39 | %{targets} 40 | (run %{deps})))) 41 | 42 | (library 43 | (name test_returning_errno_lwt_preemptive_bindings) 44 | (wrapped false) 45 | (foreign_stubs 46 | (language c) 47 | (names generated_stubs)) 48 | (modules generated_bindings generated_struct_bindings) 49 | (libraries ctypes test_functions lwt.unix)) 50 | 51 | (test 52 | (name test_returning_errno) 53 | (modules test_returning_errno) 54 | (package ctypes-foreign) 55 | (action 56 | (run %{test} -runner sequential)) 57 | (libraries 58 | ounit2 59 | ctypes 60 | ctypes.stubs 61 | ctypes-foreign 62 | test_returning_errno_lwt_preemptive_stubs 63 | test_functions 64 | test_returning_errno_lwt_preemptive_bindings 65 | tests_common)) 66 | -------------------------------------------------------------------------------- /tests/test-returning-errno-lwt-preemptive/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the errno / Lwt_preemptive tests. *) 9 | 10 | let cheader = "#include 11 | #include 12 | #include 13 | #include 14 | #include 15 | " 16 | 17 | let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) 18 | ~structs:(module Types.Struct_stubs) 19 | ~concurrency:Cstubs.lwt_preemptive 20 | ~errno:Cstubs.return_errno 21 | -------------------------------------------------------------------------------- /tests/test-returning-errno-lwt-preemptive/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_returning_errno_lwt_preemptive_stubs tests_common)) 5 | -------------------------------------------------------------------------------- /tests/test-returning-errno-lwt-preemptive/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_returning_errno_lwt_preemptive_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-returning-errno-lwt-preemptive/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the errno / Lwt_preemptive tests. *) 9 | 10 | open Ctypes 11 | 12 | module Stubs (F: Ctypes.FOREIGN) = 13 | struct 14 | open F 15 | 16 | let struct_stat : [`stat] structure typ = structure "stat" 17 | let stat = foreign "stat" 18 | (string @-> ptr struct_stat @-> returning int) 19 | 20 | let sixargs = foreign "sixargs" 21 | (int @-> int @-> int @-> int @-> int @-> int @-> returning int) 22 | 23 | let return_10 = foreign "return_10" 24 | (void @-> returning int) 25 | 26 | let return_void = foreign "return_void" 27 | (ptr int @-> returning void) 28 | end 29 | -------------------------------------------------------------------------------- /tests/test-returning-errno-lwt-preemptive/stubs/types.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes 9 | open PosixTypes 10 | 11 | module Struct_stubs(S : Ctypes.TYPE) = 12 | struct 13 | open S 14 | 15 | let _ENOENT = constant "ENOENT" sint 16 | 17 | let ifdir = constant "S_IFDIR" (lift_typ mode_t) 18 | let ifmt = constant "S_IFMT" (lift_typ mode_t) 19 | 20 | let stat : [`stat] structure typ = structure "stat" 21 | let st_mode = field stat "st_mode" (lift_typ mode_t) 22 | let () = seal stat 23 | end 24 | -------------------------------------------------------------------------------- /tests/test-returning-errno/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets generated_stubs.c) 3 | (action 4 | (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) 5 | 6 | (rule 7 | (targets generated_bindings.ml) 8 | (action 9 | (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_struct_stubs.c) 13 | (action 14 | (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) 15 | 16 | (rule 17 | (targets ml-stub-generator.exe) 18 | (deps 19 | generated_struct_stubs.c 20 | ../clib/test_functions.h 21 | ../config/test-cflags) 22 | (action 23 | (run 24 | %{cc} 25 | %{read-lines:../config/test-cflags} 26 | -I 27 | ../clib 28 | -I 29 | %{ocaml-config:standard_library} 30 | -o 31 | %{targets} 32 | generated_struct_stubs.c))) 33 | 34 | (rule 35 | (targets generated_struct_bindings.ml) 36 | (deps ml-stub-generator.exe) 37 | (action 38 | (with-stdout-to 39 | %{targets} 40 | (run %{deps})))) 41 | 42 | (library 43 | (name test_returning_errno_bindings) 44 | (wrapped false) 45 | (foreign_stubs 46 | (language c) 47 | (names generated_stubs)) 48 | (modules generated_bindings generated_struct_bindings) 49 | (libraries ctypes test_functions lwt.unix)) 50 | 51 | (test 52 | (name test_returning_errno) 53 | (modules test_returning_errno) 54 | (action 55 | (run %{test} -runner sequential)) 56 | (package ctypes-foreign) 57 | (libraries 58 | ounit2 59 | ctypes 60 | ctypes.stubs 61 | ctypes-foreign 62 | test_returning_errno_stubs 63 | test_functions 64 | test_returning_errno_bindings 65 | tests_common)) 66 | -------------------------------------------------------------------------------- /tests/test-returning-errno/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the errno tests. *) 9 | 10 | let cheader = "#include 11 | #include 12 | #include 13 | #include 14 | #include 15 | " 16 | 17 | let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) 18 | ~structs:(module Types.Struct_stubs) 19 | ~errno:Cstubs.return_errno 20 | -------------------------------------------------------------------------------- /tests/test-returning-errno/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_returning_errno_stubs tests_common)) 5 | -------------------------------------------------------------------------------- /tests/test-returning-errno/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_returning_errno_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-returning-errno/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the Errno tests. *) 9 | 10 | open Ctypes 11 | 12 | module Stubs (F: Ctypes.FOREIGN) = 13 | struct 14 | open F 15 | 16 | let struct_stat : [`stat] structure typ = structure "stat" 17 | let stat = foreign "stat" 18 | (string @-> ptr struct_stat @-> returning int) 19 | end 20 | -------------------------------------------------------------------------------- /tests/test-returning-errno/stubs/types.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes 9 | open PosixTypes 10 | 11 | module Struct_stubs(S : Ctypes.TYPE) = 12 | struct 13 | open S 14 | 15 | let _ENOENT = constant "ENOENT" sint 16 | 17 | let ifdir = constant "S_IFDIR" (lift_typ mode_t) 18 | let ifmt = constant "S_IFMT" (lift_typ mode_t) 19 | 20 | let stat : [`stat] structure typ = structure "stat" 21 | let st_mode = field stat "st_mode" (lift_typ mode_t) 22 | let () = seal stat 23 | end 24 | -------------------------------------------------------------------------------- /tests/test-returning-errno/test_returning_errno.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open OUnit2 9 | open Ctypes 10 | 11 | 12 | module Bindings = Functions.Stubs(Generated_bindings) 13 | module Constants = Types.Struct_stubs(Generated_struct_bindings) 14 | 15 | 16 | (* 17 | Test the binding to "stat". 18 | *) 19 | let test_stat _ = 20 | let st = make Constants.stat in 21 | begin 22 | let x, errno = Bindings.stat "." (addr st) in 23 | assert_equal 0 x; 24 | assert_equal Signed.SInt.zero errno; 25 | 26 | let x, errno = Bindings.stat "/does-not-exist" (addr st) in 27 | assert_equal (-1) x; 28 | assert_equal Constants._ENOENT errno; 29 | end 30 | 31 | 32 | let suite = "Errno tests" >::: 33 | ["calling stat" 34 | >:: test_stat; 35 | ] 36 | 37 | 38 | let _ = 39 | run_test_tt_main suite 40 | -------------------------------------------------------------------------------- /tests/test-roots/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_roots) 3 | (package ctypes-foreign) 4 | (deps ../clib/clib%{ext_dll}) 5 | (libraries ctypes ctypes-foreign ounit2)) 6 | -------------------------------------------------------------------------------- /tests/test-sizeof/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_sizeof) 3 | (package ctypes-foreign) 4 | (libraries ctypes ctypes-foreign ounit2)) 5 | -------------------------------------------------------------------------------- /tests/test-structs/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets generated_stubs.c) 3 | (action 4 | (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) 5 | 6 | (rule 7 | (targets generated_bindings.ml) 8 | (action 9 | (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_struct_stubs.c) 13 | (action 14 | (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) 15 | 16 | (rule 17 | (targets ml-stub-generator.exe) 18 | (deps 19 | generated_struct_stubs.c 20 | ../clib/test_functions.h 21 | ../config/test-cflags) 22 | (action 23 | (run 24 | %{cc} 25 | %{read-lines:../config/test-cflags} 26 | -I 27 | ../clib 28 | -I 29 | %{ocaml-config:standard_library} 30 | -o 31 | %{targets} 32 | generated_struct_stubs.c))) 33 | 34 | (rule 35 | (targets generated_struct_bindings.ml) 36 | (deps ml-stub-generator.exe) 37 | (action 38 | (with-stdout-to 39 | %{targets} 40 | (run %{deps})))) 41 | 42 | (library 43 | (name test_structs_bindings) 44 | (wrapped false) 45 | (foreign_stubs 46 | (language c) 47 | (names generated_stubs)) 48 | (modules generated_bindings generated_struct_bindings) 49 | (libraries ctypes test_functions lwt.unix)) 50 | 51 | (test 52 | (name test_structs) 53 | (modules test_structs) 54 | (package ctypes-foreign) 55 | (deps ../clib/clib%{ext_dll}) 56 | (action 57 | (run %{test} -runner sequential)) 58 | (link_flags 59 | (:include ../flags/link-flags.sexp)) 60 | (libraries 61 | ounit2 62 | ctypes 63 | ctypes.stubs 64 | ctypes-foreign 65 | test_structs_stubs 66 | test_functions 67 | test_structs_bindings 68 | tests_common)) 69 | -------------------------------------------------------------------------------- /tests/test-structs/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the struct tests. *) 9 | 10 | let () = Tests_common.run Sys.argv 11 | ~structs:(module Types.Struct_stubs) 12 | (module Functions.Stubs) 13 | -------------------------------------------------------------------------------- /tests/test-structs/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_structs_stubs tests_common)) 5 | -------------------------------------------------------------------------------- /tests/test-structs/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_structs_stubs) 3 | (wrapped false) 4 | (libraries ctypes ctypes-foreign)) 5 | -------------------------------------------------------------------------------- /tests/test-structs/stubs/types.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes 9 | 10 | module Struct_stubs(S : Ctypes.TYPE) = 11 | struct 12 | open S 13 | 14 | (* missing fields *) 15 | let s1 : [`s1] structure typ = structure "s1" 16 | let x1 = field s1 "x1" int 17 | let x4 = field s1 "x4" int 18 | let () = seal s1 19 | 20 | (* fields reordered *) 21 | let s2 : [`s2] structure typ = structure "s2" 22 | let y2 = field s2 "y2" int 23 | let y1 = field s2 "y1" int 24 | let () = seal s2 25 | 26 | (* one struct depending on another *) 27 | let s3 : [`s3] structure typ = structure "s3" 28 | let z1 = field s3 "z1" int 29 | let z2 = field s3 "z2" (ptr s3) 30 | let () = seal s3 31 | 32 | let s4 : [`s4] structure typ = structure "s4" 33 | let z3 = field s4 "z3" s3 34 | let z4 = field s4 "z4" (ptr s3) 35 | let () = seal s4 36 | 37 | (* dependencies involving function pointers *) 38 | 39 | (* (incomplete types are available in the present) *) 40 | let s1_fwd : [`s1] Ctypes.structure Ctypes.typ = Ctypes.structure "s1" 41 | 42 | let s5 : [`s5] structure typ = structure "s5" 43 | let w1 = field s5 "w1" (lift_typ (Foreign.funptr Ctypes.(ptr s1_fwd @-> returning int))) 44 | let () = seal s5 45 | 46 | (* adding fields through views (typedefs) *) 47 | let struct_s6 : [`s6] structure typ = structure "" 48 | let s6 = typedef struct_s6 "s6" 49 | let v1 = field s6 "v1" int 50 | let v2 = field s6 "v2" float 51 | let () = seal s6 52 | 53 | let funptr = static_funptr (struct_s6 @-> returning int) 54 | let funptr2 = static_funptr (int @-> returning struct_s6) 55 | end 56 | -------------------------------------------------------------------------------- /tests/test-stubs/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_stubs) 3 | (package ctypes-foreign) 4 | (libraries ctypes-foreign ounit2)) 5 | -------------------------------------------------------------------------------- /tests/test-stubs/test_stubs.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open OUnit2 9 | open Ctypes 10 | open Foreign 11 | 12 | let missing = "_60d2dd04_1b66_4b79_a2ea_8375157da563" 13 | 14 | let test_missing _ = 15 | let miss = foreign missing ~stub:true (int @-> int @-> (returning int)) in 16 | begin try ignore (miss 2 3); assert_failure "should raise" with _exn -> () end; 17 | try 18 | let _miss = foreign missing ~stub:false (int @-> int @-> (returning int)) in 19 | assert_failure "should raise" 20 | with _exn -> () 21 | 22 | 23 | let suite = 24 | "Foreign value stubs" >::: 25 | [ 26 | "missing symbols" 27 | >:: test_missing; 28 | ] 29 | 30 | let _ = run_test_tt_main suite 31 | -------------------------------------------------------------------------------- /tests/test-threads/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_threads) 3 | (package ctypes-foreign) 4 | (deps ../clib/clib%{ext_dll}) 5 | (link_flags 6 | (:include ../flags/link-flags.sexp)) 7 | (libraries 8 | ounit2 9 | ctypes 10 | ctypes.stubs 11 | ctypes-foreign 12 | test_threads_stubs 13 | test_threads_bindings 14 | tests_common)) 15 | -------------------------------------------------------------------------------- /tests/test-threads/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2016 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the threads tests. *) 9 | 10 | let () = Tests_common.run ~concurrency:Cstubs.unlocked Sys.argv (module Functions.Stubs) 11 | -------------------------------------------------------------------------------- /tests/test-threads/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_threads_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_threads_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-threads/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_threads_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-threads/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the threads tests. *) 9 | 10 | open Ctypes 11 | 12 | module Stubs(F: Ctypes.FOREIGN) = 13 | struct 14 | open F 15 | let initialize_waiters = foreign "initialize_waiters" 16 | (void @-> returning void) 17 | 18 | let post1_wait2 = foreign "post1_wait2" 19 | (void @-> returning void) 20 | 21 | let post2_wait1 = foreign "post2_wait1" 22 | (void @-> returning void) 23 | end 24 | -------------------------------------------------------------------------------- /tests/test-type_printing/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets generated_stubs.c) 3 | (action 4 | (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) 5 | 6 | (rule 7 | (targets generated_bindings.ml) 8 | (action 9 | (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_struct_stubs.c) 13 | (action 14 | (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) 15 | 16 | (rule 17 | (targets ml-stub-generator.exe) 18 | (deps 19 | generated_struct_stubs.c 20 | ../clib/test_functions.h 21 | ../config/test-cflags) 22 | (action 23 | (run 24 | %{cc} 25 | %{read-lines:../config/test-cflags} 26 | -I 27 | ../clib 28 | -I 29 | %{ocaml-config:standard_library} 30 | -o 31 | %{targets} 32 | generated_struct_stubs.c))) 33 | 34 | (rule 35 | (targets generated_struct_bindings.ml) 36 | (deps ml-stub-generator.exe) 37 | (action 38 | (with-stdout-to 39 | %{targets} 40 | (run %{deps})))) 41 | 42 | (library 43 | (name test_type_printing_bindings) 44 | (wrapped false) 45 | (foreign_stubs 46 | (language c) 47 | (names generated_stubs)) 48 | (modules generated_bindings generated_struct_bindings) 49 | (libraries ctypes test_functions lwt.unix)) 50 | 51 | (test 52 | (name test_type_printing) 53 | (modules test_type_printing) 54 | (package ctypes-foreign) 55 | (libraries 56 | ounit2 57 | ctypes 58 | ctypes.stubs 59 | ctypes-foreign 60 | test_type_printing_stubs 61 | test_functions 62 | test_type_printing_bindings 63 | tests_common)) 64 | -------------------------------------------------------------------------------- /tests/test-type_printing/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2017 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the type printing tests. *) 9 | 10 | let () = Tests_common.run Sys.argv 11 | ~structs:(module Types.Stubs) 12 | (module functor (B:Ctypes.FOREIGN) -> struct end) 13 | 14 | -------------------------------------------------------------------------------- /tests/test-type_printing/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_type_printing_stubs tests_common)) 5 | -------------------------------------------------------------------------------- /tests/test-type_printing/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_type_printing_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-type_printing/stubs/types.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2017 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | module Stubs(S : Ctypes.TYPE) = 9 | struct 10 | open S 11 | let fruit : int64 S.typ = enum "fruit" [] 12 | 13 | let bears_t : int64 S.typ = enum "bears_t" [] 14 | ~typedef:true 15 | 16 | let letter_t : int64 S.typ = typedef (enum "letter" []) "letter_t" 17 | end 18 | -------------------------------------------------------------------------------- /tests/test-unions/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets generated_stubs.c) 3 | (action 4 | (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) 5 | 6 | (rule 7 | (targets generated_bindings.ml) 8 | (action 9 | (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_struct_stubs.c) 13 | (action 14 | (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) 15 | 16 | (rule 17 | (targets ml-stub-generator.exe) 18 | (deps 19 | generated_struct_stubs.c 20 | ../clib/test_functions.h 21 | ../config/test-cflags) 22 | (action 23 | (run 24 | %{cc} 25 | %{read-lines:../config/test-cflags} 26 | -I 27 | ../clib 28 | -I 29 | %{ocaml-config:standard_library} 30 | -o 31 | %{targets} 32 | generated_struct_stubs.c))) 33 | 34 | (rule 35 | (targets generated_struct_bindings.ml) 36 | (deps ml-stub-generator.exe) 37 | (action 38 | (with-stdout-to 39 | %{targets} 40 | (run %{deps})))) 41 | 42 | (library 43 | (name test_unions_bindings) 44 | (wrapped false) 45 | (foreign_stubs 46 | (language c) 47 | (names generated_stubs)) 48 | (modules generated_bindings generated_struct_bindings) 49 | (libraries ctypes test_functions lwt.unix)) 50 | 51 | (test 52 | (name test_unions) 53 | (modules test_unions) 54 | (deps ../clib/clib%{ext_dll}) 55 | (package ctypes-foreign) 56 | (action 57 | (run %{test} -runner sequential)) 58 | (link_flags 59 | (:include ../flags/link-flags.sexp)) 60 | (libraries 61 | ounit2 62 | ctypes 63 | ctypes.stubs 64 | ctypes-foreign 65 | test_unions_stubs 66 | test_functions 67 | test_unions_bindings 68 | tests_common)) 69 | -------------------------------------------------------------------------------- /tests/test-unions/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the union tests. *) 9 | 10 | let () = Tests_common.run Sys.argv 11 | ~structs:(module Types.Struct_stubs) 12 | (module Functions.Stubs) 13 | -------------------------------------------------------------------------------- /tests/test-unions/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_unions_stubs tests_common)) 5 | -------------------------------------------------------------------------------- /tests/test-unions/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_unions_stubs) 3 | (wrapped false) 4 | (libraries ctypes ctypes-foreign)) 5 | -------------------------------------------------------------------------------- /tests/test-unions/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the union tests. *) 9 | 10 | open Ctypes 11 | 12 | type padded 13 | let padded : padded union typ = union "padded" 14 | let (-:) ty label = field padded label ty 15 | let i = int64_t -: "i" 16 | let a = array (sizeof int64_t + 1) char -: "a" 17 | let () = seal padded 18 | 19 | (* These functions can be bound either dynamically using Foreign or statically 20 | using stub generation. *) 21 | module Common (F: Ctypes.FOREIGN) = 22 | struct 23 | let sum_union_components = 24 | F.(foreign "sum_union_components" 25 | (ptr padded @-> size_t @-> returning int64_t)) 26 | end 27 | 28 | (* These functions can only be bound using stub generation, since Foreign 29 | doesn't support passing unions by value. *) 30 | module Stubs_only(F : Ctypes.FOREIGN) = 31 | struct 32 | let add_unions = 33 | F.(foreign "add_unions" 34 | (padded @-> padded @-> returning padded)) 35 | end 36 | 37 | module Stubs (F: Ctypes.FOREIGN) = 38 | struct 39 | include Common(F) 40 | include Stubs_only(F) 41 | end 42 | -------------------------------------------------------------------------------- /tests/test-unions/stubs/types.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | open Ctypes 9 | 10 | module Struct_stubs(S : Ctypes.TYPE) = 11 | struct 12 | open S 13 | 14 | (* missing fields *) 15 | let u1 : [`u1] union typ = union "u1" 16 | let x1 = field u1 "x1" char 17 | let () = seal u1 18 | 19 | (* adding fields through views (typedefs) *) 20 | let union_u2 : [`s7] union typ = union "" 21 | let u2 = typedef union_u2 "u2" 22 | let t1 = field u2 "t1" int 23 | let t2 = field u2 "t2" float 24 | let () = seal u2 25 | end 26 | -------------------------------------------------------------------------------- /tests/test-value_printing/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_value_printing) 3 | (package ctypes-foreign) 4 | (deps ../clib/clib%{ext_dll}) 5 | (link_flags 6 | (:include ../flags/link-flags.sexp)) 7 | (libraries 8 | ounit2 9 | ctypes 10 | ctypes.stubs 11 | ctypes-foreign 12 | test_value_printing_stubs 13 | test_value_printing_bindings 14 | tests_common)) 15 | -------------------------------------------------------------------------------- /tests/test-value_printing/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the value printing tests. *) 9 | 10 | let () = Tests_common.run Sys.argv (module Functions.Stubs) 11 | -------------------------------------------------------------------------------- /tests/test-value_printing/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_value_printing_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_value_printing_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-value_printing/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_value_printing_stubs) 3 | (wrapped false) 4 | (libraries ctypes)) 5 | -------------------------------------------------------------------------------- /tests/test-variadic/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_variadic) 3 | (package ctypes-foreign) 4 | (libraries 5 | ounit2 6 | ctypes 7 | integers 8 | test_variadic_stubs 9 | test_variadic_bindings 10 | tests_common)) 11 | -------------------------------------------------------------------------------- /tests/test-variadic/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the variadic function tests. *) 9 | 10 | let cheader = " 11 | #include 12 | " 13 | 14 | let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) 15 | -------------------------------------------------------------------------------- /tests/test-variadic/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_variadic_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_variadic_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-variadic/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_variadic_stubs) 3 | (wrapped false) 4 | (libraries ctypes integers)) 5 | -------------------------------------------------------------------------------- /tests/test-variadic/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the variadic function tests. *) 9 | 10 | open Ctypes 11 | 12 | module Stubs (F: Ctypes.FOREIGN) = 13 | struct 14 | open F 15 | 16 | let size_t_as_int : int typ = view size_t 17 | ~read:Unsigned.Size_t.to_int 18 | ~write:Unsigned.Size_t.of_int 19 | 20 | let bind_snprintf tail = 21 | foreign "snprintf" (ptr char @-> size_t_as_int @-> string @-> tail) 22 | 23 | let snprintf_int = 24 | bind_snprintf (int @-> returning int) 25 | 26 | let snprintf_char_unsigned = 27 | bind_snprintf (char @-> uint @-> returning int) 28 | 29 | let snprintf_longlong_int = 30 | bind_snprintf (llong @-> int @-> returning int) 31 | 32 | let snprintf_string_ushort = 33 | bind_snprintf (string @-> ushort @-> returning int) 34 | end 35 | -------------------------------------------------------------------------------- /tests/test-views/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_views) 3 | (package ctypes-foreign) 4 | (deps ../clib/clib%{ext_dll}) 5 | (link_flags 6 | (:include ../flags/link-flags.sexp)) 7 | (libraries ounit2 ctypes test_views_stubs test_views_bindings tests_common)) 8 | -------------------------------------------------------------------------------- /tests/test-views/stub-generator/driver.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Stub generation driver for the views tests. *) 9 | 10 | let cheader = " 11 | #include 12 | #include 13 | " 14 | 15 | let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) 16 | -------------------------------------------------------------------------------- /tests/test-views/stub-generator/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | (modules driver) 4 | (libraries ctypes test_views_stubs tests_common)) 5 | 6 | (rule 7 | (targets generated_stubs.c) 8 | (action 9 | (run %{exe:driver.exe} --c-file %{targets}))) 10 | 11 | (rule 12 | (targets generated_bindings.ml) 13 | (action 14 | (run %{exe:driver.exe} --ml-file %{targets}))) 15 | 16 | (library 17 | (name test_views_bindings) 18 | (wrapped false) 19 | (foreign_stubs 20 | (language c) 21 | (names generated_stubs)) 22 | (modules generated_bindings) 23 | (libraries ctypes test_functions)) 24 | -------------------------------------------------------------------------------- /tests/test-views/stubs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test_views_stubs) 3 | (wrapped false) 4 | (libraries ctypes ctypes-foreign)) 5 | -------------------------------------------------------------------------------- /tests/test-views/stubs/functions.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Jeremy Yallop. 3 | * 4 | * This file is distributed under the terms of the MIT License. 5 | * See the file LICENSE for details. 6 | *) 7 | 8 | (* Foreign function bindings for the views tests. *) 9 | 10 | open Ctypes 11 | 12 | module Stubs (F: Ctypes.FOREIGN) = 13 | struct 14 | open F 15 | 16 | let charish = view ~read:Char.chr ~write:Char.code int 17 | 18 | let nullable_intptr = Foreign.funptr_opt Ctypes.(int @-> int @-> 19 | returning int) 20 | 21 | let concat_strings = foreign "concat_strings" 22 | (ptr string @-> int @-> ptr char @-> returning void) 23 | 24 | let toupper = foreign "toupper" 25 | (charish @-> returning charish) 26 | 27 | let returning_funptr = foreign "returning_funptr" 28 | (int @-> returning nullable_intptr) 29 | let accepting_possibly_null_funptr = foreign "accepting_possibly_null_funptr" 30 | (nullable_intptr @-> int @-> int @-> returning int) 31 | 32 | let strcmp = foreign "strcmp" 33 | (string @-> string @-> returning int) 34 | end 35 | -------------------------------------------------------------------------------- /tests/tests-common/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tests_common) 3 | (libraries ctypes ctypes.stubs ctypes-foreign)) 4 | --------------------------------------------------------------------------------