pax_global_header00006660000000000000000000000064144563111260014515gustar00rootroot0000000000000052 comment=3f8211a81bcce2d3785bf7158ee72b7d6a107afe yallop-ocaml-ctypes-3f8211a/000077500000000000000000000000001445631112600157425ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/.github/000077500000000000000000000000001445631112600173025ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/.github/workflows/000077500000000000000000000000001445631112600213375ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/.github/workflows/test.yml000066400000000000000000000033341445631112600230440ustar00rootroot00000000000000name: Ctypes on: - pull_request - push - workflow_dispatch jobs: tests: name: Tests strategy: fail-fast: false matrix: include: - os: ubuntu-latest ocaml-compiler: 4.03.0 - os: ubuntu-latest ocaml-compiler: 4.04.0 - os: ubuntu-latest ocaml-compiler: 4.05.0 - os: ubuntu-latest ocaml-compiler: 4.06.0 - os: ubuntu-latest ocaml-compiler: 4.07.0 - os: ubuntu-latest ocaml-compiler: 4.08.0 - os: ubuntu-latest ocaml-compiler: 4.09.0 - os: ubuntu-latest ocaml-compiler: ocaml-variants.4.11.2+fp+flambda - os: ubuntu-latest ocaml-compiler: 4.11.1 - os: ubuntu-latest ocaml-compiler: 4.12.0 - os: ubuntu-latest ocaml-compiler: 4.13.1 - os: ubuntu-latest ocaml-compiler: 4.14.0 - os: ubuntu-latest ocaml-compiler: 5.0.0 - os: windows-latest ocaml-compiler: 4.13.1 - os: macos-latest ocaml-compiler: 4.13.1 runs-on: ${{ matrix.os }} steps: - name: Checkout code uses: actions/checkout@v2 - name: Use OCaml ${{ matrix.ocaml-compiler }} uses: ocaml/setup-ocaml@v2 with: ocaml-compiler: ${{ matrix.ocaml-compiler }} - name: Deps run: | opam pin add -n ctypes.dev . opam pin add -n ctypes-foreign.dev . opam depext -ty ctypes ctypes-foreign opam install -t --deps-only . - name: Build run: opam exec -- dune build - name: Test run: opam exec -- dune runtest yallop-ocaml-ctypes-3f8211a/.gitignore000066400000000000000000000000461445631112600177320ustar00rootroot00000000000000.*.swp _build _opam *.install .merlin yallop-ocaml-ctypes-3f8211a/CHANGES.md000066400000000000000000000564201445631112600173430ustar00rootroot00000000000000## ctypes 0.21.1 * Add missing version information to dune-project ## ctypes 0.21.0 * Switch to dune https://github.com/yallop/ocaml-ctypes/pull/588 Thanks to Anil Madhavapeddy (@avsm) and Etienne Millon (@emillon) for contributing to this release. ## ctypes 0.20.2 * Restore compilation of cmxs for 5.0 https://github.com/ocamllabs/ocaml-ctypes/pull/727 * Update build rules to make .o files a dependency of cmxs https://github.com/ocamllabs/ocaml-ctypes/pull/723 * update CArray.of_string comment to accurately reflect the length https://github.com/ocamllabs/ocaml-ctypes/pull/716 Thanks to @houseofsuns, @ygrek, Alpha Diallo (@moyodiallo), François Bobot (@bobot) and Alfredo Tupone (@atupone) for contributions to this release. ## ctypes 0.20.1 * Fix warning 9 [missing-record-field-pattern] in generated OCaml code https://github.com/ocamllabs/ocaml-ctypes/pull/700 Thanks to Antonin Décimo (@MisterDA) for contributing to this release. ## ctypes 0.20.0 * Remove naked pointers from the Dl library https://github.com/ocamllabs/ocaml-ctypes/pull/681 * Avoid running a full GC cycle on every FFI closure allocation https://github.com/ocamllabs/ocaml-ctypes/pull/694 * Check output of `brew ls --versions` when detecting homebrew https://github.com/ocamllabs/ocaml-ctypes/pull/697 Thanks to Martin Kletzander (@nertpinx) and Arseniy Alekseyev (@aalekseyev) for contributions to this release. ## ctypes 0.19.1 * Fix use of CAMLdrop in generated code https://github.com/ocamllabs/ocaml-ctypes/pull/680 ## ctypes 0.19.0 * Drop compatibility with 4.02, and improve compatibility with Multicore OCaml https://github.com/ocamllabs/ocaml-ctypes/pull/673 Thanks to Kate Deplaix (@kit-ty-kate) for contributing to this release. ## ctypes 0.18.0 * Remove the `Unix` dependency by using `bigarray-compat` https://github.com/ocamllabs/ocaml-ctypes/pull/660 * Remove the threaded/unthreaded split in ctypes-foreign https://github.com/ocamllabs/ocaml-ctypes/pull/651 * Eliminate some `const` warnings in generated code https://github.com/ocamllabs/ocaml-ctypes/pull/646 https://github.com/ocamllabs/ocaml-ctypes/pull/638 * Speed-up `CArray.make` with initial value https://github.com/ocamllabs/ocaml-ctypes/pull/644 * Fix complex allocation size https://github.com/ocamllabs/ocaml-ctypes/pull/642 * Report names of missing symbols also under windows https://github.com/ocamllabs/ocaml-ctypes/pull/641 * Remove a level of boxing from struct and union values https://github.com/ocamllabs/ocaml-ctypes/pull/640 * Fix a markup issue in the `funptr` docstring https://github.com/ocamllabs/ocaml-ctypes/pull/633 * Move conf-pkg-config dependency to ctypes-foreign https://github.com/ocamllabs/ocaml-ctypes/pull/631 Thanks to Andreas Hauptmann (@fdopen), Anil Madhavapeddy (@avsm), Anton Bachin (@aantron), Calascibetta Romain (@dinosaure), Sora Morimoto (@smorimoto) and and Stéphane Glondu (@glondu) for contributions to this release. ## ctypes 0.17.1 * Hide the managed component in pointer values https://github.com/ocamllabs/ocaml-ctypes/pull/629 (This is an internal-only change that addresses a problem introduced in 0.17.0) ## ctypes 0.17.0 * ocaml_bytes now corresponds to 'unsigned char *', not 'char *' https://github.com/ocamllabs/ocaml-ctypes/pull/625 * Distinguish bytes and string in generated stub code https://github.com/ocamllabs/ocaml-ctypes/pull/622 * Reflect "managed" status in the types of fat pointers https://github.com/ocamllabs/ocaml-ctypes/pull/619 (This is an internal-only change.) ## ctypes 0.16.0 * Add `Foreign.dynamic_funptr`, a variant of `Foreign.funptr` with explicit life cycle management. https://github.com/ocamllabs/ocaml-ctypes/pull/595 * fix ctypes-foreign depexts to work with opam 2 https://github.com/ocamllabs/ocaml-ctypes/pull/617 * Build with -strict-sequence https://github.com/ocamllabs/ocaml-ctypes/pull/613 Thanks to Andreas Hauptmann (@fdopen), Andrew Ray (@andrewray), Anil Madhavapeddy (@avsm), Armaël Guéneau (@Armael) and Matthias Horn (@tiash) for contributions to this release. ## ctypes 0.15.1 * Fix -related compilation issues on FreeBSD https://github.com/ocamllabs/ocaml-ctypes/pull/608 ## ctypes 0.15.0 * Avoid unaligned stores/loads https://github.com/ocamllabs/ocaml-ctypes/pull/584 * Fix LDouble.to_int bug resulting from upstream Val_long change https://github.com/ocamllabs/ocaml-ctypes/pull/583 * use CMPLX[FL]? macros instead of I https://github.com/ocamllabs/ocaml-ctypes/pull/585 * Various Windows fixes https://github.com/ocamllabs/ocaml-ctypes/pull/586 * Drop OCaml 4.01 support https://github.com/ocamllabs/ocaml-ctypes/pull/577 * Eliminate uses of on Android https://github.com/ocamllabs/ocaml-ctypes/pull/579 Thanks to Anton Bachin (@aantron), Andreas Hauptmann (@fdopen) and @ygrek for contributions to this release. ## ctypes 0.14.0 * Add `CArray.of_string` https://github.com/ocamllabs/ocaml-ctypes/pull/562 https://github.com/ocamllabs/ocaml-ctypes/pull/563 * Attach ocaml_integers.h to the cstubs subpackage https://github.com/ocamllabs/ocaml-ctypes/pull/557 * fix custom operations of ComplexL https://github.com/ocamllabs/ocaml-ctypes/pull/549 Thanks to Andreas Hauptmann (@fdopen), Rudi Grinberg (@rgrinberg) and Marcello Seri (@mseri) for contributions to this release. ## ctypes 0.13.1 * Add -no-keep-locs to the foreign-(un)?threaded build rules. https://github.com/ocamllabs/ocaml-ctypes/pull/553 ## ctypes 0.13.0 * Print typedefed enums correctly https://github.com/ocamllabs/ocaml-ctypes/pull/547 * Move the TYPE and FOREIGN signatures from cstubs to ctypes https://github.com/ocamllabs/ocaml-ctypes/pull/544 https://github.com/ocamllabs/ocaml-ctypes/pull/537 Thanks to Leo White (@lpw25) for contributing to this release. ## ctypes 0.12.1 * Preserve intermediate values from views across foreign calls. https://github.com/ocamllabs/ocaml-ctypes/pull/531 ## ctypes 0.12.0 * Support for Fortran-layout bigarrays https://github.com/ocamllabs/ocaml-ctypes/pull/523 * Use the integers package for signed and unsigned integer support https://github.com/ocamllabs/ocaml-ctypes/pull/515 * Add support for binding enums defined without tags https://github.com/ocamllabs/ocaml-ctypes/pull/510 Thanks to Bertrand Bonnefoy-Claudet (@bbc2) and Leo White (@lpw25) for contributions to this release. ## ctypes 0.11.4 * Fix function pointer support on no-exec platforms https://github.com/ocamllabs/ocaml-ctypes/pull/511 Thanks to Matthias Horn (@tiash) for contributing to this release. ## ctypes 0.11.3 * Stub out some `long double` functions that are not supported on NetBSD and OpenBSD https://github.com/ocamllabs/ocaml-ctypes/pull/503 * Fix the build when shared libraries are not available https://github.com/ocamllabs/ocaml-ctypes/pull/495 Thanks to Andreas Hauptmann (@fdopen) and Peter Zotov (@whitequark) for contributions to this release. ## ctypes 0.11.2 ### Bug fixes * Fix truncation in UInt64.of_int; remove other uses of `Val_int`/`Int_val` https://github.com/ocamllabs/ocaml-ctypes/pull/492 ## ctypes 0.11.1 ### Bug fixes * Stub out some `long double complex` functions that are not supported on Android https://github.com/ocamllabs/ocaml-ctypes/pull/486 Thanks to Peter Zotov (@whitequark) and Jeremie Dimino (@diml) for contributions to this release. ## ctypes 0.11.0 ### Features * Support for the `long double` and `long double complex` types https://github.com/ocamllabs/ocaml-ctypes/pull/475 * Support for binding foreign arrays https://github.com/ocamllabs/ocaml-ctypes/pull/470 * Improved printing for structs and unions without tags https://github.com/ocamllabs/ocaml-ctypes/pull/467 * Added a function `is_null` https://github.com/ocamllabs/ocaml-ctypes/pull/463 ### Bug fixes * Custom operations (namely deserializing) for unsigned integers registered https://github.com/ocamllabs/ocaml-ctypes/pull/480 * All objects kept live when the runtime lock is released https://github.com/ocamllabs/ocaml-ctypes/pull/473 Thanks to Andrew Ray (@andrewray) and Yunxing Dai (@yunxing) for contributions to this release. ## ctypes 0.10.2 ### Bug fixes * Fix generated code for Lwt jobs where the return type is `void`. https://github.com/ocamllabs/ocaml-ctypes/pull/460 Thanks to David Sheets (@dsheets) for contributions to this release. ## ctypes 0.10.1 ### Bug fixes * Always extend integers returned from closures to full word size (Fixes incorrectly-promoted integers returned from callbacks on ARM and MIPS) https://github.com/ocamllabs/ocaml-ctypes/pull/456 Thanks to Andreas Hauptmann (@fdopen) for contributions to this release. ## ctypes 0.10.0 ### Features * Windows support for registration of C threads from callbacks https://github.com/ocamllabs/ocaml-ctypes/issues/450 * Auto-load custom printers in the OCaml toplevel https://github.com/ocamllabs/ocaml-ctypes/issues/448 * Add some extra `CArray` functions: `sub`, `copy`, `fold_right`, `fold_left`, `mapi`, `map`, `iter` https://github.com/ocamllabs/ocaml-ctypes/pull/323 ### Bug fixes * Build fix for OpenBSD https://github.com/ocamllabs/ocaml-ctypes/issues/454 * Fix for platforms (e.g. NetBSD) where standard integer types are defined as macros https://github.com/ocamllabs/ocaml-ctypes/issues/453 * Add missing bounds check in `CArray` https://github.com/ocamllabs/ocaml-ctypes/issues/447 ### Compatibility * Dl.dlsym now returns `nativeint`, not `Ctypes_ptr.voidp` https://github.com/ocamllabs/ocaml-ctypes/issues/445 Thanks to Andreas Hauptmann (@fdopen) for contributions to this release. ## ctypes 0.9.2 ### Bug fixes * Revert a ctypes-foreign build regression in 0.9.1 https://github.com/ocamllabs/ocaml-ctypes/pull/443 ## ctypes 0.9.1 ### Bug fixes * Fix build rules on OpenBSD https://github.com/ocamllabs/ocaml-ctypes/issues/428 * Fix a memory leak that occurs when passing closures to C https://github.com/ocamllabs/ocaml-ctypes/issues/436 Thanks to Enguerrand Decorne (@engil) for contributing to this release. ## ctypes 0.9.0 ### Features * NetBSD support * Support for releasing the runtime lock in generated stubs https://github.com/ocamllabs/ocaml-ctypes/issues/429 * Support for Lwt_preemptive https://github.com/ocamllabs/ocaml-ctypes/issues/430 Thanks to Martin Lucina (@mato) for contributing to this release. ## ctypes 0.8.0 ### Features * Use unboxed types for `uint8_t` and `uint16_t` https://github.com/ocamllabs/ocaml-ctypes/issues/413 * Reset `errno` in Lwt jobs before invoking job function https://github.com/ocamllabs/ocaml-ctypes/issues/426 * Add a `~thread_registration` argument to `funptr` to support registering C threads with the OCaml runtime. https://github.com/ocamllabs/ocaml-ctypes/issues/420 ### Bug fixes * Use `-opaque` for module interfaces whose `cmx` files are not installed. https://github.com/ocamllabs/ocaml-ctypes/issues/423 * Install `cstubs` `cmx` files. https://github.com/ocamllabs/ocaml-ctypes/issues/424 Thanks to David Sheets (@dsheets) and Demi Obenour (@DemiMarie) for contributions to this release. ## ctypes 0.7.0 ### Features * Add support for bytecode-only architectures https://github.com/ocamllabs/ocaml-ctypes/issues/410 * Add a new `sint` type corresponding to a full-range C integer and update `errno` support to use `sint` https://github.com/ocamllabs/ocaml-ctypes/issues/411 ### Bug fixes * Handle small integer return types correctly on big-endian platforms https://github.com/ocamllabs/ocaml-ctypes/issues/404 https://github.com/ocamllabs/ocaml-ctypes/issues/405 * Fix a bug with callbacks that return small types (less than a word) https://github.com/ocamllabs/ocaml-ctypes/issues/405 Thanks to Stephane Glondu (@glondu) for contributions to this release. ## ctypes 0.6.2 ### Bug fixes * Fix for argument quoting in the Windows build after new cross compilation support https://github.com/ocamllabs/ocaml-ctypes/pull/399 * Improve Lwt jobs support for functions with many or no arguments https://github.com/ocamllabs/ocaml-ctypes/pull/400 Thanks to Andreas Hauptmann (@fdopen) for contributing to this release. ## ctypes 0.6.1 ### Bug fixes * Fix constructor qualification in code generated for inverted stubs: https://github.com/ocamllabs/ocaml-ctypes/pull/397 ## ctypes 0.6.0 ### Features * The `Cstubs.FOREIGN` interface has been extended with `returning` and `@->`, and some new types. See the pull request for details: https://github.com/ocamllabs/ocaml-ctypes/pull/389 NB: code that generates bindings using `Cstubs` may need to be updated to select `return` and `@->` from the bindings functor argument rather than from the `Ctypes` module. Code that needs to be updated will fail to compile with the new interface. The pull request shows how to update your code, if necessary. * The `Cstubs` module can now generate asynchronous bindings to C functions using the Lwt jobs framework. See the pull request for details: https://github.com/ocamllabs/ocaml-ctypes/pull/391 * The `Cstubs` module now supports optionally returning `errno` alongside the return value of bound C functions. See the pull request for details: https://github.com/ocamllabs/ocaml-ctypes/pull/392 * Cross-compilation support is improved: the configuration step no longer runs binaries on the host. See the pull request for details: https://github.com/ocamllabs/ocaml-ctypes/pull/383 * The `Unsigned.S` interface has new `of_int64` and `to_int64` functions. ### Compatibility * The deprecated `*:*` and `+:+` functions have been removed. Use `Ctypes.field` instead. * OCaml 4.00.* is no longer supported. The earliest supported OCaml release is 4.01.0 Thanks to Spiros Eliopoulos (@seliopou), @orbitz, Leonid Rozenberg (@rleonid) and Peter Zotov (@whitequark) for contributions to this release. ## ctypes 0.5.1 ### Bug fixes * Use a C function, not `Pervasives.ignore`, to keep values alive. ## ctypes 0.5.0 Thanks to Andreas Hauptmann (@fdopen), David Sheets (@dsheets), Etienne Millon (@emillon), Goswin von Brederlow (@mrvn), Leonid Rozenberg (@rleonid), @orbitz, Max Mouratov (@cakeplus), and Peter Zotov (@whitequark) for contributions to this release. ### Features * Build and install `*.cmt` and `*.cmti` files. * Expose `time_t` as an unsigned value * Expose larger interfaces for POSIX types known to be integer types. * Add support for 1- and 2-byte unsigned integer typedefs. * Add support for 1-byte and 2-byte integer typedefs. * Add a `Signed.Int` module. * Expose more information in the `Uncoercible` exception. * `allocate_n` now defaults to zeroing its memory. * Add public root management interface. NB: the interface is experimental and subject to change. * Look through views to add fields to structs and unions. * Support signed arithmetic operations for `ssize_t`. * Add support for `ptrdiff_t` as a typedef for a signed integer type. * Support `intptr_t` and `uintptr_t` as typedefs * Support coercions between object and function pointers. * Add public `funptr_of_raw_address` function. * Support `static_funptr` coercions * Add function pointers to the core type language (See the `Ctypes_static.static_funptr` type, on which `Foreign.funptr` and `Foreign.foreign` are now based.) * Better support for functions returning void with inverted stubs. * Add support for releasing runtime lock to Cstubs_inverted. ### Bug fixes * Fix: inconsistent use of `caml_stat_*` functions * Fix: a memory leak in `ctypes_caml_roots_release` ## ctypes 0.4.2 * Fix a bug involving access to local roots while the runtime lock was not held. ## ctypes 0.4.1 Thanks to Etienne Millon (@emillon) for contributing to this release. * Fix placement of docstring titles * Add funptr's optional arguments to funptr_opt * Fix a typo in libffi detection code * Synchronize foreign.mli files (documentation) ## ctypes 0.4 Thanks to A. Hauptmann (@fdopen), David Sheets (@dsheets), Maverick Woo (@maverickwoo), Peter Zotov (@whitequark), David Kaloper (@pqwy), Ramkumar Ramachandra (@artagnon), Thomas Braibant (@braibant), Hugo Heuzard (@hhugo) and Edwin Török (@edwintorok) for contributions to this release. ### Major features * Support for the C99 bool type * Typedef support * Enum support * Support for accessing C globals with foreign_value in generated stubs * Support for retrieving #define and enum constants from C * Windows support There is now support for Windows (32-bit and 64-bit, using MinGW) and automatic building and testing on Windows using [Appveyor][appveyor-builds]. * Support for releasing the runtime lock in C calls The new `release_runtime_lock` argument to `Foreign.foreign` indicates whether the OCaml runtime lock should be released during the call to the bound C function, allowing other threads to run. * Support for acquiring the runtime lock in callbacks There is a new `runtime_lock` argument to `Foreign.funptr`. Setting `runtime_lock` to `true` indicates that the OCaml runtime lock should be acquired during calls from C to OCaml and released during calls through function pointers from OCaml to C. * Support for passing 'bytes' values directly to C See the [relevant section of the FAQ][strings_faq]. * Add support for custom printers in views. * Optionally obtain struct and union layout from C #### Other changes * string_opt wraps char *, not void *. * Remove some poorly-supported POSIX types * Use nativeint to represent pointers * Support zero-argument callbacks * findlib package naming: ctypes.foreign-base ~> ctypes.foreign.base &c. * Make it possible to print a field name * Better exception handling when using RTLD_NOLOAD * RTLD_LOCAL support * Changed the #include path to $(ocamlfind query ctypes) * Renamed some internal modules to avoid name clashes [appveyor-builds]: https://ci.appveyor.com/project/yallop/ocaml-ctypes/branch/master ## ctypes 0.3.4 #### Bug fixes Thanks to Yakov Zaytsev (@ysz) for contributing to this release. * fix printing for nullary function stubs ## ctypes 0.3.3 #### Bug fixes * respect `pbyte_offset` with cstubs ## ctypes 0.3.2 * Add bytes to the META "requires" field ## ctypes 0.3.1 #### New features * Support for 'bytes' #### Bug fixes * Avoid invalidated pointer access ## ctypes 0.3 Thanks to Peter Zotov (@whitequark), David Sheets (@dsheets), Mike McClurg (@mcclurmc) and Anil Madhavapeddy (@avsm) for contributions to this release. #### Major features ##### Support for passing OCaml strings directly to C (Patch by Peter Zotov.) The implications are discussed [in the FAQ][strings_faq]. [strings_faq]: https://github.com/ocamllabs/ocaml-ctypes/wiki/FAQ#strings ##### Support for generating C stubs from names and type declarations. There are various examples available of packages which use stub support: see the [fts example][fts-example] in the distribution (which uses a custom Makefile), [this fork of async_ssl][async_ssl] (which uses OCamlMakefile), and [the cstubs branch of ocaml-lz4][ocaml-lz4] (which uses oasis and ocamlbuild). [fts-example]: https://github.com/ocamllabs/ocaml-ctypes/tree/master/examples/fts/stub-generation [async_ssl]: https://github.com/yallop/async_ssl/tree/stub-generation [ocaml-lz4]: https://github.com/whitequark/ocaml-lz4/tree/cstubs ##### Support for turning OCaml modules into C libraries. See the [ocaml-ctypes-inverted-stubs-example][inverted-stubs-example] repository for a sample project which exposes a part of [Xmlm][xmlm]'s API to C. [inverted-stubs-example]: https://github.com/yallop/ocaml-ctypes-inverted-stubs-example/ [xmlm]: http://erratique.ch/software/xmlm #### Other changes * Add a function [`string_from_ptr`][string_from_ptr] for creating a string from an address and length. * Generate [codes for libffi ABI specifications][libffi_abi]. * Support for passing complex numbers to C using the stub generation backend. * Add [`raw_address_of_ptr`][raw_address_of_ptr], an inverse of [`ptr_of_raw_address`][ptr_of_raw_address]. * Add a function [`typ_of_bigarray_kind`][typ_of_bigarray_kind] for converting `Bigarray.kind` values to `Ctypes.typ` values. * Improved [coercion][coercion] support [typ_of_bigarray_kind]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALtyp_of_bigarray_kind [string_from_ptr]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALstring_from_ptr [raw_address_of_ptr]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALraw_address_of_ptr [ptr_of_raw_address]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALptr_of_raw_address [CArray]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.Array.html [libffi_abi]: http://ocamllabs.github.io/ocaml-ctypes/Libffi_abi.html [coercion]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALcoerce #### Backwards incompatibilities * `Array` has been renamed to [`CArray`][CArray]. ## ctypes 0.2.3 #### Bug fixes * Fix GC-related bug that shows up on OS X. ## ctypes 0.2.2 * Don't install ctypes-foreign cmx files. ## ctypes 0.2.1 * Bump META version ## ctypes 0.2 Thanks to Ivan Gotovchits, Greg Perkins, Daniel Bünzli, Rob Hoes and Anil Madhavapeddy for contributions to this release. #### Major features ##### Bigarray support. See [Bigarray types][bigarray-types] and [Bigarray values][bigarray-values] for details. [bigarray-types]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#4_Bigarraytypes [bigarray-values]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#4_Bigarrayvalues ##### Give the user control over the lifetime of closures passed to C. See [the FAQ][faq-lifetime] for details. [faq-lifetime]: https://github.com/ocamllabs/ocaml-ctypes/wiki/FAQ#function-lifetime ##### Top level printing for C values and types Loading the new findlib package `ctypes.top` in the toplevel will install custom printers for C types and values. #### Other changes * Basic [coercion][coercion] support * Remove `returning_checking_errno`; pass a flag to [`foreign`][foreign] instead. * Add an optional argument to [`Foreign.foreign`][foreign] that ignores absent symbols. (Patch by Daniel Bünzli.) * More precise tests for whether types are 'passable' * Compulsory names for structure and union fields (`*:*` and `+:+` are deprecated, but still supported for now.) * [`UInt32.of_int32`][of_int32], [`UInt32.to_int32`][to_int32], [`UInt64.of_int64`][of_int64], and [`UInt64.to_int64`][to_int64] functions. * Finalisers for ctypes-allocated memory. * Add a [`string_opt`][string_opt] view (Patch by Rob Hoes.) * Add the ['camlint'][camlint] basic type. * Complex number support * Abstract types [now have names][abstract]. [foreign]: http://ocamllabs.github.io/ocaml-ctypes/Foreign.html#VALforeign [of_int32]: http://ocamllabs.github.io/ocaml-ctypes/Unsigned.Uint32.html#VALof_int32 [to_int32]: http://ocamllabs.github.io/ocaml-ctypes/Unsigned.Uint32.html#VALto_int32 [of_int64]: http://ocamllabs.github.io/ocaml-ctypes/Unsigned.Uint64.html#VALof_int64 [to_int64]: http://ocamllabs.github.io/ocaml-ctypes/Unsigned.Uint64.html#VALto_int64 [string_opt]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALstring_opt [camlint]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALcamlint [abstract]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALabstract [coercion]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALcoerce ## ctypes 0.1.1 #### Bug fixes * Remove hard-coded alloc size ## ctypes 0.1 initial release yallop-ocaml-ctypes-3f8211a/LICENSE000066400000000000000000000020401445631112600167430ustar00rootroot00000000000000Copyright (c) 2013 Jeremy Yallop Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.yallop-ocaml-ctypes-3f8211a/Makefile000066400000000000000000000001261445631112600174010ustar00rootroot00000000000000.PHONY: build clean test build: dune build test: dune runtest clean: dune clean yallop-ocaml-ctypes-3f8211a/README.md000066400000000000000000000100061445631112600172160ustar00rootroot00000000000000ctypes is a library for binding to C libraries using pure OCaml. The primary aim is to make writing C extensions as straightforward as possible. The core of ctypes is a set of combinators for describing the structure of C types -- numeric types, arrays, pointers, structs, unions and functions. You can use these combinators to describe the types of the functions that you want to call, then bind directly to those functions -- all without writing or generating any C! ![GitHub Actions status](https://github.com/ocamllabs/ocaml-ctypes/workflows/Ctypes/badge.svg) ## Usage Suppose you want to bind to the following C functions: ```C int sigemptyset(sigset_t *set); int sigfillset(sigset_t *set); int sigaddset(sigset_t *set, int signum); int sigdelset(sigset_t *set, int signum); int sigismember(const sigset_t *set, int signum); ``` Using ctypes you can describe the interfaces to these functions as follows: ```OCaml let sigemptyset = foreign "sigemptyset" (ptr sigset_t @-> returning int) let sigfillset = foreign "sigfillset" (ptr sigset_t @-> returning int) let sigaddset = foreign "sigaddset" (ptr sigset_t @-> int @-> returning int) let sigdelset = foreign "sigdelset" (ptr sigset_t @-> int @-> returning int) let sigismember = foreign "sigismember" (ptr sigset_t @-> int @-> returning int) ``` The names bound by this code have the types you might expect: ```OCaml val sigemptyset : sigset_t ptr -> int val sigfillset : sigset_t ptr -> int val sigaddset : sigset_t ptr -> int -> int val sigdelset : sigset_t ptr -> int -> int val sigismember : sigset_t ptr -> int -> int ``` That's all there is to it. Unlike the [usual way](http://caml.inria.fr/pub/docs/manual-ocaml/intfc.html) of writing C extensions, there are no C "stub" functions to write, so there's much less opportunity for error. The documentation and source distribution contain more complex examples, involving structs, unions, arrays, callback functions, and so on, and show how to create and use C values (like instances of `sigset_t ptr`) in OCaml. ## Links * [Building C libraries in OCaml with the dune ctypes stanza][dune-ctypes] describes how to use ctypes with [dune][dune] * [Chapter 19: Foreign Function Interface][rwo-ffi] of [Real World OCaml][rwo] describes ctypes * [Modular Foreign Function Bindings][mirage-blogpost] introduces ctypes in the context of the [Mirage][mirage] library operating system * [Tutorial][tutorial] * [API documentation][apidoc] * [Mailing list][mailing-list] * [Type-safe C bindings using ocaml-ctypes and stub generation][sjb-cstubs-post] introduces the [Cstubs][cstubs] interface * [Using Cstubs_structs][orbitz-cstubs_structs] shows how to use the [`Cstubs_structs`][cstubs_structs] module to reliably determine data layout * [A modular foreign function interface][scp-extended] is a research paper (extending an [earlier paper][flops-paper]) that presents the design of ctypes * [FAQ][faq] [rwo-ffi]: https://dev.realworldocaml.org/foreign-function-interface.html [rwo]: http://realworldocaml.org/ [mirage-blogpost]: https://mirage.io/blog/modular-foreign-function-bindings [tutorial]: https://github.com/ocamllabs/ocaml-ctypes/wiki/ctypes-tutorial [apidoc]: https://docs.ocaml.pro/docs/LIBRARY.ctypes@ctypes.0.17.1/index.html [mailing-list]: http://lists.ocaml.org/listinfo/ctypes [faq]: https://github.com/ocamllabs/ocaml-ctypes/wiki/FAQ [mirage]: https://mirage.io/ [sjb-cstubs-post]: http://simonjbeaumont.com/posts/ocaml-ctypes/ [cstubs]: https://github.com/ocamllabs/ocaml-ctypes/blob/master/src/cstubs/cstubs.mli [orbitz-cstubs_structs]: https://github.com/ocamllabs/ocaml-ctypes/blob/master/examples/cstubs_structs/README.md [cstubs_structs]: http://ocamllabs.github.io/ocaml-ctypes/Cstubs_structs.html [flops-paper]: http://www.cl.cam.ac.uk/~jdy22/papers/declarative-foreign-function-binding-through-generic-programming.pdf [scp-extended]: http://www.cl.cam.ac.uk/~jdy22/papers/a-modular-foreign-function-interface.pdf [dune-ctypes]: https://michael.bacarella.com/2022/02/19/dune-ctypes/ [dune]: https://dune.build/ yallop-ocaml-ctypes-3f8211a/ctypes-foreign.opam000066400000000000000000000023561445631112600215640ustar00rootroot00000000000000# This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "Dynamic access to foreign C libraries using Ctypes" description: """ This installs the `ctypes-foreign` interface which uses `libffi` to provide dynamic access to foreign libraries.""" maintainer: ["Jeremy Yallop "] authors: ["Jeremy Yallop"] license: "MIT" tags: ["org:mirage" "org:ocamllabs"] homepage: "https://github.com/ocamllabs/ocaml-ctypes" doc: "https://ocamllabs.github.io/ocaml-ctypes/" bug-reports: "https://github.com/ocamllabs/ocaml-ctypes/issues" depends: [ "dune" {>= "2.9"} "ocaml" {>= "4.03.0"} "integers" {with-test & >= "0.2.2"} "ctypes" {= version} "dune-configurator" "conf-pkg-config" "lwt" {with-test & >= "2.4.7"} "ounit2" {with-test} "conf-ncurses" {with-test} "stdlib-shims" {with-test} "conf-fts" {with-test & os != "win32"} "conf-libffi" {>= "2.0.0"} "odoc" {with-doc} ] build: [ ["dune" "subst"] {dev} [ "dune" "build" "-p" name "-j" jobs "--promote-install-files=false" "@install" "@runtest" {with-test} "@doc" {with-doc} ] ["dune" "install" "-p" name "--create-install-files" name] ] dev-repo: "git+https://github.com/ocamllabs/ocaml-ctypes.git" yallop-ocaml-ctypes-3f8211a/ctypes.opam000066400000000000000000000033601445631112600201310ustar00rootroot00000000000000# This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "Combinators for binding to C libraries without writing any C" description: """ ctypes is a library for binding to C libraries using pure OCaml. The primary aim is to make writing C extensions as straightforward as possible. The core of ctypes is a set of combinators for describing the structure of C types -- numeric types, arrays, pointers, structs, unions and functions. You can use these combinators to describe the types of the functions that you want to call, then bind directly to those functions -- all without writing or generating any C! To install the optional `ctypes-foreign` interface (which uses `libffi` to provide dynamic access to foreign libraries), you will need to also install the `ctypes-foreign` package. opam install ctypes-foreign This will make the `ctypes-foreign` ocamlfind subpackage available.""" maintainer: ["Jeremy Yallop "] authors: ["Jeremy Yallop"] license: "MIT" tags: ["org:mirage" "org:ocamllabs"] homepage: "https://github.com/ocamllabs/ocaml-ctypes" doc: "https://ocamllabs.github.io/ocaml-ctypes/" bug-reports: "https://github.com/ocamllabs/ocaml-ctypes/issues" depends: [ "dune" {>= "2.9"} "ocaml" {>= "4.03.0"} "integers" "dune-configurator" "bigarray-compat" "ounit2" {with-test} "conf-fts" {with-test & os != "win32"} "conf-pkg-config" {with-test} "odoc" {with-doc} ] build: [ ["dune" "subst"] {dev} [ "dune" "build" "-p" name "-j" jobs "--promote-install-files=false" "@install" "@runtest" {with-test} "@doc" {with-doc} ] ["dune" "install" "-p" name "--create-install-files" name] ] dev-repo: "git+https://github.com/ocamllabs/ocaml-ctypes.git" yallop-ocaml-ctypes-3f8211a/dune000066400000000000000000000002241445631112600166160ustar00rootroot00000000000000(env (dev (flags (:standard -principal)))) (deprecated_library_name (old_public_name "ctypes.foreign") (new_public_name "ctypes-foreign")) yallop-ocaml-ctypes-3f8211a/dune-project000066400000000000000000000037301445631112600202670ustar00rootroot00000000000000(lang dune 2.9) (name ctypes) (version 0.21.1) (formatting (enabled_for dune)) (use_standard_c_and_cxx_flags true) (generate_opam_files true) (license MIT) (maintainers "Jeremy Yallop ") (authors "Jeremy Yallop") (source (github ocamllabs/ocaml-ctypes)) (documentation "https://ocamllabs.github.io/ocaml-ctypes/") (package (name ctypes) (tags (org:mirage org:ocamllabs)) (depends (ocaml (>= 4.03.0)) integers dune-configurator bigarray-compat (ounit2 :with-test) (conf-fts (and :with-test (<> :os win32))) (conf-pkg-config :with-test)) (synopsis "Combinators for binding to C libraries without writing any C") (description " ctypes is a library for binding to C libraries using pure OCaml. The primary aim is to make writing C extensions as straightforward as possible. The core of ctypes is a set of combinators for describing the structure of C types -- numeric types, arrays, pointers, structs, unions and functions. You can use these combinators to describe the types of the functions that you want to call, then bind directly to those functions -- all without writing or generating any C! To install the optional `ctypes-foreign` interface (which uses `libffi` to provide dynamic access to foreign libraries), you will need to also install the `ctypes-foreign` package. opam install ctypes-foreign This will make the `ctypes-foreign` ocamlfind subpackage available.")) (package (name ctypes-foreign) (tags (org:mirage org:ocamllabs)) (depends (ocaml (>= 4.03.0)) (integers (and :with-test (>= 0.2.2))) (ctypes (= :version)) dune-configurator conf-pkg-config (lwt (and :with-test (>= 2.4.7))) (ounit2 :with-test) (conf-ncurses :with-test) (stdlib-shims :with-test) (conf-fts (and :with-test (<> :os win32))) (conf-libffi (>= 2.0.0))) (synopsis "Dynamic access to foreign C libraries using Ctypes") (description " This installs the `ctypes-foreign` interface which uses `libffi` to provide dynamic access to foreign libraries.")) yallop-ocaml-ctypes-3f8211a/examples/000077500000000000000000000000001445631112600175605ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/cstubs_structs/000077500000000000000000000000001445631112600226525ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/cstubs_structs/Makefile000066400000000000000000000031751445631112600243200ustar00rootroot00000000000000all: main # Step 1 bindings.cmx: bindings.ml ocamlfind ocamlopt -w '@f@p@u@s@40' -package ctypes,ctypes.foreign,ctypes.stubs -c bindings.ml # Step 2 bindings_c_gen.cmx: bindings_c_gen.ml bindings.cmx ocamlfind ocamlopt -w '@f@p@u@s@40' -package ctypes,ctypes.foreign,ctypes.stubs -c bindings_c_gen.ml bindings.cmx # Step 3 compiling bindings_c_gen: bindings_c_gen.cmx bindings.cmx 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 # Step 3 executing bindings_stubs_gen.c: bindings_c_gen ./bindings_c_gen # Step 4 compiling bindings_stubs_gen.o: bindings_stubs_gen.c ocamlfind ocamlc -w '@f@p@u@s@40' -package ctypes,ctypes.foreign -c bindings_stubs_gen.c # Step 4 compiling bindings_stubs_gen: bindings_stubs_gen.o cc -o bindings_stubs_gen bindings_stubs_gen.o # Step 5 bindings_stubs.ml: bindings_stubs_gen ./bindings_stubs_gen > bindings_stubs.ml # Step 6 bindings_stubs.cmx: bindings_stubs.ml ocamlfind ocamlopt -w '@f@p@u@s@40' -package ctypes,ctypes.foreign,ctypes.stubs -c bindings_stubs.ml # Use in the main program main.cmx: bindings_stubs.cmx main.ml ocamlfind ocamlopt -w '@f@p@u@s@40' -package ctypes,ctypes.foreign,ctypes.stubs -c main.ml bindings_stubs.cmx main: main.cmx ocamlfind ocamlopt -w '@f@p@u@s@40' -package ctypes,ctypes.foreign,ctypes.stubs -linkpkg -o main bindings.cmx bindings_stubs.cmx main.cmx clean: -rm *.cmx *.cmi *.c *.o bindings_c_gen bindings_stubs_gen bindings_stubs.ml main with_ocamlbuild: ocamlbuild -use-ocamlfind -package ctypes,ctypes.foreign,ctypes.stubs main.native ocamlbuild_clean: ocamlbuild -clean yallop-ocaml-ctypes-3f8211a/examples/cstubs_structs/README.md000066400000000000000000000067371445631112600241460ustar00rootroot00000000000000# Using Cstubs_structs Ctypes is generally used to specify how to call C code using a DSL that is executed at runtime. This works great for functions but has some limitations when it comes to data types and macros. For example, one can define a C struct using the Ctypes DSL, however the complete data type needs to be defined so that Ctypes can calculate the proper size of the struct and the correct offsets of members. However, with some structs one may only want to access part of the struct, or it might be large, or can change across OS and OS versions, or may be constructed using compile-time tools such as macros. In those cases, `Cstubs_structs` provides a powerful tool to use C itself to generate the ML definition of the struct that Ctypes can then use at runtime. This definition will always be correct. Because C is being used to generate the definition, it also gives access to other constructs that only exist at compile time, such as macros. Using Cstubs_structs is a bit of a Rube Goldberg machine, however, no step is superfluous. The series of steps that will be needed are: 1. Write a stubs module that is a functor which defines the bindings. 2. Write a module that uses the bindings module and outputs a C file. 3. Compile the program from step 2 and execute it. 4. Compile the C program generated in step 3. 5. Run the C program from step 4, generating an ML module. 6. Compile the module generated in step 5. The generated module can then be applied to the functor created in step 1. # Example The example program included in this tutorial shows how to partially define a struct and access a macro. The struct is `struct tm`, which is used in the time API in C. And the macro is `SHRT_MAX`, which defines the maximum value a value of type `short` can hold. ## The Makefile This tutorial contains a `Makefile` which builds the tutorial. This is done using a Makefile to make the steps clear and executable anywhere. ## Bindings The file `bindings.ml` defines the functor for the stubs. The struct is defined in the module `Tm` and defines that the value `t` is the structure `tm`. The two fields defined are `tm_hour` and `tm_year`. The actual `struct tm` has several fields in its struct. The strings are important in this case because they will be what the generated C program references. The module `Limits` defines the value `shrt_max` which corresponds to a constant value of type `int`. Again, the string is important because that is the name of the macro which will be referenced. ## C Generator The file `bindings_c_gen.ml` defines the ML program which will generate a C source file when executed. The important line is the one that calls `Cstubs_structs.write_c`. This takes the functor which will be applied as a parameter. This functor is applied to a module that generates the C program and outputs it. ## Using it The file `main.ml` defines a usage of the generated ML file. It applies to the `Bindings.Stubs` functor the module, `Bindings_stubs`, that was generated after running the generated C program. Accessing the struct and constant is the same as if it were generated at runtime. # A lot of steps, but not much code The process of using `Cstubs_structs` is has several steps to it, however the amount of code needed to do the whole thing is fairly small. Most of the magic is in the build process. When binding data types, it might be a good idea to use `Cstubs_structs` as the default tool, it is safer and less fragile then defining a struct completely in Ocaml. yallop-ocaml-ctypes-3f8211a/examples/cstubs_structs/bindings.ml000066400000000000000000000005561445631112600250070ustar00rootroot00000000000000module Stubs = functor (S : Cstubs_structs.TYPE) -> struct module Tm = struct type tm type t = tm Ctypes.structure let t : t S.typ = S.structure "tm" let tm_hour = S.(field t "tm_hour" int) let tm_year = S.(field t "tm_year" int) let () = S.seal t end module Limits = struct let shrt_max = S.(constant "SHRT_MAX" short) end end yallop-ocaml-ctypes-3f8211a/examples/cstubs_structs/bindings_c_gen.ml000066400000000000000000000005651445631112600261420ustar00rootroot00000000000000let c_headers = "#include \n#include " let main () = let stubs_out = open_out "bindings_stubs_gen.c" in let stubs_fmt = Format.formatter_of_out_channel stubs_out in Format.fprintf stubs_fmt "%s@\n" c_headers; Cstubs_structs.write_c stubs_fmt (module Bindings.Stubs); Format.pp_print_flush stubs_fmt (); close_out stubs_out let () = main () yallop-ocaml-ctypes-3f8211a/examples/cstubs_structs/main.ml000066400000000000000000000011601445631112600241260ustar00rootroot00000000000000module Stubs = Bindings.Stubs(Bindings_stubs) let time = Foreign.foreign "time" Ctypes.(ptr PosixTypes.time_t @-> returning PosixTypes.time_t) let gmtime = Foreign.foreign "gmtime" Ctypes.(ptr PosixTypes.time_t @-> returning (ptr Stubs.Tm.t)) let main () = let tme = Ctypes.allocate PosixTypes.time_t (time Ctypes.(from_voidp PosixTypes.time_t null)) in let tm = gmtime tme in Printf.printf "tm_hour = %d\n" Ctypes.(getf (!@ tm) Stubs.Tm.tm_hour); Printf.printf "tm_year = %d\n" Ctypes.(getf (!@ tm) Stubs.Tm.tm_year); Printf.printf "SHRT_MAX = %d\n" Stubs.Limits.shrt_max let () = main () yallop-ocaml-ctypes-3f8211a/examples/cstubs_structs/myocamlbuild.ml000066400000000000000000000025221445631112600256660ustar00rootroot00000000000000(* This example relies on Ocamlbuild version 0.9.0 (specifically on PR#6794). Otherwise compiling bindings_stubs_gen.c, Step 4, will fail because the package information isn't passed to "ocamlfind ocamlc". *) open Ocamlbuild_plugin let () = let additional_rules = function | Before_hygiene -> () | After_hygiene -> () | Before_options -> () | After_options -> () | Before_rules -> () | After_rules -> (* Generate stubs. Steps 1, 2, & 3 of Makefile (1 & 2 via built-in rules). ML -> C *) rule "cstubs: x_c_gen.native -> x_stubs_gen.c" ~dep:"%_c_gen.native" ~prod:"%_stubs_gen.c" (fun env _build -> Cmd (A (env "./%_c_gen.native"))); (* Step 4. OCamlbuild (nor ocamlc/ocamlopt) has a built in rule for linking executables from C. Call out to 'cc'. *) rule "stub_gen 1: x_stubs_gen.o -> x_stubs_gen" ~dep:"%_stubs_gen.o" ~prod:"%_stubs_gen" (fun env _build -> Cmd (S [ A "cc"; A "-o"; A (env "%_stubs_gen"); A (env "%_stubs_gen.o") ])); (* Step 5. Generate ml stubs. C -> ML *) rule "stubs_gen 2: x_stubs_gen -> x_stubs.ml" ~dep:"%_stubs_gen" ~prod:"%_stubs.ml" (fun env _build -> Cmd (S[A (env "./%_stubs_gen"); Sh">"; A (env "%_stubs.ml")])); in dispatch additional_rules yallop-ocaml-ctypes-3f8211a/examples/date/000077500000000000000000000000001445631112600204755ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/date/foreign/000077500000000000000000000000001445631112600221265ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/date/foreign/date.ml000066400000000000000000000023521445631112600233770ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open PosixTypes open Foreign type tm let tm = structure "tm" let (-:) ty label = field tm label ty let tm_sec = int -: "tm_sec" (* seconds *) let tm_min = int -: "tm_min" (* minutes *) let tm_hour = int -: "tm_hour" (* hours *) let tm_mday = int -: "tm_mday" (* day of the month *) let tm_mon = int -: "tm_mon" (* month *) let tm_year = int -: "tm_year" (* year *) let tm_wday = int -: "tm_wday" (* day of the week *) let tm_yday = int -: "tm_yday" (* day in the year *) let tm_isdst = int -: "tm_isdst" (* daylight saving time *) let () = seal (tm : tm structure typ) let time = foreign "time" ~check_errno:true (ptr time_t @-> returning time_t) let asctime = foreign "asctime" (ptr tm @-> returning string) let localtime = foreign "localtime" (ptr time_t @-> returning (ptr tm)) let () = begin let timep = allocate_n ~count:1 time_t in let time = time timep in assert (time = !@timep); let tm = localtime timep in Printf.printf "tm.tm_mon = %d\n" (getf !@tm tm_mon); Printf.printf "tm.tm_year = %d\n" (getf !@tm tm_year); print_endline (asctime tm) end yallop-ocaml-ctypes-3f8211a/examples/date/foreign/date.mli000066400000000000000000000012311445631112600235430ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open PosixTypes type tm val tm_sec : (int, tm structure) field val tm_min : (int, tm structure) field val tm_hour : (int, tm structure) field val tm_mday : (int, tm structure) field val tm_mon : (int, tm structure) field val tm_year : (int, tm structure) field val tm_wday : (int, tm structure) field val tm_yday : (int, tm structure) field val tm_isdst : (int, tm structure) field val time : time_t ptr -> time_t val asctime : tm structure ptr -> string val localtime : time_t ptr -> tm structure ptr yallop-ocaml-ctypes-3f8211a/examples/date/foreign/dune000066400000000000000000000000701445631112600230010ustar00rootroot00000000000000(executables (names date) (libraries ctypes-foreign)) yallop-ocaml-ctypes-3f8211a/examples/date/stub-generation/000077500000000000000000000000001445631112600236035ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/date/stub-generation/bindings/000077500000000000000000000000001445631112600254005ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/date/stub-generation/bindings/date_stubs.ml000066400000000000000000000017551445631112600300770ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open PosixTypes type tm let tm = structure "tm" let (-:) ty label = field tm label ty let tm_sec = int -: "tm_sec" (* seconds *) let tm_min = int -: "tm_min" (* minutes *) let tm_hour = int -: "tm_hour" (* hours *) let tm_mday = int -: "tm_mday" (* day of the month *) let tm_mon = int -: "tm_mon" (* month *) let tm_year = int -: "tm_year" (* year *) let tm_wday = int -: "tm_wday" (* day of the week *) let tm_yday = int -: "tm_yday" (* day in the year *) let tm_isdst = int -: "tm_isdst" (* daylight saving time *) let () = seal (tm : tm structure typ) module Bindings (F : Ctypes.FOREIGN) = struct open F let time = foreign "time" (ptr time_t @-> returning time_t) let asctime = foreign "asctime" (ptr tm @-> returning string) let localtime = foreign "localtime" (ptr time_t @-> returning (ptr tm)) end yallop-ocaml-ctypes-3f8211a/examples/date/stub-generation/bindings/dune000066400000000000000000000000611445631112600262530ustar00rootroot00000000000000(library (name date_stubs) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/examples/date/stub-generation/date_cmd.ml000066400000000000000000000010161445631112600256730ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open PosixTypes open Date_stubs module D = Bindings(Date_generated) open D let () = begin let timep = allocate_n ~count:1 time_t in let time = time timep in assert (time = !@timep); let tm = localtime timep in Printf.printf "tm.tm_mon = %d\n" (getf !@tm tm_mon); Printf.printf "tm.tm_year = %d\n" (getf !@tm tm_year); print_endline (asctime tm) end yallop-ocaml-ctypes-3f8211a/examples/date/stub-generation/dune000066400000000000000000000001051445631112600244550ustar00rootroot00000000000000(executable (name date_cmd) (libraries date_stubs date_generated)) yallop-ocaml-ctypes-3f8211a/examples/date/stub-generation/stub-generator/000077500000000000000000000000001445631112600265445ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/date/stub-generation/stub-generator/date_stub_generator.ml000066400000000000000000000013071445631112600331170ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) let c_headers = "#include " let main () = let ml_out = open_out "date_generated.ml" and c_out = open_out "date_stubs.c" in let ml_fmt = Format.formatter_of_out_channel ml_out and c_fmt = Format.formatter_of_out_channel c_out in Format.fprintf c_fmt "%s@\n" c_headers; Cstubs.write_c c_fmt ~prefix:"date_stub_" (module Date_stubs.Bindings); Cstubs.write_ml ml_fmt ~prefix:"date_stub_" (module Date_stubs.Bindings); Format.pp_print_flush ml_fmt (); Format.pp_print_flush c_fmt (); close_out ml_out; close_out c_out let () = main () yallop-ocaml-ctypes-3f8211a/examples/date/stub-generation/stub-generator/dune000066400000000000000000000005531445631112600274250ustar00rootroot00000000000000(executable (name date_stub_generator) (modules date_stub_generator) (libraries date_stubs ctypes.stubs ctypes)) (rule (targets date_stubs.c date_generated.ml) (deps date_stub_generator.exe) (action (run %{deps}))) (library (name date_generated) (modules date_generated) (foreign_stubs (language c) (names date_stubs)) (libraries ctypes.stubs)) yallop-ocaml-ctypes-3f8211a/examples/fts/000077500000000000000000000000001445631112600203545ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/fts/foreign/000077500000000000000000000000001445631112600220055ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/fts/foreign/dune000066400000000000000000000002031445631112600226560ustar00rootroot00000000000000(test (name fts_cmd) (enabled_if (= %{os_type} Unix)) (libraries ctypes-foreign) (package ctypes-foreign) (action (progn))) yallop-ocaml-ctypes-3f8211a/examples/fts/foreign/fts.ml000066400000000000000000000152621445631112600231410ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@warning "-9-32"] open Ctypes type fts_info = FTS_D | FTS_DC | FTS_DEFAULT | FTS_DNR | FTS_DOT | FTS_DP | FTS_ERR | FTS_F | FTS_NS | FTS_NSOK | FTS_SL | FTS_SLNONE let fts_info_of_int = function | 1 -> FTS_D | 2 -> FTS_DC | 3 -> FTS_DEFAULT | 4 -> FTS_DNR | 5 -> FTS_DOT | 6 -> FTS_DP | 7 -> FTS_ERR | 8 -> FTS_F (* | 9 -> FTS_INIT *) | 10 -> FTS_NS | 11 -> FTS_NSOK | 12 -> FTS_SL | 13 -> FTS_SLNONE | n -> invalid_arg ("fts_info: " ^ (string_of_int n)) type fts_open_option = FTS_COMFOLLOW | FTS_LOGICAL | FTS_NOCHDIR | FTS_NOSTAT | FTS_PHYSICAL | FTS_SEEDOT | FTS_XDEV let fts_children_option_of_bool = function | false -> 0 | true -> 0x0100 let fts_open_option_value = function | FTS_COMFOLLOW -> 0x0001 | FTS_LOGICAL -> 0x0002 | FTS_NOCHDIR -> 0x0004 | FTS_NOSTAT -> 0x0008 | FTS_PHYSICAL -> 0x0010 | FTS_SEEDOT -> 0x0020 | FTS_XDEV -> 0x0040 type fts_set_option = FTS_AGAIN | FTS_FOLLOW | FTS_SKIP let fts_set_option_value = function | FTS_AGAIN -> 1 | FTS_FOLLOW -> 2 | FTS_SKIP -> 4 let castp typ p = from_voidp typ (to_voidp p) module FTSENT = struct open PosixTypes open Unsigned type ftsent let ftsent : ftsent structure typ = structure "ftsent" let ( -: ) ty label = field ftsent label ty let fts_cycle = ptr ftsent -: "fts_cycle" let fts_parent = ptr ftsent -: "fts_parent" let fts_link = ptr ftsent -: "fts_link" let fts_number = int -: "fts_number" let fts_pointer = ptr void -: "fts_pointer" let fts_accpath = string -: "fts_accpath" let fts_path = string -: "fts_path" let fts_errno = int -: "fts_errno" let fts_symfd = int -: "fts_symfd" let fts_pathlen = ushort -: "fts_pathlen" let fts_namelen = ushort -: "fts_namelen" let fts_ino = ino_t -: "fts_ino" let fts_dev = dev_t -: "fts_dev" let fts_nlink = nlink_t -: "fts_nlink" let fts_level = short -: "fts_level" let fts_info = ushort -: "fts_info" let fts_flags = ushort -: "fts_flags" let fts_instr = ushort -: "fts_instr" let fts_statp = ptr void -: "fts_statp" (* really a struct stat * *) let fts_name = char -: "fts_name" let () = seal ftsent type t = ftsent structure ptr let t = ptr ftsent let info : t -> fts_info = fun t -> fts_info_of_int (UShort.to_int (getf !@t fts_info)) let accpath : t -> string = fun t -> getf !@t fts_accpath let path : t -> string = fun t -> getf !@t fts_path let name : t -> string = fun t -> Ctypes_coerce.coerce (ptr char) string (t |-> fts_name) let level : t -> int = fun t -> getf !@t fts_level let errno : t -> int = fun t -> getf !@t fts_errno let number : t -> int = fun t -> getf !@t fts_number let set_number : t -> int -> unit = fun t -> setf !@t fts_number let pointer : t -> unit ptr = fun t -> getf !@t fts_pointer let set_pointer : t -> unit ptr -> unit = fun t -> setf !@t fts_pointer let parent : t -> t = fun t -> getf !@t fts_parent let link : t -> t = fun t -> getf !@t fts_link let cycle : t -> t = fun t -> getf !@t fts_cycle end module FTS = struct open PosixTypes open FTSENT type fts let fts : fts structure typ = structure "fts" let ( -: ) ty label = field fts label ty let fts_cur = ptr ftsent -: "fts_cur" let fts_child = ptr ftsent -: "fts_child" let fts_array = ptr (ptr ftsent) -: "fts_array" let fts_dev = dev_t -: "fts_dev" let fts_path = string -: "fts_path" let fts_rfd = int -: "fts_rfd" let fts_pathlen = int -: "fts_pathlen" let fts_nitems = int -: "fts_nitems" let fts_compar = Foreign.funptr (ptr FTSENT.t @-> ptr FTSENT.t @-> returning int) -: "fts_compar" (* fts_options would work well as a view *) let fts_options = int -: "fts_options" let () = seal fts type t = { ptr : fts structure ptr; (* The compar field ties the lifetime of the comparison function to the lifetime of the fts object to prevent untimely collection. *) compar: (FTSENT.t ptr -> FTSENT.t ptr -> int) option } let cur : t -> FTSENT.t = fun { ptr } -> getf !@ptr fts_cur let child : t -> FTSENT.t = fun { ptr } -> getf !@ptr fts_child let array : t -> FTSENT.t list = fun { ptr } -> CArray.(to_list (from_ptr (getf !@ptr fts_array) (getf !@ptr fts_nitems))) let dev : t -> dev_t = fun { ptr } -> getf !@ptr fts_dev let path : t -> string = fun { ptr } -> getf !@ptr fts_path let rfd : t -> int = fun { ptr } -> getf !@ptr fts_rfd end open FTSENT open FTS (* FTS *fts_open(char * const *path_argv, int options, int ( *compar)(const FTSENT **, const FTSENT ** )); *) let compar_type = ptr FTSENT.t @-> ptr FTSENT.t @-> returning int let _fts_open = Foreign.foreign "fts_open" (ptr string @-> int @-> Foreign.funptr_opt compar_type @-> returning (ptr fts)) (* FTSENT *fts_read(FTS *ftsp); *) let _fts_read = Foreign.foreign "fts_read" ~check_errno:true (ptr fts @-> returning (ptr ftsent)) (* FTSENT *fts_children(FTS *ftsp, int options); *) let _fts_children = Foreign.foreign "fts_children" (ptr fts @-> int @-> returning (ptr ftsent)) (* int fts_set(FTS *ftsp, FTSENT *f, int options); *) let _fts_set = Foreign.foreign "fts_set" ~check_errno:true (ptr fts @-> ptr (ftsent) @-> int @-> returning int) (* int fts_close(FTS *ftsp); *) let _fts_close = Foreign.foreign "fts_close" ~check_errno:true (ptr fts @-> returning int) let crush_options f : 'a list -> int = List.fold_left (fun i o -> i lor (f o)) 0 let fts_read fts = let p = _fts_read fts.ptr in if to_voidp p = null then None else Some p let fts_close ftsp = ignore (_fts_close ftsp.ptr) let fts_set ~ftsp ~f ~options = ignore (_fts_set ftsp.ptr f (crush_options fts_set_option_value options)) let fts_children ~ftsp ~name_only = _fts_children ftsp.ptr (fts_children_option_of_bool name_only) let null_terminated_array_of_ptr_list typ list = let nitems = List.length list in let arr = CArray.make typ (1 + nitems) in List.iteri (CArray.set arr) list; (castp (ptr void) (CArray.start arr +@ nitems)) <-@ null; arr let fts_open ~path_argv ?compar ~options () = let paths = null_terminated_array_of_ptr_list string path_argv in let options = crush_options fts_open_option_value options in { ptr = _fts_open (CArray.start paths) options compar; compar } yallop-ocaml-ctypes-3f8211a/examples/fts/foreign/fts.mli000066400000000000000000000325041445631112600233100ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes (* The fts functions are provided for traversing file hierarchies. A simple overview is that the fts_open() function returns a "handle" on a file hierarchy, which is then supplied to the other fts functions. The function fts_read() returns a pointer to a structure describing one of the files in the file hierarchy. The function fts_children() returns a pointer to a linked list of structures, each of which describes one of the files contained in a directory in the hierarchy. In general, directories are visited two distinguishable times; in preorder (before any of their descendants are visited) and in postorder (after all of their descendants have been visited). Files are visited once. It is possible to walk the hierarchy "logically" (ignoring symbolic links) or physically (visiting symbolic links), order the walk of the hierarchy or prune and/or revisit portions of the hierarchy. *) type fts_info = (* A directory being visited in preorder. *) FTS_D (* A directory that causes a cycle in the tree. (The fts_cycle field of the FTSENT structure will be filled in as well.) *) | FTS_DC (* Any FTSENT structure that represents a file type not explicitly described by one of the other fts_info values. *) | FTS_DEFAULT (* A directory which cannot be read. This is an error return, and the fts_errno field will be set to indicate what caused the error. *) | FTS_DNR (* A file named "." or ".." which was not specified as a filename to fts_open() (see FTS_SEEDOT). *) | FTS_DOT (* A directory being visited in postorder. The contents of the FTSENT structure will be unchanged from when it was returned in preorder, that is, with the fts_info field set to FTS_D. *) | FTS_DP (* This is an error return, and the fts_errno field will be set to indicate what caused the error. *) | FTS_ERR (* A regular file. *) | FTS_F (* A file for which no stat(2) information was available. The contents of the fts_statp field are undefined. This is an error return, and the fts_errno field will be set to indicate what caused the error. *) | FTS_NS (* A file for which no stat(2) information was requested. The contents of the fts_statp field are undefined. *) | FTS_NSOK (* A symbolic link. *) | FTS_SL (* A symbolic link with a nonexistent target. The contents of the fts_statp field reference the file characteristic information for the symbolic link itself. *) | FTS_SLNONE module FTSENT : sig type t (* flags for FTSENT structure *) val info : t -> fts_info (* A path for accessing the file from the current directory. *) val accpath : t -> string (* The path for the file relative to the root of the traversal. This path contains the path specified to fts_open() as a prefix. *) val path : t -> string (* The name of the file. *) val name : t -> string (* The depth of the traversal, numbered from -1 to N, where this file was found. The FTSENT structure representing the parent of the starting point (or root) of the traversal is numbered -1, and the FTSENT structure for the root itself is numbered 0. *) val level : t -> int (* Upon return of a FTSENT structure from the fts_children() or fts_read() functions, with its fts_info field set to FTS_DNR, FTS_ERR or FTS_NS, the fts_errno field contains the value of the external variable errno specifying the cause of the error. Otherwise, the contents of the fts_errno field are undefined. *) val errno : t -> int (* This field is provided for the use of the application program and is not modified by the fts functions. It is initialized to 0. *) val number : t -> int val set_number : t -> int -> unit (* This field is provided for the use of the application program and is not modified by the fts functions. It is initialized to NULL. *) val pointer : t -> unit ptr val set_pointer : t -> unit ptr -> unit (* A pointer to the FTSENT structure referencing the file in the hierarchy immediately above the current file, that is, the directory of which this file is a member. A parent structure for the initial entry point is provided as well, however, only the fts_level, fts_number and fts_pointer fields are guaranteed to be initialized. *) val parent : t -> t (* Upon return from the fts_children() function, the fts_link field points to the next structure in the NULL-terminated linked list of directory members. Otherwise, the contents of the fts_link field are undefined. *) val link : t -> t (* If a directory causes a cycle in the hierarchy (see FTS_DC), either because of a hard link between two directories, or a symbolic link pointing to a directory, the fts_cycle field of the structure will point to the FTSENT structure in the hierarchy that references the same file as the current FTSENT structure. Otherwise, the contents of the fts_cycle field are undefined. *) val cycle : t -> t (* A pointer to stat(2) information for the file. *) (* val statp : t -> stat *) end module FTS : sig type t val cur : t -> FTSENT.t val child : t -> FTSENT.t val array : t -> FTSENT.t list val dev : t -> PosixTypes.dev_t val path : t -> string val rfd : t -> int end type fts_open_option = (* This option causes any symbolic link specified as a root path to be followed immediately whether or not FTS_LOGICAL is also specified. *) FTS_COMFOLLOW (* This option causes the fts routines to return FTSENT structures for the targets of symbolic links instead of the symbolic links themselves. If this option is set, the only symbolic links for which FTSENT structures are returned to the application are those referencing nonexistent files. Either FTS_LOGICAL or FTS_PHYSICAL must be provided to the fts_open() function. *) | FTS_LOGICAL (* As a performance optimization, the fts functions change directories as they walk the file hierarchy. This has the side-effect that an application cannot rely on being in any particular directory during the traversal. The FTS_NOCHDIR option turns off this optimization, and the fts functions will not change the current directory. Note that applications should not themselves change their current directory and try to access files unless FTS_NOCHDIR is specified and absolute pathnames were provided as arguments to fts_open(). *) | FTS_NOCHDIR (* By default, returned FTSENT structures reference file characteristic information (the statp field) for each file visited. This option relaxes that requirement as a performance optimization, allowing the fts functions to set the fts_info field to FTS_NSOK and leave the contents of the statp field undefined. *) | FTS_NOSTAT (* This option causes the fts routines to return FTSENT structures for symbolic links themselves instead of the target files they point to. If this option is set, FTSENT structures for all symbolic links in the hierarchy are returned to the application. Either FTS_LOGICAL or FTS_PHYSICAL must be provided to the fts_open() function. *) | FTS_PHYSICAL (* By default, unless they are specified as path arguments to fts_open(), any files named "." or ".." encountered in the file hierarchy are ignored. This option causes the fts routines to return FTSENT structures for them. *) | FTS_SEEDOT (* This option prevents fts from descending into directories that have a different device number than the file from which the descent began. *) | FTS_XDEV (* The fts_open() function takes a list of strings naming one or more paths which make up a logical file hierarchy to be traversed. There are a number of options, at least one of which (either FTS_LOGICAL or FTS_PHYSICAL) must be specified. The argument compar() specifies a user-defined function which may be used to order the traversal of the hierarchy. It takes two pointers to pointers to FTSENT structures as arguments and should return a negative value, zero, or a positive value to indicate if the file referenced by its first argument comes before, in any order with respect to, or after, the file referenced by its second argument. The fts_accpath, fts_path and fts_pathlen fields of the FTSENT structures may never be used in this comparison. If the fts_info field is set to FTS_NS or FTS_NSOK, the fts_statp field may not either. If the compar() argument is NULL, the directory traversal order is in the order listed in path_argv for the root paths, and in the order listed in the directory for everything else. *) val fts_open : path_argv:string list -> ?compar:(FTSENT.t ptr -> FTSENT.t ptr -> int) -> options:fts_open_option list -> unit -> FTS.t (* The fts_children() function returns a pointer to an FTSENT structure describing the first entry in a NULL-terminated linked list of the files in the directory represented by the FTSENT structure most recently returned by fts_read(). The list is linked through the fts_link field of the FTSENT struc‐ ture, and is ordered by the user-specified comparison function, if any. Repeated calls to fts_children() will recreate this linked list. As a special case, if fts_read() has not yet been called for a hierarchy, fts_children() will return a pointer to the files in the logical directory specified to fts_open(), that is, the arguments specified to fts_open(). Otherwise, if the FTSENT structure most recently returned by fts_read() is not a directory being visited in preorder, or the directory does not contain any files, fts_children() returns NULL and sets errno to zero. If an error occurs, fts_children() returns NULL and sets errno appropriately. The FTSENT structures returned by fts_children() may be overwritten after a call to fts_children(), fts_close() or fts_read() on the same file hierarchy stream. The name_only option indicates that only the names of the files are needed. The contents of all the fields in the returned linked list of structures are undefined with the exception of the fts_name and fts_namelen fields. *) val fts_children : ftsp:FTS.t -> name_only:bool -> FTSENT.t (* The fts_read() function returns a pointer to an FTSENT structure describing a file in the hierarchy. Directories (that are readable and do not cause cycles) are visited at least twice, once in preorder and once in postorder. All other files are visited at least once. (Hard links between directories that do not cause cycles or symbolic links to symbolic links may cause files to be visited more than once, or directories more than twice.) The FTSENT structures returned by fts_read() may be overwritten after a call to fts_close() on the same file hierarchy stream, or, after a call to fts_read() on the same file hierarchy stream unless they represent a file of type directory, in which case they will not be overwritten until after a call to fts_read() after the FTSENT structure has been returned by the function fts_read() in postorder. *) val fts_read : FTS.t -> FTSENT.t option type fts_set_option = (* Re-visit the file; any file type may be revisited. The next call to fts_read() will return the referenced file. The fts_stat and fts_info fields of the structure will be reinitialized at that time, but no other fields will have been changed. This option is meaningful only for the most recently returned file from fts_read(). Normal use is for postorder directory visits, where it causes the directory to be revisited (in both preorder and postorder) as well as all of its descendants. *) FTS_AGAIN (* The referenced file must be a symbolic link. If the referenced file is the one most recently returned by fts_read(), the next call to fts_read() returns the file with the fts_info and fts_statp fields reinitialized to reflect the target of the symbolic link instead of the symbolic link itself. If the file is one of those most recently returned by fts_children(), the fts_info and fts_statp fields of the structure, when returned by fts_read(), will reflect the target of the symbolic link instead of the symbolic link itself. In either case, if the target of the symbolic link does not exist the fields of the returned structure will be unchanged and the fts_info field will be set to FTS_SLNONE. If the target of the link is a directory, the preorder return, followed by the return of all of its descendants, followed by a postorder return, is done. *) | FTS_FOLLOW (* No descendants of this file are visited. The file may be one of those most recently returned by either fts_children() or fts_read(). *) | FTS_SKIP (* The function fts_set() allows the user application to determine further processing for the file f of the stream ftsp. *) val fts_set : ftsp:FTS.t -> f:FTSENT.t -> options:fts_set_option list -> unit (* The fts_close() function closes a file hierarchy stream ftsp and restores the current directory to the directory from which fts_open() was called to open ftsp. *) val fts_close : FTS.t -> unit yallop-ocaml-ctypes-3f8211a/examples/fts/foreign/fts_cmd.ml000066400000000000000000000021051445631112600237540ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Fts let usage = "fts_cmd path [ path .. ]" let sort_by_name lp rp = let open Ctypes in let open FTSENT in String.compare (name !@lp) (name !@rp) let rec iter ~gen ~f = match gen () with | None -> () | Some x -> begin f x; iter ~gen ~f end let ents ?compar path_argv = let fts : FTS.t = fts_open ~path_argv ?compar ~options:[] () in (fun _ -> fts_read fts) let main paths = let indent = ref 0 in let show_path ent = Printf.printf "%*s%s\n" !indent "" (FTSENT.path ent); in iter ~f:FTSENT.(fun ent -> match info ent with | FTS_D -> begin show_path ent; incr indent end | FTS_F | FTS_SL | FTS_SLNONE -> show_path ent | FTS_DP -> decr indent | _ -> ()) ~gen:(ents ~compar:sort_by_name paths) let () = match List.tl (Array.to_list Sys.argv) with | [] -> prerr_endline usage | l -> main l yallop-ocaml-ctypes-3f8211a/examples/fts/stub-generation/000077500000000000000000000000001445631112600234625ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/fts/stub-generation/bindings/000077500000000000000000000000001445631112600252575ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/fts/stub-generation/bindings/dune000066400000000000000000000001661445631112600261400ustar00rootroot00000000000000(library (name fts_stubs) (wrapped false) (modules_without_implementation fts) (libraries ctypes ctypes-foreign)) yallop-ocaml-ctypes-3f8211a/examples/fts/stub-generation/bindings/fts.mli000066400000000000000000000123741445631112600265650ustar00rootroot00000000000000(* * Copyright (c) Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open Fts_types (* The fts functions are provided for traversing file hierarchies. A simple overview is that the fts_open() function returns a "handle" on a file hierarchy, which is then supplied to the other fts functions. The function fts_read() returns a pointer to a structure describing one of the files in the file hierarchy. The function fts_children() returns a pointer to a linked list of structures, each of which describes one of the files contained in a directory in the hierarchy. In general, directories are visited two distinguishable times; in preorder (before any of their descendants are visited) and in postorder (after all of their descendants have been visited). Files are visited once. It is possible to walk the hierarchy "logically" (ignoring symbolic links) or physically (visiting symbolic links), order the walk of the hierarchy or prune and/or revisit portions of the hierarchy. *) module Bindings (F : sig val foreign : string -> 'a fn -> unit end) : sig (* The fts_open() function takes a list of strings naming one or more paths which make up a logical file hierarchy to be traversed. There are a number of options, at least one of which (either FTS_LOGICAL or FTS_PHYSICAL) must be specified. The argument compar() specifies a user-defined function which may be used to order the traversal of the hierarchy. It takes two pointers to pointers to FTSENT structures as arguments and should return a negative value, zero, or a positive value to indicate if the file referenced by its first argument comes before, in any order with respect to, or after, the file referenced by its second argument. The fts_accpath, fts_path and fts_pathlen fields of the FTSENT structures may never be used in this comparison. If the fts_info field is set to FTS_NS or FTS_NSOK, the fts_statp field may not either. If the compar() argument is NULL, the directory traversal order is in the order listed in path_argv for the root paths, and in the order listed in the directory for everything else. *) val fts_open : path_argv:string list -> ?compar:(FTSENT.t ptr -> FTSENT.t ptr -> int) -> options:fts_open_option list -> FTS.t (* The fts_children() function returns a pointer to an FTSENT structure describing the first entry in a NULL-terminated linked list of the files in the directory represented by the FTSENT structure most recently returned by fts_read(). The list is linked through the fts_link field of the FTSENT struc‐ ture, and is ordered by the user-specified comparison function, if any. Repeated calls to fts_children() will recreate this linked list. As a special case, if fts_read() has not yet been called for a hierarchy, fts_children() will return a pointer to the files in the logical directory specified to fts_open(), that is, the arguments specified to fts_open(). Otherwise, if the FTSENT structure most recently returned by fts_read() is not a directory being visited in preorder, or the directory does not contain any files, fts_children() returns NULL and sets errno to zero. If an error occurs, fts_children() returns NULL and sets errno appropriately. The FTSENT structures returned by fts_children() may be overwritten after a call to fts_children(), fts_close() or fts_read() on the same file hierarchy stream. The name_only option indicates that only the names of the files are needed. The contents of all the fields in the returned linked list of structures are undefined with the exception of the fts_name and fts_namelen fields. *) val fts_children : ftsp:FTS.t -> name_only:bool -> FTSENT.t (* The fts_read() function returns a pointer to an FTSENT structure describing a file in the hierarchy. Directories (that are readable and do not cause cycles) are visited at least twice, once in preorder and once in postorder. All other files are visited at least once. (Hard links between directories that do not cause cycles or symbolic links to symbolic links may cause files to be visited more than once, or directories more than twice.) The FTSENT structures returned by fts_read() may be overwritten after a call to fts_close() on the same file hierarchy stream, or, after a call to fts_read() on the same file hierarchy stream unless they represent a file of type directory, in which case they will not be overwritten until after a call to fts_read() after the FTSENT structure has been returned by the function fts_read() in postorder. *) val fts_read : FTS.t -> FTSENT.t option (* The function fts_set() allows the user application to determine further processing for the file f of the stream ftsp. *) val fts_set : ftsp:FTS.t -> f:FTSENT.t -> options:fts_set_option list -> unit (* The fts_close() function closes a file hierarchy stream ftsp and restores the current directory to the directory from which fts_open() was called to open ftsp. *) val fts_close : FTS.t -> unit end yallop-ocaml-ctypes-3f8211a/examples/fts/stub-generation/bindings/fts_bindings.ml000066400000000000000000000022731445631112600302660ustar00rootroot00000000000000(* * Copyright (c) Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open Fts_types open FTSENT open FTS module Bindings (F : Ctypes.FOREIGN) = struct open F (* FTS *fts_open(char * const *path_argv, int options, int ( *compar)(const FTSENT **, const FTSENT ** )); *) let _fts_open = foreign "fts_open" (ptr (ptr char) @-> int @-> compar_typ_opt @-> returning (ptr fts)) (* FTSENT *fts_read(FTS *ftsp); *) let _fts_read = foreign "fts_read" (* ~check_errno:true *) (ptr fts @-> returning (ptr ftsent)) (* FTSENT *fts_children(FTS *ftsp, int options); *) let _fts_children = foreign "fts_children" (ptr fts @-> int @-> returning (ptr ftsent)) (* int fts_set(FTS *ftsp, FTSENT *f, int options); *) let _fts_set = foreign "fts_set" (* ~check_errno:true *) (ptr fts @-> ptr (ftsent) @-> int @-> returning int) (* int fts_close(FTS *ftsp); *) let _fts_close = foreign "fts_close" (* ~check_errno:true *) (ptr fts @-> returning int) let _strdup = foreign "strdup" (string @-> returning (ptr char)) let _free = foreign "free" (ptr char @-> returning void) end yallop-ocaml-ctypes-3f8211a/examples/fts/stub-generation/bindings/fts_types.ml000066400000000000000000000126711445631112600276400ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@warning "-9"] open Ctypes type fts_info = FTS_D | FTS_DC | FTS_DEFAULT | FTS_DNR | FTS_DOT | FTS_DP | FTS_ERR | FTS_F | FTS_NS | FTS_NSOK | FTS_SL | FTS_SLNONE let fts_info_of_int = function | 1 -> FTS_D | 2 -> FTS_DC | 3 -> FTS_DEFAULT | 4 -> FTS_DNR | 5 -> FTS_DOT | 6 -> FTS_DP | 7 -> FTS_ERR | 8 -> FTS_F (* | 9 -> FTS_INIT *) | 10 -> FTS_NS | 11 -> FTS_NSOK | 12 -> FTS_SL | 13 -> FTS_SLNONE | _ -> invalid_arg "fts_info" type fts_open_option = FTS_COMFOLLOW | FTS_LOGICAL | FTS_NOCHDIR | FTS_NOSTAT | FTS_PHYSICAL | FTS_SEEDOT | FTS_XDEV let fts_children_option_of_bool = function | false -> 0 | true -> 0x0100 let fts_open_option_value = function | FTS_COMFOLLOW -> 0x0001 | FTS_LOGICAL -> 0x0002 | FTS_NOCHDIR -> 0x0004 | FTS_NOSTAT -> 0x0008 | FTS_PHYSICAL -> 0x0010 | FTS_SEEDOT -> 0x0020 | FTS_XDEV -> 0x0040 type fts_set_option = FTS_AGAIN | FTS_FOLLOW | FTS_SKIP let fts_set_option_value = function | FTS_AGAIN -> 1 | FTS_FOLLOW -> 2 | FTS_SKIP -> 4 let id x = x module FTSENT = struct open PosixTypes open Unsigned type ftsent let struct_ftsent : ftsent structure typ = structure "FTSENT" let ( -: ) ty label = field struct_ftsent label ty let fts_cycle = ptr struct_ftsent -: "fts_cycle" let fts_parent = ptr struct_ftsent -: "fts_parent" let fts_link = ptr struct_ftsent -: "fts_link" let fts_number = int -: "fts_number" let fts_pointer = ptr void -: "fts_pointer" let fts_accpath = string -: "fts_accpath" let fts_path = string -: "fts_path" let fts_errno = int -: "fts_errno" let fts_symfd = int -: "fts_symfd" let fts_pathlen = ushort -: "fts_pathlen" let fts_namelen = ushort -: "fts_namelen" let fts_ino = ino_t -: "fts_ino" let fts_dev = dev_t -: "fts_dev" let fts_nlink = nlink_t -: "fts_nlink" let fts_level = short -: "fts_level" let fts_info = ushort -: "fts_info" let fts_flags = ushort -: "fts_flags" let fts_instr = ushort -: "fts_instr" let fts_statp = ptr void -: "fts_statp" (* really a struct stat * *) let fts_name = char -: "fts_name" let () = seal struct_ftsent let ftsent = view struct_ftsent ~read:id ~write:id ~format_typ:(fun k fmt -> Format.pp_print_string fmt "FTSENT"; k fmt) type t = ftsent structure ptr let t = ptr ftsent let info : t -> fts_info = fun t -> fts_info_of_int (UShort.to_int (getf !@t fts_info)) let accpath : t -> string = fun t -> getf !@t fts_accpath let path : t -> string = fun t -> getf !@t fts_path let name : t -> string = fun t -> Ctypes_coerce.coerce (ptr char) string (t |-> fts_name) let level : t -> int = fun t -> getf !@t fts_level let errno : t -> int = fun t -> getf !@t fts_errno let number : t -> int = fun t -> getf !@t fts_number let set_number : t -> int -> unit = fun t -> setf !@t fts_number let pointer : t -> unit ptr = fun t -> getf !@t fts_pointer let set_pointer : t -> unit ptr -> unit = fun t -> setf !@t fts_pointer let parent : t -> t = fun t -> getf !@t fts_parent let link : t -> t = fun t -> getf !@t fts_link let cycle : t -> t = fun t -> getf !@t fts_cycle end module FTS = struct open PosixTypes open FTSENT type compar_typ = t ptr -> t ptr -> int let compar_typ : compar_typ typ = Foreign.funptr (ptr FTSENT.t @-> ptr FTSENT.t @-> returning int) type compar_typ_opt = compar_typ option let compar_typ_opt : compar_typ_opt typ = Foreign.funptr_opt (ptr FTSENT.t @-> ptr FTSENT.t @-> returning int) type fts let struct_fts : fts structure typ = structure "FTS" let ( -: ) ty label = field struct_fts label ty let fts_cur = ptr ftsent -: "fts_cur" let fts_child = ptr ftsent -: "fts_child" let fts_array = ptr (ptr ftsent) -: "fts_array" let fts_dev = dev_t -: "fts_dev" let fts_path = string -: "fts_path" let fts_rfd = int -: "fts_rfd" let fts_pathlen = int -: "fts_pathlen" let fts_nitems = int -: "fts_nitems" let fts_compar = compar_typ -: "fts_compar" (* fts_options would work well as a view *) let fts_options = int -: "fts_options" let () = seal struct_fts let fts = view struct_fts ~read:id ~write:id ~format_typ:(fun k fmt -> Format.pp_print_string fmt "FTS"; k fmt) type t = { ptr : fts structure ptr; (* The compar field ties the lifetime of the comparison function to the lifetime of the fts object to prevent untimely collection. *) compar: compar_typ option } let cur : t -> FTSENT.t = fun { ptr } -> getf !@ptr fts_cur let child : t -> FTSENT.t = fun { ptr } -> getf !@ptr fts_child let array : t -> FTSENT.t list = fun { ptr } -> CArray.(to_list (from_ptr (getf !@ptr fts_array) (getf !@ptr fts_nitems))) let dev : t -> dev_t = fun { ptr } -> getf !@ptr fts_dev let path : t -> string = fun { ptr } -> getf !@ptr fts_path let rfd : t -> int = fun { ptr } -> getf !@ptr fts_rfd end yallop-ocaml-ctypes-3f8211a/examples/fts/stub-generation/config/000077500000000000000000000000001445631112600247275ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/fts/stub-generation/config/discover.ml000066400000000000000000000011741445631112600271020ustar00rootroot00000000000000module C = Configurator.V1 let prepend opt flags = if flags = [] then [] else opt :: flags let () = C.main ~name:"fts_example" (fun c -> let default : C.Pkg_config.package_conf = { libs = []; cflags = [] } in let conf = match C.Pkg_config.get c with | None -> default | Some pc -> (match C.Pkg_config.query pc ~package:"libfts" with | None -> default | Some v -> v) in C.Flags.write_sexp "c_flags.sexp" (prepend "-ccopt" conf.cflags); C.Flags.write_sexp "c_library_flags.sexp" (prepend "-cclib" conf.libs) ) yallop-ocaml-ctypes-3f8211a/examples/fts/stub-generation/config/discover.mli000066400000000000000000000000141445631112600272430ustar00rootroot00000000000000(* empty *) yallop-ocaml-ctypes-3f8211a/examples/fts/stub-generation/config/dune000066400000000000000000000002231445631112600256020ustar00rootroot00000000000000(executable (name discover) (libraries dune-configurator)) (rule (targets c_flags.sexp c_library_flags.sexp) (action (run ./discover.exe))) yallop-ocaml-ctypes-3f8211a/examples/fts/stub-generation/dune000066400000000000000000000006541445631112600243450ustar00rootroot00000000000000(* -*- tuareg -*- *) (* This can be ported to build_if once available, ocaml/dune#7899 *) let unix = List.mem ("os_type", "Unix") Jbuild_plugin.V1.ocamlc_config let () = Jbuild_plugin.V1.send @@ if not unix then "" else {| (test (name fts_cmd) (enabled_if (= %{os_type} Unix)) (libraries fts_stubs fts_generated) (package ctypes) (action (progn)) (link_flags :standard (:include config/c_library_flags.sexp))) |} yallop-ocaml-ctypes-3f8211a/examples/fts/stub-generation/fts_cmd.ml000066400000000000000000000021271445631112600254350ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Fts_types open Fts_if let usage = "fts_cmd path [ path .. ]" let sort_by_name lp rp = let open Ctypes in let open FTSENT in String.compare (name !@lp) (name !@rp) let rec iter ~gen ~f = match gen () with | None -> () | Some x -> begin f x; iter ~gen ~f end let ents ?compar path_argv = let fts : FTS.t = fts_open ~path_argv ?compar ~options:[] () in (fun _ -> fts_read fts) let main paths = let indent = ref 0 in let show_path ent = Printf.printf "%*s%s\n" !indent "" (FTSENT.path ent); in iter ~f:FTSENT.(fun ent -> match info ent with | FTS_D -> begin show_path ent; incr indent end | FTS_F | FTS_SL | FTS_SLNONE -> show_path ent | FTS_DP -> decr indent | _ -> ()) ~gen:(ents ~compar:sort_by_name paths) let () = match List.tl (Array.to_list Sys.argv) with | [] -> prerr_endline usage | l -> main l yallop-ocaml-ctypes-3f8211a/examples/fts/stub-generation/fts_if.ml000066400000000000000000000024351445631112600252720ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open Fts_types open FTS module N = Fts_bindings.Bindings(Fts_generated) open N let crush_options f : 'a list -> int = List.fold_left (fun i o -> i lor (f o)) 0 let fts_read fts = let p = _fts_read fts.ptr in if to_voidp p = null then None else Some p let fts_close ftsp = ignore (_fts_close ftsp.ptr) let fts_set ~ftsp ~f ~options = ignore (_fts_set ftsp.ptr f (crush_options fts_set_option_value options)) let fts_children ~ftsp ~name_only = _fts_children ftsp.ptr (fts_children_option_of_bool name_only) let null_terminated_array_of_ptr_list typ list = let nitems = List.length list in let arr = CArray.make typ (1 + nitems) in List.iteri (CArray.set arr) list; (coerce (ptr typ) (ptr (ptr void)) (CArray.start arr +@ nitems)) <-@ null; arr let fts_open ~path_argv ?compar ~options () = let path_argv_cpointers = List.map _strdup path_argv in let paths = null_terminated_array_of_ptr_list (ptr char) path_argv_cpointers in let options = crush_options fts_open_option_value options in let r = { ptr = _fts_open (CArray.start paths) options compar; compar } in List.iter _free path_argv_cpointers; r yallop-ocaml-ctypes-3f8211a/examples/fts/stub-generation/stub-generator/000077500000000000000000000000001445631112600264235ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/fts/stub-generation/stub-generator/dune000066400000000000000000000010201445631112600272720ustar00rootroot00000000000000(executable (name fts_stub_generator) (enabled_if (= %{os_type} "Unix")) (modules fts_stub_generator) (libraries fts_stubs ctypes.stubs ctypes)) (rule (targets fts_stubs.c fts_generated.ml) (deps fts_stub_generator.exe) (enabled_if (= %{os_type} "Unix")) (action (run %{deps}))) (library (name fts_generated) (enabled_if (= %{os_type} "Unix")) (modules fts_generated) (foreign_stubs (language c) (names fts_stubs) (flags :standard (:include ../config/c_flags.sexp))) (libraries ctypes.stubs)) yallop-ocaml-ctypes-3f8211a/examples/fts/stub-generation/stub-generator/fts_stub_generator.ml000066400000000000000000000014051445631112600326540ustar00rootroot00000000000000(* * Copyright (c) Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) let c_headers = " #include #include #include #include " let main () = let ml_out = open_out "fts_generated.ml" and c_out = open_out "fts_stubs.c" in let ml_fmt = Format.formatter_of_out_channel ml_out and c_fmt = Format.formatter_of_out_channel c_out in Format.fprintf c_fmt "%s@\n" c_headers; Cstubs.write_c c_fmt ~prefix:"fts_stub_" (module Fts_bindings.Bindings); Cstubs.write_ml ml_fmt ~prefix:"fts_stub_" (module Fts_bindings.Bindings); Format.pp_print_flush ml_fmt (); Format.pp_print_flush c_fmt (); close_out ml_out; close_out c_out let () = main () yallop-ocaml-ctypes-3f8211a/examples/ncurses/000077500000000000000000000000001445631112600212425ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/ncurses/foreign/000077500000000000000000000000001445631112600226735ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/ncurses/foreign/dune000066400000000000000000000003061445631112600235500ustar00rootroot00000000000000(library (name ncurses) (modules ncurses) (libraries ctypes-foreign)) (executables (names ncurses_cmd) (modules ncurses_cmd) (link_flags (:standard -cclib -lncurses)) (libraries ncurses)) yallop-ocaml-ctypes-3f8211a/examples/ncurses/foreign/ncurses.ml000066400000000000000000000017731445631112600247170ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open Foreign type window = unit ptr let window : window typ = ptr void let initscr = foreign "initscr" (void @-> (returning window)) let endwin = foreign "endwin" (void @-> (returning void)) let refresh = foreign "refresh" (void @-> (returning void)) let wrefresh = foreign "wrefresh" (window @-> (returning void)) let newwin = foreign "newwin" (int @-> int @-> int @-> int @-> (returning window)) let addch = foreign "addch" (char @-> (returning void)) let mvwaddch = foreign "mvwaddch" (window @-> int @-> int @-> char @-> (returning void)) let addstr = foreign "addstr" (string @-> (returning void)) let mvwaddstr = foreign "mvwaddstr" (window @-> int @-> int @-> string @-> (returning void)) let box = foreign "box" (window @-> int @-> int @-> (returning void)) let cbreak = foreign "cbreak" (void @-> (returning void)) yallop-ocaml-ctypes-3f8211a/examples/ncurses/foreign/ncurses.mli000066400000000000000000000050371445631112600250650ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) type window (** The ncurses library routines give the user a terminal-independent method of updating character screens with reasonable optimization. *) (** initscr is normally the first curses routine to call when initializing a program. It determines the terminal type and initializes all data structures. initscr also causes the first call to [refresh] to clear the screen. If errors occur, initscr writes an appropriate error message to standard error and exits; otherwise, a pointer is returned to [window]. *) val initscr : unit -> window (** A program should always call [endwin] before exiting or escaping from curses mode temporarily. This routine restores tty modes, moves the cursor to the lower left-hand corner of the screen and resets the terminal into the proper non-visual mode. *) val endwin : unit -> unit (** [refresh] must be called to get actual output to the terminal, as other routines merely manipulate data structures. *) val refresh : unit -> unit (** [wrefresh window] must be called to get actual output to the terminal for a specific sub-window, as other routines merely manipulate data structures. *) val wrefresh : window -> unit (** Initially the terminal may or may not be in [cbreak] mode, as the mode is inherited; therefore, a program should call [cbreak] explicitly. Most interactive programs will need to be in this mode. *) val cbreak : unit -> unit (** [newwin nlines ncols begin_y begin_x] creates and returns a pointer to a new [window] with the [nlines] lines and [ncols] columns. The upper left-hand corner of the window is at line [begin_y] and column [begin_x]. A new full-screen window is created by calling [newwin 0 0 0 0] *) val newwin : int -> int -> int -> int -> window (** [addch ch] puts the character [ch] into the given window at its current window position, which is then advanced. *) val addch : char -> unit (** [addstr s] is analogous to calling [addch] for each character in [s] *) val addstr : string -> unit (** [mvwaddch win y x ch] puts the character [ch] into the given window at line [y] and column [x]. *) val mvwaddch : window -> int -> int -> char -> unit (** [mvwaddrstr win y x s] is analogous to calling [mvwaddch] for each character [ch] in [s] *) val mvwaddstr : window -> int -> int -> string -> unit (** [box TODO TODO] draws a border around the [window] *) val box : window -> int -> int -> unit yallop-ocaml-ctypes-3f8211a/examples/ncurses/foreign/ncurses_cmd.ml000066400000000000000000000006711445631112600255360ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ncurses let () = let main_window = initscr () in cbreak (); let small_window = newwin 10 10 5 5 in mvwaddstr main_window 1 2 "Hello"; mvwaddstr small_window 2 2 "World"; box small_window 0 0; refresh (); Unix.sleep 1; wrefresh small_window; Unix.sleep 5; endwin() yallop-ocaml-ctypes-3f8211a/examples/ncurses/stub-generation/000077500000000000000000000000001445631112600243505ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/ncurses/stub-generation/bindings/000077500000000000000000000000001445631112600261455ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/ncurses/stub-generation/bindings/dune000066400000000000000000000000671445631112600270260ustar00rootroot00000000000000(library (name ncurses_bindings) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/examples/ncurses/stub-generation/bindings/ncurses_bindings.ml000066400000000000000000000021261445631112600320370ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes type window = unit ptr let window : window typ = ptr void module Bindings (F : Ctypes.FOREIGN) = struct open F let initscr = foreign "initscr" (void @-> (returning window)) let endwin = foreign "endwin" (void @-> (returning void)) let refresh = foreign "refresh" (void @-> (returning void)) let wrefresh = foreign "wrefresh" (window @-> (returning void)) let newwin = foreign "newwin" (int @-> int @-> int @-> int @-> (returning window)) let addch = foreign "addch" (char @-> (returning void)) let mvwaddch = foreign "mvwaddch" (window @-> int @-> int @-> char @-> (returning void)) let addstr = foreign "addstr" (string @-> (returning void)) let mvwaddstr = foreign "mvwaddstr" (window @-> int @-> int @-> string @-> (returning void)) let box = foreign "box" (window @-> int @-> int @-> (returning void)) let cbreak = foreign "cbreak" (void @-> (returning void)) end yallop-ocaml-ctypes-3f8211a/examples/ncurses/stub-generation/dune000066400000000000000000000001331445631112600252230ustar00rootroot00000000000000(executable (name ncurses_stub_cmd) (libraries ncurses_bindings ncurses_generated unix)) yallop-ocaml-ctypes-3f8211a/examples/ncurses/stub-generation/ncurses_stub_cmd.ml000066400000000000000000000007531445631112600302510ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) module N = Ncurses_bindings.Bindings(Ncurses_generated) open N let () = let main_window = initscr () in cbreak (); let small_window = newwin 10 10 5 5 in mvwaddstr main_window 1 2 "Hello"; mvwaddstr small_window 2 2 "World"; box small_window 0 0; refresh (); Unix.sleep 1; wrefresh small_window; Unix.sleep 5; endwin() yallop-ocaml-ctypes-3f8211a/examples/ncurses/stub-generation/stub-generator/000077500000000000000000000000001445631112600273115ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/ncurses/stub-generation/stub-generator/dune000066400000000000000000000006461445631112600301750ustar00rootroot00000000000000(executable (name ncurses_stub_generator) (modules ncurses_stub_generator) (libraries ncurses_bindings ctypes.stubs ctypes)) (rule (targets ncurses_stubs.c ncurses_generated.ml) (deps ncurses_stub_generator.exe) (action (run %{deps}))) (library (name ncurses_generated) (modules ncurses_generated) (c_library_flags -lncurses) (foreign_stubs (language c) (names ncurses_stubs)) (libraries ctypes.stubs)) ncurses_stub_generator.ml000066400000000000000000000013501445631112600343500ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/ncurses/stub-generation/stub-generator(* * Copyright (c) 2017 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) let c_headers = "#include " let main () = let ml_out = open_out "ncurses_generated.ml" in let c_out = open_out "ncurses_stubs.c" in let c_fmt = Format.formatter_of_out_channel c_out in let ml_fmt = Format.formatter_of_out_channel ml_out in Format.fprintf c_fmt "%s@\n" c_headers; Cstubs.write_c c_fmt ~prefix:"ncurses_stub_" (module Ncurses_bindings.Bindings); Cstubs.write_ml ml_fmt ~prefix:"ncurses_stub_" (module Ncurses_bindings.Bindings); Format.pp_print_flush ml_fmt (); Format.pp_print_flush c_fmt (); close_out ml_out; close_out c_out let () = main () yallop-ocaml-ctypes-3f8211a/examples/sigset/000077500000000000000000000000001445631112600210565ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/examples/sigset/sigset.ml000066400000000000000000000041771445631112600227170ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open PosixTypes open Ctypes open Foreign type t = sigset_t ptr let t = ptr sigset_t (* This function initializes the signal set set to exclude all of the defined signals. It always returns 0. *) let sigemptyset = foreign "sigemptyset" (ptr sigset_t @-> returning int) let empty () = let setp = allocate_n ~count:1 sigset_t in begin ignore (sigemptyset setp); setp end (* This function initializes the signal set set to include all of the defined signals. Again, the return value is 0. *) let sigfillset = foreign "sigfillset" (ptr sigset_t @-> returning int) let full () = let setp = allocate_n ~count:1 sigset_t in begin ignore (sigfillset setp); setp end (* This function adds the signal signum to the signal set set. All sigaddset does is modify set; it does not block or unblock any signals. The return value is 0 on success and -1 on failure. The following errno error condition is defined for this function: EINVAL The signum argument doesn't specify a valid signal. *) let sigaddset = foreign "sigaddset" ~check_errno:true (ptr sigset_t @-> int @-> returning int) let add set signal = ignore (sigaddset set signal) (* This function removes the signal signum from the signal set set. All sigdelset does is modify set; it does not block or unblock any signals. The return value and error conditions are the same as for sigaddset. *) let sigdelset = foreign "sigdelset" ~check_errno:true (ptr sigset_t @-> int @-> returning int) let del set signal = ignore (sigdelset set signal) (* The sigismember function tests whether the signal signum is a member of the signal set set. It returns 1 if the signal is in the set, 0 if not, and -1 if there is an error. The following errno error condition is defined for this function: EINVAL The signum argument doesn't specify a valid signal. *) let sigismember = foreign "sigismember" ~check_errno:true (ptr sigset_t @-> int @-> returning int) let mem set signal = sigismember set signal <> 0 yallop-ocaml-ctypes-3f8211a/examples/sigset/sigset.mli000066400000000000000000000005431445631112600230610ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open PosixTypes open Ctypes type t = sigset_t ptr val t : sigset_t ptr typ val empty : unit -> t val full : unit -> t val add : t -> int -> unit val del : t -> int -> unit val mem : t -> int -> bool yallop-ocaml-ctypes-3f8211a/src/000077500000000000000000000000001445631112600165315ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/src/configure/000077500000000000000000000000001445631112600205125ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/src/configure/dune000066400000000000000000000001411445631112600213640ustar00rootroot00000000000000(executable (name gen_c_primitives) (libraries dune-configurator) (modules gen_c_primitives)) yallop-ocaml-ctypes-3f8211a/src/configure/gen_c_primitives.ml000066400000000000000000000116131445631112600243740ustar00rootroot00000000000000[@@@warning "-9"] module C = Configurator.V1 let header ="\ (* * Copyright (c) 2016 whitequark * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes_primitive_types " type c_format = | No_format | Known_format of string | Defined_format of string type c_primitive = { constructor : string; typ : string; format : c_format; size : string; alignment : string; } let c_primitive constructor typ format = { constructor; typ; format; size = "sizeof("^typ^")"; alignment = "alignof("^typ^")"; } let c_primitives = [ c_primitive "Char" "char" (Known_format "d"); c_primitive "Schar" "signed char" (Known_format "d"); c_primitive "Uchar" "unsigned char" (Known_format "d"); c_primitive "Bool" "bool" (Known_format "d"); c_primitive "Short" "short" (Known_format "hd"); c_primitive "Int" "int" (Known_format "d"); c_primitive "Long" "long" (Known_format "ld"); c_primitive "Llong" "long long" (Known_format "lld"); c_primitive "Ushort" "unsigned short" (Known_format "hu"); c_primitive "Sint" "int" (Known_format "d"); c_primitive "Uint" "unsigned int" (Known_format "u"); c_primitive "Ulong" "unsigned long" (Known_format "lu"); c_primitive "Ullong" "unsigned long long" (Known_format "llu"); c_primitive "Size_t" "size_t" (Known_format "zu"); c_primitive "Int8_t" "int8_t" (Defined_format "PRId8"); c_primitive "Int16_t" "int16_t" (Defined_format "PRId16"); c_primitive "Int32_t" "int32_t" (Defined_format "PRId32"); c_primitive "Int64_t" "int64_t" (Defined_format "PRId64"); c_primitive "Uint8_t" "uint8_t" (Defined_format "PRIu8"); c_primitive "Uint16_t" "uint16_t" (Defined_format "PRIu16"); c_primitive "Uint32_t" "uint32_t" (Defined_format "PRIu32"); c_primitive "Uint64_t" "uint64_t" (Defined_format "PRIu64"); c_primitive "Float" "float" (Known_format ".12g"); c_primitive "Double" "double" (Known_format ".12g"); c_primitive "LDouble" "long double" (Known_format ".12Lg"); c_primitive "Complex32" "float _Complex" (No_format); c_primitive "Complex64" "double _Complex" (No_format); c_primitive "Complexld" "long double _Complex"(No_format); c_primitive "Nativeint" "intnat" (Defined_format "REAL_ARCH_INTNAT_PRINTF_FORMAT \"d\""); { constructor = "Camlint"; typ = "intnat"; format = Defined_format "REAL_ARCH_INTNAT_PRINTF_FORMAT \"d\""; size = "sizeof(intnat)"; alignment = "alignof(intnat)" }; ] open Printf let generate name typ f = printf "let %s : type a. a prim -> %s = function\n" name typ; List.iter (fun c_primitive -> printf " | %s -> " c_primitive.constructor; begin try f c_primitive with Not_found -> failwith (name^": "^c_primitive.constructor) end; printf "\n") c_primitives let prelude = "\ #if defined(__MINGW32__) || defined(__MINGW64__) #define __USE_MINGW_ANSI_STDIO 1 #include /* see: https://sourceforge.net/p/mingw-w64/bugs/627/ */ #endif #include #include #include #include #define alignof(T) (offsetof(struct { char c; T t; }, t)) #define STRINGIFY1(x) #x #define STRINGIFY(x) STRINGIFY1(x) #if __USE_MINGW_ANSI_STDIO && defined(__MINGW64__) #define REAL_ARCH_INTNAT_PRINTF_FORMAT \"ll\" #else #define REAL_ARCH_INTNAT_PRINTF_FORMAT ARCH_INTNAT_PRINTF_FORMAT #endif " let includes = [] let () = C.main ~name:"ctypes" (fun c -> let import_int l = match C.C_define.(import c ~prelude ~includes [l,Type.Int]) with |[_,C.C_define.Value.Int i] -> i |_ -> failwith ("unable to find integer definition for " ^ l) in let import_string l = match C.C_define.(import c ~prelude ~includes [l,Type.String]) with |[_,C.C_define.Value.String s] -> s |_ -> failwith ("unable to find string definition for " ^ l) in print_string header; generate "sizeof" "int" (fun { size } -> printf "%d" (import_int size)); generate "alignment" "int" (fun { alignment } -> printf "%d" (import_int alignment)); generate "name" "string" (fun { typ } -> printf "%S" (import_string ("STRINGIFY("^typ^")"))); generate "format_string" "string option" (fun { format } -> match format with | Known_format str -> printf "Some %S" ("%"^str) | Defined_format str -> printf "Some %S" ("%"^(import_string str)) | No_format -> printf "None"); printf "let pointer_size = %d\n" (import_int "sizeof(void*)"); printf "let pointer_alignment = %d\n" (import_int "alignof(void*)"); ) yallop-ocaml-ctypes-3f8211a/src/cstubs/000077500000000000000000000000001445631112600200345ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs.ml000066400000000000000000000145071445631112600217000ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Cstubs public interface. *) [@@@warning "-27-32"] module type FOREIGN = Ctypes.FOREIGN module type FOREIGN' = FOREIGN with type 'a result = unit module type BINDINGS = functor (F : FOREIGN') -> sig end type concurrency_policy = [ `Sequential | `Lwt_jobs | `Lwt_preemptive | `Unlocked ] type errno_policy = [ `Ignore_errno | `Return_errno ] let gen_c ~concurrency ~errno prefix fmt : (module FOREIGN') = (module struct let counter = ref 0 let var prefix name = incr counter; Printf.sprintf "%s_%d_%s" prefix !counter name type 'a fn = 'a Ctypes.fn type 'a return = 'a type 'a result = unit let foreign cname fn = Cstubs_generate_c.fn ~concurrency ~errno ~cname ~stub_name:(var prefix cname) fmt fn let foreign_value cname typ = Cstubs_generate_c.value ~cname ~stub_name:(var prefix cname) fmt typ let returning = Ctypes.returning let (@->) = Ctypes.(@->) end) type bind = Bind : string * string * ('a -> 'b) Ctypes.fn -> bind type val_bind = Val_bind : string * string * 'a Ctypes.typ -> val_bind let write_return : concurrency:concurrency_policy -> errno:errno_policy -> Format.formatter -> unit = fun ~concurrency ~errno fmt -> match concurrency, errno with (`Sequential|`Unlocked), `Ignore_errno -> Format.fprintf fmt "type 'a return = 'a@\n" | (`Sequential|`Unlocked), `Return_errno -> Format.fprintf fmt "type 'a return = 'a * Signed.sint@\n" | (`Lwt_jobs|`Lwt_preemptive), `Ignore_errno -> begin Format.fprintf fmt "type 'a return = { lwt: 'a Lwt.t }@\n"; Format.fprintf fmt "let box_lwt lwt = {lwt}@\n"; end | (`Lwt_jobs|`Lwt_preemptive), `Return_errno -> begin Format.fprintf fmt "type 'a return = { lwt: ('a * Signed.sint) Lwt.t }@\n"; Format.fprintf fmt "let box_lwt lwt = {lwt}@\n"; end let write_fn ~concurrency ~errno fmt = begin Format.fprintf fmt "type 'a fn =@\n"; Format.fprintf fmt " | Returns : 'a CI.typ -> 'a return fn@\n"; Format.fprintf fmt " | Function : 'a CI.typ * 'b fn -> ('a -> 'b) fn@\n" end let write_map_result ~concurrency ~errno fmt = match concurrency, errno with (`Sequential|`Unlocked), `Ignore_errno -> Format.fprintf fmt "let map_result f x = f x@\n" | (`Sequential|`Unlocked), `Return_errno -> Format.fprintf fmt "let map_result f (x, y) = (f x, y)@\n" | (`Lwt_jobs|`Lwt_preemptive), `Ignore_errno -> Format.fprintf fmt "let map_result f x = Lwt.map f x@\n" | (`Lwt_jobs|`Lwt_preemptive), `Return_errno -> Format.fprintf fmt "let map_result f v = Lwt.map (fun (x, y) -> (f x, y)) v@\n" let write_foreign ~concurrency ~errno fmt bindings val_bindings = Format.fprintf fmt "type 'a result = 'a@\n"; write_return ~concurrency ~errno fmt; write_fn ~concurrency ~errno fmt; write_map_result ~concurrency ~errno fmt; Format.fprintf fmt "let returning t = Returns t@\n"; Format.fprintf fmt "let (@@->) f p = Function (f, p)@\n"; Format.fprintf fmt "let foreign : type a b. string -> (a -> b) fn -> (a -> b) =@\n"; Format.fprintf fmt " fun name t -> match t, name with@\n@["; ListLabels.iter bindings ~f:(fun (Bind (stub_name, external_name, fn)) -> Cstubs_generate_ml.case ~concurrency ~errno ~stub_name ~external_name fmt fn); Format.fprintf fmt "@[@[|@ _,@ s@ ->@]@ "; Format.fprintf fmt " @[Printf.ksprintf@ failwith@ \"No match for %%s\" s@]@]@]@.@\n"; Format.fprintf fmt "@\n"; Format.fprintf fmt "let foreign_value : type a. string -> a Ctypes.typ -> a Ctypes.ptr =@\n"; Format.fprintf fmt " fun name t -> match t, name with@\n@["; ListLabels.iter val_bindings ~f:(fun (Val_bind (stub_name, external_name, typ)) -> Cstubs_generate_ml.val_case ~stub_name ~external_name fmt typ); Format.fprintf fmt "@[@[|@ _,@ s@ ->@]@ "; Format.fprintf fmt " @[Printf.ksprintf@ failwith@ \"No match for %%s\" s@]@]@]@.@\n" let gen_ml ~concurrency ~errno prefix fmt : (module FOREIGN') * (unit -> unit) = let bindings = ref [] and val_bindings = ref [] and counter = ref 0 in let var prefix name = incr counter; Printf.sprintf "%s_%d_%s" prefix !counter name in (module struct type 'a fn = 'a Ctypes.fn type 'a return = 'a let (@->) = Ctypes.(@->) let returning = Ctypes.returning type 'a result = unit let foreign cname fn = let name = var prefix cname in bindings := Bind (cname, name, fn) :: !bindings; Cstubs_generate_ml.extern ~concurrency ~errno ~stub_name:name ~external_name:name fmt fn let foreign_value cname typ = let name = var prefix cname in Cstubs_generate_ml.extern ~concurrency:`Sequential ~errno:`Ignore_errno ~stub_name:name ~external_name:name fmt Ctypes.(void @-> returning (ptr void)); val_bindings := Val_bind (cname, name, typ) :: !val_bindings let returning = Ctypes.returning let (@->) = Ctypes.(@->) end), fun () -> write_foreign ~concurrency ~errno fmt !bindings !val_bindings let sequential = `Sequential let lwt_jobs = `Lwt_jobs let lwt_preemptive = `Lwt_preemptive let ignore_errno = `Ignore_errno let return_errno = `Return_errno let unlocked = `Unlocked let concurrency_headers = function `Sequential -> [] | `Lwt_jobs | `Lwt_preemptive -> ["\"lwt_unix.h\""; ""] | `Unlocked -> [""] let errno_headers = function `Ignore_errno -> [] | `Return_errno -> [""] let headers : concurrency_policy -> errno_policy -> string list = fun concurrency errno -> ["\"ctypes_cstubs_internals.h\""] @ errno_headers errno @ concurrency_headers concurrency let write_c ?(concurrency=`Sequential) ?(errno=`Ignore_errno) fmt ~prefix (module B : BINDINGS) = List.iter (Format.fprintf fmt "#include %s@\n") (headers concurrency errno); let module M = B((val gen_c ~concurrency ~errno prefix fmt)) in () let write_ml ?(concurrency=`Sequential) ?(errno=`Ignore_errno) fmt ~prefix (module B : BINDINGS) = let foreign, finally = gen_ml ~concurrency ~errno prefix fmt in let () = Format.fprintf fmt "module CI = Cstubs_internals@\n@\n" in let module M = B((val foreign)) in finally () module Types = Cstubs_structs yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs.mli000066400000000000000000000110341445631112600220410ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** Operations for generating C bindings stubs. *) module Types : sig module type TYPE = Ctypes.TYPE module type BINDINGS = functor (F : TYPE) -> sig end val write_c : Format.formatter -> (module BINDINGS) -> unit end module type FOREIGN = Ctypes.FOREIGN module type BINDINGS = functor (F : FOREIGN with type 'a result = unit) -> sig end type errno_policy (** Values of the [errno_policy] type specify the errno support provided by the generated code. See {!ignore_errno} for the available option. *) val ignore_errno : errno_policy (** Generate code with no special support for errno. This is the default. *) val return_errno : errno_policy (** Generate code that returns errno in addition to the return value of each function. Passing [return_errno] as the [errno] argument to {!Cstubs.write_c} and {!Cstubs.write_ml} changes the return type of bound functions from a single value to a pair of values. For example, the binding specification [let realpath = foreign "reaplath" (string @-> string @-> returning string)] generates a value of the following type by default: [val realpath : string -> string -> stirng] but when using [return_errno] the generated type is as follows: [val realpath : string -> string -> stirng * int] and when using both [return_errno] and [lwt_jobs] the generated type is as follows: [val realpath : string -> string -> (stirng * int) Lwt.t] *) type concurrency_policy (** Values of the [concurrency_policy] type specify the concurrency support provided by the generated code. See {!sequential} and {!lwt_jobs} for the available options. *) val sequential : concurrency_policy (** Generate code with no special support for concurrency. This is the default. *) val unlocked : concurrency_policy (** Generate code that releases the runtime lock during C calls. *) val lwt_preemptive : concurrency_policy (** Generate code which runs C function calls with the Lwt_preemptive module: http://ocsigen.org/lwt/2.5.1/api/Lwt_preemptive Passing [lwt_preemptive] as the [concurrency] argument to {!Cstubs.write_c} and {!Cstubs.write_ml} changes the return type of bound functions to include the {!Lwt.t} constructor. For example, the binding specification [let unlink = foreign "unlink" (string @-> returning int)] generates a value of the following type by default: [val unlink : string -> int] but when using [lwt_preemptive] the generated type is as follows: [val unlink : string -> int Lwt.t] Additionally, the OCaml runtime lock is released during calls to functions bound with [lwt_preemptive]. *) val lwt_jobs : concurrency_policy (** Generate code which implements C function calls as Lwt jobs: http://ocsigen.org/lwt/2.5.1/api/Lwt_unix#TYPEjob Passing [lwt_jobs] as the [concurrency] argument to {!Cstubs.write_c} and {!Cstubs.write_ml} changes the return type of bound functions to include the {!Lwt.t} constructor. For example, the binding specification [let unlink = foreign "unlink" (string @-> returning int)] generates a value of the following type by default: [val unlink : string -> int] but when using [lwt_jobs] the generated type is as follows: [val unlink : string -> int Lwt.t] *) val write_c : ?concurrency:concurrency_policy -> ?errno:errno_policy -> Format.formatter -> prefix:string -> (module BINDINGS) -> unit (** [write_c fmt ~prefix bindings] generates C stubs for the functions bound with [foreign] in [bindings]. The stubs are intended to be used in conjunction with the ML code generated by {!write_ml}. The optional argument [concurrency] specifies the concurrency support provided by the generated code. The default is [sequential]. The generated code uses definitions exposed in the header file [ctypes_cstubs_internals.h]. *) val write_ml : ?concurrency:concurrency_policy -> ?errno:errno_policy -> Format.formatter -> prefix:string -> (module BINDINGS) -> unit (** [write_ml fmt ~prefix bindings] generates ML bindings for the functions bound with [foreign] in [bindings]. The generated code conforms to the {!FOREIGN} interface. The optional argument [concurrency] specifies the concurrency support provided by the generated code. The default is [sequential]. The generated code uses definitions exposed in the module [Cstubs_internals]. *) yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs_analysis.ml000066400000000000000000000075701445631112600236050ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Analysis for stub generation *) open Ctypes_static let is_float_primitive : type a. a typ -> bool = let open Ctypes_primitive_types in function | Primitive Float -> true | Primitive Double -> true | _ -> false let rec float : type a. a fn -> bool = function | Returns t -> is_float_primitive t | Function (f, t) -> is_float_primitive f && float t (* A value of type 'a noalloc says that reading a value of type 'a will not cause an OCaml allocation in C code. *) type _ noalloc = Noalloc_unit : unit noalloc | Noalloc_int : int noalloc | Noalloc_uint8_t : Unsigned.uint8 noalloc | Noalloc_uint16_t : Unsigned.uint16 noalloc | Noalloc_char : char noalloc | Noalloc_bool : bool noalloc | Noalloc_view : ('a, 'b) view * 'b noalloc -> 'a noalloc (* A value of type 'a alloc says that reading a value of type 'a may cause an OCaml allocation in C code. *) type _ alloc = | Alloc_sint : Signed.sint alloc | Alloc_long : Signed.long alloc | Alloc_llong : Signed.llong alloc | Alloc_uint : Unsigned.uint alloc | Alloc_uchar : Unsigned.uchar alloc | Alloc_ushort : Unsigned.ushort alloc | Alloc_ulong : Unsigned.ulong alloc | Alloc_ullong : Unsigned.ullong alloc | Alloc_size_t : Unsigned.size_t alloc | Alloc_int32_t : int32 alloc | Alloc_int64_t : int64 alloc | Alloc_uint32_t : Unsigned.uint32 alloc | Alloc_uint64_t : Unsigned.uint64 alloc | Alloc_nativeint : nativeint alloc | Alloc_float : float alloc | Alloc_ldouble : LDouble.t alloc | Alloc_complex : Complex.t alloc | Alloc_complexld : ComplexL.t alloc | Alloc_pointer : (_, _) pointer alloc | Alloc_funptr : _ static_funptr alloc | Alloc_structured : (_, _) structured alloc | Alloc_array : _ carray alloc | Alloc_bigarray : (_, 'a, _) Ctypes_bigarray.t -> 'a alloc | Alloc_view : ('a, 'b) view * 'b alloc -> 'a alloc type 'a allocation = [ `Noalloc of 'a noalloc | `Alloc of 'a alloc ] let primitive_allocation : type a. a Ctypes_primitive_types.prim -> a allocation = let open Ctypes_primitive_types in function | Char -> `Noalloc Noalloc_char | Bool -> `Noalloc Noalloc_bool | Schar -> `Noalloc Noalloc_int | Short -> `Noalloc Noalloc_int | Int -> `Noalloc Noalloc_int | Int8_t -> `Noalloc Noalloc_int | Int16_t -> `Noalloc Noalloc_int | Uint8_t -> `Noalloc Noalloc_uint8_t | Uint16_t -> `Noalloc Noalloc_uint16_t | Camlint -> `Noalloc Noalloc_int | Long -> `Alloc Alloc_long | Llong -> `Alloc Alloc_llong | Ushort -> `Alloc Alloc_ushort | Uchar -> `Alloc Alloc_uchar | Sint -> `Alloc Alloc_sint | Uint -> `Alloc Alloc_uint | Ulong -> `Alloc Alloc_ulong | Ullong -> `Alloc Alloc_ullong | Size_t -> `Alloc Alloc_size_t | Int32_t -> `Alloc Alloc_int32_t | Int64_t -> `Alloc Alloc_int64_t | Uint32_t -> `Alloc Alloc_uint32_t | Uint64_t -> `Alloc Alloc_uint64_t | Nativeint -> `Alloc Alloc_nativeint | Float -> `Alloc Alloc_float | Double -> `Alloc Alloc_float | LDouble -> `Alloc Alloc_ldouble | Complex32 -> `Alloc Alloc_complex | Complex64 -> `Alloc Alloc_complex | Complexld -> `Alloc Alloc_complexld let rec allocation : type a. a typ -> a allocation = function | Void -> `Noalloc Noalloc_unit | Primitive p -> primitive_allocation p | Pointer _ -> `Alloc Alloc_pointer | Funptr _ -> `Alloc Alloc_funptr | Struct _ -> `Alloc Alloc_structured | Union _ -> `Alloc Alloc_structured | Abstract _ -> `Alloc Alloc_structured | View v -> begin match allocation v.ty with | `Alloc a -> `Alloc (Alloc_view (v, a)) | `Noalloc na -> `Noalloc (Noalloc_view (v, na)) end | Array _ -> `Alloc Alloc_array | Bigarray ba -> `Alloc (Alloc_bigarray ba) | OCaml _ -> `Alloc Alloc_pointer let rec may_allocate : type a. a fn -> bool = function | Returns t -> begin match allocation t with | `Noalloc _ -> false | `Alloc _ -> true end | Function (_, t) -> may_allocate t yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs_analysis.mli000066400000000000000000000004201445631112600237410ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Analysis for stub generation *) val float : 'a Ctypes_static.fn -> bool val may_allocate : 'a Ctypes_static.fn -> bool yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs_c_language.ml000066400000000000000000000220141445631112600240350ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* C code representation. *) [@@@warning "-9"] open Ctypes_static let fresh_var = let var_counter = ref 0 in fun ?(prefix="x") () -> incr var_counter; Printf.sprintf "%s%d" prefix !var_counter type ty = Ty : _ typ -> ty type tfn = Fn : _ fn -> tfn type fieldname = string type cfunction = { fname: string; allocates: bool; reads_ocaml_heap: bool; fn: tfn; } type cglobal = { name: string; typ: ty; references_ocaml_heap: bool; } type clocal = [ `Local of string * ty ] type cvar = [ clocal | `Global of cglobal ] type storage_class = [`Static | `Extern] type cconst = [ `Int of Signed.sint ] type cexp = [ cconst | clocal | `Cast of ty * cexp | `Addr of cvar ] type clvalue = [ cvar | `Index of clvalue * cexp | `Field of clvalue * fieldname | `PointerField of clvalue * fieldname ] type camlop = [ `CAMLparam0 | `CAMLlocalN of cexp * cexp | `CAMLdrop ] type ceff = [ cexp | camlop | `Global of cglobal | `App of cfunction * cexp list | `Index of ceff * cexp | `Deref of cexp | `DerefField of cexp * fieldname ] type cbind = clocal * ceff type ccomp = [ ceff | `CAMLparam of string list * ccomp | `LetConst of clocal * cconst * ccomp | `LetAssign of clvalue * ceff * ccomp | `CAMLreturnT of ty * cexp | `Return of ty * cexp | `Let of cbind * ccomp ] type cfundec = [ `Fundec of string * (string * ty) list * ty ] type cfundef = [ `Function of cfundec * ccomp * storage_class ] let rec return_type : type a. a fn -> ty = function | Function (_, f) -> return_type f | Returns t -> Ty t let args : type a. a fn -> (string * ty) list = fun fn -> let rec loop : type a. a Ctypes.fn -> (string * ty) list = function | Ctypes_static.Function (ty, fn) -> (fresh_var (), Ty ty) :: loop fn | Ctypes_static.Returns _ -> [] in loop fn module Type_C = struct let cexp : cexp -> ty = function | `Int _ -> Ty sint | `Local (_, ty) -> ty | `Cast (Ty ty, _) -> Ty ty | `Addr (`Global { typ = Ty ty }) -> Ty (Pointer ty) | `Addr (`Local (_, Ty ty)) -> Ty (Pointer ty) let camlop : camlop -> ty = function | `CAMLparam0 | `CAMLlocalN _ | `CAMLdrop -> Ty Void let rec ceff : ceff -> ty = function | #cexp as e -> cexp e | #camlop as o -> camlop o | `Global { typ } -> typ | `App ({ fn = Fn f }, _) -> return_type f | `Index (e, _) -> reference_ceff e | `Deref e -> reference_ceff (e :> ceff) | `DerefField (e, f) -> field_ceff (e :> ceff) f and reference_ceff : ceff -> ty = fun e -> begin match ceff e with | Ty (Pointer ty) -> Ty ty | Ty (Array (ty, _)) -> Ty ty | Ty t -> Cstubs_errors.internal_error "dereferencing expression of non-pointer type %s" (Ctypes.string_of_typ t) end and field_ceff : ceff -> fieldname -> ty = fun e f -> begin match ceff e with Ty (Pointer (Struct { fields } as s)) -> lookup_field f s fields | Ty t -> Cstubs_errors.internal_error "accessing a field %s in an expression of type %s, which is not a pointer-to-struct type" f (Ctypes.string_of_typ t) end and lookup_field : type s a. string -> a typ -> s boxed_field list -> ty = fun f ty fields -> match fields with [] -> Cstubs_errors.internal_error "field %s not found in struct %s" f (Ctypes.string_of_typ ty) | BoxedField { ftype; fname } :: _ when fname = f -> Ty ftype | _ :: fields -> lookup_field f ty fields let rec ccomp : ccomp -> ty = function | #cexp as e -> cexp e | #ceff as e -> ceff e | `CAMLparam (_, c) -> ccomp c | `Let (_, c) | `LetConst (_, _, c) -> ccomp c | `LetAssign (_, _, c) -> ccomp c | `CAMLreturnT (ty, _) -> ty | `Return (ty, _) -> ty end let value : [`value] abstract typ = abstract ~name:"value" ~size:0 ~alignment:0 let reader fname fn = { fname; allocates = false; reads_ocaml_heap = true; fn = Fn fn } let conser fname fn = { fname; allocates = true; reads_ocaml_heap = false; fn = Fn fn } let immediater fname fn = { fname; allocates = false; reads_ocaml_heap = false; fn = Fn fn } module Unchecked_function_types = struct (* We're using an abstract type ([value]) as an argument and return type, so we'll use the [Function] and [Return] constructors directly. The smart constructors [@->] and [returning] would reject the abstract type. *) let (@->) f t = Function (f, t) let returning t = Returns t end let prim_prj : type a. a Ctypes_primitive_types.prim -> _ = let open Unchecked_function_types in let open Ctypes_primitive_types in function | Char -> reader "Int_val" (value @-> returning int) | Schar -> reader "Int_val" (value @-> returning int) | Uchar -> reader "Uint8_val" (value @-> returning uint8_t) | Bool -> reader "Bool_val" (value @-> returning bool) | Short -> reader "Int_val" (value @-> returning int) | Int -> reader "Long_val" (value @-> returning int) | Long -> reader "ctypes_long_val" (value @-> returning long) | Llong -> reader "ctypes_llong_val" (value @-> returning llong) | Ushort -> reader "ctypes_ushort_val" (value @-> returning ushort) | Sint -> reader "ctypes_sint_val" (value @-> returning sint) | Uint -> reader "ctypes_uint_val" (value @-> returning uint) | Ulong -> reader "ctypes_ulong_val" (value @-> returning ulong) | Ullong -> reader "ctypes_ullong_val" (value @-> returning ullong) | Size_t -> reader "ctypes_size_t_val" (value @-> returning size_t) | Int8_t -> reader "Int_val" (value @-> returning int) | Int16_t -> reader "Int_val" (value @-> returning int) | Int32_t -> reader "Int32_val" (value @-> returning int32_t) | Int64_t -> reader "Int64_val" (value @-> returning int64_t) | Uint8_t -> reader "Uint8_val" (value @-> returning uint8_t) | Uint16_t -> reader "Uint16_val" (value @-> returning uint16_t) | Uint32_t -> reader "Uint32_val" (value @-> returning uint32_t) | Uint64_t -> reader "Uint64_val" (value @-> returning uint64_t) | Camlint -> reader "Long_val" (value @-> returning int) | Nativeint -> reader "Nativeint_val" (value @-> returning nativeint) | Float -> reader "Double_val" (value @-> returning double) | Double -> reader "Double_val" (value @-> returning double) | LDouble -> reader "ctypes_ldouble_val" (value @-> returning ldouble) | Complex32 -> reader "ctypes_float_complex_val" (value @-> returning complex32) | Complex64 -> reader "ctypes_double_complex_val" (value @-> returning complex64) | Complexld -> reader "ctypes_ldouble_complex_val" (value @-> returning complexld) let prim_inj : type a. a Ctypes_primitive_types.prim -> _ = let open Unchecked_function_types in let open Ctypes_primitive_types in function | Char -> immediater "Ctypes_val_char" (int @-> returning value) | Schar -> immediater "Val_int" (int @-> returning value) | Uchar -> immediater "Integers_val_uint8" (uint8_t @-> returning value) | Bool -> immediater "Val_bool" (bool @-> returning value) | Short -> immediater "Val_int" (int @-> returning value) | Int -> immediater "Val_long" (int @-> returning value) | Long -> conser "ctypes_copy_long" (long @-> returning value) | Llong -> conser "ctypes_copy_llong" (llong @-> returning value) | Ushort -> conser "ctypes_copy_ushort" (ushort @-> returning value) | Sint -> conser "ctypes_copy_sint" (sint @-> returning value) | Uint -> conser "ctypes_copy_uint" (uint @-> returning value) | Ulong -> conser "ctypes_copy_ulong" (ulong @-> returning value) | Ullong -> conser "ctypes_copy_ullong" (ullong @-> returning value) | Size_t -> conser "ctypes_copy_size_t" (size_t @-> returning value) | Int8_t -> immediater "Val_int" (int @-> returning value) | Int16_t -> immediater "Val_int" (int @-> returning value) | Int32_t -> conser "caml_copy_int32" (int32_t @-> returning value) | Int64_t -> conser "caml_copy_int64" (int64_t @-> returning value) | Uint8_t -> immediater "Integers_val_uint8" (uint8_t @-> returning value) | Uint16_t -> immediater "Integers_val_uint16" (uint16_t @-> returning value) | Uint32_t -> conser "integers_copy_uint32" (uint32_t @-> returning value) | Uint64_t -> conser "integers_copy_uint64" (uint64_t @-> returning value) | Camlint -> immediater "Val_long" (int @-> returning value) | Nativeint -> conser "caml_copy_nativeint" (nativeint @-> returning value) | Float -> conser "caml_copy_double" (double @-> returning value) | Double -> conser "caml_copy_double" (double @-> returning value) | LDouble -> conser "ctypes_copy_ldouble" (ldouble @-> returning value) | Complex32 -> conser "ctypes_copy_float_complex" (complex32 @-> returning value) | Complex64 -> conser "ctypes_copy_double_complex" (complex64 @-> returning value) | Complexld -> conser "ctypes_copy_ldouble_complex" (complexld @-> returning value) yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs_emit_c.ml000066400000000000000000000141021445631112600232070ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* C pretty printing. *) [@@@warning "-9-27"] open Ctypes_static open Cstubs_c_language open Format let format_seq lbr fmt_item sep rbr fmt items = let open Format in fprintf fmt "%s@[@[" lbr; ListLabels.iteri items ~f:(fun i item -> if i <> 0 then fprintf fmt "@]%s@ @[" sep; fmt_item fmt item); fprintf fmt "@]%s@]" rbr let format_ty fmt (Ty ty) = Ctypes.format_typ fmt ty let cvar_name = function | `Local (name, _) | `Global { name } -> name let cvar fmt v = fprintf fmt "%s" (cvar_name v) let cconst fmt (`Int i) = fprintf fmt "%s" (Signed.SInt.to_string i) let rec camlxParam fmt args = match args with [] -> () | x1 :: [] -> fprintf fmt "@[CAMLxparam1@;(%s)@];" x1 | x1 :: x2 :: [] -> fprintf fmt "@[CAMLxparam2@;(%s,@;%s)@];" x1 x2 | x1 :: x2 :: x3 :: [] -> fprintf fmt "@[CAMLxparam3@;(%s,@;%s,@;%s)@];" x1 x2 x3 | x1 :: x2 :: x3 :: x4 :: [] -> fprintf fmt "@[CAMLxparam4@;(%s,@;%s,@;%s,@;%s)@];" x1 x2 x3 x4 | x1 :: x2 :: x3 :: x4 :: x5 :: rest -> fprintf fmt "@[CAMLxparam5@;(%s,@;%s,@;%s,@;%s,@;%s)@];" x1 x2 x3 x4 x5; camlxParam fmt rest let camlParam fmt args = match args with [] -> fprintf fmt "@[CAMLparam0@;()@];" | x1 :: [] -> fprintf fmt "@[CAMLparam1@;(%s)@];" x1 | x1 :: x2 :: [] -> fprintf fmt "@[CAMLparam2@;(%s,@;%s)@];" x1 x2 | x1 :: x2 :: x3 :: [] -> fprintf fmt "@[CAMLparam3@;(%s,@;%s,@;%s)@];" x1 x2 x3 | x1 :: x2 :: x3 :: x4 :: [] -> fprintf fmt "@[CAMLparam4@;(%s,@;%s,@;%s,@;%s)@];" x1 x2 x3 x4 | x1 :: x2 :: x3 :: x4 :: x5 :: rest -> fprintf fmt "@[CAMLparam5@;(%s,@;%s,@;%s,@;%s,@;%s)@];@ %a" x1 x2 x3 x4 x5 camlxParam rest (* Determine whether the C expression [(ty)e] is equivalent to [e] *) let cast_unnecessary : ty -> cexp -> bool = let rec harmless l r = match l, r with | Ty (Pointer Void), Ty (Pointer _) -> true | Ty (View { ty }), t -> harmless (Ty ty) t | t, Ty (View { ty }) -> harmless t (Ty ty) | (Ty (Primitive _) as l), (Ty (Primitive _) as r) -> l = r | _ -> false in fun ty e -> harmless ty (Type_C.cexp e) let rec cexp fmt : cexp -> unit = function | #cconst as c -> cconst fmt c | `Local _ as x -> cvar fmt x | `Cast (ty, e) when cast_unnecessary ty e -> cexp fmt e | `Cast (ty, e) -> fprintf fmt "@[@[(%a)@]%a@]" format_ty ty cexp e | `Addr (`Global { name }) | `Addr (`Local (name, _)) -> fprintf fmt "@[&@[%s@]@]" name let rec clvalue fmt : clvalue -> unit = function | #cvar as x -> cvar fmt x | `Index (lv, i) -> fprintf fmt "@[@[%a@]@[[%a]@]@]" clvalue lv cexp i | `Field (lv, f) -> fprintf fmt "@[@[%a@]@[.%s@]@]" clvalue lv f | `PointerField (lv, f) -> fprintf fmt "@[@[%a@]@[->%s@]@]" clvalue lv f let camlop fmt : camlop -> unit = function | `CAMLparam0 -> Format.fprintf fmt "CAMLparam0()" | `CAMLlocalN (e, c) -> Format.fprintf fmt "CAMLlocalN(@[%a@],@ @[%a@])" cexp e cexp c | `CAMLdrop -> Format.fprintf fmt "CAMLdrop" let rec ceff fmt : ceff -> unit = function | #cexp as e -> cexp fmt e | #camlop as o -> camlop fmt o | `Global _ as x -> cvar fmt x | `App ({fname}, es) -> fprintf fmt "@[%s(@[" fname; let last_exp = List.length es - 1 in List.iteri (fun i e -> fprintf fmt "@[%a@]%(%)" cexp e (if i <> last_exp then ",@ " else "" : (_,_,_) format)) es; fprintf fmt ")@]@]"; | `Index (e, i) -> fprintf fmt "@[@[%a@]@[[%a]@]@]" ceff e cexp i | `Deref e -> fprintf fmt "@[*@[%a@]@]" cexp e | `DerefField (e, f) -> fprintf fmt "@[@[%a@]->%s@]" cexp e f let rec ccomp fmt : ccomp -> unit = function | #cexp as e when Type_C.cexp e = Ty Void -> fprintf fmt "@[return@];" | #cexp as e -> fprintf fmt "@[<2>return@;@[%a@]@];" cexp e | #ceff as e -> fprintf fmt "@[<2>return@;@[%a@]@];" ceff e | `CAMLparam (xs, c) -> fprintf fmt "@[%a;@]@ %a" camlParam xs ccomp c | `Return (Ty Void, _) -> fprintf fmt "@[return@];" | `Return (Ty ty, e) -> fprintf fmt "@[<2>return@;@[%a@]@];" cexp e | `CAMLreturnT (Ty Void, _) -> fprintf fmt "@[CAMLreturn0@];" | `CAMLreturnT (Ty ty, e) -> fprintf fmt "@[<2>CAMLreturnT(@[%a@],@;@[%a@])@];" (fun t -> Ctypes.format_typ t) ty cexp e | `Let (xe, `Cast (ty, (#cexp as e'))) when cast_unnecessary ty e' -> ccomp fmt (`Let (xe, e')) | `Let ((`Local (x, _), e), `Local (y, _)) when x = y -> ccomp fmt (e :> ccomp) | `Let ((`Local (name, Ty Void), e), s) -> fprintf fmt "@[%a;@]@ %a" ceff e ccomp s | `Let ((`Local (name, Ty (Struct { tag })), e), s) -> fprintf fmt "@[struct@;%s@;%s@;=@;@[%a;@]@]@ %a" tag name ceff e ccomp s | `Let ((`Local (name, Ty (Union { utag })), e), s) -> fprintf fmt "@[union@;%s@;%s@;=@;@[%a;@]@]@ %a" utag name ceff e ccomp s | `Let ((`Local (name, Ty ty), e), s) -> fprintf fmt "@[@[%a@]@;=@;@[%a;@]@]@ %a" (Ctypes.format_typ ~name) ty ceff e ccomp s | `LetConst (`Local (x, _), `Int c, s) -> fprintf fmt "@[enum@ {@[@ %s@ =@ %s@ };@]@]@ %a" x (Signed.SInt.to_string c) ccomp s | `LetAssign (lv, e, c) -> fprintf fmt "@[@[%a@]@;=@;@[%a@];@]@ %a" clvalue lv ceff e ccomp c let format_parameter_list parameters k fmt = let format_arg fmt (name, Ty t) = Ctypes_type_printing.format_typ ~name fmt t in match parameters with | [] -> Format.fprintf fmt "%t(void)" k | [(_, Ty Void)] -> Format.fprintf fmt "@[%t@[(void)@]@]" k | _ -> Format.fprintf fmt "@[%t@[%a@]@]" k (format_seq "(" format_arg "," ")") parameters let cfundec : Format.formatter -> cfundec -> unit = fun fmt (`Fundec (name, args, Ty return)) -> Ctypes_type_printing.format_typ' return (fun context fmt -> format_parameter_list args (Ctypes_type_printing.format_name ~name) fmt) `nonarray fmt let storage_class fmt = function `Static -> fprintf fmt "static@\n" | `Extern -> () let cfundef fmt (`Function (dec, body, sc) : cfundef) = storage_class fmt sc; fprintf fmt "%a@\n{@[@\n%a@]@\n}@\n" cfundec dec ccomp body yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs_errors.ml000066400000000000000000000004701445631112600232660ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Exception definitions *) exception Cstubs_internal_error of string let internal_error fmt = Format.ksprintf (fun s -> raise (Cstubs_internal_error s)) fmt yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs_errors.mli000066400000000000000000000004271445631112600234410ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Exception definitions *) exception Cstubs_internal_error of string val internal_error : ('a, unit, string, 'b) format4 -> 'a yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs_generate_c.ml000066400000000000000000000454771445631112600240660ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* C stub generation *) [@@@warning "-9-27"] open Ctypes_static open Cstubs_c_language open Unchecked_function_types let max_byte_args = 5 type errno_policy = [ `Ignore_errno | `Return_errno ] module Generate_C = struct let report_unpassable what = let msg = Printf.sprintf "cstubs does not support passing %s" what in raise (Unsupported msg) let local name ty = `Local (name, Ty ty) let rec (>>=) : type a. ccomp * a typ -> (cexp -> ccomp) -> ccomp = fun (e, ty) k -> let x = fresh_var () in match e with (* let x = v in e ~> e[x:=v] *) | #cexp as v -> k v | #ceff as e -> `Let ((local x ty, e), k (local x ty)) | `CAMLparam (xs, c) -> let Ty t = Type_C.ccomp c in `CAMLparam (xs, (c, t) >>= k) | `LetConst (y, i, c) -> (* let x = (let const y = i in c) in e ~> let const y = i in (let x = c in e) *) let Ty t = Type_C.ccomp c in `LetConst (y, i, (c, t) >>= k) | `CAMLreturnT (Ty ty, v) -> (k v, ty) >>= fun e -> `CAMLreturnT (Type_C.cexp e, e) | `Return (Ty ty, v) -> (k v, ty) >>= fun e -> `Return (Type_C.cexp e, e) | `Let (ye, c) -> (* let x = (let y = e1 in e2) in e3 ~> let y = e1 in (let x = e2 in e3) *) let Ty t = Type_C.ccomp c in `Let (ye, (c, t) >>= k) | `LetAssign (lv, v, c) -> (* let x = (y := e1; e2) in e3 ~> y := e1; let x = e2 in e3 *) let Ty t = Type_C.ccomp c in `LetAssign (lv, v, (c, t) >>= k) let (>>) c1 c2 = (c1, Void) >>= fun _ -> c2 let of_fatptr : cexp -> ceff = fun x -> `App (reader "CTYPES_ADDR_OF_FATPTR" (value @-> returning (ptr void)), [x]) let pair_with_errno : cexp -> ceff = fun x -> `App (conser "ctypes_pair_with_errno" (value @-> returning value), [x]) let string_to_ptr : cexp -> ccomp = fun x -> `App (reader "CTYPES_PTR_OF_OCAML_STRING" (value @-> returning (ptr void)), [x]) let bytes_to_ptr : cexp -> ccomp = fun x -> `App (reader "CTYPES_PTR_OF_OCAML_BYTES" (value @-> returning (ptr void)), [x]) let float_array_to_ptr : cexp -> ccomp = fun x -> `App (reader "CTYPES_PTR_OF_FLOAT_ARRAY" (value @-> returning (ptr void)), [x]) let from_ptr : cexp -> ceff = fun x -> `App (conser "CTYPES_FROM_PTR" (ptr void @-> returning value), [x]) let acquire_runtime_system : ccomp = `App (conser "caml_acquire_runtime_system" (void @-> returning void), []) let release_runtime_system : ccomp = `App (conser "caml_release_runtime_system" (void @-> returning void), []) let val_unit : ceff = `Global { name = "Val_unit"; references_ocaml_heap = true; typ = Ty value } let errno = `Global { name = "errno"; references_ocaml_heap = false; typ = Ty sint } let functions : ceff = `Global { name = "functions"; references_ocaml_heap = true; typ = Ty (ptr value) } let caml_callbackN : cfunction = { fname = "caml_callbackN"; allocates = true; reads_ocaml_heap = true; fn = Fn (value @-> int @-> ptr value @-> returning value) } let copy_bytes : cfunction = { fname = "ctypes_copy_bytes"; allocates = true; reads_ocaml_heap = true; fn = Fn (ptr void @-> size_t @-> returning value) } let cast : from:ty -> into:ty -> ccomp -> ccomp = fun ~from:(Ty from) ~into e -> (e, from) >>= fun x -> `Cast (into, x) let rec prj : type a b. a typ -> orig: b typ -> cexp -> ccomp option = fun ty ~orig x -> match ty with | Void -> None | Primitive p -> let { fn = Fn fn } as prj = prim_prj p in let rt = return_type fn in Some (cast ~from:rt ~into:(Ty (Primitive p)) (`App (prj, [x]))) | Pointer _ -> Some (of_fatptr x :> ccomp) | Funptr _ -> Some (of_fatptr x :> ccomp) | Struct s -> Some (((of_fatptr x :> ccomp), ptr void) >>= fun y -> `Deref (`Cast (Ty (ptr orig), y))) | Union u -> Some (((of_fatptr x :> ccomp), ptr void) >>= fun y -> `Deref (`Cast (Ty (ptr orig), y))) | Abstract _ -> report_unpassable "values of abstract type" | View { ty } -> prj ty ~orig x | Array _ -> report_unpassable "arrays" | Bigarray _ -> report_unpassable "bigarrays" | OCaml String -> Some (string_to_ptr x) | OCaml Bytes -> Some (bytes_to_ptr x) | OCaml FloatArray -> Some (float_array_to_ptr x) let prj ty x = prj ty ~orig:ty x let rec inj : type a. a typ -> clocal -> ceff = fun ty x -> match ty with | Void -> val_unit | Primitive p -> `App (prim_inj p, [`Cast (Ty (Primitive p), (x :> cexp))]) | Pointer _ -> from_ptr (x:> cexp) | Funptr _ -> from_ptr (x:> cexp) | Struct s -> `App (copy_bytes, [`Addr (x :> cvar); `Int (Signed.SInt.of_int (sizeof ty))]) | Union u -> `App (copy_bytes, [`Addr (x :> cvar); `Int (Signed.SInt.of_int (sizeof ty))]) | Abstract _ -> report_unpassable "values of abstract type" | View { ty } -> inj ty x | Array _ -> report_unpassable "arrays" | Bigarray _ -> report_unpassable "bigarrays" | OCaml _ -> report_unpassable "ocaml references as return values" type _ fn = | Returns : 'a typ -> 'a fn | Function : string * 'a typ * 'b fn -> ('a -> 'b) fn let rec name_params : type a. a Ctypes_static.fn -> a fn = function | Ctypes_static.Returns t -> Returns t | Ctypes_static.Function (f, t) -> Function (fresh_var (), f, name_params t) let rec value_params : type a. a fn -> (string * ty) list = function | Returns t -> [] | Function (x, _, t) -> (x, Ty value) :: value_params t let fundec : type a. string -> a Ctypes.fn -> cfundec = fun name fn -> `Fundec (name, args fn, return_type fn) let fn : type a. concurrency:[`Sequential|`Unlocked] -> errno:errno_policy -> cname:string -> stub_name:string -> a Ctypes_static.fn -> cfundef = fun ~concurrency ~errno:errno_ ~cname ~stub_name f -> let fvar = { fname = cname; allocates = false; reads_ocaml_heap = false; fn = Fn f; } in let rec body : type a. _ -> a fn -> _ = fun vars -> function | Returns t -> let x = fresh_var () in let e = `App (fvar, (List.rev vars :> cexp list)) in begin match errno_, concurrency with `Ignore_errno, `Sequential -> `Let ((local x t, e), (inj t (local x t) :> ccomp)) | `Ignore_errno, `Unlocked -> release_runtime_system >> `Let ((local x t, e), acquire_runtime_system >> (((inj t (local x t) :> ccomp), value) >>= fun x -> `CAMLreturnT (Ty value, x) :> ccomp)) | `Return_errno, `Sequential -> (`LetAssign (errno, `Int Signed.SInt.zero, `Let ((local x t, e), ((inj t (local x t) :> ccomp), value) >>= fun v -> (pair_with_errno v :> ccomp))) : ccomp) | `Return_errno, `Unlocked -> (`LetAssign (errno, `Int Signed.SInt.zero, release_runtime_system >> `Let ((local x t, e), (acquire_runtime_system >> (inj t (local x t) :> ccomp), value) >>= fun v -> ((pair_with_errno v :> ccomp), value) >>= fun x -> `CAMLreturnT (Ty value, x))) : ccomp) end | Function (x, f, t) -> begin match prj f (local x value) with None -> body vars t | Some projected -> (projected, f) >>= fun x' -> body (x' :: vars) t end in let f' = name_params f in let vp = value_params f' in `Function (`Fundec (stub_name, vp, Ty value), (match concurrency with `Unlocked -> `CAMLparam(List.map fst vp, body [] f') | `Sequential -> body [] f'), `Extern) let byte_fn : type a. string -> a Ctypes_static.fn -> int -> cfundef = fun fname fn nargs -> let argv = ("argv", Ty (ptr value)) in let argc = ("argc", Ty int) in let f = { fname ; allocates = true; reads_ocaml_heap = true; fn = Fn fn } in let rec build_call ?(args=[]) = function | 0 -> `App (f, args) | n -> (`Index (`Local argv, `Int (Signed.SInt.of_int (n - 1))), value) >>= fun x -> build_call ~args:(x :: args) (n - 1) in let bytename = Printf.sprintf "%s_byte%d" fname nargs in `Function (`Fundec (bytename, [argv; argc], Ty value), build_call nargs, `Extern) let inverse_fn ~stub_name ~runtime_lock f = let `Fundec (_, args, Ty rtyp) as dec = fundec stub_name f in let idx = local (Printf.sprintf "fn_%s" stub_name) int in let project typ e = match prj typ e with None -> (e :> ccomp) | Some e -> e in let wrap_if cond (lft:ccomp) (rgt:ccomp) = if cond then lft >> rgt else rgt in let call = (* f := functions[fn_name]; x := caml_callbackN(f, nargs, locals); y := T_val(x); CAMLdrop; y *) (`Index (functions, idx), value) >>= fun f -> (`App (caml_callbackN, [f; local "nargs" int; local "locals" (ptr value)]), value) >>= fun x -> (project rtyp x, rtyp) >>= fun y -> (`CAMLdrop, void) >>= fun _ -> wrap_if runtime_lock release_runtime_system (`Return (Ty rtyp, y)) in let body = (* locals[0] = Val_T0(x0); locals[1] = Val_T1(x1); ... locals[n] = Val_Tn(xn); call; *) snd (ListLabels.fold_right args ~init:(List.length args - 1, call) ~f:(fun (x, Ty t) (i, c) -> i - 1, `LetAssign (`Index (local "locals" (ptr value), `Int (Signed.SInt.of_int i)), (inj t (local x t)), c))) in (* T f(T0 x0, T1 x1, ..., Tn xn) { enum { nargs = n }; CAMLparam0(); CAMLlocalN(locals, nargs); body } *) `Function (dec, `LetConst (local "nargs" int, `Int (Signed.SInt.of_int (List.length args)), wrap_if runtime_lock acquire_runtime_system ( `CAMLparam0 >> `CAMLlocalN (local "locals" (array (List.length args) value), local "nargs" int) >> body)), `Extern) let value : type a. cname:string -> stub_name:string -> a Ctypes_static.typ -> cfundef = fun ~cname ~stub_name typ -> let (e, ty) = (`Addr (`Global { name = cname; typ = Ty typ; references_ocaml_heap = false }), (ptr typ)) in let x = fresh_var () in `Function (`Fundec (stub_name, ["_", Ty value], Ty value), `Let ((local x ty, e), (inj (ptr typ) (local x ty) :> ccomp)), `Extern) end let fn ~concurrency ~errno ~cname ~stub_name fmt fn = let `Function (`Fundec (f, xs, _), _, _) as dec = Generate_C.fn ~concurrency ~errno ~stub_name ~cname fn in let nargs = List.length xs in if nargs > max_byte_args then begin Cstubs_emit_c.cfundef fmt dec; Cstubs_emit_c.cfundef fmt (Generate_C.byte_fn f fn nargs) end else Cstubs_emit_c.cfundef fmt dec let value ~cname ~stub_name fmt typ = let dec = Generate_C.value ~cname ~stub_name typ in Cstubs_emit_c.cfundef fmt dec let inverse_fn ~stub_name ~runtime_lock fmt fn : unit = Cstubs_emit_c.cfundef fmt (Generate_C.inverse_fn ~stub_name ~runtime_lock fn) let inverse_fn_decl ~stub_name fmt fn = Format.fprintf fmt "@[%a@];@\n" Cstubs_emit_c.cfundec (Generate_C.fundec stub_name fn) module Lwt = struct let fprintf, sprintf = Format.fprintf, Printf.sprintf let unsupported t = let fail msg = raise (Unsupported msg) in Printf.ksprintf fail "cstubs.lwt does not support the type %s" (Ctypes.string_of_typ t) let rec prj : type a b. a typ -> orig: b typ -> cexp -> ceff = fun ty ~orig x -> match ty with | Primitive p -> `App (prim_prj p, [x]) | Pointer _ -> Generate_C.of_fatptr x | Funptr _ -> Generate_C.of_fatptr x | View { ty } -> prj ty ~orig x | t -> unsupported t let prj ty x = prj ty ~orig:ty x let lwt_unix_job = abstract ~name:"struct lwt_unix_job" ~size:1 ~alignment:1 let structure_type stub_name = structure (sprintf "job_%s" stub_name) let structure (type r) ~errno ~stub_name fmt fn args (result : r typ) = let open Ctypes in let s = structure_type stub_name in let _ : (_,_) field = field s "job" lwt_unix_job in let () = match result with Void -> let _ : (_,_) field = field s "result" int in () | result -> let _ : (_,_) field = field s "result" result in () in let () = match errno with `Ignore_errno -> () | `Return_errno -> ignore (field s "error_status" sint) in let () = ListLabels.iter args ~f:(fun (BoxedType t, name) -> ignore (field s name t : (_,_) field)) in let () = seal s in fprintf fmt "@[%a@];@\n" (fun t -> format_typ t) s let worker (type r) ~errno ~cname ~stub_name fmt f (result : r typ) args = let fn' = { fname = cname; allocates = false; reads_ocaml_heap = false; fn = Fn f } and j = "j", Ty (ptr (structure_type stub_name)) in let rec body args : _ -> ccomp = function [] -> let r c = match result with | Void -> Generate_C.(`App (fn', List.rev args) >> c) | result -> Generate_C.cast ~from:(Ty result) ~into:(Ty Void) (`LetAssign (`PointerField (`Local j, "result"), `App (fn', List.rev args), c)) in begin match errno with `Ignore_errno -> r (`Return (Ty Void, (`Int Signed.SInt.zero))) | `Return_errno -> let open Generate_C in `LetAssign (errno, `Int Signed.SInt.zero, r (`LetAssign (`PointerField (`Local j, "error_status"), errno, `Return (Ty Void, (`Int Signed.SInt.zero))))) end | (BoxedType ty, x) :: xs -> Generate_C.((`DerefField (`Local j, x), ty) >>= fun y -> body (y :: args) xs) in Cstubs_emit_c.cfundef fmt (`Function (`Fundec (sprintf "worker_%s" stub_name, [j], Ty void), body [] args, `Static)) let result (type r) ~errno ~stub_name fmt fn (result : r typ) = begin fprintf fmt "@[static@ value@ result_%s@;@[(struct@ job_%s@ *j)@]@]@;@[<2>{@\n" stub_name stub_name; fprintf fmt "@[CAMLparam0@ ();@]@\n"; fprintf fmt "@[CAMLlocal1@ (rv);@]@\n"; let () = match errno with `Ignore_errno -> fprintf fmt "@[rv@ =@ ("; | `Return_errno -> fprintf fmt "@[rv@ =@ caml_alloc_tuple(2);@]@\n"; fprintf fmt "@[Store_field(rv,@ 1,@ ctypes_copy_sint(j->error_status));@]@\n"; fprintf fmt "@[Store_field(rv,@ 0,@ "; in fprintf fmt "%a);@]@\n" (let f (type r) fmt : r typ -> _ = function Void -> Cstubs_emit_c.ceff fmt Generate_C.val_unit | ty -> Cstubs_emit_c.ceff fmt (Generate_C.inj ty (`Local ("j->result", Cstubs_c_language.(Ty ty)))) in f ) result; fprintf fmt "@[lwt_unix_free_job(&j->job)@];@\n"; fprintf fmt "@[CAMLreturn@ (rv)@];@]@\n"; fprintf fmt "}@\n"; end let stub ~errno ~stub_name fmt fn args = begin fprintf fmt "@[value@ %s@;@[(%s)@]@]@;@[<2>{@\n" stub_name (String.concat ", " (List.map (fun (_, x) -> "value "^ x) args)); Cstubs_emit_c.camlParam fmt (List.map snd args); fprintf fmt "@[LWT_UNIX_INIT_JOB(job,@ %s,@ 0)@];@\n" stub_name; let () = match errno with `Ignore_errno -> () | `Return_errno -> fprintf fmt "@[job->error_status@ =@ 0@];@\n" in ListLabels.iter args ~f:(fun (BoxedType t, x) -> fprintf fmt "@[job->%s@ =@ %a@];@\n" x (fun fmt (t, x) -> Cstubs_emit_c.ceff fmt (prj t (`Local (x, Cstubs_c_language.(Ty value))))) (t, x)); fprintf fmt "@[CAMLreturn(lwt_unix_alloc_job(&(job->job)))@];@]@\n"; fprintf fmt "}@\n"; end let byte_stub ~errno ~stub_name fmt fn args = begin let nargs = List.length args in fprintf fmt "@[value@ %s_byte%d@;@[(value *argv, int argc)@]@]@;@[<2>{@\n" stub_name nargs; fprintf fmt "@[<2>return@ @[%s(@[" stub_name; ListLabels.iteri args ~f:(fun i _ -> if i = nargs - 1 then fprintf fmt "argv[%d]" i else fprintf fmt "argv[%d],@ " i); fprintf fmt ")@]@]@];@]@\n"; fprintf fmt "}@\n"; end let fn_args_and_result fn = let counter = ref 0 in let var prefix = incr counter; Printf.sprintf "%s_%d" prefix !counter in let rec aux : type a. a fn -> _ -> _ = fun fn args -> match fn with Function (Void, f) -> aux f args | Function (t, f) -> aux f ((BoxedType t, var "arg") :: args) | Returns t -> List.rev args, BoxedType t in aux fn [] let fn ~errno ~cname ~stub_name fmt fn = let args, BoxedType r = fn_args_and_result fn in begin structure ~errno ~stub_name fmt fn args r; worker ~errno ~cname ~stub_name fmt fn r args; result ~errno ~stub_name fmt fn r; stub ~errno ~stub_name fmt fn args; if List.length args > max_byte_args then byte_stub ~errno ~stub_name fmt fn args; fprintf fmt "@\n"; end end let fn ~concurrency ~errno ~cname ~stub_name fmt f = match concurrency with | `Lwt_preemptive | `Unlocked | `Lwt_jobs when has_ocaml_argument f -> raise (Unsupported "Unsupported argument type when releasing runtime lock") | `Lwt_preemptive | `Unlocked -> fn ~concurrency:`Unlocked ~errno ~cname ~stub_name fmt f | `Sequential -> fn ~concurrency:`Sequential ~errno ~cname ~stub_name fmt f | `Lwt_jobs -> Lwt.fn ~errno ~cname ~stub_name fmt f yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs_generate_c.mli000066400000000000000000000013011445631112600242110ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* C stub generation *) val fn : concurrency:[ `Sequential | `Lwt_jobs | `Lwt_preemptive | `Unlocked ] -> errno:[ `Ignore_errno | `Return_errno ] -> cname:string -> stub_name:string -> Format.formatter -> 'a Ctypes.fn -> unit val value : cname:string -> stub_name:string -> Format.formatter -> 'a Ctypes.typ -> unit val inverse_fn : stub_name:string -> runtime_lock:bool -> Format.formatter -> 'a Ctypes.fn -> unit val inverse_fn_decl : stub_name:string -> Format.formatter -> 'a Ctypes.fn -> unit yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs_generate_ml.ml000066400000000000000000000617771445631112600242550ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* ML stub generation *) [@@@warning "-9-27"] open Ctypes_static open Ctypes_path open Cstubs_errors type non_lwt = [ `Sequential | `Unlocked ] type lwt = [ `Lwt_jobs | `Lwt_preemptive ] type concurrency_policy = [ non_lwt | lwt ] type errno_policy = [ `Ignore_errno | `Return_errno ] type lident = string type ml_type = [ `Ident of path | `Appl of path * ml_type list | `Pair of ml_type * ml_type | `Fn of ml_type * ml_type ] type ml_external_type = [ `Prim of ml_type list * ml_type ] type ml_pat = [ `Var of string | `Record of (path * ml_pat) list * [`Etc | `Complete] | `As of ml_pat * string | `Underscore | `Con of path * ml_pat list ] type ml_exp = [ `Ident of path | `Project of ml_exp * path | `MakePtr of ml_exp * ml_exp | `MakeFunPtr of ml_exp * ml_exp | `MakeStructured of ml_exp * ml_exp | `Appl of ml_exp * ml_exp | `Tuple of ml_exp list | `Seq of ml_exp * ml_exp | `Let of ml_pat * ml_exp * ml_exp | `Unit | `Fun of lident list * ml_exp ] type attributes = { float: bool; noalloc: bool } type extern = { ident : string; typ: ml_external_type; primname: string; primname_byte: string option; attributes: attributes; } module Emit_ML : sig type appl_parens = ApplParens | NoApplParens val ml_exp : appl_parens -> Format.formatter -> ml_exp -> unit val ml_pat : appl_parens -> Format.formatter -> ml_pat -> unit val ml_external_type : Format.formatter -> ml_external_type -> unit val extern : Format.formatter -> extern -> unit end = struct let fprintf = Format.fprintf (* We (only) need to parenthesize function types in certain contexts * on the lhs of a function type: - -> t * as the argument to a single-argument type constructor: - t *) type arrow_parens = ArrowParens | NoArrowParens (* We (only) need to parenthesize application expressions in certain contexts * in a projection expression: -.l * in a dereference expression: !@ - * as an argument in an application: e - *) type appl_parens = ApplParens | NoApplParens let ident = format_path let rec ml_type arrow_parens fmt t = match arrow_parens, t with | _, `Ident i -> ident fmt i | _, `Appl (t, []) -> ident fmt t | _, `Appl (t, [t']) -> fprintf fmt "@[%a@ %a@]" (ml_type ArrowParens) t' ident t | _, `Appl (t, ts) -> let nargs = List.length ts in fprintf fmt "("; List.iteri (fun i arg -> if i = nargs - 1 then (ml_type NoArrowParens) fmt arg else fprintf fmt "%a,@ " (ml_type NoArrowParens) arg ) ts; fprintf fmt ")@ %a" ident t; | ArrowParens, `Fn (t, t') -> fprintf fmt "@[(%a@ ->@ %a)@]" (ml_type ArrowParens) t (ml_type NoArrowParens) t' | NoArrowParens, `Fn (t, t') -> fprintf fmt "@[%a@ ->@]@ %a" (ml_type ArrowParens) t (ml_type NoArrowParens) t' | _, `Pair (t, t') -> fprintf fmt "@[(%a@ *@ %a)@]" (ml_type NoArrowParens) t (ml_type NoArrowParens) t' let ml_external_type fmt (`Prim (args, ret) : ml_external_type) = List.iter (fprintf fmt "@[%a@ ->@]@ " (ml_type ArrowParens)) args; ml_type ArrowParens fmt ret let primname_opt fmt = function | None -> () | Some primname -> fprintf fmt "%S@ " primname let attrs fmt { float; noalloc } = begin (* TODO: float support not yet implemented *) (* if float then pp_print_string fmt "\"float\""; *) (* TODO: fix this. The may_allocate function determines whether any of the functions in the generated C cause OCaml heap allocations. However, it doesn't currently account for callbacks: if we pass a handle to an OCaml function into C, calling the function can trigger an allocation. We need some way in the interface of the library for the client to indicate whether it is safe to assume that a C function cannot call back into OCaml. *) (* if noalloc then pp_print_string fmt "\"noalloc\"" *) end let args fmt xs = List.iter (fprintf fmt "%s@ ") xs let rec ml_exp appl_parens fmt (e : ml_exp) = match appl_parens, e with | _, `Unit -> fprintf fmt "()" | _, `Ident x -> ident fmt x | _, `Project (e, l) -> fprintf fmt "%a.%a" (ml_exp ApplParens) e ident l | ApplParens, `Appl (f, p) -> fprintf fmt "@[(%a@;<1 2>%a)@]" (ml_exp NoApplParens) f (ml_exp ApplParens) p | NoApplParens, `Appl (f, p) -> fprintf fmt "@[%a@ %a@]" (ml_exp NoApplParens) f (ml_exp ApplParens) p | ApplParens, `MakePtr (t, e) -> fprintf fmt "(@[CI.make_ptr@ %a@ %a)@]" (ml_exp ApplParens) t (ml_exp ApplParens) e | NoApplParens, `MakePtr (t, e) -> fprintf fmt "@[CI.make_ptr@ %a@ %a@]" (ml_exp ApplParens) t (ml_exp ApplParens) e | ApplParens, `MakeFunPtr (t, e) -> fprintf fmt "(@[CI.make_fun_ptr@ %a@ %a)@]" (ml_exp ApplParens) t (ml_exp ApplParens) e | NoApplParens, `MakeFunPtr (t, e) -> fprintf fmt "@[CI.make_fun_ptr@ %a@ %a@]" (ml_exp ApplParens) t (ml_exp ApplParens) e | ApplParens, `MakeStructured (t, e) -> fprintf fmt "(@[CI.make_structured@ %a@ %a)@]" (ml_exp ApplParens) t (ml_exp ApplParens) e | NoApplParens, `MakeStructured (t, e) -> fprintf fmt "@[CI.make_structured@ %a@ %a@]" (ml_exp ApplParens) t (ml_exp ApplParens) e | _, `Fun (xs, e) -> fprintf fmt "(@[<1>fun@ %a->@ %a)@]" args xs (ml_exp NoApplParens) e | _, `Tuple es -> fprintf fmt "(@[%a)@]" tuple_elements es | _, `Seq (e1, e2) -> fprintf fmt "(@[%a;@ %a)@]" (ml_exp NoApplParens) e1 (ml_exp NoApplParens) e2 | ApplParens, `Let (p, e1, e2) -> fprintf fmt "(@[let@ %a@ = %a@ in@ %a)@]" (ml_pat NoApplParens) p (ml_exp NoApplParens) e1 (ml_exp NoApplParens) e2 | NoApplParens, `Let (p, e1, e2) -> fprintf fmt "@[let@ %a@ = %a@ in@ %a@]" (ml_pat NoApplParens) p (ml_exp NoApplParens) e1 (ml_exp NoApplParens) e2 and tuple_elements fmt : ml_exp list -> unit = fun xs -> let last = List.length xs - 1 in List.iteri (fun i -> if i <> last then fprintf fmt "%a,@ " (ml_exp NoApplParens) else fprintf fmt "%a" (ml_exp NoApplParens)) xs and ml_pat appl_parens fmt pat = match appl_parens, pat with | _, `Var x -> fprintf fmt "%s" x | _, `Record (fs, `Etc) -> fprintf fmt "{@[%a_}@]" pat_fields fs | _, `Record (fs, `Complete) -> fprintf fmt "{@[%a}@]" pat_fields fs | _, `As (p, x) -> fprintf fmt "@[(%a@ as@ %s)@]" (ml_pat NoApplParens) p x | _, `Underscore -> fprintf fmt "_" | _, `Con (c, []) -> fprintf fmt "%a" format_path c | NoApplParens, `Con (c, [p]) -> fprintf fmt "@[<2>%a@ @[%a@]@]" format_path c (ml_pat ApplParens) p | ApplParens, `Con (c, [p]) -> fprintf fmt "(@[<2>%a@ @[%a@])@]" format_path c (ml_pat ApplParens) p | ApplParens, `Con (c, ps) -> fprintf fmt "(@[<2>%a@ (@[%a)@])@]" format_path c pat_args ps | NoApplParens, `Con (c, ps) -> fprintf fmt "@[<2>%a@ (@[%a)@]@]" format_path c pat_args ps and pat_fields fmt : (path * ml_pat) list -> unit = List.iter (fun (l, p) -> fprintf fmt "@[%a@ =@ %a;@]@ " format_path l (ml_pat NoApplParens) p) and pat_args fmt : ml_pat list -> unit = fun xs -> let last = List.length xs - 1 in List.iteri (fun i -> if i <> last then fprintf fmt "%a,@ " (ml_pat NoApplParens) else fprintf fmt "%a" (ml_pat NoApplParens)) xs let extern fmt { ident; typ; primname; primname_byte; attributes } = fprintf fmt "@[@[external@ %s@]@ @[:@ @[%a@]@]@ " ident ml_external_type typ; fprintf fmt "@[=@ @[@[%a@]@[%S@]@ %a@]@]@]@." primname_opt primname_byte primname attrs attributes end let arity : ml_external_type -> int = fun (`Prim (args, _)) -> List.length args let max_byte_args = 5 let byte_stub_name : string -> ml_external_type -> string option = fun name t -> let arity = arity t in if arity > max_byte_args then Some (Printf.sprintf "%s_byte%d" name arity) else None let attributes : type a. a fn -> attributes = let open Cstubs_analysis in fun fn -> { float = float fn; noalloc = not (may_allocate fn) } let managed_buffer = `Ident (path_of_string "CI.managed_buffer") let voidp = `Ident (path_of_string "CI.voidp") let fatptr = `Appl (path_of_string "CI.fatptr", [`Ident (path_of_string "_")]) let fatfunptr = `Appl (path_of_string "CI.fatfunptr", [`Ident (path_of_string "_")]) (* These functions determine the type that should appear in the extern signature *) let rec ml_typ_of_return_typ : type a. a typ -> ml_type = function | Void -> `Ident (path_of_string "unit") | Primitive p -> `Ident (Cstubs_public_name.ident_of_ml_prim (Ctypes_primitive_types.ml_prim p)) | Struct _ -> managed_buffer | Union _ -> managed_buffer | Abstract _ -> managed_buffer | Pointer _ -> voidp | Funptr _ -> voidp | View { ty } -> ml_typ_of_return_typ ty | Array _ as a -> internal_error "Unexpected array type in the return type: %s" (Ctypes.string_of_typ a) | Bigarray _ as a -> internal_error "Unexpected bigarray type in the return type: %s" (Ctypes.string_of_typ a) | OCaml String -> Ctypes_static.unsupported "cstubs does not support OCaml strings as return values" | OCaml Bytes -> Ctypes_static.unsupported "cstubs does not support OCaml bytes values as return values" | OCaml FloatArray -> Ctypes_static.unsupported "cstubs does not support OCaml float arrays as return values" let rec ml_typ_of_arg_typ : type a. a typ -> ml_type = function | Void -> `Ident (path_of_string "unit") | Primitive p -> `Ident (Cstubs_public_name.ident_of_ml_prim (Ctypes_primitive_types.ml_prim p)) | Pointer _ -> fatptr | Funptr _ -> fatfunptr | Struct _ -> fatptr | Union _ -> fatptr | Abstract _ -> fatptr | View { ty } -> ml_typ_of_arg_typ ty | Array _ as a -> internal_error "Unexpected array in an argument type: %s" (Ctypes.string_of_typ a) | Bigarray _ as a -> internal_error "Unexpected bigarray in an argument type: %s" (Ctypes.string_of_typ a) | OCaml String -> `Appl (path_of_string "CI.ocaml", [`Ident (path_of_string "string")]) | OCaml Bytes -> `Appl (path_of_string "CI.ocaml", [`Ident (path_of_string "bytes")]) | OCaml FloatArray -> `Appl (path_of_string "CI.ocaml", [`Appl (path_of_string "array", [`Ident (path_of_string "float")])]) type polarity = In | Out let flip = function | In -> Out | Out -> In let ml_typ_of_typ = function In -> ml_typ_of_arg_typ | Out -> ml_typ_of_return_typ let lwt_job_type = Ctypes_path.path_of_string "Lwt_unix.job" let int_type = `Ident (Ctypes_path.path_of_string "Signed.sint") let rec ml_external_type_of_fn : type a. concurrency:concurrency_policy -> errno:errno_policy -> a fn -> polarity -> ml_external_type = fun ~concurrency ~errno fn polarity -> match fn, concurrency, errno with | Returns t, (#non_lwt|`Lwt_preemptive), `Ignore_errno -> `Prim ([], ml_typ_of_typ polarity t) | Returns t, (#non_lwt|`Lwt_preemptive), `Return_errno -> `Prim ([], `Pair (ml_typ_of_typ polarity t, int_type)) | Returns t, `Lwt_jobs, `Ignore_errno -> `Prim ([], `Appl (lwt_job_type, [ml_typ_of_typ polarity t])) | Returns t, `Lwt_jobs, `Return_errno -> `Prim ([], `Appl (lwt_job_type, [`Pair (ml_typ_of_typ polarity t, int_type)])) | Function (f, t), _, _ -> let `Prim (l, t) = ml_external_type_of_fn ~concurrency ~errno t polarity in `Prim (ml_typ_of_typ (flip polarity) f :: l, t) let var_counter = ref 0 let fresh_var () = incr var_counter; Printf.sprintf "x%d" !var_counter let extern ~concurrency ~errno ~stub_name ~external_name fmt fn = let ext = let typ = ml_external_type_of_fn ~concurrency ~errno fn Out in ({ ident = external_name; typ = typ; primname = stub_name; primname_byte = byte_stub_name stub_name typ; attributes = attributes fn; }) in Format.fprintf fmt "%a@." Emit_ML.extern ext let static_con c args = `Con (Ctypes_path.path_of_string ("CI." ^ c), args) let local_con c args = `Con (Ctypes_path.path_of_string c, args) let map_result_id = Ctypes_path.path_of_string "map_result" let make_ptr = Ctypes_path.path_of_string "CI.make_ptr" let make_fun_ptr = Ctypes_path.path_of_string "CI.make_fun_ptr" let make_structured = Ctypes_path.path_of_string "CI.make_structured" let map_result ~concurrency ~errno f e = let map_result f x = `Appl (`Appl (`Ident map_result_id, f), x) in match concurrency, errno, f with #non_lwt, `Ignore_errno, `MakePtr x -> `MakePtr (`Ident (path_of_string x), e) | #non_lwt, `Ignore_errno, `MakeFunPtr x -> `MakeFunPtr (`Ident (path_of_string x), e) | #non_lwt, `Ignore_errno, `MakeStructured x -> `MakeStructured (`Ident (path_of_string x), e) | #non_lwt, `Ignore_errno, `Appl x -> `Appl (`Ident (path_of_string x), e) | _, _, `MakePtr x -> map_result (`Appl (`Ident make_ptr, `Ident (path_of_string x))) e | _, _, `MakeFunPtr x -> map_result (`Appl (`Ident make_fun_ptr, `Ident (path_of_string x))) e | _, _, `MakeStructured x -> map_result (`Appl (`Ident make_structured, `Ident (path_of_string x))) e | _, _, `Appl x -> map_result (`Ident (path_of_string x)) e type pattern_exp_return = ml_pat * ml_exp option * (ml_pat * ml_exp) list let rec pattern_and_exp_of_typ : type a. concurrency:concurrency_policy -> errno:errno_policy -> a typ -> ml_exp -> polarity -> (ml_pat * ml_exp) list -> pattern_exp_return = fun ~concurrency ~errno typ e pol binds -> match typ with | Void -> (static_con "Void" [], None, binds) | Primitive p -> let id = Cstubs_public_name.constructor_cident_of_prim ~module_name:"CI" p in (static_con "Primitive" [`Con (id, [])], None, binds) | Pointer _ -> begin match pol with | In -> let pat = static_con "Pointer" [`Underscore] in let x = fresh_var () in (pat, Some (`Ident (path_of_string x)), binds @ [static_con "CPointer" [`Var x], e]) | Out -> let x = fresh_var () in let pat = static_con "Pointer" [`Var x] in (pat, Some (map_result ~concurrency ~errno (`MakePtr x) e), binds) end | Funptr _ -> begin match pol with | In -> let pat = static_con "Funptr" [`Underscore] in let x = fresh_var () in (pat, Some (`Ident (path_of_string x)), binds @ [static_con "Static_funptr" [`Var x], e]) | Out -> let x = fresh_var () in let pat = static_con "Funptr" [`Var x] in (pat, Some (map_result ~concurrency ~errno (`MakeFunPtr x) e), binds) end | Struct _ -> begin match pol with | In -> let pat = static_con "Struct" [`Underscore] in let x = fresh_var () in (pat, Some (`Ident (path_of_string x)), binds @ [static_con "CPointer" [`Var x], `Appl (`Ident (path_of_string "Ctypes.addr"), e)]) | Out -> let x = fresh_var () in let pat = `As (static_con "Struct" [`Underscore], x) in (pat, Some (map_result ~concurrency ~errno (`MakeStructured x) e), binds) end | Union _ -> begin match pol with | In -> let pat = static_con "Union" [`Underscore] in let x = fresh_var () in (pat, Some (`Ident (path_of_string x)), binds @ [static_con "CPointer" [`Var x], `Appl (`Ident (path_of_string "Ctypes.addr"), e)]) | Out -> let x = fresh_var () in let pat = `As (static_con "Union" [`Underscore], x) in (pat, Some (map_result ~concurrency ~errno (`MakeStructured x) e), binds) end | View { ty } -> begin match pol with | In -> let x = fresh_var () in let y = fresh_var () in let e = `Appl (`Ident (path_of_string x), e) in let (p, None, binds), e | (p, Some e, binds), _ = pattern_and_exp_of_typ ~concurrency ~errno ty e pol binds, e in let pat = static_con "View" [`Record ([path_of_string "CI.ty", p; path_of_string "write", `Var x], `Etc)] in (pat, Some (`Ident (Ctypes_path.path_of_string y)), (`Var y, e) :: binds) | Out -> let (p, None, binds), e | (p, Some e, binds), _ = pattern_and_exp_of_typ ~concurrency ~errno ty e pol binds, e in let x = fresh_var () in let pat = static_con "View" [`Record ([path_of_string "CI.ty", p; path_of_string "read", `Var x], `Etc)] in (pat, Some (map_result ~concurrency ~errno (`Appl x) e), binds) end | OCaml ty -> begin match pol, ty with | In, String -> (static_con "OCaml" [static_con "String" []], None, binds) | In, Bytes -> (static_con "OCaml" [static_con "Bytes" []], None, binds) | In, FloatArray -> (static_con "OCaml" [static_con "FloatArray" []], None, binds) | Out, String -> Ctypes_static.unsupported "cstubs does not support OCaml strings as return values" | Out, Bytes -> Ctypes_static.unsupported "cstubs does not support OCaml bytes values as return values" | Out, FloatArray -> Ctypes_static.unsupported "cstubs does not support OCaml float arrays as return values" end | Abstract _ as ty -> internal_error "Unexpected abstract type encountered during ML code generation: %s" (Ctypes.string_of_typ ty) | Array _ as ty -> internal_error "Unexpected array type encountered during ML code generation: %s" (Ctypes.string_of_typ ty) | Bigarray _ as ty -> internal_error "Unexpected bigarray type encountered during ML code generation: %s" (Ctypes.string_of_typ ty) (* Build a pattern (without variables) that matches the argument *) let rec pattern_of_typ : type a. a typ -> ml_pat = function Void -> static_con "Void" [] | Primitive p -> let id = Cstubs_public_name.constructor_cident_of_prim ~module_name:"CI" p in static_con "Primitive" [`Con (id, [])] | Pointer _ -> static_con "Pointer" [`Underscore] | Funptr _ -> static_con "Funptr" [`Underscore] | Struct _ -> static_con "Struct" [`Underscore] | Union _ -> static_con "Union" [`Underscore] | View { ty } -> static_con "View" [`Record ([path_of_string "CI.ty", pattern_of_typ ty], `Etc)] | Array (_, _) -> static_con "Array" [`Underscore; `Underscore] | Bigarray _ -> static_con "Bigarray" [`Underscore] | OCaml String -> Ctypes_static.unsupported "cstubs does not support OCaml strings as global values" | OCaml Bytes -> Ctypes_static.unsupported "cstubs does not support OCaml bytes values as global values" | OCaml FloatArray -> Ctypes_static.unsupported "cstubs does not support OCaml float arrays as global values" | Abstract _ as ty -> internal_error "Unexpected abstract type encountered during ML code generation: %s" (Ctypes.string_of_typ ty) type wrapper_state = { pat: ml_pat; exp: ml_exp; args: lident list; trivial: bool; binds: (ml_pat * ml_exp) list; } let lwt_unix_run_job = Ctypes_path.path_of_string "Lwt_unix.run_job" let lwt_preemptive_detach = Ctypes_path.path_of_string "Lwt_preemptive.detach" let run_exp ~concurrency exp = match concurrency with #non_lwt -> exp | `Lwt_jobs -> `Appl (`Ident lwt_unix_run_job, exp) | `Lwt_preemptive -> `Appl (`Appl (`Ident lwt_preemptive_detach, `Fun (["_"], exp)), `Unit) let let_bind : (ml_pat * ml_exp) list -> ml_exp -> ml_exp = fun binds e -> ListLabels.fold_left ~init:e binds ~f:(fun e' (x, e) -> `Let (x, e, e')) let rec wrapper_body : type a. concurrency:concurrency_policy -> errno:errno_policy -> a fn -> ml_exp -> polarity -> (ml_pat * ml_exp) list -> wrapper_state = fun ~concurrency ~errno fn exp pol binds -> match fn with | Returns t -> let exp = run_exp ~concurrency exp in begin match pattern_and_exp_of_typ ~concurrency ~errno t exp (flip pol) binds with pat, None, binds -> { exp ; args = []; trivial = true; binds; pat = local_con "Returns" [pat] } | pat, Some exp, binds -> { exp; args = []; trivial = false; binds; pat = local_con "Returns" [pat] } end | Function (f, t) -> let x = fresh_var () in begin match pattern_and_exp_of_typ ~concurrency ~errno f (`Ident (path_of_string x)) pol binds with | fpat, None, binds -> let { exp; args; trivial; pat = tpat; binds } = wrapper_body ~concurrency ~errno t (`Appl (exp, `Ident (path_of_string x))) pol binds in { exp; args = x :: args; trivial; binds; pat = local_con "Function" [fpat; tpat] } | fpat, Some exp', binds -> let { exp; args = xs; trivial; pat = tpat; binds } = wrapper_body ~concurrency ~errno t (`Appl (exp, exp')) pol binds in { exp; args = x :: xs; trivial = false; binds; pat = local_con "Function" [fpat; tpat] } end let lwt_bind = Ctypes_path.path_of_string "Lwt.bind" let lwt_return = Ctypes_path.path_of_string "Lwt.return" let box_lwt = Ctypes_path.path_of_string "box_lwt" let use_value = Ctypes_path.path_of_string "CI.use_value" let return_result : args:lident list -> ml_exp = fun ~args -> let x = fresh_var () in (* fun v -> CI.use_value (x1,x2,....xn); Lwt.return v *) `Fun ([x], `Seq (`Appl (`Ident use_value, `Tuple (ListLabels.map args ~f:(fun x -> `Ident (Ctypes_path.path_of_string x)))), `Appl (`Ident lwt_return, `Ident (Ctypes_path.path_of_string x)))) (** Returns the variables bound in a pattern, in no particular order *) let rec pat_bound_vars : ml_pat -> lident list = function | `Var x -> [x] | `Record (args, _) -> pats_bound_vars (List.map snd args) | `As (p, x) -> x :: pat_bound_vars p | `Underscore -> [] | `Con (_, ps) -> pats_bound_vars ps and pats_bound_vars : ml_pat list -> lident list = fun ps -> List.fold_left (fun xs p -> pat_bound_vars p @ xs) [] ps let wrapper : type a. concurrency:concurrency_policy -> errno:errno_policy -> path -> a fn -> string -> polarity -> ml_pat * ml_exp = fun ~concurrency ~errno id fn f pol -> let p = wrapper_body ~concurrency ~errno fn (`Ident (path_of_string f)) pol [] in match p, concurrency with { trivial = true; pat; binds }, #non_lwt -> (pat, let_bind binds (run_exp ~concurrency (`Ident id))) | { exp; args; pat; binds }, #non_lwt -> (pat, `Fun (args, let_bind binds exp)) | { trivial = true; pat; args; binds }, #lwt -> let exp : ml_exp = List.fold_left (fun f p -> `Appl (f, `Ident (path_of_string p))) (`Ident id) args in (pat, `Fun (args, let_bind binds (`Appl (`Ident box_lwt, `Appl (`Appl (`Ident lwt_bind, run_exp ~concurrency exp), return_result ~args:(args @ pats_bound_vars (List.map fst binds))))))) | { exp; args; pat; binds }, #lwt -> (pat, `Fun (args, let_bind binds (`Appl (`Ident box_lwt, `Appl (`Appl (`Ident lwt_bind, exp), return_result ~args:(args @ pats_bound_vars (List.map fst binds))))))) let case ~concurrency ~errno ~stub_name ~external_name fmt fn = let p, e = wrapper ~concurrency ~errno (path_of_string external_name) fn external_name In in Format.fprintf fmt "@[@[|@ @[@[%a@],@ %S@]@ ->@]@ " Emit_ML.(ml_pat NoApplParens) p stub_name; Format.fprintf fmt "@[@[%a@]@]@]@." Emit_ML.(ml_exp ApplParens) e let val_case ~stub_name ~external_name fmt typ = let x = fresh_var () in let p = `As (pattern_of_typ typ, x) in let app = `Appl (`Ident (path_of_string external_name), `Unit) in let rhs = `MakePtr (`Ident (path_of_string x), app) in Format.fprintf fmt "@[@[|@ @[@[%a@],@ %S@]@ ->@]@ " Emit_ML.(ml_pat NoApplParens) p stub_name; Format.fprintf fmt "@[@[%a@]@]@]@." Emit_ML.(ml_exp (ApplParens)) rhs let constructor_decl : type a. concurrency:concurrency_policy -> errno:errno_policy -> string -> a fn -> Format.formatter -> unit = fun ~concurrency ~errno name fn fmt -> Format.fprintf fmt "@[|@ %s@ : (@[%a@])@ name@]@\n" name Emit_ML.ml_external_type (ml_external_type_of_fn ~concurrency ~errno fn In) let inverse_case ~register_name ~constructor name fmt fn : unit = let p, e = wrapper ~concurrency:`Sequential ~errno:`Ignore_errno (path_of_string "f") fn "f" Out in Format.fprintf fmt "|@[ @[%a, %S@] -> %s %s (%a)@]@\n" Emit_ML.(ml_pat NoApplParens) p name register_name constructor Emit_ML.(ml_exp ApplParens) e yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs_generate_ml.mli000066400000000000000000000021301445631112600244000ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* ML stub generation *) val extern : concurrency:[ `Sequential | `Lwt_jobs | `Lwt_preemptive | `Unlocked ] -> errno:[ `Ignore_errno | `Return_errno ] -> stub_name:string -> external_name:string -> Format.formatter -> ('a -> 'b) Ctypes.fn -> unit val case : concurrency:[ `Sequential | `Lwt_jobs | `Lwt_preemptive | `Unlocked ] -> errno:[ `Ignore_errno | `Return_errno ] -> stub_name:string -> external_name:string -> Format.formatter -> ('a -> 'b) Ctypes.fn -> unit val val_case : stub_name:string -> external_name:string -> Format.formatter -> 'a Ctypes.typ -> unit val constructor_decl : concurrency:[ `Sequential | `Lwt_jobs | `Lwt_preemptive | `Unlocked ] -> errno:[ `Ignore_errno | `Return_errno ] -> string -> 'a Ctypes.fn -> Format.formatter -> unit val inverse_case : register_name:string -> constructor:string -> string -> Format.formatter -> ('a -> 'b) Ctypes.fn -> unit yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs_inverted.ml000066400000000000000000000135011445631112600235710ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Cstubs_inverted public interface. *) [@@@warning "-9-27"] module type INTERNAL = sig val enum : (string * int64) list -> 'a Ctypes.typ -> unit val structure : _ Ctypes.structure Ctypes.typ -> unit val union : _ Ctypes.union Ctypes.typ -> unit val typedef : _ Ctypes.typ -> string -> unit val internal : ?runtime_lock:bool -> string -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) -> unit end module type BINDINGS = functor (F : INTERNAL) -> sig end type fn_meta = { fn_runtime_lock : bool; fn_name : string; } type fn_info = Fn : fn_meta * (_ -> _) Ctypes.fn -> fn_info type ty = Ty : _ Ctypes.typ -> ty type typedef = Typedef : _ Ctypes.typ * string -> typedef type enum = Enum : (string * int64) list * _ Ctypes.typ -> enum type decl = Decl_fn of fn_info | Decl_ty of ty | Decl_typedef of typedef | Decl_enum of enum let functions decls = List.concat (List.map (function Decl_fn fn -> [fn] | _ -> []) decls) let collector () : (module INTERNAL) * (unit -> decl list) = let decls = ref [] in let push d = decls := d :: !decls in ((module struct let enum constants typ = push (Decl_enum (Enum (constants, typ))) let structure typ = push (Decl_ty (Ty typ)) let union typ = push (Decl_ty (Ty typ)) let typedef typ name = push (Decl_typedef (Typedef (typ, name))) let internal ?(runtime_lock=false) name fn _ = let meta = { fn_runtime_lock = runtime_lock; fn_name = name } in push (Decl_fn ((Fn (meta, fn)))) end), (fun () -> List.rev !decls)) let format_enum_values fmt infos = List.iter (fun (Fn ({fn_name}, _)) -> Format.fprintf fmt "@[fn_%s,@]@ " fn_name) infos let c_prologue fmt register infos = Format.fprintf fmt "#include @\n"; Format.fprintf fmt "#include @\n"; Format.fprintf fmt "#include \"ctypes_cstubs_internals.h\"@\n@\n"; Format.fprintf fmt "enum functions@\n{@[@ %afn_count@]@\n};" format_enum_values infos; Format.fprintf fmt "@\n /* A table of OCaml \"callbacks\". */ static value functions[fn_count]; /* Record a value in the callback table. */ value %s(value i, value v) { CAMLparam2(i, v); functions[Long_val(i)] = v; caml_register_global_root(&functions[Long_val(i)]); CAMLreturn (Val_unit); }@\n" register let c_function fmt (Fn ({fn_name; fn_runtime_lock}, fn)) : unit = Cstubs_generate_c.inverse_fn ~stub_name:fn_name ~runtime_lock:fn_runtime_lock fmt fn let gen_c fmt register infos = begin c_prologue fmt register infos; List.iter (c_function fmt) infos end let c_declaration fmt (Fn ({fn_name; fn_runtime_lock}, fn)) : unit = Cstubs_generate_c.inverse_fn_decl ~stub_name:fn_name fmt fn let write_structure_declaration fmt (Ty ty) = Format.fprintf fmt "@[%a@];@\n@\n" (fun ty -> Ctypes.format_typ ty) ty let write_enum_declaration fmt (Enum (constants, ty)) = Format.fprintf fmt "@[%a@ {@\n@[@\n" (fun ty -> Ctypes.format_typ ty) ty; let last = List.length constants - 1 in List.iteri (fun i (name, value) -> (* Trailing commas are not allowed. *) if i < last then Format.fprintf fmt "@[%s@ =@ %Ld,@]@\n" name value else Format.fprintf fmt "@[%s@ =@ %Ld@]@\n" name value) constants; Format.fprintf fmt "@]@]@\n};@\n@\n" let write_typedef fmt (Typedef (ty, name)) = let write_name _ fmt = Format.fprintf fmt "@ %s" name in Format.fprintf fmt "@[typedef@ @["; Ctypes_type_printing.format_typ' ty write_name `nonarray fmt; Format.fprintf fmt "@]@];@\n@\n" let write_declaration fmt = function Decl_fn f -> c_declaration fmt f | Decl_ty s -> write_structure_declaration fmt s | Decl_typedef t -> write_typedef fmt t | Decl_enum e -> write_enum_declaration fmt e let write_c fmt ~prefix (module B : BINDINGS) : unit = let register = prefix ^ "_register" in let m, decls = collector () in let module M = B((val m)) in gen_c fmt register (functions (decls ())); Format.fprintf fmt "@." let write_c_header fmt ~prefix (module B : BINDINGS) : unit = let m, decls = collector () in let module M = B((val m)) in List.iter (write_declaration fmt) (decls ()); Format.fprintf fmt "@." let gen_ml fmt register (infos : fn_info list) : unit = Format.fprintf fmt "type 'a fn = 'a@\n@\n"; Format.fprintf fmt "module CI = Cstubs_internals@\n@\n"; Format.fprintf fmt "type 'a f = 'a CI.fn =@\n"; Format.fprintf fmt " | Returns : 'a CI.typ -> 'a f@\n"; Format.fprintf fmt " | Function : 'a CI.typ * 'b f -> ('a -> 'b) f@\n"; Format.fprintf fmt "type 'a name = @\n"; ListLabels.iter infos ~f:(fun (Fn ({fn_name}, fn)) -> Cstubs_generate_ml.constructor_decl ~concurrency:`Sequential ~errno:`Ignore_errno (Printf.sprintf "Fn_%s" fn_name) fn fmt); Format.fprintf fmt "@\n"; Format.fprintf fmt "@[external register_value : 'a name -> 'a fn -> unit =@\n@ @ \"%s\"@]@\n@\n" register; Format.fprintf fmt "@[let internal : "; Format.fprintf fmt "@[type a b.@ @[?runtime_lock:bool -> string -> (a -> b) Ctypes.fn -> (a -> b) -> unit@]@]@ =@\n"; Format.fprintf fmt "fun ?runtime_lock name fn f -> match fn, name with@\n@["; ListLabels.iter infos ~f:(fun (Fn ({fn_name}, fn)) -> Cstubs_generate_ml.inverse_case ~register_name:"register_value" ~constructor:(Printf.sprintf "Fn_%s" fn_name) fn_name fmt fn); Format.fprintf fmt "| _ -> failwith (\"Linking mismatch on name: \" ^ name)@]@]@]@\n@\n"; Format.fprintf fmt "let enum _ _ = () and structure _ = () and union _ = () and typedef _ _ = ()@." let write_ml fmt ~prefix (module B : BINDINGS) : unit = let register = prefix ^ "_register" in let m, decls = collector () in let module M = B((val m)) in gen_ml fmt register (functions (decls ())) yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs_inverted.mli000066400000000000000000000033441445631112600237460ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** Operations for exposing OCaml code as C libraries. *) module type INTERNAL = sig (* Expose type definitions to C. The types are printed to the header file generated by [write_c_header]. *) val enum : (string * int64) list -> 'a Ctypes.typ -> unit val structure : _ Ctypes.structure Ctypes.typ -> unit val union : _ Ctypes.union Ctypes.typ -> unit val typedef : _ Ctypes.typ -> string -> unit val internal : ?runtime_lock:bool -> string -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) -> unit end module type BINDINGS = functor (F : INTERNAL) -> sig end val write_c : Format.formatter -> prefix:string -> (module BINDINGS) -> unit (** [write_c fmt ~prefix bindings] generates C stubs for the functions bound with [internal] in [bindings]. The stubs are intended to be used in conjunction with the ML code generated by {!write_ml}. The generated code uses definitions exposed in the header file [cstubs_internals.h]. *) val write_c_header : Format.formatter -> prefix:string -> (module BINDINGS) -> unit (** [write_c_header fmt ~prefix bindings] generates a C header file for the functions bound with [internal] in [bindings]. The stubs are intended to be used in conjunction with the C code generated by {!write_c}. *) val write_ml : Format.formatter -> prefix:string -> (module BINDINGS) -> unit (** [write_ml fmt ~prefix bindings] generates ML bindings for the functions bound with [internal] in [bindings]. The generated code conforms to the {!INTERNAL} interface. The generated code uses definitions exposed in the module [Cstubs_internals]. *) yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs_public_name.ml000066400000000000000000000077761445631112600242500ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Publicly visible names for type values *) open Ctypes_path let ident_of_ml_prim : type a. a Ctypes_primitive_types.ml_prim -> path = let open Ctypes_primitive_types in function | ML_char -> path_of_string "char" | ML_bool -> path_of_string "bool" | ML_complex -> path_of_string "Complex.t" | ML_float -> path_of_string "float" | ML_int -> path_of_string "int" | ML_int32 -> path_of_string "int32" | ML_int64 -> path_of_string "int64" | ML_llong -> path_of_string "Signed.llong" | ML_long -> path_of_string "Signed.long" | ML_sint -> path_of_string "Signed.sint" | ML_nativeint -> path_of_string "nativeint" | ML_size_t -> path_of_string "Unsigned.size_t" | ML_uchar -> path_of_string "Unsigned.uchar" | ML_uint -> path_of_string "Unsigned.uint" | ML_uint16 -> path_of_string "Unsigned.uint16" | ML_uint32 -> path_of_string "Unsigned.uint32" | ML_uint64 -> path_of_string "Unsigned.uint64" | ML_uint8 -> path_of_string "Unsigned.uint8" | ML_ullong -> path_of_string "Unsigned.ullong" | ML_ulong -> path_of_string "Unsigned.ulong" | ML_ushort -> path_of_string "Unsigned.ushort" | ML_ldouble -> path_of_string "LDouble.t" | ML_complexld -> path_of_string "ComplexL.t" let constructor_ident_of_prim : type a. a Ctypes_primitive_types.prim -> path = let open Ctypes_primitive_types in function | Char -> path_of_string "Ctypes.char" | Schar -> path_of_string "Ctypes.schar" | Uchar -> path_of_string "Ctypes.uchar" | Bool -> path_of_string "Ctypes.bool" | Short -> path_of_string "Ctypes.short" | Int -> path_of_string "Ctypes.int" | Long -> path_of_string "Ctypes.long" | Llong -> path_of_string "Ctypes.llong" | Ushort -> path_of_string "Ctypes.ushort" | Sint -> path_of_string "Ctypes.sint" | Uint -> path_of_string "Ctypes.uint" | Ulong -> path_of_string "Ctypes.ulong" | Ullong -> path_of_string "Ctypes.ullong" | Size_t -> path_of_string "Ctypes.size_t" | Int8_t -> path_of_string "Ctypes.int8_t" | Int16_t -> path_of_string "Ctypes.int16_t" | Int32_t -> path_of_string "Ctypes.int32_t" | Int64_t -> path_of_string "Ctypes.int64_t" | Uint8_t -> path_of_string "Ctypes.uint8_t" | Uint16_t -> path_of_string "Ctypes.uint16_t" | Uint32_t -> path_of_string "Ctypes.uint32_t" | Uint64_t -> path_of_string "Ctypes.uint64_t" | Camlint -> path_of_string "Ctypes.camlint" | Nativeint -> path_of_string "Ctypes.nativeint" | Float -> path_of_string "Ctypes.float" | Double -> path_of_string "Ctypes.double" | LDouble -> path_of_string "Ctypes.ldouble" | Complex32 -> path_of_string "Ctypes.complex32" | Complex64 -> path_of_string "Ctypes.complex64" | Complexld -> path_of_string "Ctypes.complexld" let constructor_cident_of_prim : type a. ?module_name:string -> a Ctypes_primitive_types.prim -> path = fun ?(module_name="Cstubs_internals") -> let path ident = path_of_string (Printf.sprintf "%s.%s" module_name ident) in Ctypes_primitive_types.(function | Char -> path "Char" | Schar -> path "Schar" | Uchar -> path "Uchar" | Bool -> path "Bool" | Short -> path "Short" | Int -> path "Int" | Long -> path "Long" | Llong -> path "Llong" | Ushort -> path "Ushort" | Sint -> path "Sint" | Uint -> path "Uint" | Ulong -> path "Ulong" | Ullong -> path "Ullong" | Size_t -> path "Size_t" | Int8_t -> path "Int8_t" | Int16_t -> path "Int16_t" | Int32_t -> path "Int32_t" | Int64_t -> path "Int64_t" | Uint8_t -> path "Uint8_t" | Uint16_t -> path "Uint16_t" | Uint32_t -> path "Uint32_t" | Uint64_t -> path "Uint64_t" | Camlint -> path "Camlint" | Nativeint -> path "Nativeint" | Float -> path "Float" | Double -> path "Double" | LDouble -> path "LDouble" | Complex32 -> path "Complex32" | Complex64 -> path "Complex64" | Complexld -> path "Complexld") yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs_public_name.mli000066400000000000000000000012141445631112600243760ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Publicly visible names for type values *) val ident_of_ml_prim : 'a Ctypes_primitive_types.ml_prim -> Ctypes_path.path (* The type that should appear in the extern signature *) val constructor_ident_of_prim : 'a Ctypes_primitive_types.prim -> Ctypes_path.path (* The path to a value that represents the primitive type *) val constructor_cident_of_prim : ?module_name:string -> 'a Ctypes_primitive_types.prim -> Ctypes_path.path (* The path to a constructor that represents the primitive type *) yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs_structs.ml000066400000000000000000000256041445631112600234670ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@warning "-9-27"] open Ctypes module type TYPE = sig include Ctypes_types.TYPE type 'a const val constant : string -> 'a typ -> 'a const val enum : string -> ?typedef:bool -> ?unexpected:(int64 -> 'a) -> ('a * int64 const) list -> 'a typ end module type BINDINGS = functor (F : TYPE) -> sig end let cstring s = (* Format a string for output as a C string literal. *) let mappings = [Str.regexp "\"", "\\\""; Str.regexp "\n", "\\n"] in let escaped = List.fold_left (fun s (r, r') -> Str.(global_replace r r') s) s mappings in "\""^ escaped ^"\"" let cprologue = [ "#include "; "#include "; "#include \"ctypes_cstubs_internals.h\""; ""; "int main(void)"; "{"; ] let cepilogue = [ " return 0;"; "}"; ] let mlprologue = [ "[@@@warning \"-9-27\"]"; "include Ctypes"; "let lift x = x"; "open Ctypes_static"; ] (* [puts fmt s] writes the call [puts(s);] on [fmt]. *) let puts fmt s = Format.fprintf fmt "@[puts@[(%s);@]@]@\n" (cstring s) (* [printf1 fmt s v] writes the call [printf(s, v);] on [fmt]. *) let printf1 fmt s v = Format.fprintf fmt "@[ctypes_printf@[(%s,@ %t);@]@]@\n" (cstring s) v (* [printf2 fmt s u v] writes the call [printf(s, u, v);] on [fmt]. *) let printf2 fmt s u v = Format.fprintf fmt "@[ctypes_printf@[(%s,@ %t,@ %t);@]@]@\n" (cstring s) u v (* [offsetof fmt t f] writes the call [offsetof(t, f)] on [fmt]. *) let offsetof fmt (t, f) = Format.fprintf fmt "@[offsetof@[(%s,@ %s)@]@]" t f (* [sizeof fmt t] writes the call [sizeof(t)] on [fmt]. *) let sizeof fmt t = Format.fprintf fmt "@[sizeof@[(%s)@]@]" t let alignmentof fmt t = offsetof fmt (Format.sprintf "struct { char c; %s x; }" t, "x") let write_c fmt body = List.iter (Format.fprintf fmt "@[%s@]@\n") cprologue; Format.fprintf fmt "@[@\n@[%t@]@]@\n" body; List.iter (Format.fprintf fmt "%s@\n") cepilogue let cases fmt list prologue epilogue ~case = List.iter (puts fmt) prologue; List.iter case list; List.iter (puts fmt) epilogue let write_field fmt specs = let case = function | `Struct (tag, typedef), fname -> let foffset fmt = offsetof fmt (typedef, fname) in puts fmt (Printf.sprintf " | Struct ({ tag = %S; _} as s'), %S ->" tag fname); printf1 fmt " let f = {ftype; fname; foffset = %zu} in \n" foffset; puts fmt " (s'.fields <- BoxedField f :: s'.fields; f)"; | `Union (tag, typedef), fname -> let foffset fmt = offsetof fmt (typedef, fname) in puts fmt (Printf.sprintf " | Union ({ utag = %S; _} as s'), %S ->" tag fname); printf1 fmt " let f = {ftype; fname; foffset = %zu} in \n" foffset; puts fmt " (s'.ufields <- BoxedField f :: s'.ufields; f)"; | _ -> raise (Unsupported "Adding a field to non-structured type") in cases fmt specs [""; "let rec field : type t a. t typ -> string -> a typ -> (a, t) field ="; " fun s fname ftype -> match s, fname with";] ~case [" | View { ty; _ }, _ ->"; " let { ftype; foffset; fname } = field ty fname ftype in"; " { ftype; foffset; fname }"; " | _ -> failwith (\"Unexpected field \"^ fname)"] let write_seal fmt specs = let case = function | `Struct (tag, typedef) -> let ssize fmt = sizeof fmt typedef and salign fmt = alignmentof fmt typedef in puts fmt (Printf.sprintf " | Struct ({ tag = %S; spec = Incomplete _; _ } as s') ->" tag); printf2 fmt " s'.spec <- Complete { size = %zu; align = %zu }\n" ssize salign; | `Union (tag, typedef) -> let usize fmt = sizeof fmt typedef and ualign fmt = alignmentof fmt typedef in puts fmt (Printf.sprintf " | Union ({ utag = %S; uspec = None; _ } as s') ->" tag); printf2 fmt " s'.uspec <- Some { size = %zu; align = %zu }\n" usize ualign; | `Other -> raise (Unsupported "Sealing a non-structured type") in cases fmt specs [""; "let rec seal : type a. a typ -> unit = function"] ~case [" | Struct { tag; spec = Complete _; _ } ->"; " raise (ModifyingSealedType tag)"; " | Union { utag; uspec = Some _; _ } ->"; " raise (ModifyingSealedType utag)"; " | View { ty; _ } -> seal ty"; " | _ ->"; " raise (Unsupported \"Sealing a non-structured type\")"; ""] let primitive_format_string : type a. a Ctypes_primitive_types.prim -> string = fun p -> let open Ctypes_primitive_types in let sprintf = Printf.sprintf in let fail () = Printf.ksprintf failwith "Cannot retrieve constants of type %s" (Ctypes_primitives.name p) in match p, Ctypes_primitives.format_string p with | _, None -> fail () | Char, Some fmt -> sprintf "Char.chr (((%s) + 256) mod 256)" fmt | Schar, Some fmt -> fmt | Uchar, Some fmt -> sprintf "Unsigned.UChar.of_string \"%s\"" fmt | Bool, Some fmt -> sprintf "((%s) <> 0)" fmt | Short, Some fmt -> fmt | Int, Some fmt -> fmt | Long, Some fmt -> sprintf "Signed.Long.of_string \"%s\"" fmt | Llong, Some fmt -> sprintf "Signed.LLong.of_string \"%s\"" fmt | Ushort, Some fmt -> sprintf "Unsigned.UShort.of_string \"%s\"" fmt | Sint, Some fmt -> sprintf "Signed.SInt.of_string \"%s\"" fmt | Uint, Some fmt -> sprintf "Unsigned.UInt.of_string \"%s\"" fmt | Ulong, Some fmt -> sprintf "Unsigned.ULong.of_string \"%s\"" fmt | Ullong, Some fmt -> sprintf "Unsigned.ULLong.of_string \"%s\"" fmt | Size_t, Some fmt -> sprintf "Unsigned.Size_t.of_string \"%s\"" fmt | Int8_t, Some fmt -> fmt | Int16_t, Some fmt -> fmt | Int32_t, Some fmt -> fmt ^"l" | Int64_t, Some fmt -> fmt ^"L" | Uint8_t, Some fmt -> sprintf "Unsigned.UInt8.of_string \"%s\"" fmt | Uint16_t, Some fmt -> sprintf "Unsigned.UInt16.of_string \"%s\"" fmt | Uint32_t, Some fmt -> sprintf "Unsigned.UInt32.of_string \"%s\"" fmt | Uint64_t, Some fmt -> sprintf "Unsigned.UInt64.of_string \"%s\"" fmt | Camlint, Some fmt -> fmt | Nativeint, Some fmt -> fmt ^"n" (* Integer constant expressions cannot have non-integer type *) | Complex32, _ -> fail () | Complex64, _ -> fail () | Complexld, _ -> fail () | Float, _ -> fail () | Double, _ -> fail () | LDouble, _ -> fail () let rec ml_pat_and_exp_of_typ : type a. a typ -> string * string = fun ty -> match ty with | Ctypes_static.View { Ctypes_static.ty } -> let p, e = ml_pat_and_exp_of_typ ty in let x = Cstubs_c_language.fresh_var ~prefix:"read" () in let p' = Printf.sprintf "Ctypes_static.View { Ctypes_static.read = %s; ty = %s }" x p and e' = Printf.sprintf "(%s (%s))" x e in (p', e') | Ctypes_static.Primitive p -> let pat = (Format.asprintf "Ctypes_static.Primitive %a" Ctypes_path.format_path (Cstubs_public_name.constructor_cident_of_prim p)) and exp = primitive_format_string p in (pat, exp) | _ -> failwith "constant of non-primitive" let write_consts fmt consts = let case = function (name, Ctypes_static.BoxedType ty) -> let p, e = ml_pat_and_exp_of_typ ty in Format.fprintf fmt "{@[@\n"; Format.fprintf fmt "enum { check_%s_const = (int)%s };@\n" name name; (* Since printf is variadic we can't rely on implicit conversions. We'll use assignment rather than casts to coerce to the correct type because casts typically result in silent truncation whereas narrowing assignments typically trigger warnings even on default compiler settings. *) Format.fprintf fmt "%a = (%s);@\n" (Ctypes.format_typ ~name:"v") ty name; printf1 fmt (Format.asprintf " | %s, %S ->@\n %s\n" p name e) (fun fmt -> Format.fprintf fmt "v"); Format.fprintf fmt "@]@\n}@\n" in cases fmt consts ["type 'a const = 'a"; "let constant (type t) name (t : t typ) : t = match t, name with"] ~case [" | _, s -> failwith (\"unmatched constant: \"^ s)"] let write_enums fmt enums = let case (name, typedef) = printf1 fmt (Format.sprintf " | %S -> \n Cstubs_internals.build_enum_type %S Ctypes_static.%%s ?typedef ?unexpected alist\n" name name) (fun fmt -> Format.fprintf fmt "ctypes_arithmetic_type_name(CTYPES_CLASSIFY_ARITHMETIC_TYPE(%s%s))" (if typedef then "" else "enum ") name) in cases fmt enums [""; "let enum (type a) name ?typedef ?unexpected (alist : (a * int64) list) ="; " match name with"] ~case [" | s ->"; " failwith (\"unmatched enum: \"^ s)"] let write_ml fmt fields structures consts enums = List.iter (puts fmt) mlprologue; write_field fmt fields; write_seal fmt structures; write_consts fmt consts; write_enums fmt enums let gen_c () = let fields = ref [] and structures = ref [] and consts = ref [] and enums = ref [] in let finally fmt = write_c fmt (fun fmt -> write_ml fmt !fields !structures !consts !enums) in let m = (module struct include Ctypes open Ctypes_static let rec field' : type a s r. string -> s typ -> string -> a typ -> (a, r) field = fun structname s fname ftype -> match s with | Struct { tag } -> fields := (`Struct (tag, structname), fname) :: !fields; { ftype; foffset = -1; fname} | Union { utag } -> fields := (`Union (utag, structname), fname) :: !fields; { ftype; foffset = -1; fname} | View { ty } -> field' structname ty fname ftype | _ -> raise (Unsupported "Adding a field to non-structured type") let field s fname ftype = field' (Ctypes.string_of_typ s) s fname ftype let rec seal' : type s. string -> s typ -> unit = fun structname -> function | Struct { tag } -> structures := `Struct (tag, structname) :: !structures | Union { utag } -> structures := `Union (utag, structname) :: !structures | View { ty } -> seal' structname ty | _ -> raise (Unsupported "Sealing a field to non-structured type") let seal ty = seal' (Ctypes.string_of_typ ty) ty type _ const = unit let constant name ty = consts := (name, Ctypes_static.BoxedType ty) :: !consts let enum name ?(typedef=false) ?unexpected alist = let () = enums := (name, typedef) :: !enums in let format_typ k fmt = Format.fprintf fmt "%s%s%t" (if typedef then "" else "enum ") name k in (* a dummy value of type 'a typ, mostly unusable *) view void ~format_typ ~read:(fun _ -> assert false) ~write:(fun _ -> assert false) end : TYPE) in (m, finally) let write_c fmt (module B : BINDINGS) = let m, finally = gen_c () in let module M = B((val m)) in finally fmt yallop-ocaml-ctypes-3f8211a/src/cstubs/cstubs_structs.mli000066400000000000000000000007461445631112600236400ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) module type TYPE = sig include Ctypes_types.TYPE type 'a const val constant : string -> 'a typ -> 'a const val enum : string -> ?typedef:bool -> ?unexpected:(int64 -> 'a) -> ('a * int64 const) list -> 'a typ end module type BINDINGS = functor (F : TYPE) -> sig end val write_c : Format.formatter -> (module BINDINGS) -> unit yallop-ocaml-ctypes-3f8211a/src/cstubs/ctypes_path.ml000066400000000000000000000012761445631112600227170ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Paths (long identifiers) *) type path = string list let is_uident s = Str.(string_match (regexp "[A-Z][a-zA-Z0-9_]*") s 0);; let is_ident s = Str.(string_match (regexp "[A-Za-z_][a-zA-Z0-9_]*") s 0);; let rec is_valid_path = function | [] -> false | [l] -> is_ident l | u :: p -> is_uident u && is_valid_path p let path_of_string s = let p = Str.(split (regexp_string ".") s) in if is_valid_path p then p else invalid_arg "Ctypes_ident.path_of_string" let format_path fmt p = Format.pp_print_string fmt (String.concat "." p) yallop-ocaml-ctypes-3f8211a/src/cstubs/ctypes_path.mli000066400000000000000000000004351445631112600230640ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Value paths (long identifiers) *) type path val path_of_string : string -> path val format_path : Format.formatter -> path -> unit yallop-ocaml-ctypes-3f8211a/src/cstubs/dune000066400000000000000000000002361445631112600207130ustar00rootroot00000000000000(library (name ctypes_stubs) (public_name ctypes.stubs) (instrumentation (backend bisect_ppx)) (wrapped false) (libraries (re_export ctypes) str)) yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/000077500000000000000000000000001445631112600214675ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/config/000077500000000000000000000000001445631112600227345ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/config/discover.ml000066400000000000000000000021631445631112600251060ustar00rootroot00000000000000module C = Configurator.V1 let () = C.main ~name:"ffi" (fun c -> let default : C.Pkg_config.package_conf = { libs = ["-lffi"]; cflags = [] } in let conf = match C.Pkg_config.get c with | None -> default | Some pc -> (match C.Pkg_config.query pc ~package:"libffi" with | None -> default | Some v -> v) in let backend = match Sys.os_type with | "Win32" | "Cygwin" -> "win" | _ -> "unix" in let f = "as_needed_test" in let ml = f ^ ".ml" in open_out ml |> close_out; let extra_ldflags = match backend with |"win" -> ["-lpsapi"] |_ -> let res = C.Process.run_ok c "ocamlopt" ["-shared"; "-cclib"; "-Wl,--no-as-needed"; ml; "-o"; f^".cmxs"] in if res then ["-Wl,--no-as-needed"] else [] in C.Flags.write_sexp "c_flags.sexp" conf.cflags; C.Flags.write_lines "c_flags" conf.cflags; C.Flags.write_sexp "c_library_flags.sexp" (conf.libs @ extra_ldflags); C.Flags.write_lines "backend.sexp" [backend] ) yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/config/dune000066400000000000000000000002571445631112600236160ustar00rootroot00000000000000(executable (name discover) (modules discover) (libraries dune-configurator)) (executable (name gen_libffi_abi) (modules gen_libffi_abi) (libraries dune-configurator)) yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/config/gen_libffi_abi.ml000066400000000000000000000054331445631112600261720ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) module C = Configurator.V1 let header = "\ (* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Support for various ABIs *) [@@@warning \"-37\"] type abi = Code of int | Unsupported of string let abi_code = function Code c -> c | Unsupported sym -> raise (Ctypes.Unsupported sym) " let ffi_is_defined = Printf.sprintf "\ #include int main(int argc, char **argv) { int s = %s; return 0; } " let symbols = [ ("aix" , "FFI_AIX"); ("darwin" , "FFI_DARWIN"); ("eabi" , "FFI_EABI"); ("fastcall" , "FFI_FASTCALL"); ("gcc_sysv" , "FFI_GCC_SYSV"); ("linux" , "FFI_LINUX"); ("linux64" , "FFI_LINUX64"); ("linux_soft_float" , "FFI_LINUX_SOFT_FLOAT"); ("ms_cdecl" , "FFI_MS_CDECL"); ("n32" , "FFI_N32"); ("n32_soft_float" , "FFI_N32_SOFT_FLOAT"); ("n64" , "FFI_N64"); ("n64_soft_float" , "FFI_N64_SOFT_FLOAT"); ("o32" , "FFI_O32"); ("o32_soft_float" , "FFI_O32_SOFT_FLOAT"); ("osf" , "FFI_OSF"); ("pa32" , "FFI_PA32"); ("stdcall" , "FFI_STDCALL"); ("sysv" , "FFI_SYSV"); ("thiscall" , "FFI_THISCALL"); ("unix" , "FFI_UNIX"); ("unix64" , "FFI_UNIX64"); ("v8" , "FFI_V8"); ("v8plus" , "FFI_V8PLUS"); ("v9" , "FFI_V9"); ("vfp" , "FFI_VFP"); ("default_abi" , "FFI_DEFAULT_ABI"); ] let includes = ["ffi.h"] module CD = C.C_define let find_defined_symbols c c_flags = List.fold_left (fun acc (_,sym) -> if C.c_test c ~c_flags (ffi_is_defined sym) then sym :: acc else acc) [] symbols let get_symbol c c_flags symbol = match CD.(import c ~includes ~c_flags [symbol,Type.Int]) with |[_,CD.Value.Int i] -> i |_ -> failwith (Printf.sprintf "unexpected error parsing ffi.h: is %s not an integer?" symbol) let write_line c ~c_flags ~defined_symbols ~name ~symbol = if List.mem symbol defined_symbols then get_symbol c c_flags symbol |> Printf.printf "let %s = Code %d\n" name else Printf.printf "let %s = Unsupported \"%s\"\n" name symbol let () = let c_flags = ref "" in let args = ["-cflags", Arg.Set_string c_flags, "CFLAGS for libffi"] in C.main ~args ~name:"ctypes-ffi" (fun c -> let c_flags = match !c_flags with "" -> [] | c -> [c] in let defined_symbols = find_defined_symbols c c_flags in print_string header; List.iter (fun (name, symbol) -> write_line c ~c_flags ~defined_symbols ~name ~symbol) symbols ) yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/ctypes_closure_properties.ml000066400000000000000000000047751445631112600273550ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) module type MUTEX = sig type t val create : unit -> t val lock : t -> unit val try_lock : t -> bool val unlock : t -> unit end module HashPhysical = Hashtbl.Make (struct type t = Obj.t let hash = Hashtbl.hash let equal = (==) end) module Make (Mutex : MUTEX) = struct (* Map integer identifiers to functions. *) let function_by_id : (int, Obj.t) Hashtbl.t = Hashtbl.create 10 (* Map functions (not closures) to identifiers. *) let id_by_function : int HashPhysical.t = HashPhysical.create 10 (* A single mutex guards both tables *) let tables_lock = Mutex.create () (* (The caller must hold tables_lock) *) let store_non_closure_function fn boxed_fn id = try (* Return the existing identifier, if any. *) HashPhysical.find id_by_function fn with Not_found -> (* Add entries to both tables *) HashPhysical.add id_by_function fn id; Hashtbl.add function_by_id id boxed_fn; id let fresh () = Oo.id (object end) let finalise key = (* GC can be triggered while the lock is already held, in which case we abandon the attempt and re-install the finaliser. *) let rec cleanup fn = begin if Mutex.try_lock tables_lock then begin Hashtbl.remove function_by_id key; Mutex.unlock tables_lock; end else Gc.finalise cleanup fn; end in cleanup let try_finalise f x = match Gc.finalise f x with | () -> true | exception Invalid_argument _ -> false let record closure boxed_closure : int = let key = fresh () in (* For closures we add an entry to function_by_id and a finaliser that removes the entry. *) if try_finalise (finalise key) closure then begin Mutex.lock tables_lock; Hashtbl.add function_by_id key boxed_closure; Mutex.unlock tables_lock; key end else begin (* For non-closures we add entries to function_by_id and id_by_function. *) Mutex.lock tables_lock; let id = store_non_closure_function closure boxed_closure key in Mutex.unlock tables_lock; id end let retrieve id = begin Mutex.lock tables_lock; match Hashtbl.find function_by_id id with | exception Not_found -> Mutex.unlock tables_lock; raise Not_found | f -> Mutex.unlock tables_lock; f end end yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/ctypes_closure_properties.mli000066400000000000000000000013401445631112600275070ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) module type MUTEX = sig type t val create : unit -> t val lock : t -> unit val try_lock : t -> bool val unlock : t -> unit end module Make (Mutex : MUTEX) : sig val record : Obj.t -> Obj.t -> int (** [record c v] links the lifetimes of [c] and [v], ensuring that [v] is not collected while [c] is still live. The return value is a key that can be used to retrieve [v] while [v] is still live. *) val retrieve : int -> Obj.t (** [retrieve v] retrieves a value using a key returned by [record], or raises [Not_found] if [v] is no longer live. *) end yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/ctypes_ffi.ml000066400000000000000000000277421445631112600241700ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@warning "-9-27"] module type CLOSURE_PROPERTIES = sig val record : Obj.t -> Obj.t -> int (** [record c v] links the lifetimes of [c] and [v], ensuring that [v] is not collected while [c] is still live. The return value is a key that can be used to retrieve [v] while [v] is still live. *) val retrieve : int -> Obj.t (** [retrieve v] retrieves a value using a key returned by [record], or raises [Not_found] if [v] is no longer live. *) end module Make(Closure_properties : CLOSURE_PROPERTIES) = struct open Ctypes_static open Libffi_abi (* Register the closure lookup function with C. *) let () = Ctypes_ffi_stubs.set_closure_callback Closure_properties.retrieve type _ ccallspec = Call : bool * (Ctypes_ptr.voidp -> 'a) -> 'a ccallspec | WriteArg : ('a -> Ctypes_ptr.voidp -> (Obj.t * int) array -> Obj.t) * 'b ccallspec -> ('a -> 'b) ccallspec type arg_type = ArgType : 'a Ctypes_ffi_stubs.ffitype -> arg_type (* keep_alive ties the lifetimes of objects together. [keep_alive w ~while_live:v] ensures that [w] is not collected while [v] is still live. If the object v in the call [keep_alive w ~while_live:v] is static -- for example, if it is a top-level function -- then it is not possible to attach a finaliser to [v] and [w] should be kept alive indefinitely, which we achieve by adding it to the list [kept_alive_indefinitely]. *) let kept_alive_indefinitely = ref [] let keep_alive w ~while_live:v = try Gc.finalise (fun _ -> Ctypes_memory_stubs.use_value w; ()) v with Invalid_argument _ -> kept_alive_indefinitely := Obj.repr w :: !kept_alive_indefinitely let report_unpassable what = let msg = Printf.sprintf "libffi does not support passing %s" what in raise (Unsupported msg) let rec arg_type : type a. a typ -> arg_type = function | Void -> ArgType (Ctypes_ffi_stubs.void_ffitype ()) | Primitive p as prim -> let ffitype = Ctypes_ffi_stubs.primitive_ffitype p in if ffitype = Ctypes_ptr.Raw.null then report_unpassable (Ctypes_type_printing.string_of_typ prim) else ArgType ffitype | Pointer _ -> ArgType (Ctypes_ffi_stubs.pointer_ffitype ()) | Funptr _ -> ArgType (Ctypes_ffi_stubs.pointer_ffitype ()) | OCaml _ -> ArgType (Ctypes_ffi_stubs.pointer_ffitype ()) | Union _ -> report_unpassable "unions" | Struct ({ spec = Complete _ } as s) -> struct_arg_type s | View { ty } -> arg_type ty | Array _ -> report_unpassable "arrays" | Bigarray _ -> report_unpassable "bigarrays" | Abstract _ -> (report_unpassable "values of abstract type") (* The following case should never happen; incomplete types are excluded during type construction. *) | Struct { spec = Incomplete _ } -> report_unpassable "incomplete types" and struct_arg_type : type s. s structure_type -> arg_type = fun ({fields} as s) -> let bufspec = Ctypes_ffi_stubs.allocate_struct_ffitype (List.length fields) in (* Ensure that `bufspec' stays alive as long as the type does. *) keep_alive bufspec ~while_live:s; List.iteri (fun i (BoxedField {ftype; foffset}) -> let ArgType t = arg_type ftype in Ctypes_ffi_stubs.struct_type_set_argument bufspec i t) fields; Ctypes_ffi_stubs.complete_struct_type bufspec; ArgType (Ctypes_ffi_stubs.ffi_type_of_struct_type bufspec) (* call addr callspec (fun buffer -> write arg_1 buffer v_1 write arg buffer v ... write arg_n buffer v_n) read_return_value *) let rec invoke : type a b m. string option -> a ccallspec -> (Ctypes_ptr.voidp -> (Obj.t * int) array -> Obj.t) list -> Ctypes_ffi_stubs.callspec -> (m, b fn) Ctypes_ptr.Fat.t -> a = fun name -> function | Call (check_errno, read_return_value) -> let name = match name with Some name -> name | None -> "" in fun writers callspec addr -> let r = ref [] in let v = Ctypes_ffi_stubs.call name addr callspec (fun buf arr -> List.iter (fun w -> r := w buf arr :: !r) writers) read_return_value in Ctypes_memory_stubs.use_value r; v | WriteArg (write, ccallspec) -> let next = invoke name ccallspec in fun writers callspec addr v -> next (write v :: writers) callspec addr let add_argument : type a. Ctypes_ffi_stubs.callspec -> a typ -> int = fun callspec -> function | Void -> 0 | ty -> let ArgType ffitype = arg_type ty in Ctypes_ffi_stubs.add_argument callspec ffitype let prep_callspec callspec abi ty = let ArgType ctype = arg_type ty in Ctypes_ffi_stubs.prep_callspec callspec (abi_code abi) ctype let rec box_function : type a. abi -> a fn -> Ctypes_ffi_stubs.callspec -> a Ctypes_weak_ref.t -> Ctypes_ffi_stubs.boxedfn = fun abi fn callspec -> match fn with | Returns ty -> let () = prep_callspec callspec abi ty in let write_rv = Ctypes_memory.write ty in fun f -> let w = write_rv (Ctypes_weak_ref.get f) in Ctypes_ffi_stubs.Done ((fun p -> w (Ctypes_ptr.Fat.make ~managed:None ~reftyp:Void p)), callspec) | Function (p, f) -> let _ = add_argument callspec p in let box = box_function abi f callspec in let read = Ctypes_memory.build p in fun f -> Ctypes_ffi_stubs.Fn (fun buf -> let f' = try Ctypes_weak_ref.get f (read (Ctypes_ptr.Fat.make ~managed:None ~reftyp:Void buf)) with Ctypes_weak_ref.EmptyWeakReference -> raise Ctypes_ffi_stubs.CallToExpiredClosure in let v = box (Ctypes_weak_ref.make f') in let () = Gc.finalise (fun _ -> Ctypes_memory_stubs.use_value f') v in v) let rec write_arg : type a. a typ -> offset:int -> idx:int -> a -> Ctypes_ptr.voidp -> (Obj.t * int) array -> Obj.t = let ocaml_arg elt_size = fun ~offset ~idx (OCamlRef (disp, obj, _)) dst mov -> mov.(idx) <- (Obj.repr obj, disp * elt_size); Obj.repr obj in function | OCaml String -> ocaml_arg 1 | OCaml Bytes -> ocaml_arg 1 | OCaml FloatArray -> ocaml_arg (Ctypes_primitives.sizeof Ctypes_primitive_types.Double) | View { write = w; ty } -> (fun ~offset ~idx v dst mov -> let wv = w v in let wa = write_arg ty ~offset ~idx wv dst mov in Obj.repr (wv, wa)) | ty -> (fun ~offset ~idx v dst mov -> Ctypes_memory.write ty v (Ctypes_ptr.Fat.(add_bytes (make ~managed:None ~reftyp:Void dst) offset)); Obj.repr v) (* callspec = allocate_callspec () add_argument callspec arg1 add_argument callspec arg2 ... add_argument callspec argn prep_callspec callspec rettype *) let rec build_ccallspec : type a. abi:abi -> check_errno:bool -> ?idx:int -> a fn -> Ctypes_ffi_stubs.callspec -> a ccallspec = fun ~abi ~check_errno ?(idx=0) fn callspec -> match fn with | Returns t -> let () = prep_callspec callspec abi t in let b = Ctypes_memory.build t in Call (check_errno, (fun p -> b (Ctypes_ptr.Fat.make ~managed:None ~reftyp:Void p))) | Function (p, f) -> let offset = add_argument callspec p in let rest = build_ccallspec ~abi ~check_errno ~idx:(idx+1) f callspec in WriteArg (write_arg p ~offset ~idx, rest) let build_function ?name ~abi ~release_runtime_lock ~check_errno fn = let c = Ctypes_ffi_stubs.allocate_callspec ~check_errno ~runtime_lock:release_runtime_lock ~thread_registration:false in let e = build_ccallspec ~abi ~check_errno fn c in invoke name e [] c let funptr_of_rawptr fn raw_ptr = Static_funptr (Ctypes_ptr.Fat.make ~managed:None ~reftyp:fn raw_ptr) let function_of_pointer ?name ~abi ~check_errno ~release_runtime_lock fn = if release_runtime_lock && has_ocaml_argument fn then raise (Unsupported "Unsupported argument type when releasing runtime lock") else fun (Static_funptr p) -> build_function ?name ~abi ~check_errno ~release_runtime_lock fn p let pointer_of_function_internal ~abi ~acquire_runtime_lock ~thread_registration fn = let cs' = Ctypes_ffi_stubs.allocate_callspec ~check_errno:false ~runtime_lock:acquire_runtime_lock ~thread_registration in let cs = box_function abi fn cs' in fun f -> let boxed = cs (Ctypes_weak_ref.make f) in let id = Closure_properties.record (Obj.repr f) (Obj.repr boxed) in Ctypes_ffi_stubs.make_function_pointer cs' id let pointer_of_function ~abi ~acquire_runtime_lock ~thread_registration fn = let make_funptr = pointer_of_function_internal ~abi ~acquire_runtime_lock ~thread_registration fn in fun f -> let funptr = make_funptr f in (* TODO: use a more intelligent strategy for keeping function pointers associated with top-level functions alive (e.g. cache function pointer creation by (function, type), or possibly even just by function, since the C arity and types must be the same in each case.) See the note by [kept_alive_indefinitely]. [dynamic_funptr_of_fun] allows for explicit life cycle management. *) let () = keep_alive funptr ~while_live:f in funptr_of_rawptr fn (Ctypes_ffi_stubs.raw_address_of_function_pointer funptr) type 'a funptr = { mutable gc_root : unit Ctypes.ptr ; fn : 'a Ctypes.static_funptr } let free_funptr t = if Ctypes.is_null t.gc_root then failwith "This funptr was previously freed" else ( Ctypes.Root.release t.gc_root; t.gc_root <- Ctypes.null; ) let report_leaked_funptr : (string -> unit) ref = ref (fun msg -> Printf.eprintf "%s\n%!" msg) let retain_funptr_root_to_avoid_segfaults_when_not_freed_correctly = ref [] let create_funptr gc_root fn = let t = { gc_root = Ctypes.Root.create gc_root; fn } in Gc.finalise (fun t -> if Ctypes.is_null t.gc_root then () else ( retain_funptr_root_to_avoid_segfaults_when_not_freed_correctly := t.gc_root :: !retain_funptr_root_to_avoid_segfaults_when_not_freed_correctly; t.gc_root <- Ctypes.null; !report_leaked_funptr "WARN: a ctypes function pointer was not explicitly released.\n\ Releasing a function pointer or the associated OCaml closure while \n\ the function pointer is still in use from C will cause segmentation faults.\n\ Please call [Foreign.Funptr.free] explicitly when the funptr is no longer needed.\n\ To avoid a segmentation fault we are preventing this funptr from\n\ being garbage collected. Please use [Foreign.Funptr.free].\n%!")) t; t let funptr_of_fun ~abi ~acquire_runtime_lock ~thread_registration fn = let make_funptr = pointer_of_function_internal ~abi ~acquire_runtime_lock ~thread_registration fn in (fun f -> let funptr = make_funptr f in create_funptr (f,funptr) (funptr_of_rawptr fn (Ctypes_ffi_stubs.raw_address_of_function_pointer funptr))) let funptr_of_static_funptr fp = create_funptr () fp let funptr_to_static_funptr t = if Ctypes.is_null t.gc_root then failwith "This funptr was previously freed" else t.fn end yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/ctypes_ffi.mli000066400000000000000000000033551445631112600243330ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) module type CLOSURE_PROPERTIES = sig val record : Obj.t -> Obj.t -> int (** [record c v] links the lifetimes of [c] and [v], ensuring that [v] is not collected while [c] is still live. The return value is a key that can be used to retrieve [v] while [v] is still live. *) val retrieve : int -> Obj.t (** [retrieve v] retrieves a value using a key returned by [record], or raises [Not_found] if [v] is no longer live. *) end module Make(Closure_properties : CLOSURE_PROPERTIES) : sig open Ctypes_static open Libffi_abi (** Dynamic function calls based on libffi *) val function_of_pointer : ?name:string -> abi:abi -> check_errno:bool -> release_runtime_lock:bool -> ('a -> 'b) fn -> ('a -> 'b) static_funptr -> ('a -> 'b) (** Build an OCaml function from a type specification and a pointer to a C function. *) val pointer_of_function : abi:abi -> acquire_runtime_lock:bool -> thread_registration:bool -> ('a -> 'b) fn -> ('a -> 'b) -> ('a -> 'b) static_funptr (** Build an C function from a type specification and an OCaml function. The C function pointer returned is callable as long as the OCaml function value is live. *) type 'a funptr val free_funptr : _ funptr -> unit val funptr_of_fun : abi:abi -> acquire_runtime_lock:bool -> thread_registration:bool -> ('a -> 'b) fn -> ('a -> 'b) -> ('a -> 'b) funptr val funptr_of_static_funptr : ('a -> 'b) static_funptr -> ('a -> 'b) funptr val funptr_to_static_funptr : ('a -> 'b) funptr -> ('a -> 'b) static_funptr val report_leaked_funptr : (string -> unit) ref end yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/ctypes_ffi_stubs.ml000066400000000000000000000055651445631112600254070ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stubs for binding to libffi. *) open Ctypes_ptr (* The type of structure types *) type 'a ffitype = voidp type struct_ffitype external primitive_ffitype : 'a Ctypes_primitive_types.prim -> 'a ffitype = "ctypes_primitive_ffitype" external pointer_ffitype : unit -> voidp ffitype = "ctypes_pointer_ffitype" external void_ffitype : unit -> unit ffitype = "ctypes_void_ffitype" (* Allocate a new C typed buffer specification *) external allocate_struct_ffitype : int -> struct_ffitype = "ctypes_allocate_struct_ffitype" external struct_type_set_argument : struct_ffitype -> int -> _ ffitype -> unit = "ctypes_struct_ffitype_set_argument" (* Produce a structure type representation from the buffer specification. *) external complete_struct_type : struct_ffitype -> unit = "ctypes_complete_structspec" external ffi_type_of_struct_type : struct_ffitype -> _ ffitype = "ctypes_block_address" (* A specification of argument C-types and C-return values *) type callspec (* Allocate a new C call specification *) external allocate_callspec : check_errno:bool -> runtime_lock:bool -> thread_registration:bool -> callspec = "ctypes_allocate_callspec" (* Add an argument to the C buffer specification *) external add_argument : callspec -> _ ffitype -> int = "ctypes_add_argument" (* Pass the return type and conclude the specification preparation *) external prep_callspec : callspec -> int -> _ ffitype -> unit = "ctypes_prep_callspec" (* Call the function specified by `callspec' at the given address. The callback functions write the arguments to the buffer and read the return value. *) external call : string -> (_, _ Ctypes_static.fn) Fat.t -> callspec -> (voidp -> (Obj.t * int) array -> unit) -> (voidp -> 'a) -> 'a = "ctypes_call" (* nary callbacks *) type boxedfn = | Done of (voidp -> unit) * callspec | Fn of (voidp -> boxedfn) type funptr_handle (* Construct a pointer to an OCaml function represented by an identifier *) external make_function_pointer : callspec -> int -> funptr_handle = "ctypes_make_function_pointer" external raw_address_of_function_pointer : funptr_handle -> voidp = "ctypes_raw_address_of_function_pointer" (* Set the function used to retrieve functions by identifier. *) external set_closure_callback : (int -> Obj.t) -> unit = "ctypes_set_closure_callback" (* An internal error: for example, an `ffi_type' object passed to ffi_prep_cif was incorrect. *) exception Ffi_internal_error of string let () = Callback.register_exception "FFI_internal_error" (Ffi_internal_error "") (* A closure passed to C was collected by the OCaml garbage collector before it was called. *) exception CallToExpiredClosure let () = Callback.register_exception "CallToExpiredClosure" CallToExpiredClosure yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/ctypes_foreign_basis.ml000066400000000000000000000055001445631112600262220ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) module Make(Closure_properties : Ctypes_ffi.CLOSURE_PROPERTIES) = struct open Dl open Ctypes module Ffi = Ctypes_ffi.Make(Closure_properties) exception CallToExpiredClosure = Ctypes_ffi_stubs.CallToExpiredClosure let funptr ?(abi=Libffi_abi.default_abi) ?name ?(check_errno=false) ?(runtime_lock=false) ?(thread_registration=false) fn = let open Ffi in let read = function_of_pointer ~abi ~check_errno ~release_runtime_lock:runtime_lock ?name fn and write = pointer_of_function fn ~abi ~acquire_runtime_lock:runtime_lock ~thread_registration in Ctypes_static.(view ~read ~write (static_funptr fn)) let funptr_opt ?abi ?name ?check_errno ?runtime_lock ?thread_registration fn = Ctypes_std_views.nullable_funptr_view (funptr ?abi ?name ?check_errno ?runtime_lock ?thread_registration fn) fn let funptr_of_raw_ptr p = Ctypes.funptr_of_raw_address (Ctypes_ptr.Raw.to_nativeint p) let ptr_of_raw_ptr p = Ctypes.ptr_of_raw_address (Ctypes_ptr.Raw.to_nativeint p) let foreign_value ?from symbol t = from_voidp t (ptr_of_raw_ptr (Ctypes_ptr.Raw.of_nativeint (dlsym ?handle:from ~symbol))) let foreign ?(abi=Libffi_abi.default_abi) ?from ?(stub=false) ?(check_errno=false) ?(release_runtime_lock=false) symbol typ = try let coerce = Ctypes_coerce.coerce (static_funptr (void @-> returning void)) (funptr ~abi ~name:symbol ~check_errno ~runtime_lock:release_runtime_lock typ) in coerce (funptr_of_raw_ptr (Ctypes_ptr.Raw.of_nativeint (dlsym ?handle:from ~symbol))) with | exn -> if stub then fun _ -> raise exn else raise exn module type Funptr = sig type fn type t val t : t Ctypes.typ val t_opt : t option Ctypes.typ val free : t -> unit val of_fun : fn -> t val with_fun : fn -> (t -> 'c) -> 'c end let dynamic_funptr (type a) (type b) ?(abi=Libffi_abi.default_abi) ?(runtime_lock=false) ?(thread_registration=false) fn : (module Funptr with type fn = a -> b) = (module struct type fn = a -> b type t = fn Ffi.funptr let t = let write = Ffi.funptr_to_static_funptr in let read = Ffi.funptr_of_static_funptr in Ctypes_static.(view ~read ~write (static_funptr fn)) let t_opt = Ctypes_std_views.nullable_funptr_view t fn let free = Ffi.free_funptr let of_fun = Ffi.funptr_of_fun ~abi ~acquire_runtime_lock:runtime_lock ~thread_registration fn let with_fun f do_it = let f = of_fun f in match do_it f with | res -> free f; res | exception exn -> free f; raise exn end) let report_leaked_funptr = Ffi.report_leaked_funptr end yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/ctypes_foreign_threaded_stubs.ml000066400000000000000000000003561445631112600301250ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) external setup_thread_registration : unit -> unit = "ctypes_setup_thread_registration" yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/ctypes_weak_ref.ml000066400000000000000000000006651445631112600252020ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) exception EmptyWeakReference type 'a t = 'a Weak.t let empty () = raise EmptyWeakReference let make v = Weak.(let a = create 1 in set a 0 (Some v); a) let set r v = Weak.set r 0 (Some v) let get r = match Weak.get r 0 with Some v -> v | None -> empty () let is_empty r = Weak.check r 0 yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/ctypes_weak_ref.mli000066400000000000000000000012021445631112600253370ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** A single-cell variant of the weak arrays in the standard library. *) exception EmptyWeakReference (** An expired weak reference was accessed. *) type 'a t (** The type of weak references.. *) val make : 'a -> 'a t (** Obtain a weak reference from a strong reference. *) val set : 'a t -> 'a -> unit (** Update a weak reference. *) val get : 'a t -> 'a (** Obtain a strong reference from a weak reference. *) val is_empty : 'a t -> bool (** Whether a weak reference is still live. *) yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/dl.ml.unix000066400000000000000000000032271445631112600234060ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@ocaml.warning "-16"] type library type flag = RTLD_LAZY | RTLD_NOW | RTLD_GLOBAL | RTLD_LOCAL | RTLD_NODELETE | RTLD_NOLOAD | RTLD_DEEPBIND exception DL_error of string (* void *dlopen(const char *filename, int flag); *) external _dlopen : ?filename:string -> flags:int -> library option = "ctypes_dlopen" (* void *dlsym(void *handle, const char *symbol); *) external _dlsym : ?handle:library -> symbol:string -> nativeint option = "ctypes_dlsym" (* int dlclose(void *handle); *) external _dlclose : handle:library -> int = "ctypes_dlclose" (* char *dlerror(void); *) external _dlerror : unit -> string option = "ctypes_dlerror" external resolve_flag : flag -> int = "ctypes_resolve_dl_flag" let _report_dl_error noload = match _dlerror () with | Some error -> raise (DL_error (error)) | None -> if noload then raise (DL_error "library not loaded") else failwith "dl_error: expected error, but no error reported" let crush_flags f : 'a list -> int = List.fold_left (fun i o -> i lor (f o)) 0 [@@@warning "-16"] let dlopen ?filename ~flags = match _dlopen ?filename ~flags:(crush_flags resolve_flag flags) with | Some library -> library | None -> _report_dl_error (List.mem RTLD_NOLOAD flags) let dlclose ~handle = match _dlclose ~handle with | 0 -> () | _ -> _report_dl_error false let dlsym ?handle ~symbol = match _dlsym ?handle ~symbol with | Some symbol -> symbol | None -> _report_dl_error false yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/dl.ml.win000066400000000000000000000062471445631112600232250ustar00rootroot00000000000000(* * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@ocaml.warning "-16-37"] type library type dlsym_ret = | Dlsy_unknown | Dlsy_nomem | Dlsy_enoent | Dlsy_error of string | Dlsy_ok of nativeint external _dlsym_default: string -> dlsym_ret = "ctypes_win32_dlsym_rtld_default" external _dlsym: library -> string -> dlsym_ret = "ctypes_win32_dlsym" type dlopen_ret = | Dlop_unknown | Dlop_nomem | Dlop_notloaded | Dlop_error of string | Dlop_ok of library external _dlopen: string option -> int -> dlopen_ret = "ctypes_win32_dlopen" type dlclose_ret = | Dlcl_unknown | Dlcl_nomem | Dlcl_ok | Dlcl_error of string external _dlclose: library -> dlclose_ret = "ctypes_win32_dlclose" exception DL_error of string type flag = | RTLD_LAZY | RTLD_NOW | RTLD_GLOBAL | RTLD_LOCAL | RTLD_NODELETE | RTLD_NOLOAD | RTLD_DEEPBIND let unknown = "unknown_error" let nomem = "no memory" let nonl s = let l = String.length s in if l = 0 || s.[l-1] <> '\n' then s else let nl = if l > 1 && s.[l-2] = '\r' then l - 2 else l - 1 in String.sub s 0 nl let replace_slash s = let l = String.length s in let b = Bytes.create l in (* according to msdn, slashes are not supported for LoadLibrary *) for i = 0 to pred l do match s.[i] with | '/' -> Bytes.set b i '\\' | x -> Bytes.set b i x done; Bytes.unsafe_to_string b let dlopen_raise s msg = let s = match s with | None -> "NULL" | Some x -> x in let msg = Printf.sprintf "dlopen (%s): %s" s (nonl msg) in raise (DL_error msg) let dlopen ?filename ~flags = let filename = match filename with | None -> None | (Some x) as sx -> let s = if String.contains x '/' then replace_slash x else x in let ls = String.lowercase_ascii s in let s' = if Filename.check_suffix ls ".so" || Filename.check_suffix ls ".dylib" then Filename.chop_extension s ^ ".dll" else s in if s' == x then sx else Some s' in let iflags = (if List.mem RTLD_NOLOAD flags then 1 else 0) + (if List.mem RTLD_NODELETE flags then 2 else 0) in match _dlopen filename iflags with | Dlop_ok x -> x | Dlop_nomem -> dlopen_raise filename nomem | Dlop_unknown -> dlopen_raise filename unknown | Dlop_error s -> dlopen_raise filename s | Dlop_notloaded -> raise (DL_error "library not loaded") let draise y x = raise (DL_error ( y ^ ": " ^ nonl x)) let dlclose ~handle = match _dlclose handle with | Dlcl_ok -> () | Dlcl_unknown -> draise "dlclose" unknown | Dlcl_nomem -> draise "dlclose" nomem | Dlcl_error s -> draise "dlclose" s let dlsym ?handle ~symbol = let r = match handle with | None -> _dlsym_default symbol | Some x -> _dlsym x symbol in match r with | Dlsy_ok v -> v | Dlsy_unknown -> draise "dlsym" unknown | Dlsy_nomem -> draise "dlsym" nomem | Dlsy_enoent -> let msg = Printf.sprintf "no such symbol: %S" symbol in draise "dlsym" msg | Dlsy_error x -> draise "dlsym" x yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/dl.mli000066400000000000000000000024671445631112600226020ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** Bindings to the dlopen / dlsym interface. *) type library (** The type of dynamic libraries, as returned by {!dlopen}. *) exception DL_error of string (** An error condition occurred when calling {!dlopen}, {!dlclose} or {!dlsym}. The argument is the string returned by the [dlerror] function. *) (** Flags for {!dlopen} Note for windows users: Only [RTLD_NOLOAD] and [RTLD_NODELETE] are supported. Passing no or any other flags to {!dlopen} will result in standard behaviour: just LoadLibrary is called. If [RTLD_NOLOAD] is specified and the module is not already loaded, a {!DL_error} with the string "library not loaded" is thrown; there is however no test, if such a library exists at all (like under linux). *) type flag = RTLD_LAZY | RTLD_NOW | RTLD_GLOBAL | RTLD_LOCAL | RTLD_NODELETE | RTLD_NOLOAD | RTLD_DEEPBIND val dlopen : ?filename:string -> flags:flag list -> library (** Open a dynamic library. Note for windows users: the filename must be encoded in UTF-8 *) val dlclose : handle:library -> unit (** Close a dynamic library. *) val dlsym : ?handle:library -> symbol:string -> nativeint (** Look up a symbol in a dynamic library. *) yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/dl_stubs.c.unix000066400000000000000000000052431445631112600244400ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #define _GNU_SOURCE #include #include #include #include #include #include #define Val_none Val_int(0) #define Some_val(v) Field(v, 0) enum dl_flags_caml { _RTLD_LAZY, _RTLD_NOW, _RTLD_GLOBAL, _RTLD_LOCAL, #ifdef RTLD_NODELETE _RTLD_NODELETE, #endif /* RTLD_NODELETE */ #ifdef RTLD_NOLOAD _RTLD_NOLOAD, #endif /* RTLD_NOLOAD */ #ifdef RTLD_DEEPBIND _RTLD_DEEPBIND, #endif /* RTLD_DEEPBIND */ }; static value Val_some(value v) { CAMLparam1(v); CAMLlocal1(some); some = caml_alloc(1, 0); Store_field(some, 0, v); CAMLreturn(some); } /* ctypes_resolve_dl_flag : flag -> int */ value ctypes_resolve_dl_flag(value flag) { int rv; switch (Int_val(flag)) { case _RTLD_LAZY: rv = RTLD_LAZY; break; case _RTLD_NOW: rv = RTLD_NOW; break; case _RTLD_GLOBAL: rv = RTLD_GLOBAL; break; case _RTLD_LOCAL: rv = RTLD_LOCAL; break; #ifdef RTLD_NODELETE case _RTLD_NODELETE: rv = RTLD_NODELETE; break; #endif /* RTLD_NODELETE */ #ifdef RTLD_NOLOAD case _RTLD_NOLOAD: rv = RTLD_NOLOAD; break; #endif /* RTLD_NOLOAD */ #ifdef RTLD_DEEPBIND case _RTLD_DEEPBIND: rv = RTLD_DEEPBIND; break; #endif /* RTLD_DEEPBIND */ default: assert(0); } return Val_long(rv); } /* ctypes_dlopen : filename:string -> flags:int -> library option */ value ctypes_dlopen(value filename, value flag) { CAMLparam2(filename, flag); const char *cfilename = filename == Val_none ? NULL : String_val(Some_val(filename)); int cflag = Int_val(flag); void *handle = dlopen(cfilename, cflag); CAMLreturn (handle != NULL ? Val_some(caml_copy_nativeint((intptr_t)handle)) : Val_none); } /* ctypes_dlsym : ?handle:library -> symbol:string -> cvalue option */ value ctypes_dlsym(value handle_option, value symbol) { CAMLparam2(handle_option, symbol); void *handle = handle_option == Val_none ? RTLD_DEFAULT : (void *)Nativeint_val(Some_val(handle_option)); const char *s = String_val(symbol); void *result = dlsym(handle, s); CAMLreturn(result == NULL ? Val_none : Val_some(caml_copy_nativeint((intptr_t)result))); } /* ctypes_dlclose : handle:library -> int */ value ctypes_dlclose(value handle) { return Val_long(dlclose((void *)Nativeint_val(handle))); } /* ctypes_dlerror : unit -> string option */ value ctypes_dlerror(value unit) { CAMLparam1(unit); const char *error = dlerror(); CAMLreturn (error != NULL ? Val_some(caml_copy_string(error)) : Val_none); } yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/dl_stubs.c.win000066400000000000000000000154741445631112600242610ustar00rootroot00000000000000/* * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ /* for compatiblity with Windows Vista and XP */ #define PSAPI_VERSION 1 #include #include #include #include #include #define STUB_ERROR_UNKNOWN (Val_long(0)) #define STUB_ERROR_NOMEM (Val_long(1)) #define STUB_TAG_ERROR 0 static value get_tagged_error_msg(DWORD ecode) { CAMLparam0(); CAMLlocal1(msg); value ret=STUB_ERROR_UNKNOWN; if ( ecode ){ char buf[512]; DWORD len ; len = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL, ecode, MAKELANGID(LANG_NEUTRAL,SUBLANG_DEFAULT), buf, sizeof(buf), NULL); if (len){ msg=caml_copy_string(buf); ret=caml_alloc_small(1,STUB_TAG_ERROR); Field(ret,0)=msg; } } CAMLreturn(ret); } static value utf8_to_wstring(value utf8string) { CAMLparam1(utf8string); value ret; int n; WCHAR *result; n = MultiByteToWideChar(CP_UTF8,0,String_val(utf8string),-1, NULL,0); if (!n){ ret=Val_unit; goto endp; } ret = caml_alloc_string(n * sizeof(*result)); result = (WCHAR *)String_val(ret); if ( n != MultiByteToWideChar(CP_UTF8,0,String_val(utf8string),-1,result,n) ){ ret = Val_unit; } endp: CAMLreturn(ret); } /* In order to get a list of all used dlls, we can use the following approaches: - EnumProcessModules (psapi.dll on older windows versions) - RtlQueryProcessDebugInformation (no documented by microsoft, seems to be slower than EnumProcessModules) - CreateToolhelp32Snapshot (even slower, see http://securityxploded.com/enumheaps.php) - using NtQueryInformationProcess (low level and fiddly) details: https://sites.google.com/site/ericuday/EICAR2008_UserMode_Memory_Scanning_3.doc (Eric Uday Kumar: User-mode memory scanning on 32-bit & 64-bit windows) */ /* integer: 0: unknown error 1: nomem 2: enoent blocks of size 1: 0: error message 1: success handle */ value ctypes_win32_dlsym_rtld_default(value needle) { CAMLparam1(needle); CAMLlocal2(ret,tmp); HMODULE hmodules[128]; HMODULE *r_modules = hmodules; HANDLE proc = NULL; DWORD bytes_hmodules; DWORD bytes_hmodules_real; DWORD i; proc = OpenProcess( PROCESS_QUERY_INFORMATION | PROCESS_VM_READ, FALSE, GetCurrentProcessId() ); if ( !proc ){ ret=get_tagged_error_msg(GetLastError()); goto endp; } if( ! EnumProcessModules(proc, r_modules, sizeof(hmodules), &bytes_hmodules)){ DWORD ec = GetLastError(); CloseHandle(proc); ret=get_tagged_error_msg(ec); goto endp; } bytes_hmodules_real = bytes_hmodules; if ( bytes_hmodules > sizeof(hmodules) ){ r_modules=malloc(bytes_hmodules); if ( !r_modules ){ ret=STUB_ERROR_NOMEM; CloseHandle(proc); goto endp; } if(!EnumProcessModules(proc, r_modules, bytes_hmodules, &bytes_hmodules_real)){ DWORD ec = GetLastError(); free(r_modules); CloseHandle(proc); ret=get_tagged_error_msg(ec); goto endp; } bytes_hmodules_real = bytes_hmodules < bytes_hmodules_real ? bytes_hmodules : bytes_hmodules_real; } for ( i = 0; i < (bytes_hmodules_real / sizeof(HMODULE)); i++ ) { FARPROC result=GetProcAddress(r_modules[i],String_val(needle)); if ( result ){ if ( r_modules != hmodules ){ free(r_modules); } CloseHandle(proc); tmp=caml_copy_nativeint((intnat)result); ret=caml_alloc_small(1,1); Field(ret,0)=tmp; goto endp; } } ret=Val_long(2); /* enoent */ CloseHandle(proc); if ( r_modules != hmodules ){ free(r_modules); } endp: CAMLreturn(ret); } /* integer: 0: unknown error 1: nomem block of size one: 0: error message 1: success handle */ value ctypes_win32_dlsym(value handle,value sym) { CAMLparam2(handle,sym); CAMLlocal2(ret,tmp); PROC p = GetProcAddress((HMODULE)Nativeint_val(handle), String_val(sym)); if ( !p ){ ret=get_tagged_error_msg(GetLastError()); } else { tmp=caml_copy_nativeint((intnat)p); ret=caml_alloc_small(1,1); Field(ret,0)=tmp; } CAMLreturn(ret); } #define Val_none Val_int(0) #define Some_val(v) Field(v, 0) /* integer: 0: unknown error 1: nomem 2: not loaded block of size one: 0: error msg; 1: handle; */ value ctypes_win32_dlopen(value filename, value flags) { CAMLparam1(filename); CAMLlocal2(ret,tmp); if ( filename == Val_none ){ HMODULE p = GetModuleHandle(NULL); if ( !p ){ ret=get_tagged_error_msg(GetLastError()); } else { tmp = caml_copy_nativeint((intnat)p); ret=caml_alloc_small(1,1); Field(ret,0)=tmp; } } else { intnat iflags = Long_val(flags); HMODULE p; UINT e_mode; DWORD ec = ERROR_SUCCESS; filename=utf8_to_wstring(Some_val(filename)); if ( filename == Val_unit ){ tmp=caml_copy_string("invalid filename"); ret=caml_alloc_small(1,STUB_TAG_ERROR); Field(ret,0)=tmp; goto endp; } if ( iflags & 1 ){ /* RTLD_NOLOAD */ p= GetModuleHandleW((WCHAR *)String_val(filename)); if ( !p ){ ret=Val_long(2); goto endp; } /* Note: If GetModuleHandle succeeds, we still need to call LoadLibrary in order to increase the reference count for the module. */ } /* allocations first, so we are not responsible for not decreasing the reference count, if we are out of memory or another thread does something strange */ tmp = caml_copy_nativeint(0); ret = caml_alloc_small(1,1); Field(ret,0)=tmp; /* some windows version show a message box without this */ e_mode = SetErrorMode(SEM_FAILCRITICALERRORS|SEM_NOOPENFILEERRORBOX); p=LoadLibraryW((WCHAR *)String_val(filename)); if ( !p ){ ec = GetLastError(); } SetErrorMode(e_mode); /* restores the previous state */ if ( !p ){ ret=get_tagged_error_msg(ec); goto endp; } *((intnat *)Data_custom_val(tmp))=(intnat)p; if (iflags & 2 ){ /* RTLD_NODELETE */ GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_PIN, (WCHAR *)String_val(filename), &p); } } endp: CAMLreturn(ret); } /* integer: 0: unknown error 1: nomem 2: ok block of size one: 0: error msg */ value ctypes_win32_dlclose(value ohandle) { CAMLparam1(ohandle); CAMLlocal1(ret); ret= Val_long(2); HMODULE handle = (HMODULE) Nativeint_val(ohandle); if (handle && handle != GetModuleHandle(NULL)){ if (!FreeLibrary(handle)){ ret=get_tagged_error_msg(GetLastError()); } } CAMLreturn(ret); } yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/dune000066400000000000000000000014001445631112600223400ustar00rootroot00000000000000(rule (copy# "dl_stubs.c.%{read-lines:backend.sexp}" dl_stubs.c)) (rule (copy# "dl.ml.%{read-lines:backend.sexp}" dl.ml)) (rule (with-stdout-to libffi_abi.ml (run ./config/gen_libffi_abi.exe -cflags "%{read-lines:c_flags}"))) (library (name ctypes_foreign) (public_name ctypes-foreign) (instrumentation (backend bisect_ppx)) (wrapped false) (private_modules ctypes_foreign_threaded_stubs) (libraries ctypes threads) (c_library_flags :standard (:include c_library_flags.sexp)) (foreign_stubs (language c) (names dl_stubs ffi_call_stubs ffi_type_stubs foreign_threaded_stubs) (flags :standard (:include c_flags.sexp)))) (rule (targets c_flags c_flags.sexp c_library_flags.sexp backend.sexp) (action (run ./config/discover.exe))) yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/ffi_call_stubs.c000066400000000000000000000417111445631112600246160ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include "../ctypes/ctypes_managed_buffer_stubs.h" #include "../ctypes/ctypes_type_info_stubs.h" #include "../ctypes/ctypes_raw_pointer.h" /* TODO: support callbacks that raise exceptions? e.g. using caml_callback_exn etc. */ /* Register a C thread with the OCaml runtime. By default this simply fails. The ctypes.foreign.threaded subpackage overrides it to call [caml_c_thread_register]. */ static int ctypes_thread_register_fail(void) { caml_failwith("ctypes_thread_register unavailable: " "please link with the threads library"); } int (*ctypes_thread_register)(void) = ctypes_thread_register_fail; /* An OCaml function that converts resolves identifiers to OCaml functions */ static value retrieve_closure_; /* Resolve identifiers to OCaml functions */ static value retrieve_closure(intnat key) { CAMLparam0 (); CAMLlocal1(result); result = caml_callback_exn(retrieve_closure_, Val_long(key)); if (Is_exception_result(result)) { caml_raise_constant(*caml_named_value("CallToExpiredClosure")); } CAMLreturn (result); } /* Register the function used to resolve closure identifiers */ /* set_closure_callback : (int -> boxedfn) -> unit */ value ctypes_set_closure_callback(value retrieve) { CAMLparam1(retrieve); caml_register_global_root(&retrieve_closure_); retrieve_closure_ = retrieve; CAMLreturn(Val_unit); } void ctypes_check_ffi_status(ffi_status status) { switch (status) { case FFI_OK: break; case FFI_BAD_TYPEDEF: caml_raise_with_string(*caml_named_value("FFI_internal_error"), "FFI_BAD_TYPEDEF"); case FFI_BAD_ABI: caml_raise_with_string(*caml_named_value("FFI_internal_error"), "FFI_BAD_ABI"); default: assert(0); } } /* Given an offset into a fully-aligned buffer, compute the next offset that satisfies `alignment'. */ static size_t aligned_offset(size_t offset, size_t alignment) { size_t overhang = offset % alignment; return overhang == 0 ? offset : offset - overhang + alignment; } static struct callspec { /* A description of the buffer used to hold the arguments that we pass to C functions via ffi_call. */ /* The ffi_cif structure holds some of the information that we're maintaining here, but it isn't part of the public interface. */ /* The space needed to store properly-aligned arguments and return value. */ size_t bytes; /* The number of elements. */ size_t nelements; /* The capacity of the args array, including the terminating null. */ size_t capacity; /* The maximum element alignment */ size_t max_align; /* The state of the callspec value. */ enum { BUILDING, CALLSPEC } state; /* A null-terminated array of size `nelements' types */ ffi_type **args; /* return value offset */ size_t roffset; /* return offset adjustment. libffi promotes return types that are less than the size of the system register to the word-sized type ffi_arg. On a big-endian system this means that the address where libffi writes the return value is not always the same as the address from which ctypes should read the value. */ size_t radjustment; /* The context in which the call should run: whether errno is checked, whether the runtime lock is released, and so on. */ struct call_context { int check_errno:1; int runtime_lock:1; int thread_registration:1; } context; /* The libffi call interface structure. It would be nice for this member to be a value rather than a pointer (to save a layer of indirection) but the ffi_closure structure keeps the address of the structure, and the GC can move callspec values around. */ ffi_cif *cif; } callspec_prototype = { 0, 0, 0, 0, BUILDING, NULL, -1, 0, { 0, 0 }, NULL }; static void finalize_callspec(value v) { struct callspec *callspec = Data_custom_val(v); caml_stat_free(callspec->args); caml_stat_free(callspec->cif); } static struct custom_operations callspec_custom_ops = { "ocaml-ctypes:callspec", finalize_callspec, custom_compare_default, custom_hash_default, custom_serialize_default, custom_deserialize_default, custom_compare_ext_default }; /* We store two things in the callbuffer: a "scratch" area for passing arguments and receiving the return value, and an array of pointers into the scratch area; we pass that array to ffi_call along with a pointer to the return value space. The scratch area comes first, followed by the pointer array. The incomplete struct type gives a modicum of type safety over void *: the compiler should reject incompatible assignments, for example. */ typedef struct callbuffer callbuffer; /* Compute the size of the buffer needed to hold the pointer array used by ffi_call, the arguments and the return value */ static size_t compute_arg_buffer_size(struct callspec *callspec, size_t *arg_array_offset) { assert(callspec->state == CALLSPEC); size_t bytes = callspec->bytes; *arg_array_offset = aligned_offset(bytes, ffi_type_pointer.alignment); bytes = *arg_array_offset + callspec->nelements * sizeof(void *); return bytes; } /* Set the pointers in `arg_array' to the addresses of the argument slots in `callbuffer' as indicated by the elements of the ffitype array in the callspec. */ static void populate_arg_array(struct callspec *callspec, callbuffer *callbuffer, void **arg_array) { size_t i = 0, offset = 0; for (; i < callspec->nelements; i++) { offset = aligned_offset(offset, callspec->args[i]->alignment); arg_array[i] = (char *)callbuffer + offset; offset += callspec->args[i]->size; } } /* Allocate a new C call specification */ /* allocate_callspec : check_errno:bool -> runtime_lock:bool -> callspec */ value ctypes_allocate_callspec(value check_errno, value runtime_lock, value thread_registration) { struct call_context context = { Int_val(check_errno), Int_val(runtime_lock), Int_val(thread_registration), }; value block = caml_alloc_custom(&callspec_custom_ops, sizeof(struct callspec), 0, 1); struct callspec *spec = Data_custom_val(block); memcpy(spec, &callspec_prototype, sizeof(struct callspec)); spec->context = context; return block; } /* Add an argument to the C call specification */ /* add_argument : callspec -> 'a ffitype -> int */ value ctypes_add_argument(value callspec_, value argument_) { static const size_t increment_size = 8; CAMLparam2(callspec_, argument_); struct callspec *callspec = Data_custom_val(callspec_); ffi_type *argtype = CTYPES_TO_PTR(argument_); assert (callspec->state == BUILDING); /* If there's a possibility that this spec represents an argument list or a struct we might pass by value then we have to take care to maintain the args, capacity and nelements members. */ int offset = aligned_offset(callspec->bytes, argtype->alignment); callspec->bytes = offset + argtype->size; if (callspec->nelements + 2 >= callspec->capacity) { size_t new_size = ((callspec->capacity + increment_size) * sizeof *callspec->args); callspec->args = caml_stat_resize(callspec->args, new_size); callspec->capacity += increment_size; } callspec->args[callspec->nelements] = argtype; callspec->args[callspec->nelements + 1] = NULL; callspec->nelements += 1; callspec->max_align = argtype->alignment > callspec->max_align ? argtype->alignment : callspec->max_align; CAMLreturn(Val_long(offset)); } static int ffi_return_type_adjustment(ffi_type *f) { #ifdef ARCH_BIG_ENDIAN /* An adjustment is needed (on bigendian systems) for integer types less than the size of a word */ if (f->size < sizeof(ffi_arg)) { switch (f->type) { case FFI_TYPE_INT: case FFI_TYPE_UINT8: case FFI_TYPE_SINT8: case FFI_TYPE_UINT16: case FFI_TYPE_SINT16: case FFI_TYPE_UINT32: case FFI_TYPE_SINT32: case FFI_TYPE_UINT64: case FFI_TYPE_SINT64: return sizeof(ffi_arg) - f->size; default: break; } } #endif return 0; } /* Pass the return type and conclude the specification preparation */ /* prep_callspec : callspec -> 'a ffitype -> int -> unit */ value ctypes_prep_callspec(value callspec_, value abi_, value rtype) { CAMLparam3(callspec_, abi_, rtype); struct callspec *callspec = Data_custom_val(callspec_); ffi_type *rffitype = CTYPES_TO_PTR(rtype); ffi_abi abi = Int_val(abi_); /* Allocate the cif structure */ callspec->cif = caml_stat_alloc(sizeof *callspec->cif); /* Add the (aligned) space needed for the return value */ callspec->roffset = aligned_offset(callspec->bytes, rffitype->alignment); callspec->radjustment = ffi_return_type_adjustment(rffitype); callspec->bytes = callspec->roffset + rffitype->size; /* Allocate an extra word after the return value space, to work around a bug in libffi which causes it to write past the return value space. https://github.com/atgreen/libffi/issues/35 */ callspec->bytes = aligned_offset(callspec->bytes, ffi_type_pointer.alignment); callspec->bytes += ffi_type_pointer.size; ffi_status status = ffi_prep_cif(callspec->cif, abi, callspec->nelements, rffitype, callspec->args); ctypes_check_ffi_status(status); callspec->state = CALLSPEC; CAMLreturn(Val_unit); } /* Call the function specified by `callspec', passing arguments and return values in `buffer' */ /* call : string -> _ fn Fat.t -> callspec -> (raw_pointer -> Obj.t array -> unit) -> (raw_pointer -> 'a) -> 'a */ value ctypes_call(value fnname, value function, value callspec_, value argwriter, value rvreader) { CAMLparam5(fnname, function, callspec_, argwriter, rvreader); CAMLlocal3(callback_arg_buf, callback_val_arr, callback_rv_buf); struct callspec *callspec = Data_custom_val(callspec_); int roffset = callspec->roffset; struct call_context context = callspec->context; size_t nelements = callspec->nelements; ffi_cif *cif = callspec->cif; assert(callspec->state == CALLSPEC); size_t arg_array_offset; size_t bytes = compute_arg_buffer_size(callspec, &arg_array_offset); char *callbuffer = alloca(bytes); char *return_write_slot = callbuffer + roffset; char *return_read_slot = return_write_slot + callspec->radjustment; populate_arg_array(callspec, (struct callbuffer *)callbuffer, (void **)(callbuffer + arg_array_offset)); callback_arg_buf = CTYPES_FROM_PTR(callbuffer); callback_val_arr = caml_alloc_tuple(nelements); caml_callback2(argwriter, callback_arg_buf, callback_val_arr); const void **val_refs = alloca(sizeof(void*) * nelements); unsigned arg_idx; for(arg_idx = 0; arg_idx < Wosize_val(callback_val_arr); arg_idx++) { value arg_tuple = Field(callback_val_arr, arg_idx); /* >=4.02 initialize to unit. */ if(arg_tuple == Val_unit) continue; value arg_ptr = Field(arg_tuple, 0); value arg_offset = Field(arg_tuple, 1); /* Only strings have defined semantics for now. */ assert(Is_block(arg_ptr) && Tag_val(arg_ptr) == String_tag); val_refs[arg_idx] = String_val(arg_ptr) + Long_val(arg_offset); ((const void**)(callbuffer + arg_array_offset))[arg_idx] = &val_refs[arg_idx]; } void (*cfunction)(void) = (void (*)(void)) CTYPES_ADDR_OF_FATPTR(function); int check_errno = context.check_errno; int saved_errno = 0; if (context.runtime_lock) { caml_release_runtime_system(); } if (check_errno) { errno=0; } ffi_call(cif, cfunction, return_write_slot, (void **)(callbuffer + arg_array_offset)); if (check_errno) { saved_errno=errno; } if (context.runtime_lock) { caml_acquire_runtime_system(); } if (check_errno && saved_errno != 0) { char *buffer = alloca(caml_string_length(fnname) + 1); strcpy(buffer, String_val(fnname)); unix_error(saved_errno, buffer, Nothing); } callback_rv_buf = CTYPES_FROM_PTR(return_read_slot); CAMLreturn(caml_callback(rvreader, callback_rv_buf)); } typedef struct closure closure; struct closure { ffi_closure closure; intnat fnkey; struct call_context context; void* fnptr; }; enum boxedfn_tags { Done, Fn }; /* callback_handler_with_lock must only be called while the runtime lock is held. */ static void callback_handler_with_lock(ffi_cif *cif, void *ret, void **args, void *user_data) { CAMLparam0 (); CAMLlocal2(boxedfn, argptr); closure *closure = user_data; boxedfn = retrieve_closure(closure->fnkey); int i, arity = cif->nargs; switch (arity) { case 0: { assert (Tag_val(boxedfn) == Fn); boxedfn = caml_callback(Field(boxedfn, 0), Val_unit); break; } default: { for (i = 0; i < arity; i++) { void *cvalue = args[i]; assert (Tag_val(boxedfn) == Fn); /* unbox and call */ argptr = CTYPES_FROM_PTR(cvalue); boxedfn = caml_callback(Field(boxedfn, 0), argptr); } break; } } /* now store the return value */ assert (Tag_val(boxedfn) == Done); argptr = CTYPES_FROM_PTR(ret); caml_callback(Field(boxedfn, 0), argptr); /* workaround for libffi api: small integers must be promoted to * full word size (sign/zero extended) */ if (cif->rtype->size < sizeof(ffi_arg)) { int do_nothing = 0; ffi_arg x; switch (cif->rtype->type) { case FFI_TYPE_INT: x = *(int*)ret; break; case FFI_TYPE_UINT8: x = *(uint8_t*)ret; break; case FFI_TYPE_SINT8: x = *(int8_t*)ret; break; case FFI_TYPE_UINT16: x = *(uint16_t*)ret; break; case FFI_TYPE_SINT16: x = *(int16_t*)ret; break; case FFI_TYPE_UINT32: x = *(uint32_t*)ret; break; case FFI_TYPE_SINT32: x = *(int32_t*)ret; break; case FFI_TYPE_UINT64: x = *(uint64_t*)ret; break; case FFI_TYPE_SINT64: x = *(int64_t*)ret; break; default: do_nothing = 1; break; } if ( do_nothing == 0 ) { *(ffi_arg*)ret = x; } } CAMLreturn0; } static void callback_handler(ffi_cif *cif, void *ret, void **args, void *user_data) { closure *closure = user_data; if (closure->context.thread_registration) { ctypes_thread_register(); } if (closure->context.runtime_lock) { caml_acquire_runtime_system(); } callback_handler_with_lock(cif, ret, args, user_data); if (closure->context.runtime_lock) { caml_release_runtime_system(); } } static void finalize_closure(value v) { struct closure **closure = Data_custom_val(v); ffi_closure_free(*closure); } /* A custom object whose purpose is the finalizer that calls ffi_closure_free */ static struct custom_operations closure_custom_ops = { "ocaml-ctypes:closure", finalize_closure, custom_compare_default, custom_hash_default, custom_serialize_default, custom_deserialize_default, custom_compare_ext_default }; /* Construct a pointer to an OCaml function represented by an identifier */ /* make_function_pointer : callspec -> int -> raw_pointer */ value ctypes_make_function_pointer(value callspec_, value fnid) { CAMLparam2(callspec_, fnid); CAMLlocal1(codeptr); struct callspec *callspec = Data_custom_val(callspec_); assert(callspec->state == CALLSPEC); void (*code_address)(void) = NULL; closure *closure = ffi_closure_alloc(sizeof *closure, (void *)&code_address); if (closure == NULL) { caml_raise_out_of_memory(); } else { closure->fnkey = Long_val(fnid); closure->context = callspec->context; closure->fnptr = code_address; ffi_status status = ffi_prep_closure_loc ((ffi_closure *)closure, callspec->cif, callback_handler, closure, (void *)code_address); ctypes_check_ffi_status(status); codeptr = caml_alloc_custom(&closure_custom_ops, sizeof(struct closure *), 0, 1); *(struct closure **)Data_custom_val(codeptr) = closure; CAMLreturn (codeptr); } } /* Extract the raw address from a function pointer object */ value ctypes_raw_address_of_function_pointer(value closure) { return CTYPES_FROM_PTR((*(struct closure **)Data_custom_val(closure))->fnptr); } yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/ffi_type_stubs.c000066400000000000000000000135011445631112600246600ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #include #include #include #include #include #include "../ctypes/ctypes_primitives.h" #include "../ctypes/ctypes_raw_pointer.h" #include "../ctypes/ctypes_managed_buffer_stubs.h" #if CHAR_MIN < 0 #define ctypes_ffi_type_char ffi_type_schar #else #define ctypes_ffi_type_char ffi_type_uchar #endif /* We need a pointer-sized integer type. SIZEOF_PTR is from caml/config.h. */ #if SIZEOF_PTR == 4 #define ctypes_ffi_type_camlint ffi_type_sint32 #elif SIZEOF_PTR == 8 #define ctypes_ffi_type_camlint ffi_type_sint64 #else #error "No suitable pointer-sized integer type available" #endif /* long long is at least 64 bits. */ #if LLONG_MAX == 9223372036854775807LL #define ctypes_ffi_type_sllong ffi_type_sint64 #define ctypes_ffi_type_ullong ffi_type_uint64 #else # error "No suitable OCaml type available for representing longs" #endif #if SIZE_MAX == 65535U #define ctypes_ffi_type_size_t ffi_type_uint16 #elif SIZE_MAX == 4294967295UL #define ctypes_ffi_type_size_t ffi_type_uint32 #elif SIZE_MAX == 18446744073709551615ULL #define ctypes_ffi_type_size_t ffi_type_uint64 #else # error "No suitable OCaml type available for representing size_t values" #endif static ffi_type *bool_ffi_type(void) { switch (sizeof(bool)) { case sizeof(uint8_t): return &ffi_type_uint8; case sizeof(uint16_t): return &ffi_type_uint16; case sizeof(uint32_t): return &ffi_type_uint32; case sizeof(uint64_t): return &ffi_type_uint64; default: return NULL; } } /* primitive_ffitype : 'a prim -> 'a ffitype */ value ctypes_primitive_ffitype(value prim) { void *ft = NULL; switch ((enum ctypes_primitive)Int_val(prim)) { case Ctypes_Char: ft = &ctypes_ffi_type_char; break; /* Char */ case Ctypes_Schar: ft = &ffi_type_schar; break; /* Schar */ case Ctypes_Uchar: ft = &ffi_type_uchar; break; /* Uchar */ case Ctypes_Bool: ft = bool_ffi_type(); break; case Ctypes_Short: ft = &ffi_type_sshort; break; /* Short */ case Ctypes_Int: ft = &ffi_type_sint; break; /* Int */ case Ctypes_Long: ft = &ffi_type_slong; break; /* Long */ case Ctypes_Llong: ft = &ctypes_ffi_type_sllong; break; /* Llong */ case Ctypes_Ushort: ft = &ffi_type_ushort; break; /* Ushort */ case Ctypes_Sint: ft = &ffi_type_sint; break; /* Sint */ case Ctypes_Uint: ft = &ffi_type_uint; break; /* Uint */ case Ctypes_Ulong: ft = &ffi_type_ulong; break; /* Ulong */ case Ctypes_Ullong: ft = &ctypes_ffi_type_ullong; break; /* Ullong */ case Ctypes_Size_t: ft = &ctypes_ffi_type_size_t; break; /* Size */ case Ctypes_Int8_t: ft = &ffi_type_sint8; break; /* Int8 */ case Ctypes_Int16_t: ft = &ffi_type_sint16; break; /* Int16 */ case Ctypes_Int32_t: ft = &ffi_type_sint32; break; /* Int32 */ case Ctypes_Int64_t: ft = &ffi_type_sint64; break; /* Int64 */ case Ctypes_Uint8_t: ft = &ffi_type_uint8; break; /* Uint8 */ case Ctypes_Uint16_t: ft = &ffi_type_uint16; break; /* Uint16 */ case Ctypes_Uint32_t: ft = &ffi_type_uint32; break; /* Uint32 */ case Ctypes_Uint64_t: ft = &ffi_type_uint64; break; /* Uint64 */ case Ctypes_Camlint: ft = &ctypes_ffi_type_camlint; break; /* Camlint */ case Ctypes_Nativeint: ft = &ctypes_ffi_type_camlint; break; /* Nativeint */ case Ctypes_Float: ft = &ffi_type_float; break; /* Float */ case Ctypes_Double: ft = &ffi_type_double; break; /* Double */ case Ctypes_LDouble: ft = NULL; break; /* LDouble */ case Ctypes_Complex32: ft = NULL; break; /* Complex32 */ case Ctypes_Complex64: ft = NULL; break; /* Complex64 */ case Ctypes_Complexld: ft = NULL; break; /* Complexld */ } return CTYPES_FROM_PTR(ft); } /* pointer_ffitype : unit -> voidp ffitype */ value ctypes_pointer_ffitype(value _) { return CTYPES_FROM_PTR(&ffi_type_pointer); } /* void_ffitype : unit -> unit ffitype */ value ctypes_void_ffitype(value _) { return CTYPES_FROM_PTR(&ffi_type_void); } #define Struct_ffitype_val(v) (*(ffi_type **)Data_custom_val(v)) /* allocate_struct_ffitype : int -> managed_buffer */ value ctypes_allocate_struct_ffitype(value nargs_) { CAMLparam1(nargs_); int nargs = Int_val(nargs_); /* Space for the struct ffi_type plus a null-terminated array of arguments */ int size = sizeof (ffi_type) + (1 + nargs) * sizeof (ffi_type *); CAMLlocal1(block); block = ctypes_allocate(Val_int(1), Val_int(size)); ffi_type *struct_type = Struct_ffitype_val(block); struct_type->size = 0; struct_type->alignment = 0; struct_type->type = FFI_TYPE_STRUCT; struct_type->elements = (ffi_type **)(struct_type + 1); struct_type->elements[nargs] = NULL; CAMLreturn (block); } /* struct_ffitype_set_argument : managed_buffer -> int -> _ ffitype -> unit */ value ctypes_struct_ffitype_set_argument(value struct_type_, value index_, value arg_) { int index = Int_val(index_); ffi_type *arg = CTYPES_TO_PTR(arg_); ffi_type *struct_type = Struct_ffitype_val(struct_type_); struct_type->elements[index] = arg; return Val_unit; } extern void ctypes_check_ffi_status(ffi_status); /* complete_struct_type : managed_buffer -> unit */ value ctypes_complete_structspec(value struct_type_) { ffi_cif _dummy_cif; ffi_type *struct_type = Struct_ffitype_val(struct_type_); ffi_status status = ffi_prep_cif(&_dummy_cif, FFI_DEFAULT_ABI, 0, struct_type, NULL); ctypes_check_ffi_status(status); return Val_unit; } yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/foreign.ml000066400000000000000000000007061445631112600234550ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) include Ctypes_foreign_basis.Make(Ctypes_closure_properties.Make(Mutex)) let () = begin (* Initialize the Thread library and set up the hook for registering C threads with the OCaml runtime *) let _ : Thread.t = Thread.self () in Ctypes_foreign_threaded_stubs.setup_thread_registration () end yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/foreign.mli000066400000000000000000000155511445631112600236320ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** High-level bindings for C functions and values *) val foreign : ?abi:Libffi_abi.abi -> ?from:Dl.library -> ?stub:bool -> ?check_errno:bool -> ?release_runtime_lock:bool -> string -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) (** [foreign name typ] exposes the C function of type [typ] named by [name] as an OCaml value. The argument [?from], if supplied, is a library handle returned by {!Dl.dlopen}. The argument [?stub], if [true] (defaults to [false]), indicates that the function should not raise an exception if [name] is not found but return an OCaml value that raises an exception when called. The value [?check_errno], which defaults to [false], indicates whether {!Unix.Unix_error} should be raised if the C function modifies [errno]. Please note that a function that succeeds is allowed to change errno. So use this option with caution. The value [?release_runtime_lock], which defaults to [false], indicates whether the OCaml runtime lock should be released during the call to the C function, allowing other threads to run. If the runtime lock is released then the C function must not access OCaml heap objects, such as arguments passed using {!Ctypes.ocaml_string} and {!Ctypes.ocaml_bytes}, and must not call back into OCaml. @raise Dl.DL_error if [name] is not found in [?from] and [?stub] is [false]. *) val foreign_value : ?from:Dl.library -> string -> 'a Ctypes.typ -> 'a Ctypes.ptr (** [foreign_value name typ] exposes the C value of type [typ] named by [name] as an OCaml value. The argument [?from], if supplied, is a library handle returned by {!Dl.dlopen}. *) val funptr : ?abi:Libffi_abi.abi -> ?name:string -> ?check_errno:bool -> ?runtime_lock:bool -> ?thread_registration:bool -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) Ctypes.typ (** Construct a function pointer type from a function type. The ctypes library, like C itself, distinguishes functions and function pointers. Functions are not first class: it is not possible to use them as arguments or return values of calls, or store them in addressable memory. Function pointers are first class, and so have none of these restrictions. The value [?check_errno], which defaults to [false], indicates whether {!Unix.Unix_error} should be raised if the C function modifies [errno]. The value [?runtime_lock], which defaults to [false], indicates whether the OCaml runtime lock should be released during the call to the C function, allowing other threads to run. If the runtime lock is released then the C function must not access OCaml heap objects, such as arguments passed using {!Ctypes.ocaml_string} and {!Ctypes.ocaml_bytes}, and must not call back into OCaml. If the function pointer is used to call into OCaml from C then the [?runtime_lock] argument indicates whether the lock should be acquired and held during the call. @raise Dl.DL_error if [name] is not found in [?from] and [?stub] is [false]. A note on lifetime: this function ties the lifetime of the C function to the associated OCaml closure, so that the C function may be used only while the closure is still live. The {!dynamic_funptr} function is an alternative to {!funptr} with explicit lifetime management. *) val funptr_opt : ?abi:Libffi_abi.abi -> ?name:string -> ?check_errno:bool -> ?runtime_lock:bool -> ?thread_registration:bool -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) option Ctypes.typ (** Construct a function pointer type from a function type. This behaves like {!funptr}, except that null pointers appear in OCaml as [None]. *) exception CallToExpiredClosure (** A closure passed to C was collected by the OCaml garbage collector before it was called. *) module type Funptr = sig type fn (** [fn] is the signature of the underlying OCaml function. *) type t (** Handle to an OCaml function that can be passed to C for use in callbacks. Each value of type {!t} allocated by {!of_fun} must be deallocated by calling {!free}. Alternatively {!with_fun} encapsulates both allocation and deallocation. *) val t : t Ctypes.typ (** A type representation for a function pointer type with explicit lifetime management. *) val t_opt : t option Ctypes.typ (** This behaves like {!t}, except that null pointers appear in OCaml as [None]. *) val free : t -> unit (** Indicate that the [fptr] is no longer needed. Once [free] has been called any C calls to this [Dynamic_funptr.t] are unsafe. Only call [free] once the callback is no longer used from C. *) val of_fun : fn -> t (** Turn an OCaml closure into a function pointer that can be passed to C. The function pointer returned by [of_fun] should be deallocated by a call to {!free} once it is no longer in use. Failure to call {!free} is an error. Alternatively, {!with_fun} encapsulates both allocation and deallocation. Implementation detail: to avoid crashes, if {!free} is not called then the implementation will retain a reference to the OCaml closure and report a warning. See {!report_leaked_funptr}. *) val with_fun : fn -> (t -> 'c) -> 'c (** [with_fun fn (fun fptr -> e)] - Turn an OCaml closure into a function pointer and perform simple life cycle management. [with_fun fn (fun fptr -> e)] will call [free fptr] after [e] completes. [with_fun] is not safe to use if the C function ptr [fptr] may still be used after [e] completes. *) end val dynamic_funptr : ?abi:Libffi_abi.abi -> ?runtime_lock:bool -> ?thread_registration:bool -> ('a -> 'b) Ctypes.fn -> (module Funptr with type fn = 'a->'b) (** Define a type representation for passing OCaml functions to C with explicit lifetime management. [(val (dynamic_funptr (foo @-> returning bar)))] corresponds to the C type [bar( * )(foo)]. Example: {[ module Progress_callback = (val (dynamic_funptr (int @-> int @-> ptr void @-> returning void))) let keygen = foreign "RSA_generate_key" (int @-> int @-> Progress_callback.t @-> ptr void @-> returning rsa_key) let secret_key = Progress_callback.with_fun (fun a b _ -> printf "progress: a:%d, b:%d\n" a b) (fun progress -> keygen 2048 65537 progress null) ]} *) val report_leaked_funptr : (string -> unit) ref (** Hook called on collection of closures associated with {!dynamic_funptr} values that have not been deallocated with {!free}. By default the ctypes library retains closures associated with function pointers that have not been freed and prints a warning to stderr. You can use this hook to change how these error messages are reported. *) yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/foreign_threaded_stubs.c000066400000000000000000000067371445631112600263610ustar00rootroot00000000000000/* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #include #include extern int (*ctypes_thread_register)(void); #ifdef _WIN32 #include #include /* The OCaml runtime stores the pointers to the information that must be cleaned up in thread local storage. Therefore caml_c_thread_unregister must be called from the thread itself. .CRT$XLA to .CRT$XLZ is an array of callback pointers that are called by the OS when the DLL is loaded and on thread attachment / detachment (they were introduced for the current task: set up and clean thread local storage). Note: Only Windows Vista and later execute the TLS callbacks for dynamically loaded DLLs (-> Windows XP restrictions: no toplevel support, bytecode executables must be compiled with '-custom'). */ /* ctypes_tls_callback will be called for all threads. The OCaml runtime use the same TLS $index for its own threads and threads registered with caml_c_thread_register. TlsSetValue($index,NULL) is only called during caml_c_thread_unregister, but not for threads created by OCaml. Therefore an additional TLS index is allocated to ensure, that caml_c_thread_unregister is not called for these threads. */ static DWORD tls_index; #define CTYPES_TLS_MAGIC_VALUE ((void*)0x78) static void NTAPI ctypes_tls_callback(void* a, DWORD reason, PVOID b) { (void)a; (void)b; if ( reason == DLL_THREAD_DETACH ) { void * x = TlsGetValue(tls_index); if ( x == CTYPES_TLS_MAGIC_VALUE ) { TlsSetValue(tls_index, NULL); caml_c_thread_unregister(); } } } PIMAGE_TLS_CALLBACK __crt_ctypes_tls_callback__ __attribute__ \ ((section(".CRT$XLB"))) = ctypes_tls_callback; static int ctypes_thread_actually_register(void) { int rv = caml_c_thread_register(); if ( rv != 0 ) { /* errors ignored (like in the case of pthread_key_create). I can't raise an exception here and I can't store the information anywhere */ TlsSetValue(tls_index, CTYPES_TLS_MAGIC_VALUE); } return rv; } value ctypes_setup_thread_registration(value _) { tls_index = TlsAlloc(); if ( tls_index == TLS_OUT_OF_INDEXES ) { caml_failwith("ctypes_thread_registration: TlsAlloc failed"); } ctypes_thread_register = ctypes_thread_actually_register; return Val_unit; } #else #include static pthread_key_t cleanup_key; static void ctypes_thread_unregister(void* _) { caml_c_thread_unregister(); pthread_setspecific(cleanup_key, NULL); } static int ctypes_thread_actually_register(void) { int rv = caml_c_thread_register(); if (rv != 0) { /* Register a destructor function for a TLS key that unregisters this thread from the OCaml runtime when the thread exits. */ /* Assumption: caml_c_thread_unregister is not called in this thread, except by the destructor, so caml_c_thread_register() will always succeed. Consequently, there is no need to protect the TLS-creation code with pthread_once. (And at worst, if the assumption is violated then caml_c_thread_unregister will be called multiple times, which is harmless.) */ pthread_key_create(&cleanup_key, ctypes_thread_unregister); pthread_setspecific(cleanup_key, &cleanup_key); } return rv; } value ctypes_setup_thread_registration(value _) { ctypes_thread_register = ctypes_thread_actually_register; return Val_unit; } #endif yallop-ocaml-ctypes-3f8211a/src/ctypes-foreign/libffi_abi.mli000066400000000000000000000012661445631112600242450ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** Support for various ABIs. *) type abi val aix : abi val darwin : abi val eabi : abi val fastcall : abi val gcc_sysv : abi val linux : abi val linux64 : abi val linux_soft_float : abi val ms_cdecl : abi val n32 : abi val n32_soft_float : abi val n64 : abi val n64_soft_float : abi val o32 : abi val o32_soft_float : abi val osf : abi val pa32 : abi val stdcall : abi val sysv : abi val thiscall : abi val unix : abi val unix64 : abi val v8 : abi val v8plus : abi val v9 : abi val vfp : abi val default_abi : abi val abi_code : abi -> int yallop-ocaml-ctypes-3f8211a/src/ctypes-top/000077500000000000000000000000001445631112600206405ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/src/ctypes-top/ctypes_printers.ml000066400000000000000000000053601445631112600244330ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) let format_typ fmt t = Ctypes.format_typ fmt t let format_fn fmt fn = Ctypes.format_fn fmt fn let format_sint fmt v = Format.fprintf fmt "" (Signed.SInt.to_string v) let format_long fmt v = Format.fprintf fmt "" (Signed.Long.to_string v) let format_llong fmt v = Format.fprintf fmt "" (Signed.LLong.to_string v) let format_uchar fmt v = Format.fprintf fmt "" (Unsigned.UChar.to_string v) let format_uint8 fmt v = Format.fprintf fmt "" (Unsigned.UInt8.to_string v) let format_uint16 fmt v = Format.fprintf fmt "" (Unsigned.UInt16.to_string v) let format_uint32 fmt v = Format.fprintf fmt "" (Unsigned.UInt32.to_string v) let format_uint64 fmt v = Format.fprintf fmt "" (Unsigned.UInt64.to_string v) let format_ushort fmt v = Format.fprintf fmt "" (Unsigned.UShort.to_string v) let format_uint fmt v = Format.fprintf fmt "" (Unsigned.UInt.to_string v) let format_ulong fmt v = Format.fprintf fmt "" (Unsigned.ULong.to_string v) let format_ullong fmt v = Format.fprintf fmt "" (Unsigned.ULLong.to_string v) let format_pointer fmt v = let open Ctypes in let typ = ptr (reference_type v) in Format.fprintf fmt "(%a) %a" (fun fmt -> format_typ fmt) typ (format typ) v let format_struct fmt v = Ctypes.(format (reference_type (addr v)) fmt v) let format_union fmt v = Ctypes.(format (reference_type (addr v)) fmt v) let format_array fmt v = Ctypes.(format CArray.(array (length v) (reference_type (start v))) fmt v) let format_ocaml fmt (Ctypes_static.OCamlRef (_, _, ty) as v) = Ctypes.format (Ctypes_static.OCaml ty) fmt v let format_clock_t fmt v = Ctypes.format PosixTypes.clock_t fmt v let format_dev_t fmt v = Ctypes.format PosixTypes.dev_t fmt v let format_ino_t fmt v = Ctypes.format PosixTypes.ino_t fmt v let format_mode_t fmt v = Ctypes.format PosixTypes.mode_t fmt v let format_nlink_t fmt v = Ctypes.format PosixTypes.nlink_t fmt v let format_off_t fmt v = Ctypes.format PosixTypes.off_t fmt v let format_pid_t fmt v = Ctypes.format PosixTypes.pid_t fmt v let format_size_t fmt v = Ctypes.format PosixTypes.size_t fmt v let format_ssize_t fmt v = Ctypes.format PosixTypes.ssize_t fmt v let format_time_t fmt v = Ctypes.format PosixTypes.time_t fmt v let format_useconds_t fmt v = Ctypes.format PosixTypes.useconds_t fmt v let format_ldouble fmt v = Format.fprintf fmt "" (LDouble.to_string v) let format_complexld fmt v = Format.fprintf fmt "" (LDouble.to_string (ComplexL.re v)) (LDouble.to_string (ComplexL.im v)) yallop-ocaml-ctypes-3f8211a/src/ctypes-top/ctypes_printers.mli000066400000000000000000000037361445631112600246110ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Format val format_typ : formatter -> 'a Ctypes.typ -> unit val format_fn : formatter -> 'a Ctypes.fn -> unit val format_sint : formatter -> Signed.SInt.t -> unit val format_long : formatter -> Signed.Long.t -> unit val format_llong : formatter -> Signed.LLong.t -> unit val format_uchar : formatter -> Unsigned.UChar.t -> unit val format_uint8 : formatter -> Unsigned.UInt8.t -> unit val format_uint16 : formatter -> Unsigned.UInt16.t -> unit val format_uint32 : formatter -> Unsigned.UInt32.t -> unit val format_uint64 : formatter -> Unsigned.UInt64.t -> unit val format_ushort : formatter -> Unsigned.UShort.t -> unit val format_uint : formatter -> Unsigned.UInt.t -> unit val format_ulong : formatter -> Unsigned.ULong.t -> unit val format_ullong : formatter -> Unsigned.ULLong.t -> unit val format_pointer : formatter -> 'a Ctypes.ptr -> unit val format_struct : formatter -> ('a, 'b) Ctypes.structured -> unit val format_union : formatter -> ('a, 'b) Ctypes.structured -> unit val format_array : formatter -> 'a Ctypes.CArray.t -> unit val format_ocaml : formatter -> 'a Ctypes.ocaml -> unit val format_clock_t : formatter -> PosixTypes.clock_t -> unit val format_dev_t : formatter -> PosixTypes.dev_t -> unit val format_ino_t : formatter -> PosixTypes.ino_t -> unit val format_mode_t : formatter -> PosixTypes.mode_t -> unit val format_nlink_t : formatter -> PosixTypes.nlink_t -> unit val format_off_t : formatter -> PosixTypes.off_t -> unit val format_pid_t : formatter -> PosixTypes.pid_t -> unit val format_size_t : formatter -> PosixTypes.size_t -> unit val format_ssize_t : formatter -> PosixTypes.ssize_t -> unit val format_time_t : formatter -> PosixTypes.time_t -> unit val format_useconds_t : formatter -> PosixTypes.useconds_t -> unit val format_ldouble : formatter -> LDouble.t -> unit val format_complexld : formatter -> ComplexL.t -> unit yallop-ocaml-ctypes-3f8211a/src/ctypes-top/dune000066400000000000000000000002121445631112600215110ustar00rootroot00000000000000;; see https://github.com/ocaml/dune/issues/688 (library (name ctypes_top) (public_name ctypes.top) (libraries ctypes compiler-libs)) yallop-ocaml-ctypes-3f8211a/src/ctypes-top/install_ctypes_printers.ml000066400000000000000000000043201445631112600261540ustar00rootroot00000000000000(* Adapted from Anil Madhavapeddy's ocaml-uri package. *) let printers = [ "Ctypes_printers.format_typ"; "Ctypes_printers.format_fn"; "Ctypes_printers.format_sint"; "Ctypes_printers.format_long"; "Ctypes_printers.format_llong"; "Ctypes_printers.format_uchar"; "Ctypes_printers.format_uint8"; "Ctypes_printers.format_uint16"; "Ctypes_printers.format_uint32"; "Ctypes_printers.format_uint64"; "Ctypes_printers.format_size_t"; "Ctypes_printers.format_ushort"; "Ctypes_printers.format_uint"; "Ctypes_printers.format_ulong"; "Ctypes_printers.format_ullong"; "Ctypes_printers.format_pointer"; "Ctypes_printers.format_struct"; "Ctypes_printers.format_union"; "Ctypes_printers.format_array"; "Ctypes_printers.format_ocaml"; "Ctypes_printers.format_clock_t"; "Ctypes_printers.format_dev_t"; "Ctypes_printers.format_ino_t"; "Ctypes_printers.format_mode_t"; "Ctypes_printers.format_nlink_t"; "Ctypes_printers.format_off_t"; "Ctypes_printers.format_pid_t"; "Ctypes_printers.format_size_t"; "Ctypes_printers.format_ssize_t"; "Ctypes_printers.format_time_t"; "Ctypes_printers.format_useconds_t"; "Ctypes_printers.format_ldouble"; "Ctypes_printers.format_complexld";] let eval_string ?(print_outcome = false) ?(err_formatter = Format.err_formatter) str = let lexbuf = Lexing.from_string str in let phrase = !Toploop.parse_toplevel_phrase lexbuf in Toploop.execute_phrase print_outcome err_formatter phrase let rec install_printers = function | [] -> true | printer :: printers -> let cmd = Printf.sprintf "#install_printer %s;;" printer in eval_string cmd && install_printers printers let () = if not (install_printers printers) then Format.eprintf "Problem installing ctypes-printers@." yallop-ocaml-ctypes-3f8211a/src/ctypes/000077500000000000000000000000001445631112600200405ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/src/ctypes/complexL.ml000066400000000000000000000030531445631112600221560ustar00rootroot00000000000000type t external make : LDouble.t -> LDouble.t -> t = "ctypes_ldouble_complex_make" external re : t -> LDouble.t = "ctypes_ldouble_complex_real" external im : t -> LDouble.t = "ctypes_ldouble_complex_imag" let of_complex x = make (LDouble.of_float x.Complex.re) (LDouble.of_float x.Complex.im) let to_complex x = { Complex.re = LDouble.to_float (re x); im = LDouble.to_float (im x) } let norm2 x = let r, i = re x, im x in LDouble.(add (mul r r) (mul i i)) let norm x = let open LDouble in let r = abs (re x) and i = abs (im x) in if r = zero then i else if i = zero then r else if r >= i then let q = div i r in mul r (sqrt (add one (mul q q))) else let q = div r i in mul i (sqrt (add one (mul q q))) let polar n a = make LDouble.(mul (cos a) n) LDouble.(mul (sin a) n) let zero = make LDouble.zero LDouble.zero let one = make LDouble.one LDouble.zero let i = make LDouble.zero LDouble.one external neg : t -> t = "ctypes_ldouble_complex_neg" external conj : t -> t = "ctypes_ldouble_complex_conjl" external add : t -> t -> t = "ctypes_ldouble_complex_add" external sub : t -> t -> t = "ctypes_ldouble_complex_sub" external mul : t -> t -> t = "ctypes_ldouble_complex_mul" external div : t -> t -> t = "ctypes_ldouble_complex_div" let inv x = div one x external sqrt : t -> t = "ctypes_ldouble_complex_csqrtl" external arg : t -> LDouble.t = "ctypes_ldouble_complex_cargl" external exp : t -> t = "ctypes_ldouble_complex_cexpl" external log : t -> t = "ctypes_ldouble_complex_clogl" external pow : t -> t -> t = "ctypes_ldouble_complex_cpowl" yallop-ocaml-ctypes-3f8211a/src/ctypes/complexL.mli000066400000000000000000000034341445631112600223320ustar00rootroot00000000000000type t (** The type of long double complex values *) val make : LDouble.t -> LDouble.t -> t (** [make x y] creates the long double complex value [x + y * i] *) val of_complex : Complex.t -> t (** create a long double complex from a Complex.t *) val to_complex : t -> Complex.t (** Convert a long double complex to a Complex.t. The real and imaginary components are converted by calling [LDouble.to_float] which can produce unspecified results. *) val zero : t (** [0 + i0] *) val one : t (** [1 + i0] *) val i : t (** [0 + i] *) val re : t -> LDouble.t (** return the real part of the long double complex *) val im : t -> LDouble.t (** return the imaginary part of the long double complex *) val neg : t -> t (** Unary negation *) val conj : t -> t (** Conjugate: given the complex [x + i.y], returns [x - i.y]. *) val add : t -> t -> t (** Addition *) val sub : t -> t -> t (** Subtraction *) val mul : t -> t -> t (** Multiplication *) val div : t -> t -> t (** Division *) val inv : t -> t (** Multiplicative inverse ([1/z]). *) val sqrt : t -> t (** Square root. *) val norm2 : t -> LDouble.t (** Norm squared: given [x + i.y], returns [x^2 + y^2]. *) val norm : t -> LDouble.t (** Norm: given [x + i.y], returns [sqrt(x^2 + y^2)]. *) val polar : LDouble.t -> LDouble.t -> t (** [polar norm arg] returns the complex having norm [norm] and argument [arg]. *) val arg : t -> LDouble.t (** Argument. The argument of a complex number is the angle in the complex plane between the positive real axis and a line passing through zero and the number. *) val exp : t -> t (** Exponentiation. [exp z] returns [e] to the [z] power. *) val log : t -> t (** Natural logarithm (in base [e]). *) val pow : t -> t -> t (** Power function. [pow z1 z2] returns [z1] to the [z2] power. *) yallop-ocaml-ctypes-3f8211a/src/ctypes/complex_stubs.c000066400000000000000000000023561445631112600231010ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #include #include #include "ctypes_complex_compatibility.h" #include "ctypes_complex_stubs.h" static value allocate_complex_value(double r, double i) { value v = caml_alloc(2 * Double_wosize, Double_array_tag); Store_double_field(v, 0, r); Store_double_field(v, 1, i); return v; } /* ctypes_copy_float_complex : float _Complex -> Complex.t */ value ctypes_copy_float_complex(float _Complex c) { return allocate_complex_value(ctypes_compat_crealf(c), ctypes_compat_cimagf(c)); } /* ctypes_copy_double_complex : double _Complex -> Complex.t */ value ctypes_copy_double_complex(double _Complex c) { return allocate_complex_value(ctypes_compat_creal(c), ctypes_compat_cimag(c)); } /* ctypes_float_complex_val : Complex.t -> float _Complex */ float _Complex ctypes_float_complex_val(value v) { return ctypes_compat_make_complexf(Double_field(v, 0), Double_field(v, 1)); } /* ctypes_double_complex_val : Complex.t -> double _Complex */ double _Complex ctypes_double_complex_val(value v) { return ctypes_compat_make_complex(Double_field(v, 0), Double_field(v, 1)); } yallop-ocaml-ctypes-3f8211a/src/ctypes/cstubs_internals.h000066400000000000000000000006111445631112600235710ustar00rootroot00000000000000/* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef CSTUBS_INTERNALS_H #define CSTUBS_INTERNALS_H /* This is just here for backwards compatibility and will eventually be removed. */ /* Include the real header. */ #include "ctypes_cstubs_internals.h" #endif /* CSTUBS_INTERNALS_H */ yallop-ocaml-ctypes-3f8211a/src/ctypes/cstubs_internals.ml000066400000000000000000000077541445631112600237710ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Types and functions used by generated ML code. This is an internal interface and subject to change. *) type voidp = Ctypes_ptr.voidp type managed_buffer = Ctypes_memory_stubs.managed_buffer type ('m, 'a) fatptr = ('m, 'a Ctypes.typ) Ctypes_ptr.Fat.t type ('m, 'a) fatfunptr = ('m, 'a Ctypes.fn) Ctypes_ptr.Fat.t let make_structured reftyp buf = let open Ctypes_static in let raw_ptr = Ctypes_memory_stubs.block_address buf in { structured = CPointer (Ctypes_ptr.Fat.make ~managed:(Some (Obj.repr buf)) ~reftyp raw_ptr) } include Ctypes_static include Ctypes_primitive_types let make_ptr reftyp raw_ptr = CPointer (Ctypes_ptr.Fat.make ~managed:None ~reftyp raw_ptr) let make_fun_ptr reftyp raw_ptr = Static_funptr (Ctypes_ptr.Fat.make ~managed:None ~reftyp raw_ptr) let mkView : type a b. string -> a typ -> typedef:bool -> unexpected:(a -> b) -> (b * a) list -> b typ = fun name typ ~typedef ~unexpected alist -> let typedef = if typedef then "" else "enum " in let rlist = List.map (fun (l, r) -> (r, l)) alist in let write k = List.assoc k alist and read k = try List.assoc k rlist with Not_found -> unexpected k and format_typ k fmt = Format.fprintf fmt "%s%s%t" typedef name k in view typ ~format_typ ~read ~write let map_assocv f = List.map (fun (k, v) -> (k, f v)) let int8_of_int64 = Int64.to_int let int64_of_int8 = Int64.of_int let int16_of_int64 = Int64.to_int let int64_of_int16 = Int64.of_int let int32_of_int64 = Int64.to_int32 let int64_of_int32 = Int64.of_int32 let int64_of_int64 x = x (* For now we use conversion via strings: there's certainly room for improvement. The conversion from int64_t to uint8_t isn't safe in general, of course, so we don't have it available. However, we can be confident that conversion will work in this particular case, since we know that the underlying type is actually uint8_t, so the value can certainly be represented. In mitigation, these conversions are performed once during "startup", not each time we read and write enum values. *) let uint8_of_int64 x = Unsigned.UInt8.of_string (Int64.to_string x) let int64_of_uint8 x = Int64.of_int (Unsigned.UInt8.to_int x) let uint16_of_int64 x = Unsigned.UInt16.of_string (Int64.to_string x) let int64_of_uint16 x = Int64.of_int (Unsigned.UInt16.to_int x) let uint32_of_int64 x = Unsigned.UInt32.of_string (Int64.to_string x) let int64_of_uint32 x = Int64.of_string (Unsigned.UInt32.to_string x) let uint64_of_int64 = Unsigned.UInt64.of_int64 let int64_of_uint64 = Unsigned.UInt64.to_int64 let build_enum_type name underlying ?(typedef=false) ?unexpected alist = let build_view t coerce uncoerce = let unexpected = match unexpected with Some u -> fun x -> u (uncoerce x) | None -> fun x -> Printf.ksprintf failwith "Unexpected enum value for %s: %Ld" name (uncoerce x) in mkView name t ~typedef ~unexpected (map_assocv coerce alist) in match underlying with Ctypes_static.Int8 -> build_view Ctypes.int8_t int8_of_int64 int64_of_int8 | Ctypes_static.Int16 -> build_view Ctypes.int16_t int16_of_int64 int64_of_int16 | Ctypes_static.Int32 -> build_view Ctypes.int32_t int32_of_int64 int64_of_int32 | Ctypes_static.Int64 -> build_view Ctypes.int64_t int64_of_int64 int64_of_int64 | Ctypes_static.Uint8 -> build_view Ctypes.uint8_t uint8_of_int64 int64_of_uint8 | Ctypes_static.Uint16 -> build_view Ctypes.uint16_t uint16_of_int64 int64_of_uint16 | Ctypes_static.Uint32 -> build_view Ctypes.uint32_t uint32_of_int64 int64_of_uint32 | Ctypes_static.Uint64 -> build_view Ctypes.uint64_t uint64_of_int64 int64_of_uint64 | Ctypes_static.Float | Ctypes_static.Double -> Printf.ksprintf failwith "Enum type detected as floating type: %s" name let use_value v = Ctypes_memory_stubs.use_value v yallop-ocaml-ctypes-3f8211a/src/ctypes/cstubs_internals.mli000066400000000000000000000063651445631112600241370ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Types and functions used by generated ML code. This is an internal interface and subject to change. *) open Ctypes open Signed open Unsigned type voidp = Ctypes_ptr.voidp type managed_buffer = Ctypes_memory_stubs.managed_buffer type ('m, 'a) fatptr = ('m, 'a typ) Ctypes_ptr.Fat.t type ('m, 'a) fatfunptr = ('m, 'a fn) Ctypes_ptr.Fat.t val make_structured : ('a, 's) structured typ -> managed_buffer -> ('a, 's) structured val make_ptr : 'a typ -> voidp -> 'a ptr val make_fun_ptr : 'a fn -> voidp -> 'a Ctypes_static.static_funptr type 'a ocaml_type = 'a Ctypes_static.ocaml_type = String : string ocaml_type | Bytes : bytes ocaml_type | FloatArray : float array ocaml_type type 'a typ = 'a Ctypes_static.typ = Void : unit typ | Primitive : 'a Ctypes_primitive_types.prim -> 'a typ | Pointer : 'a typ -> 'a ptr typ | Funptr : 'a fn -> 'a static_funptr typ | Struct : 'a Ctypes_static.structure_type -> 'a Ctypes_static.structure typ | Union : 'a Ctypes_static.union_type -> 'a Ctypes_static.union typ | Abstract : Ctypes_static.abstract_type -> 'a Ctypes_static.abstract typ | View : ('a, 'b) view -> 'a typ | Array : 'a typ * int -> 'a Ctypes_static.carray typ | Bigarray : (_, 'a, _) Ctypes_bigarray.t -> 'a typ | OCaml : 'a ocaml_type -> 'a ocaml typ and ('a, 'b) pointer = ('a, 'b) Ctypes_static.pointer = CPointer : (Obj.t option,'a typ) Ctypes_ptr.Fat.t -> ('a, [`C]) pointer | OCamlRef : int * 'a * 'a ocaml_type -> ('a, [`OCaml]) pointer and 'a ptr = ('a, [`C]) pointer and 'a ocaml = ('a, [`OCaml]) pointer and 'a static_funptr = 'a Ctypes_static.static_funptr = Static_funptr : (Obj.t option, 'a fn) Ctypes_ptr.Fat.t -> 'a static_funptr and ('a, 'b) view = ('a, 'b) Ctypes_static.view = { read : 'b -> 'a; write : 'a -> 'b; format_typ: ((Format.formatter -> unit) -> Format.formatter -> unit) option; format: (Format.formatter -> 'a -> unit) option; ty: 'b typ; } type 'a fn = 'a Ctypes_static.fn = | Returns : 'a typ -> 'a fn | Function : 'a typ * 'b fn -> ('a -> 'b) fn type 'a prim = 'a Ctypes_primitive_types.prim = Char : char prim | Schar : int prim | Uchar : uchar prim | Bool : bool prim | Short : int prim | Int : int prim | Long : long prim | Llong : llong prim | Ushort : ushort prim | Sint : sint prim | Uint : uint prim | Ulong : ulong prim | Ullong : ullong prim | Size_t : size_t prim | Int8_t : int prim | Int16_t : int prim | Int32_t : int32 prim | Int64_t : int64 prim | Uint8_t : uint8 prim | Uint16_t : uint16 prim | Uint32_t : uint32 prim | Uint64_t : uint64 prim | Camlint : int prim | Nativeint : nativeint prim | Float : float prim | Double : float prim | LDouble : LDouble.t prim | Complex32 : Complex.t prim | Complex64 : Complex.t prim | Complexld : ComplexL.t prim val build_enum_type : string -> Ctypes_static.arithmetic -> ?typedef:bool -> ?unexpected:(int64 -> 'a) -> ('a * int64) list -> 'a typ val use_value : 'a -> unit yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes.ml000066400000000000000000000015431445631112600217040ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) include Ctypes_static include Ctypes_structs_computed include Ctypes_type_printing include Ctypes_memory include Ctypes_std_views include Ctypes_value_printing include Ctypes_coerce let lift_typ x = x module type FOREIGN = sig type 'a fn type 'a return val (@->) : 'a typ -> 'b fn -> ('a -> 'b) fn val returning : 'a typ -> 'a return fn type 'a result val foreign : string -> ('a -> 'b) fn -> ('a -> 'b) result val foreign_value : string -> 'a typ -> 'a ptr result end module type TYPE = sig include Ctypes_types.TYPE type 'a const val constant : string -> 'a typ -> 'a const val enum : string -> ?typedef:bool -> ?unexpected:(int64 -> 'a) -> ('a * int64 const) list -> 'a typ end yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes.mli000066400000000000000000000561411445631112600220610ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** The core ctypes module. The main points of interest are the set of functions for describing C types (see {!types}) and the set of functions for accessing C values (see {!values}). The {!Foreign.foreign} function uses C type descriptions to bind external C values. *) (** {4:pointer_types Pointer types} *) type ('a, 'b) pointer = ('a, 'b) Ctypes_static.pointer (** The type of pointer values. A value of type [('a, [`C]) pointer] contains a C-compatible pointer, and a value of type [('a, [`OCaml]) pointer] contains a pointer to a value that can be moved by OCaml runtime. *) (** {4 C-compatible pointers} *) type 'a ptr = ('a, [`C]) pointer (** The type of C-compatible pointer values. A value of type [t ptr] can be used to read and write values of type [t] at particular addresses. *) type 'a ocaml = 'a Ctypes_static.ocaml (** The type of pointer values pointing directly into OCaml values. {b Pointers of this type should never be captured by external code}. In particular, functions accepting ['a ocaml] pointers must not invoke any OCaml code. *) (** {4 C array types} *) type 'a carray = 'a Ctypes_static.carray (** The type of C array values. A value of type [t carray] can be used to read and write array objects in C-managed storage. *) (** {4 Bigarray types} *) type 'a bigarray_class = 'a Ctypes_static.bigarray_class (** The type of Bigarray classes. There are four instances, one for each of the Bigarray submodules. *) val genarray : < element: 'a; layout: 'l; ba_repr: 'b; bigarray: ('a, 'b, 'l) Bigarray_compat.Genarray.t; carray: 'a carray; dims: int array > bigarray_class (** The class of {!Bigarray.Genarray.t} values *) val array1 : < element: 'a; layout: 'l; ba_repr: 'b; bigarray: ('a, 'b, 'l) Bigarray_compat.Array1.t; carray: 'a carray; dims: int > bigarray_class (** The class of {!Bigarray.Array1.t} values *) val array2 : < element: 'a; layout: 'l; ba_repr: 'b; bigarray: ('a, 'b, 'l) Bigarray_compat.Array2.t; carray: 'a carray carray; dims: int * int > bigarray_class (** The class of {!Bigarray.Array2.t} values *) val array3 : < element: 'a; layout: 'l; ba_repr: 'b; bigarray: ('a, 'b, 'l) Bigarray_compat.Array3.t; carray: 'a carray carray carray; dims: int * int * int > bigarray_class (** The class of {!Bigarray.Array3.t} values *) (** {3 Struct and union types} *) type ('a, 'kind) structured = ('a, 'kind) Ctypes_static.structured (** The base type of values representing C struct and union types. The ['kind] parameter is a polymorphic variant type indicating whether the type represents a struct ([`Struct]) or a union ([`Union]). *) type 'a structure = ('a, [`Struct]) structured (** The type of values representing C struct types. *) type 'a union = ('a, [`Union]) structured (** The type of values representing C union types. *) type ('a, 't) field = ('a, 't) Ctypes_static.field (** The type of values representing C struct or union members (called "fields" here). A value of type [(a, s) field] represents a field of type [a] in a struct or union of type [s]. *) type 'a abstract = 'a Ctypes_static.abstract (** The type of abstract values. The purpose of the [abstract] type is to represent values whose type varies from platform to platform. For example, the type [pthread_t] is a pointer on some platforms, an integer on other platforms, and a struct on a third set of platforms. One way to deal with this kind of situation is to have possibly-platform-specific code which interrogates the C type in some way to help determine an appropriate representation. Another way is to use [abstract], leaving the representation opaque. (Note, however, that although [pthread_t] is a convenient example, since the type used to implement it varies significantly across platforms, it's not actually a good match for [abstract], since values of type [pthread_t] are passed and returned by value.) *) include Ctypes_types.TYPE with type 'a typ = 'a Ctypes_static.typ and type ('a, 's) field := ('a, 's) field (** {3 Operations on types} *) val sizeof : 'a typ -> int (** [sizeof t] computes the size in bytes of the type [t]. The exception {!IncompleteType} is raised if [t] is incomplete. *) val alignment : 'a typ -> int (** [alignment t] computes the alignment requirements of the type [t]. The exception {!IncompleteType} is raised if [t] is incomplete. *) val format_typ : ?name:string -> Format.formatter -> 'a typ -> unit (** Pretty-print a C representation of the type to the specified formatter. *) val format_fn : ?name:string -> Format.formatter -> 'a fn -> unit (** Pretty-print a C representation of the function type to the specified formatter. *) val string_of_typ : ?name:string -> 'a typ -> string (** Return a C representation of the type. *) val string_of_fn : ?name:string -> 'a fn -> string (** Return a C representation of the function type. *) (** {2:values Values representing C values} *) val format : 'a typ -> Format.formatter -> 'a -> unit (** Pretty-print a representation of the C value to the specified formatter. *) val string_of : 'a typ -> 'a -> string (** Return a string representation of the C value. *) (** {3 Pointer values} *) val null : unit ptr (** A null pointer. *) val (!@) : 'a ptr -> 'a (** [!@ p] dereferences the pointer [p]. If the reference type is a scalar type then dereferencing constructs a new value. If the reference type is an aggregate type then dereferencing returns a value that references the memory pointed to by [p]. *) val (<-@) : 'a ptr -> 'a -> unit (** [p <-@ v] writes the value [v] to the address [p]. *) val (+@) : ('a, 'b) pointer -> int -> ('a, 'b) pointer (** If [p] is a pointer to an array element then [p +@ n] computes the address of the [n]th next element. *) val (-@) : ('a, 'b) pointer -> int -> ('a, 'b) pointer (** If [p] is a pointer to an array element then [p -@ n] computes the address of the nth previous element. *) val ptr_diff : ('a, 'b) pointer -> ('a, 'b) pointer -> int (** [ptr_diff p q] computes [q - p]. As in C, both [p] and [q] must point into the same array, and the result value is the difference of the subscripts of the two array elements. *) val from_voidp : 'a typ -> unit ptr -> 'a ptr (** Conversion from [void *]. *) val to_voidp : _ ptr -> unit ptr (** Conversion to [void *]. *) val allocate : ?finalise:('a ptr -> unit) -> 'a typ -> 'a -> 'a ptr (** [allocate t v] allocates a fresh value of type [t], initialises it with [v] and returns its address. The argument [?finalise], if present, will be called just before the memory is freed. The value will be automatically freed after no references to the pointer remain within the calling OCaml program. *) val allocate_n : ?finalise:('a ptr -> unit) -> 'a typ -> count:int -> 'a ptr (** [allocate_n t ~count:n] allocates a fresh array with element type [t] and length [n], and returns its address. The argument [?finalise], if present, will be called just before the memory is freed. The array will be automatically freed after no references to the pointer remain within the calling OCaml program. The memory is allocated with libc's [calloc] and is guaranteed to be zero-filled. *) val ptr_compare : 'a ptr -> 'a ptr -> int (** If [p] and [q] are pointers to elements [i] and [j] of the same array then [ptr_compare p q] compares the indexes of the elements. The result is negative if [i] is less than [j], positive if [i] is greater than [j], and zero if [i] and [j] are equal. *) val is_null : 'a ptr -> bool (** [is_null p] is true when [p] is a null pointer. *) val reference_type : 'a ptr -> 'a typ (** Retrieve the reference type of a pointer. *) val ptr_of_raw_address : nativeint -> unit ptr (** Convert the numeric representation of an address to a pointer *) val funptr_of_raw_address : nativeint -> (unit -> unit) Ctypes_static.static_funptr (** Convert the numeric representation of an address to a function pointer *) val raw_address_of_ptr : unit ptr -> nativeint (** [raw_address_of_ptr p] returns the numeric representation of p. Note that the return value remains valid only as long as the pointed-to object is alive. If [p] is a managed object (e.g. a value returned by {!make}) then unless the caller retains a reference to [p], the object may be collected, invalidating the returned address. *) val string_from_ptr : char ptr -> length:int -> string (** [string_from_ptr p ~length] creates a string initialized with the [length] characters at address [p]. Raise [Invalid_argument "Ctypes.string_from_ptr"] if [length] is negative. *) val ocaml_string_start : string -> string ocaml (** [ocaml_string_start s] allows to pass a pointer to the contents of an OCaml string directly to a C function. *) val ocaml_bytes_start : bytes -> bytes ocaml (** [ocaml_bytes_start s] allows to pass a pointer to the contents of an OCaml byte array directly to a C function. *) (** {3 Array values} *) (** {4 C array values} *) module CArray : sig type 'a t = 'a carray val get : 'a t -> int -> 'a (** [get a n] returns the [n]th element of the zero-indexed array [a]. The semantics for non-scalar types are non-copying, as for {!(!@)}. If you rebind the [CArray] module to [Array] then you can also use the syntax [a.(n)] instead of [Array.get a n]. Raise [Invalid_argument "index out of bounds"] if [n] is outside of the range [0] to [(CArray.length a - 1)]. *) val set : 'a t -> int -> 'a -> unit (** [set a n v] overwrites the [n]th element of the zero-indexed array [a] with [v]. If you rebind the [CArray] module to [Array] then you can also use the [a.(n) <- v] syntax instead of [Array.set a n v]. Raise [Invalid_argument "index out of bounds"] if [n] is outside of the range [0] to [(CArray.length a - 1)]. *) val unsafe_get : 'a t -> int -> 'a (** [unsafe_get a n] behaves like [get a n] except that the check that [n] between [0] and [(CArray.length a - 1)] is not performed. *) val unsafe_set : 'a t -> int -> 'a -> unit (** [unsafe_set a n v] behaves like [set a n v] except that the check that [n] between [0] and [(CArray.length a - 1)] is not performed. *) val of_string : string -> char t (** [of_string s] builds an array of the same length as [s] plus one, and writes the elements of [s] to the corresponding elements of the array with the null character '\0' as a last element. *) val of_list : 'a typ -> 'a list -> 'a t (** [of_list t l] builds an array of type [t] of the same length as [l], and writes the elements of [l] to the corresponding elements of the array. *) val to_list : 'a t -> 'a list (** [to_list a] builds a list of the same length as [a] such that each element of the list is the result of reading the corresponding element of [a]. *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f a] is analogous to [Array.iter f a]: it applies [f] in turn to all the elements of [a]. *) val map : 'b typ -> ('a -> 'b) -> 'a t -> 'b t (** [map t f a] is analogous to [Array.map f a]: it creates a new array with element type [t] whose elements are obtained by applying [f] to the elements of [a]. *) val mapi : 'b typ -> (int -> 'a -> 'b) -> 'a t -> 'b t (** [mapi] behaves like {!Array.mapi}, except that it also passes the index of each element as the first argument to [f] and the element itself as the second argument. *) val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a (** [CArray.fold_left (@) x a] computes [(((x @ a.(0)) @ a.(1)) ...) @ a.(n-1)] where [n] is the length of the array [a]. *) val fold_right : ('b -> 'a -> 'a) -> 'b t -> 'a -> 'a (** [CArray.fold_right f a x] computes [a.(0) @ (a.(1) @ ( ... (a.(n-1) @ x) ...))] where [n] is the length of the array [a]. *) val length : 'a t -> int (** Return the number of elements of the given array. *) val start : 'a t -> 'a ptr (** Return the address of the first element of the given array. *) val from_ptr : 'a ptr -> int -> 'a t (** [from_ptr p n] creates an [n]-length array reference to the memory at address [p]. *) val make : ?finalise:('a t -> unit) -> 'a typ -> ?initial:'a -> int -> 'a t (** [make t n] creates an [n]-length array of type [t]. If the optional argument [?initial] is supplied, it indicates a value that should be used to initialise every element of the array. The argument [?finalise], if present, will be called just before the memory is freed. *) val copy : 'a t -> 'a t (** [copy a] creates a fresh array with the same elements as [a]. *) val sub : 'a t -> pos:int -> length:int -> 'a t (** [sub a ~pos ~length] creates a fresh array of length [length] containing the elements [a.(pos)] to [a.(pos + length - 1)] of [a]. Raise [Invalid_argument "CArray.sub"] if [pos] and [length] do not designate a valid subarray of [a]. *) val element_type : 'a t -> 'a typ (** Retrieve the element type of an array. *) end (** Operations on C arrays. *) (** {4 Bigarray values} *) val bigarray_start : < element: 'a; layout: 'l; ba_repr: _; bigarray: 'b; carray: _; dims: _ > bigarray_class -> 'b -> 'a ptr (** Return the address of the first element of the given Bigarray value. *) val bigarray_of_ptr : < element: 'a; layout: Bigarray_compat.c_layout; ba_repr: 'f; bigarray: 'b; carray: _; dims: 'i > bigarray_class -> 'i -> ('a, 'f) Bigarray_compat.kind -> 'a ptr -> 'b (** [bigarray_of_ptr c dims k p] converts the C pointer [p] to a C-layout bigarray value. No copy is made; the bigarray references the memory pointed to by [p]. *) val fortran_bigarray_of_ptr : < element: 'a; layout: Bigarray_compat.fortran_layout; ba_repr: 'f; bigarray: 'b; carray: _; dims: 'i > bigarray_class -> 'i -> ('a, 'f) Bigarray_compat.kind -> 'a ptr -> 'b (** [fortran_bigarray_of_ptr c dims k p] converts the C pointer [p] to a Fortran-layout bigarray value. No copy is made; the bigarray references the memory pointed to by [p]. *) val array_of_bigarray : < element: _; layout: Bigarray_compat.c_layout; ba_repr: _; bigarray: 'b; carray: 'c; dims: _ > bigarray_class -> 'b -> 'c (** [array_of_bigarray c b] converts the bigarray value [b] to a value of type {!CArray.t}. No copy is made; the result occupies the same memory as [b]. *) (** Convert a Bigarray value to a C array. *) val bigarray_of_array : < element: 'a; layout: Bigarray_compat.c_layout; ba_repr: 'f; bigarray: 'b; carray: 'c carray; dims: 'i > bigarray_class -> ('a, 'f) Bigarray_compat.kind -> 'c carray -> 'b (** [bigarray_of_array c k a] converts the {!CArray.t} value [a] to a C-layout bigarray value. No copy is made; the result occupies the same memory as [a]. *) (** {3 Struct and union values} *) val make : ?finalise:('s -> unit) -> ((_, _) structured as 's) typ -> 's (** Allocate a fresh, uninitialised structure or union value. The argument [?finalise], if present, will be called just before the underlying memory is freed. *) val setf : ((_, _) structured as 's) -> ('a, 's) field -> 'a -> unit (** [setf s f v] overwrites the value of the field [f] in the structure or union [s] with [v]. *) val getf : ((_, _) structured as 's) -> ('a, 's) field -> 'a (** [getf s f] retrieves the value of the field [f] in the structure or union [s]. The semantics for non-scalar types are non-copying, as for {!(!@)}.*) val (@.) : ((_, _) structured as 's) -> ('a, 's) field -> 'a ptr (** [s @. f] computes the address of the field [f] in the structure or union value [s]. *) val (|->) : ((_, _) structured as 's) ptr -> ('a, 's) field -> 'a ptr (** [p |-> f] computes the address of the field [f] in the structure or union value pointed to by [p]. *) val offsetof : (_, _ structure) field -> int (** [offsetof f] returns the offset, in bytes, of the field [f] from the beginning of the associated struct type. *) val field_type : ('a, _) field -> 'a typ (** [field_type f] returns the type of the field [f]. *) val field_name : (_, _) field -> string (** [field_name f] returns the name of the field [f]. *) val addr : ((_, _) structured as 's) -> 's ptr (** [addr s] returns the address of the structure or union [s]. *) (** {3 Coercions} *) val coerce : 'a typ -> 'b typ -> 'a -> 'b (** [coerce t1 t2] returns a coercion function between the types represented by [t1] and [t2]. If [t1] cannot be coerced to [t2], [coerce] raises {!Uncoercible}. The following coercions are currently supported: - All function and object pointer types are intercoercible. - Any type may be coerced to {!void} - There is a coercion between a {!view} and another type [t] (in either direction) if there is a coercion between the representation type underlying the view and [t]. - Coercion is transitive: if [t1] is coercible to [t2] and [t2] is coercible to [t3], then [t1] is directly coercible to [t3]. The set of supported coercions is subject to change. Future versions of ctypes may both add new types of coercion and restrict the existing coercions. *) val coerce_fn : 'a fn -> 'b fn -> 'a -> 'b (** [coerce_fn f1 f2] returns a coercion function between the function types represented by [f1] and [f2]. If [f1] cannot be coerced to [f2], [coerce_fn] raises {!Uncoercible}. A function type [f1] may be coerced to another function type [f2] if all of the following hold: - the C types described by [f1] and [f2] have the same arity - each argument of [f2] may be coerced to the corresponding argument of [f1] - the return type of [f1] may be coerced to the return type of [f2] The set of supported coercions is subject to change. Future versions of ctypes may both add new types of coercion and restrict the existing coercions. *) (** {2 binding interfaces} Foreign function binding interface. The {!Foreign} and {!Cstubs} modules provide concrete implementations. *) module type FOREIGN = sig type 'a fn type 'a return val (@->) : 'a typ -> 'b fn -> ('a -> 'b) fn val returning : 'a typ -> 'a return fn type 'a result val foreign : string -> ('a -> 'b) fn -> ('a -> 'b) result val foreign_value : string -> 'a typ -> 'a ptr result end (** Foreign types binding interface. The {!Cstubs} module builds concrete implementations. *) module type TYPE = sig include Ctypes_types.TYPE type 'a const val constant : string -> 'a typ -> 'a const (** [constant name typ] retrieves the value of the compile-time constant [name] of type [typ]. It can be used to retrieve enum constants, #defined values and other integer constant expressions. The type [typ] must be either an integer type such as [bool], [char], [int], [uint8], etc., or a view (or perhaps multiple views) where the underlying type is an integer type. When the value of the constant cannot be represented in the type there will typically be a diagnostic from either the C compiler or the OCaml compiler. For example, gcc will say warning: overflow in implicit constant conversion *) val enum : string -> ?typedef:bool -> ?unexpected:(int64 -> 'a) -> ('a * int64 const) list -> 'a typ (** [enum name ?unexpected alist] builds a type representation for the enum named [name]. The size and alignment are retrieved so that the resulting type can be used everywhere an integer type can be used: as an array element or struct member, as an argument or return value, etc. The value [alist] is an association list of OCaml values and values retrieved by the [constant] function. For example, to expose the enum enum letters \{ A, B, C = 10, D \}; you might first retrieve the values of the enumeration constants: {[ let a = constant "A" int64_t and b = constant "B" int64_t and c = constant "C" int64_t and d = constant "D" int64_t ]} and then build the enumeration type {[ let letters = enum "letters" [ `A, a; `B, b; `C, c; `D, d; ] ~unexpected:(fun i -> `E i) ]} The [unexpected] function specifies the value to return in the case that some unexpected value is encountered -- for example, if a function with the return type 'enum letters' actually returns the value [-1]. The optional flag [typedef] specifies whether the first argument, [name], indicates an tag or an alias. If [typedef] is [false] (the default) then [name] is treated as an enumeration tag: [enum letters { ... }] If [typedef] is [true] then [name] is instead treated as an alias: [typedef enum { ... } letters] *) end (** {2:roots Registration of OCaml values as roots} *) module Root : sig val create : 'a -> unit ptr (** [create v] allocates storage for the address of the OCaml value [v], registers the storage as a root, and returns its address. *) val get : unit ptr -> 'a (** [get p] retrieves the OCaml value whose address is stored at [p]. *) val set : unit ptr -> 'a -> unit (** [set p v] updates the OCaml value stored as a root at [p]. *) val release : unit ptr -> unit (** [release p] unregsiters the root [p]. *) end (** {2 Exceptions} *) exception Unsupported of string (** An attempt was made to use a feature not currently supported by ctypes. In practice this refers to attempts to use an union, array or abstract type as an argument or return type of a function. *) exception ModifyingSealedType of string (** An attempt was made to modify a sealed struct or union type description. *) exception IncompleteType (** An attempt was made to compute the size or alignment of an incomplete type. The incomplete types are struct and union types that have not been sealed, and the void type. It is not permitted to compute the size or alignment requirements of an incomplete type, to use it as a struct or union member, to read or write a value of the type through a pointer or to use it as the referenced type in pointer arithmetic. Additionally, incomplete struct and union types cannot be used as argument or return types. *) type uncoercible_info exception Uncoercible of uncoercible_info (** An attempt was made to coerce between uncoercible types. *) yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_bigarray.ml000066400000000000000000000106071445631112600235650ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes_bigarray_stubs let prim_of_kind : type a. a kind -> a Ctypes_primitive_types.prim = let open Ctypes_primitive_types in function Kind_float32 -> Float | Kind_float64 -> Double | Kind_int8_signed -> Int8_t | Kind_int8_unsigned -> Int8_t | Kind_int16_signed -> Int16_t | Kind_int16_unsigned -> Int16_t | Kind_int32 -> Int32_t | Kind_int64 -> Int64_t | Kind_int -> Camlint | Kind_nativeint -> Nativeint | Kind_complex32 -> Complex32 | Kind_complex64 -> Complex64 | Kind_char -> Char let bigarray_kind_sizeof k = Ctypes_primitives.sizeof (prim_of_kind k) let bigarray_kind_alignment k = Ctypes_primitives.alignment (prim_of_kind k) type (_, _, _) dims = | DimsGen : int array -> ('a, ('a, _, 'l) Bigarray_compat.Genarray.t, 'l) dims | Dims1 : int -> ('a, ('a, _, 'l) Bigarray_compat.Array1.t, 'l) dims | Dims2 : int * int -> ('a, ('a, _, 'l) Bigarray_compat.Array2.t, 'l) dims | Dims3 : int * int * int -> ('a, ('a, _, 'l) Bigarray_compat.Array3.t, 'l) dims type ('a, 'b, 'l) t = ('a, 'b, 'l) dims * 'a kind * 'l Bigarray_compat.layout let elements : type a b l. (b, a, l) dims -> int = function | DimsGen ds -> Array.fold_left ( * ) 1 ds | Dims1 d -> d | Dims2 (d1, d2) -> d1 * d2 | Dims3 (d1, d2, d3) -> d1 * d2 * d3 let element_type (_, k, _) = prim_of_kind k let dimensions : type a b l. (b, a, l) t -> int array = function | DimsGen dims, _, _ -> dims | Dims1 x, _, _ -> [| x |] | Dims2 (x, y), _, _ -> [| x; y |] | Dims3 (x, y, z), _, _ -> [| x; y; z |] let sizeof (d, k, _) = elements d * bigarray_kind_sizeof k let alignment (_, k, _) = bigarray_kind_alignment k let bigarray ds k l = (DimsGen ds, kind k, l) let bigarray1 d k l = (Dims1 d, kind k, l) let bigarray2 d1 d2 k l = (Dims2 (d1, d2), kind k, l) let bigarray3 d1 d2 d3 k l = (Dims3 (d1, d2, d3), kind k, l) let type_name : type a b l. (b, a, l) dims -> string list = function | DimsGen _ -> ["Bigarray"; "Genarray"; "t"] | Dims1 _ -> ["Bigarray"; "Array1"; "t"] | Dims2 _ -> ["Bigarray"; "Array2"; "t"] | Dims3 _ -> ["Bigarray"; "Array3"; "t"] let kind_type_names : type a. a kind -> _ = function | Kind_float32 -> (`Ident ["float"], `Ident ["Bigarray"; "float32_elt"]) | Kind_float64 -> (`Ident ["float"], `Ident ["Bigarray"; "float64_elt"]) | Kind_int8_signed -> (`Ident ["int"], `Ident ["Bigarray"; "int8_signed_elt"]) | Kind_int8_unsigned -> (`Ident ["int"], `Ident ["Bigarray"; "int8_unsigned_elt"]) | Kind_int16_signed -> (`Ident ["int"], `Ident ["Bigarray"; "int16_signed_elt"]) | Kind_int16_unsigned -> (`Ident ["int"], `Ident ["Bigarray"; "int16_unsigned_elt"]) | Kind_int32 -> (`Ident ["int32"], `Ident ["Bigarray"; "int32_elt"]) | Kind_int64 -> (`Ident ["int64"], `Ident ["Bigarray"; "int64_elt"]) | Kind_int -> (`Ident ["int"], `Ident ["Bigarray"; "int_elt"]) | Kind_nativeint -> (`Ident ["nativeint"], `Ident ["Bigarray"; "nativeint_elt"]) | Kind_complex32 -> (`Ident ["Complex"; "t"], `Ident ["Bigarray"; "complex32_elt"]) | Kind_complex64 -> (`Ident ["Complex"; "t"], `Ident ["Bigarray"; "complex64_elt"]) | Kind_char -> (`Ident ["char"], `Ident ["Bigarray"; "int8_unsigned_elt"]) let layout_path : type a. a Bigarray_compat.layout -> string list = function | Bigarray_compat.C_layout -> ["Bigarray"; "c_layout"] | Bigarray_compat.Fortran_layout -> ["Bigarray"; "fortran_layout"] let type_expression : type a b l. (a, b, l) t -> _ = fun (t, ck, l) -> begin let a, b = kind_type_names ck in let layout = `Ident (layout_path l) in (`Appl (type_name t, [a; b; layout])) end let prim_of_kind k = prim_of_kind (kind k) let unsafe_address b = Ctypes_bigarray_stubs.address b let view : type a b l m. (a, b, l) t -> (m option, _) Ctypes_ptr.Fat.t -> b = let open Ctypes_bigarray_stubs in fun (dims, kind, layout) ptr -> let ba : b = match dims with | DimsGen ds -> view kind ~dims:ds ptr layout | Dims1 d -> view1 kind ~dims:[| d |] ptr layout | Dims2 (d1, d2) -> view2 kind ~dims:[| d1; d2 |] ptr layout | Dims3 (d1, d2, d3) -> view3 kind ~dims:[| d1; d2; d3 |] ptr layout in match Ctypes_ptr.Fat.managed ptr with | None -> ba | Some src -> Gc.finalise (fun _ -> Ctypes_memory_stubs.use_value src) ba; ba yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_bigarray.mli000066400000000000000000000050731445631112600237370ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** {2 Types} *) type ('a, 'b, 'l) t (** The type of bigarray values of particular sizes. A value of type [(a, b, l) t] can be used to read and write values of type [b]. *) (** {3 Type constructors} *) val bigarray : int array -> ('a, 'b) Bigarray_compat.kind -> 'l Bigarray_compat.layout -> ('a, ('a, 'b, 'l) Bigarray_compat.Genarray.t, 'l) t (** Create a {!t} value for the {!Bigarray.Genarray.t} type. *) val bigarray1 : int -> ('a, 'b) Bigarray_compat.kind -> 'l Bigarray_compat.layout -> ('a, ('a, 'b, 'l) Bigarray_compat.Array1.t, 'l) t (** Create a {!t} value for the {!Bigarray.Array1.t} type. *) val bigarray2 : int -> int -> ('a, 'b) Bigarray_compat.kind -> 'l Bigarray_compat.layout -> ('a, ('a, 'b, 'l) Bigarray_compat.Array2.t, 'l) t (** Create a {!t} value for the {!Bigarray.Array2.t} type. *) val bigarray3 : int -> int -> int -> ('a, 'b) Bigarray_compat.kind -> 'l Bigarray_compat.layout -> ('a, ('a, 'b, 'l) Bigarray_compat.Array3.t, 'l) t (** Create a {!t} value for the {!Bigarray.Array3.t} type. *) val prim_of_kind : ('a, _) Bigarray_compat.kind -> 'a Ctypes_primitive_types.prim (** Create a {!Ctypes_ptr.Types.ctype} for a {!Bigarray.kind}. *) (** {3 Type eliminators} *) val sizeof : (_, _, _) t -> int (** Compute the size of a bigarray type. *) val alignment : (_, _, _) t -> int (** Compute the alignment of a bigarray type. *) val element_type : ('a, _, _) t -> 'a Ctypes_primitive_types.prim (** Compute the element type of a bigarray type. *) val dimensions : (_, _, _) t -> int array (** Compute the dimensions of a bigarray type. *) val type_expression : ('a, 'b, 'l) t -> ([> `Appl of string list * 'c list | `Ident of string list ] as 'c) (** Compute a type expression that denotes a bigarray type. *) (** {2 Values} *) val unsafe_address : 'a -> Ctypes_ptr.voidp (** Return the address of a bigarray value. This function is unsafe because it dissociates the raw address of the C array from the OCaml object that manages the lifetime of the array. If the caller does not hold a reference to the OCaml object then the array might be freed, invalidating the address. *) val view : (_, 'a, _) t -> (_ option, _) Ctypes_ptr.Fat.t -> 'a (** [view b ptr] creates a bigarray view onto existing memory. If [ptr] references an OCaml object then [view] will ensure that that object is not collected before the bigarray returned by [view]. *) yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_bigarray_stubs.ml000066400000000000000000000036761445631112600250150ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) type _ kind = Kind_float32 : float kind | Kind_float64 : float kind | Kind_int8_signed : int kind | Kind_int8_unsigned : int kind | Kind_int16_signed : int kind | Kind_int16_unsigned : int kind | Kind_int32 : int32 kind | Kind_int64 : int64 kind | Kind_int : int kind | Kind_nativeint : nativeint kind | Kind_complex32 : Complex.t kind | Kind_complex64 : Complex.t kind | Kind_char : char kind let kind : type a b. (a, b) Bigarray_compat.kind -> a kind = function | Bigarray_compat.Float32 -> Kind_float32 | Bigarray_compat.Float64 -> Kind_float64 | Bigarray_compat.Int8_signed -> Kind_int8_signed | Bigarray_compat.Int8_unsigned -> Kind_int8_unsigned | Bigarray_compat.Int16_signed -> Kind_int16_signed | Bigarray_compat.Int16_unsigned -> Kind_int16_unsigned | Bigarray_compat.Int32 -> Kind_int32 | Bigarray_compat.Int64 -> Kind_int64 | Bigarray_compat.Int -> Kind_int | Bigarray_compat.Nativeint -> Kind_nativeint | Bigarray_compat.Complex32 -> Kind_complex32 | Bigarray_compat.Complex64 -> Kind_complex64 | Bigarray_compat.Char -> Kind_char external address : 'b -> Ctypes_ptr.voidp = "ctypes_bigarray_address" external view : 'a kind -> dims:int array -> _ Ctypes_ptr.Fat.t -> 'l Bigarray_compat.layout -> ('a, 'b, 'l) Bigarray_compat.Genarray.t = "ctypes_bigarray_view" external view1 : 'a kind -> dims:int array -> _ Ctypes_ptr.Fat.t -> 'l Bigarray_compat.layout -> ('a, 'b, 'l) Bigarray_compat.Array1.t = "ctypes_bigarray_view" external view2 : 'a kind -> dims:int array -> _ Ctypes_ptr.Fat.t -> 'l Bigarray_compat.layout -> ('a, 'b, 'l) Bigarray_compat.Array2.t = "ctypes_bigarray_view" external view3 : 'a kind -> dims:int array -> _ Ctypes_ptr.Fat.t -> 'l Bigarray_compat.layout -> ('a, 'b, 'l) Bigarray_compat.Array3.t = "ctypes_bigarray_view" yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_bigarrays.c000066400000000000000000000024011445631112600235530ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #include #include #include "ctypes_raw_pointer.h" #ifndef Caml_ba_layout_val /* Caml_ba_layout_val was introduced when the representation of layout values changed from an integer to a GADT. Up to that point the OCaml values c_layout and fortran_layout had the same values as the C constants CAML_BA_C_LAYOUT and CAML_BA_FORTRAN_LAYOUT */ #define Caml_ba_layout_val(v) (Int_val(v)) #endif /* address : 'b -> pointer */ value ctypes_bigarray_address(value ba) { return CTYPES_FROM_PTR(Caml_ba_data_val(ba)); } /* _view : ('a, 'b) kind -> dims:int array -> fatptr -> 'l layout -> ('a, 'b, 'l) Bigarray.Genarray.t */ value ctypes_bigarray_view(value kind_, value dims_, value ptr_, value layout_) { int kind = Int_val(kind_); int layout = Caml_ba_layout_val(layout_); int ndims = Wosize_val(dims_); intnat dims[CAML_BA_MAX_NUM_DIMS]; int i; for (i = 0; i < ndims; i++) { dims[i] = Long_val(Field(dims_, i)); } int flags = kind | layout | CAML_BA_EXTERNAL; void *data = CTYPES_ADDR_OF_FATPTR(ptr_); return caml_ba_alloc(flags, ndims, data, dims); } yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_coerce.ml000066400000000000000000000103271445631112600232240ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Coercions *) [@@@warning "-27"] open Ctypes_static type uncoercible_info = Types : _ typ * _ typ -> uncoercible_info | Functions : _ fn * _ fn -> uncoercible_info exception Uncoercible of uncoercible_info let show_uncoercible = function Uncoercible (Types (l, r)) -> let pr ty = Ctypes_type_printing.string_of_typ ty in Some (Format.sprintf "Coercion failure: %s is not coercible to %s" (pr l) (pr r)) | Uncoercible (Functions (l, r)) -> let pr ty = Ctypes_type_printing.string_of_fn ty in Some (Format.sprintf "Coercion failure: %s is not coercible to %s" (pr l) (pr r)) | _ -> None let () = Printexc.register_printer show_uncoercible let uncoercible : 'a 'b 'c. 'a typ -> 'b typ -> 'c = fun l r -> raise (Uncoercible (Types (l, r))) let uncoercible_functions : 'a 'b 'c. 'a fn -> 'b fn -> 'c = fun l r -> raise (Uncoercible (Functions (l, r))) let id x = x type (_, _) coercion = | Id : ('a, 'a) coercion | Coercion : ('a -> 'b) -> ('a, 'b) coercion let ml_prim_coercion : type a b. a Ctypes_primitive_types.ml_prim -> b Ctypes_primitive_types.ml_prim -> (a, b) coercion option = let open Ctypes_primitive_types in fun l r -> match l, r with | ML_char, ML_char -> Some Id | ML_complex, ML_complex -> Some Id | ML_float, ML_float -> Some Id | ML_int, ML_int -> Some Id | ML_int32, ML_int32 -> Some Id | ML_int64, ML_int64 -> Some Id | ML_llong, ML_llong -> Some Id | ML_long, ML_long -> Some Id | ML_nativeint, ML_nativeint -> Some Id | ML_size_t, ML_size_t -> Some Id | ML_uchar, ML_uchar -> Some Id | ML_bool, ML_bool -> Some Id | ML_uint, ML_uint -> Some Id | ML_uint16, ML_uint16 -> Some Id | ML_uint32, ML_uint32 -> Some Id | ML_uint64, ML_uint64 -> Some Id | ML_uint8, ML_uint8 -> Some Id | ML_ullong, ML_ullong -> Some Id | ML_ulong, ML_ulong -> Some Id | ML_ushort, ML_ushort -> Some Id | l, r -> None let rec coercion : type a b. a typ -> b typ -> (a, b) coercion = fun atyp btyp -> match atyp, btyp with | _, Void -> Coercion ignore | Primitive l, Primitive r -> (match Ctypes_primitive_types.(ml_prim_coercion (ml_prim l) (ml_prim r)) with Some c -> c | None -> uncoercible atyp btyp) | View av, b -> begin match coercion av.ty b with | Id -> Coercion av.write | Coercion coerce -> Coercion (fun v -> coerce (av.write v)) end | a, View bv -> begin match coercion a bv.ty with | Id -> Coercion bv.read | Coercion coerce -> Coercion (fun v -> bv.read (coerce v)) end | Pointer a, Pointer b -> begin match coercion a b with | Id -> Id | Coercion _ -> Coercion (fun (CPointer p) -> CPointer (Ctypes_ptr.Fat.coerce p b)) | exception Uncoercible _ -> Coercion (fun (CPointer p) -> CPointer (Ctypes_ptr.Fat.coerce p b)) end | Pointer a, Funptr b -> Coercion (fun (CPointer p) -> Static_funptr (Ctypes_ptr.Fat.coerce p b)) | Funptr a, Pointer b -> Coercion (fun (Static_funptr p) -> CPointer (Ctypes_ptr.Fat.coerce p b)) | Funptr a, Funptr b -> begin match fn_coercion a b with | Id -> Id | Coercion _ -> Coercion (fun (Static_funptr p) -> Static_funptr (Ctypes_ptr.Fat.coerce p b)) | exception Uncoercible _ -> Coercion (fun (Static_funptr p) -> Static_funptr (Ctypes_ptr.Fat.coerce p b)) end | l, r -> uncoercible l r and fn_coercion : type a b. a fn -> b fn -> (a, b) coercion = fun afn bfn -> match afn, bfn with | Function (af, at), Function (bf, bt) -> begin match coercion bf af, fn_coercion at bt with | Id, Id -> Id | Id, Coercion h -> Coercion (fun g x -> h (g x)) | Coercion f, Id -> Coercion (fun g x -> g (f x)) | Coercion f, Coercion h -> Coercion (fun g x -> h (g (f x))) end | Returns at, Returns bt -> coercion at bt | l, r -> uncoercible_functions l r let coerce : type a b. a typ -> b typ -> a -> b = fun atyp btyp -> match coercion atyp btyp with | Id -> id | Coercion c -> c let coerce_fn : type a b. a fn -> b fn -> a -> b = fun afn bfn -> match fn_coercion afn bfn with | Id -> id | Coercion c -> c yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_coerce.mli000066400000000000000000000005451445631112600233760ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) type uncoercible_info exception Uncoercible of uncoercible_info val coerce : 'a Ctypes_static.typ -> 'b Ctypes_static.typ -> 'a -> 'b val coerce_fn : 'a Ctypes_static.fn -> 'b Ctypes_static.fn -> 'a -> 'b yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_complex_compatibility.h000066400000000000000000000130741445631112600262050ustar00rootroot00000000000000/* * Copyright (c) 2018 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef CTYPES_COMPLEX_COMPATIBILITY_H #define CTYPES_COMPLEX_COMPATIBILITY_H #include /* "Each complex type has the same representation and alignment requirements as an array type containing exactly two elements of the corresponding real type; the first element is equal to the real part, and the second element to the imaginary part, of the complex number." - C99 6.2.5 (13) */ union ctypes_complex_long_double_union { long double _Complex z; long double parts[2]; }; union ctypes_complex_double_union { double _Complex z; double parts[2]; }; union ctypes_complex_float_union { float _Complex z; float parts[2]; }; #if defined(__ANDROID__) #define CTYPES_USE_STRUCT_BUILDER 1 #include static inline long double ctypes_compat_creall(long double _Complex z) { union ctypes_complex_long_double_union u; u.z = z; return u.parts[0]; } static inline long double ctypes_compat_cimagl(long double _Complex z) { union ctypes_complex_long_double_union u; u.z = z; return u.parts[1]; } static inline long double _Complex ctypes_compat_conjl(long double _Complex z) { union ctypes_complex_long_double_union u; u.z = z; u.parts[1] = -u.parts[1]; return u.z; } static inline long double ctypes_compat_cargl(long double _Complex z) { return atan2(ctypes_compat_cimagl(z), ctypes_compat_creall(z)); } static inline double ctypes_compat_creal(double _Complex z) { union ctypes_complex_double_union u; u.z = z; return u.parts[0]; } static inline double ctypes_compat_cimag(double _Complex z) { union ctypes_complex_double_union u; u.z = z; return u.parts[1]; } static inline double _Complex ctypes_compat_conj(double _Complex z) { union ctypes_complex_double_union u; u.z = z; u.parts[1] = -u.parts[1]; return u.z; } static inline float ctypes_compat_crealf(float _Complex z) { union ctypes_complex_float_union u; u.z = z; return u.parts[0]; } static inline float ctypes_compat_cimagf(float _Complex z) { union ctypes_complex_float_union u; u.z = z; return u.parts[1]; } static inline float _Complex ctypes_compat_conjf(float _Complex z) { union ctypes_complex_float_union u; u.z = z; u.parts[1] = -u.parts[1]; return u.z; } /* Android: As of API level 24, these functions do not exist. */ static inline long double _Complex ctypes_compat_csqrtl(long double _Complex z) { caml_failwith("ctypes: csqrtl does not exist on current platform"); } static inline long double _Complex ctypes_compat_cexpl(long double _Complex z) { caml_failwith("ctypes: cexpl does not exist on current platform"); } static inline long double _Complex ctypes_compat_clogl(long double _Complex z) { caml_failwith("ctypes: clogl does not exist on current platform"); } static inline long double _Complex ctypes_compat_cpowl(long double _Complex x, long double _Complex z) { caml_failwith("ctypes: cpowl does not exist on current platform"); } #else #include static inline long double ctypes_compat_creall(long double _Complex z) { return creall(z); } static inline long double ctypes_compat_cimagl(long double _Complex z) { return cimagl(z); } static inline long double _Complex ctypes_compat_conjl(long double _Complex z) { return conjl(z); } #if defined(__FreeBSD__) static inline long double _Complex ctypes_compat_cexpl(long double _Complex z) { caml_failwith("ctypes: cexpl does not exist on current platform"); } #else static inline long double _Complex ctypes_compat_cexpl(long double _Complex z) { return cexpl(z); } #endif static inline long double _Complex ctypes_compat_clogl(long double _Complex z) { return clogl(z); } static inline long double _Complex ctypes_compat_cpowl(long double _Complex x, long double _Complex z) { return cpowl(x, z); } static inline long double _Complex ctypes_compat_csqrtl(long double _Complex z) { return csqrtl(z); } static inline long double ctypes_compat_cargl(long double _Complex z) { return cargl(z); } static inline double ctypes_compat_creal(double _Complex z) { return creal(z); } static inline double ctypes_compat_cimag(double _Complex z) { return cimag(z); } static inline double _Complex ctypes_compat_conj(double _Complex z) { return conj(z); } static inline float ctypes_compat_crealf(float _Complex z) { return crealf(z); } static inline float ctypes_compat_cimagf(float _Complex z) { return cimagf(z); } static inline float _Complex ctypes_compat_conjf(float _Complex z) { return conjf(z); } #if !defined(CMPLXF) || !defined(CMPLX) || !defined(CMPLXL) #define CTYPES_USE_STRUCT_BUILDER 1 #else static inline double _Complex ctypes_compat_make_complex(double re, double im) { return (CMPLX(re,im)); } static inline long double _Complex ctypes_compat_make_complexl(long double re, long double im) { return (CMPLXL(re,im)); } static inline float _Complex ctypes_compat_make_complexf(float re, float im) { return (CMPLXF(re,im)); } #endif #endif #ifdef CTYPES_USE_STRUCT_BUILDER static inline double _Complex ctypes_compat_make_complex(double re, double im) { union ctypes_complex_double_union u; u.parts[0] = re; u.parts[1] = im; return u.z; } static inline float _Complex ctypes_compat_make_complexf(float re, float im) { union ctypes_complex_float_union u; u.parts[0] = re; u.parts[1] = im; return u.z; } static inline long double _Complex ctypes_compat_make_complexl(long double re, long double im) { union ctypes_complex_long_double_union u; u.parts[0] = re; u.parts[1] = im; return u.z; } #undef CTYPES_USE_STRUCT_BUILDER #endif #endif /* CTYPES_COMPLEX_COMPATIBILITY_H */ yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_complex_stubs.h000066400000000000000000000013301445631112600244640ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef CTYPES_COMPLEX_STUBS_H #define CTYPES_COMPLEX_STUBS_H #include /* ctypes_copy_float_complex : float _Complex -> Complex.t */ value ctypes_copy_float_complex(float _Complex); /* ctypes_copy_double_complex : double _Complex -> Complex.t */ value ctypes_copy_double_complex(double _Complex); /* ctypes_float_complex_val : Complex.t -> float _Complex */ float _Complex ctypes_float_complex_val(value); /* ctypes_double_complex_val : Complex.t -> double _Complex */ double _Complex ctypes_double_complex_val(value); #endif /* CTYPES_COMPLEX_STUBS_H */ yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_cstubs_internals.h000066400000000000000000000026631445631112600251710ustar00rootroot00000000000000/* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef CTYPES_CSTUBS_INTERNALS_H #define CTYPES_CSTUBS_INTERNALS_H /* Types and functions used by generated C code. */ #include "ctypes_primitives.h" #include "ctypes_complex_stubs.h" #include "ctypes_ldouble_stubs.h" #include "ctypes_raw_pointer.h" #include "ctypes_managed_buffer_stubs.h" #include /* The cast here removes the 'const' qualifier in recent versions of OCaml because ctypes doesn't yet support const. TODO: when ctypes supports cv-qualifiers, remove the cast. */ #define CTYPES_PTR_OF_OCAML_STRING(s) \ ((char *)String_val(Field(s, 1)) + Long_val(Field(s, 0))) #ifdef Bytes_val #define CTYPES_PTR_OF_OCAML_BYTES(s) \ (Bytes_val(Field(s, 1)) + Long_val(Field(s, 0))) #else #define CTYPES_PTR_OF_OCAML_BYTES(s) CTYPES_PTR_OF_OCAML_STRING(s) #endif #define Ctypes_val_char(c) \ (Val_int((c + 256) % 256)) #define CTYPES_PAIR_WITH_ERRNO(v) #include #include static inline value ctypes_pair_with_errno(value p) { CAMLparam1 (p); CAMLlocal1 (v); v = caml_alloc_tuple(2); Store_field (v, 0, p); Store_field (v, 1, ctypes_copy_sint(errno)); CAMLreturn (v); } #if defined(__MINGW32__) || defined(__MINGW64__) #define ctypes_printf __mingw_printf #else #define ctypes_printf printf #endif #endif /* CTYPES_CSTUBS_INTERNALS_H */ yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_ldouble_stubs.h000066400000000000000000000013611445631112600244470ustar00rootroot00000000000000/* * Copyright (c) 2016 Andy Ray. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef CTYPES_LDOUBLE_STUBS_H #define CTYPES_LDOUBLE_STUBS_H #include extern value ctypes_copy_ldouble(long double u); extern long double ctypes_ldouble_val(value); extern value ctypes_ldouble_of_float(value a); extern value ctypes_ldouble_to_float(value a); extern value ctypes_copy_ldouble_complex(long double _Complex u); extern long double _Complex ctypes_ldouble_complex_val(value); extern value ctypes_ldouble_complex_make(value r, value i); extern value ctypes_ldouble_complex_real(value v); extern value ctypes_ldouble_complex_imag(value v); #endif /* CTYPES_LDOUBLE_STUBS_H */ yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_managed_buffer_stubs.h000066400000000000000000000012451445631112600257470ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef CTYPES_MANAGED_BUFFER_STUBS_H #define CTYPES_MANAGED_BUFFER_STUBS_H #include /* copy_bytes : void * -> size_t -> managed_buffer */ extern value ctypes_copy_bytes(void *, size_t); /* allocate : int -> int -> managed_buffer */ extern value ctypes_allocate(value count, value size); /* block_address : managed_buffer -> immediate_pointer */ extern value ctypes_block_address(value managed_buffer); /* CTYPES_FROM_FAT_PTR : _ Ctypes_ptr.Fat.t -> void * */ #endif /* CTYPES_MANAGED_BUFFER_STUBS_H */ yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_memory.ml000066400000000000000000000311731445631112600232760ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@warning "-9-27"] open Ctypes_static module Stubs = Ctypes_memory_stubs module Raw = Ctypes_ptr.Raw module Fat = Ctypes_ptr.Fat let castp reftype (CPointer p) = CPointer (Fat.coerce p reftype) let make_unmanaged ~reftyp p = Fat.make ~managed:None ~reftyp p (* Describes how to read a value, e.g. from a return buffer *) let rec build : type a b. a typ -> (_, b typ) Fat.t -> a = function | Void -> fun _ -> () | Primitive p -> Stubs.read p | Struct { spec = Incomplete _ } -> raise IncompleteType | Struct { spec = Complete { size } } as reftyp -> (fun buf -> let p = Stubs.allocate 1 size in let dst = Fat.make ~managed:(Some (Obj.repr p)) ~reftyp (Stubs.block_address p) in let () = Stubs.memcpy ~size ~dst ~src:buf in { structured = CPointer dst}) | Pointer reftyp -> (fun buf -> CPointer (make_unmanaged ~reftyp (Stubs.Pointer.read buf))) | Funptr fn -> (fun buf -> Static_funptr (make_unmanaged ~reftyp:fn (Stubs.Pointer.read buf))) | View { read; ty } -> let buildty = build ty in (fun buf -> read (buildty buf)) | OCaml _ -> (fun buf -> assert false) (* The following cases should never happen; non-struct aggregate types are excluded during type construction. *) | Union _ -> assert false | Array _ -> assert false | Bigarray _ -> assert false | Abstract _ -> assert false let rec write : type a b. a typ -> a -> (_, b) Fat.t -> unit = let write_aggregate size { structured = CPointer src } dst = Stubs.memcpy ~size ~dst ~src in function | Void -> (fun _ _ -> ()) | Primitive p -> Stubs.write p | Pointer _ -> (fun (CPointer p) dst -> Stubs.Pointer.write p dst) | Funptr _ -> (fun (Static_funptr p) dst -> Stubs.Pointer.write p dst) | Struct { spec = Incomplete _ } -> raise IncompleteType | Struct { spec = Complete _ } as s -> write_aggregate (sizeof s) | Union { uspec = None } -> raise IncompleteType | Union { uspec = Some { size } } -> write_aggregate size | Abstract { asize } -> write_aggregate asize | Array _ as a -> let size = sizeof a in (fun { astart = CPointer src } dst -> Stubs.memcpy ~size ~dst ~src) | Bigarray b as t -> let size = sizeof t in (fun ba dst -> let src = Fat.make ~managed:ba ~reftyp:Void (Ctypes_bigarray.unsafe_address ba) in Stubs.memcpy ~size ~dst ~src) | View { write = w; ty } -> let writety = write ty in (fun v -> writety (w v)) | OCaml _ -> raise IncompleteType let null : unit ptr = CPointer (Fat.make ~managed:None ~reftyp:Void Raw.null) let rec (!@) : type a. a ptr -> a = fun (CPointer cptr as ptr) -> match Fat.reftype cptr with | Void -> raise IncompleteType | Union { uspec = None } -> raise IncompleteType | Struct { spec = Incomplete _ } -> raise IncompleteType | View { read; ty } -> read (!@ (CPointer (Fat.coerce cptr ty))) (* If it's a reference type then we take a reference *) | Union _ -> { structured = ptr } | Struct _ -> { structured = ptr } | Array (elemtype, alength) -> { astart = CPointer (Fat.coerce cptr elemtype); alength } | Bigarray b -> Ctypes_bigarray.view b cptr | Abstract _ -> { structured = ptr } | OCaml _ -> raise IncompleteType (* If it's a value type then we cons a new value. *) | _ -> build (Fat.reftype cptr) cptr let ptr_diff : type a b. (a, b) pointer -> (a, b) pointer -> int = fun l r -> match l, r with | CPointer lp, CPointer rp -> (* We assume the pointers are properly aligned, or at least that the difference is a multiple of sizeof reftype. *) Fat.diff_bytes lp rp / sizeof (Fat.reftype lp) | OCamlRef (lo, l, _), OCamlRef (ro, r, _) -> if l != r then invalid_arg "Ctypes.ptr_diff"; ro - lo let (+@) : type a b. (a, b) pointer -> int -> (a, b) pointer = fun p x -> match p with | CPointer p -> CPointer (Fat.add_bytes p (x * sizeof (Fat.reftype p))) | OCamlRef (offset, obj, ty) -> OCamlRef (offset + x, obj, ty) let (-@) p x = p +@ (-x) let (<-@) : type a. a ptr -> a -> unit = fun (CPointer p) -> fun v -> write (Fat.reftype p) v p let from_voidp = castp let to_voidp p = castp Void p let allocate_n : type a. ?finalise:(a ptr -> unit) -> a typ -> count:int -> a ptr = fun ?finalise reftyp ~count -> let package p = CPointer (Fat.make ~managed:(Some (Obj.repr p)) ~reftyp (Stubs.block_address p)) in let finalise = match finalise with | Some f -> Gc.finalise (fun p -> f (package p)) | None -> ignore in let p = Stubs.allocate count (sizeof reftyp) in begin finalise p; package p end let allocate : type a. ?finalise:(a ptr -> unit) -> a typ -> a -> a ptr = fun ?finalise reftype v -> let p = allocate_n ?finalise ~count:1 reftype in begin p <-@ v; p end let ptr_compare (CPointer l) (CPointer r) = Fat.(compare l r) let reference_type (CPointer p) = Fat.reftype p let ptr_of_raw_address addr = CPointer (make_unmanaged ~reftyp:Void (Raw.of_nativeint addr)) let funptr_of_raw_address addr = Static_funptr (make_unmanaged ~reftyp:(void @-> returning void) (Raw.of_nativeint addr)) let raw_address_of_ptr (CPointer p) = (* This is unsafe by definition: if the object to which [p] refers is collected at this point then the returned address is invalid. If there is an OCaml object associated with [p] then it is vital that the caller retains a reference to it. *) Raw.to_nativeint (Fat.unsafe_raw_addr p) module CArray = struct type 'a t = 'a carray let check_bound { alength } i = if i < 0 || i >= alength then invalid_arg "index out of bounds" let unsafe_get { astart } n = !@(astart +@ n) let unsafe_set { astart } n v = (astart +@ n) <-@ v let get arr n = check_bound arr n; unsafe_get arr n let set arr n v = check_bound arr n; unsafe_set arr n v let start { astart } = astart let length { alength } = alength let from_ptr astart alength = { astart; alength } let fill { alength; astart = CPointer p } v = let size = sizeof (Fat.reftype p) in let w = write (Fat.reftype p) v in for i = 0 to alength - 1 do w (Fat.add_bytes p (i * size)) done let make : type a. ?finalise:(a t -> unit) -> a typ -> ?initial:a -> int -> a t = fun ?finalise reftype ?initial count -> let finalise = match finalise with | Some f -> Some (fun astart -> f { astart; alength = count } ) | None -> None in let arr = { astart = allocate_n ?finalise ~count reftype; alength = count } in match initial with | None -> arr | Some v -> fill arr v; arr let copy {astart = CPointer src; alength} = begin let reftyp = Fat.reftype src in let CPointer dst as r = allocate_n reftyp ~count:alength in let () = Stubs.memcpy ~dst ~src ~size:(alength * sizeof reftyp) in from_ptr r alength end let sub arr ~pos ~length:len = if pos < 0 || len < 0 || pos > length arr - len then invalid_arg "CArray.sub" else copy { astart = arr.astart +@ pos; alength = len } let element_type { astart } = reference_type astart let of_string string = let len = String.length string in let arr = make char (len + 1) in String.iteri (set arr) string; set arr len '\x00'; arr let of_list typ list = let arr = make typ (List.length list) in List.iteri (set arr) list; arr let to_list a = let l = ref [] in for i = length a - 1 downto 0 do l := get a i :: !l done; !l let iter f a = for i = 0 to length a - 1 do f (unsafe_get a i) done let map typ f a = let l = length a in let r = make typ l in for i = 0 to l - 1 do unsafe_set r i (f (unsafe_get a i)) done; r let mapi typ f a = let l = length a in let r = make typ l in for i = 0 to l - 1 do unsafe_set r i (f i (unsafe_get a i)) done; r let fold_left f x a = let r = ref x in for i = 0 to length a - 1 do r := f !r (unsafe_get a i) done; !r let fold_right f a x = let r = ref x in for i = length a - 1 downto 0 do r := f (unsafe_get a i) !r done; !r end let make ?finalise s = let finalise = match finalise with | Some f -> Some (fun structured -> f { structured }) | None -> None in { structured = allocate_n ?finalise s ~count:1 } let (|->) (CPointer p) { ftype; foffset } = CPointer (Fat.(add_bytes (Fat.coerce p ftype) foffset)) let (@.) { structured = p } f = p |-> f let setf s field v = (s @. field) <-@ v let getf s field = !@(s @. field) let addr { structured } = structured open Bigarray_compat let _bigarray_start kind ba = let raw_address = Ctypes_bigarray.unsafe_address ba in let reftyp = Primitive (Ctypes_bigarray.prim_of_kind kind) in CPointer (Fat.make ~managed:(Some (Obj.repr ba)) ~reftyp raw_address) let bigarray_kind : type a b c d f l. < element: a; layout: l; ba_repr: f; bigarray: b; carray: c; dims: d > bigarray_class -> b -> (a, f) Bigarray.kind = function | Genarray -> Genarray.kind | Array1 -> Array1.kind | Array2 -> Array2.kind | Array3 -> Array3.kind let bigarray_start spec ba = _bigarray_start (bigarray_kind spec ba) ba let array_of_bigarray : type a b c d e. < element: a; layout: Bigarray.c_layout; ba_repr: e; bigarray: b; carray: c; dims: d > bigarray_class -> b -> c = fun spec ba -> let CPointer p as element_ptr = bigarray_start spec ba in match spec with | Genarray -> let ds = Genarray.dims ba in CArray.from_ptr element_ptr (Array.fold_left ( * ) 1 ds) | Array1 -> let d = Array1.dim ba in CArray.from_ptr element_ptr d | Array2 -> let d1 = Array2.dim1 ba and d2 = Array2.dim2 ba in CArray.from_ptr (castp (array d2 (Fat.reftype p)) element_ptr) d1 | Array3 -> let d1 = Array3.dim1 ba and d2 = Array3.dim2 ba and d3 = Array3.dim3 ba in CArray.from_ptr (castp (array d2 (array d3 (Fat.reftype p))) element_ptr) d1 let bigarray_elements : type a b c d f l. < element: a; layout: l; ba_repr: f; bigarray: b; carray: c; dims: d > bigarray_class -> d -> int = fun spec dims -> match spec, dims with | Genarray, ds -> Array.fold_left ( * ) 1 ds | Array1, d -> d | Array2, (d1, d2) -> d1 * d2 | Array3, (d1, d2, d3) -> d1 * d2 * d3 let bigarray_of_ptr spec dims kind ptr = !@ (castp (bigarray spec dims kind) ptr) let fortran_bigarray_of_ptr spec dims kind ptr = !@ (castp (fortran_bigarray spec dims kind) ptr) let array_dims : type a b c d f l. < element: a; layout: l; ba_repr: f; bigarray: b; carray: c carray; dims: d > bigarray_class -> c carray -> d = let unsupported () = raise (Unsupported "taking dimensions of non-array type") in fun spec a -> match spec with | Genarray -> [| a.alength |] | Array1 -> a.alength | Array2 -> begin match a.astart with | CPointer p -> begin match Fat.reftype p with | Array (_, n) -> (a.alength, n) | _ -> unsupported () end end | Array3 -> begin match a.astart with | CPointer p -> begin match Fat.reftype p with | Array (Array (_, m), n) -> (a.alength, n, m) | _ -> unsupported () end end let bigarray_of_array spec kind a = let dims = array_dims spec a in !@ (castp (bigarray spec dims kind) (CArray.start a)) let genarray = Genarray let array1 = Array1 let array2 = Array2 let array3 = Array3 let typ_of_bigarray_kind k = Primitive (Ctypes_bigarray.prim_of_kind k) let string_from_ptr (CPointer p) ~length:len = if len < 0 then invalid_arg "Ctypes.string_from_ptr" else Stubs.string_of_array p ~len let ocaml_string_start str = OCamlRef (0, str, String) let ocaml_bytes_start str = OCamlRef (0, str, Bytes) let ocaml_float_array_start arr = OCamlRef (0, arr, FloatArray) module Root = struct module Stubs = Ctypes_roots_stubs (* Roots are not managed values so it's safe to call unsafe_raw_addr. *) let raw_addr : unit ptr -> Raw.t = fun (CPointer p) -> Fat.unsafe_raw_addr p let create : 'a. 'a -> unit ptr = fun v -> CPointer (make_unmanaged ~reftyp:void (Stubs.root v)) let get : 'a. unit ptr -> 'a = fun p -> Stubs.get (raw_addr p) let set : 'a. unit ptr -> 'a -> unit = fun p v -> Stubs.set (raw_addr p) v let release : 'a. unit ptr -> unit = fun p -> Stubs.release (raw_addr p) end let is_null (CPointer p) = Fat.is_null p yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_memory_stubs.ml000066400000000000000000000026431445631112600245160ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stubs for reading and writing memory. *) open Ctypes_ptr (* A reference, managed by the garbage collector, to a region of memory in the C heap. *) type managed_buffer (* Allocate a region of stable, zeroed memory managed by a custom block. *) external allocate : int -> int -> managed_buffer = "ctypes_allocate" (* Obtain the address of the managed block. *) external block_address : managed_buffer -> voidp = "ctypes_block_address" (* Read a C value from a block of memory *) external read : 'a Ctypes_primitive_types.prim -> _ Fat.t -> 'a = "ctypes_read" (* Write a C value to a block of memory *) external write : 'a Ctypes_primitive_types.prim -> 'a -> _ Fat.t -> unit = "ctypes_write" [@@noalloc] module Pointer = struct external read : _ Fat.t -> voidp = "ctypes_read_pointer" external write : _ Fat.t -> _ Fat.t -> unit = "ctypes_write_pointer" end (* Copy [size] bytes from [src] to [dst]. *) external memcpy : dst:_ Fat.t -> src:_ Fat.t -> size:int -> unit = "ctypes_memcpy" (* Read a fixed length OCaml string from memory *) external string_of_array : _ Fat.t -> len:int -> string = "ctypes_string_of_array" (* Do nothing, concealing from the optimizer that nothing is being done. *) external use_value : 'a -> unit = "ctypes_use" [@@noalloc] yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_primitive_types.ml000066400000000000000000000045161445631112600252230ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Unsigned open Signed type _ prim = | Char : char prim | Schar : int prim | Uchar : uchar prim | Bool : bool prim | Short : int prim | Int : int prim | Long : long prim | Llong : llong prim | Ushort : ushort prim | Sint : sint prim | Uint : uint prim | Ulong : ulong prim | Ullong : ullong prim | Size_t : size_t prim | Int8_t : int prim | Int16_t : int prim | Int32_t : int32 prim | Int64_t : int64 prim | Uint8_t : uint8 prim | Uint16_t : uint16 prim | Uint32_t : uint32 prim | Uint64_t : uint64 prim | Camlint : int prim | Nativeint : nativeint prim | Float : float prim | Double : float prim | LDouble : LDouble.t prim | Complex32 : Complex.t prim | Complex64 : Complex.t prim | Complexld : ComplexL.t prim type _ ml_prim = | ML_char : char ml_prim | ML_complex : Complex.t ml_prim | ML_complexld : ComplexL.t ml_prim | ML_float : float ml_prim | ML_ldouble : LDouble.t ml_prim | ML_int : int ml_prim | ML_int32 : int32 ml_prim | ML_int64 : int64 ml_prim | ML_llong : llong ml_prim | ML_long : long ml_prim | ML_sint : sint ml_prim | ML_nativeint : nativeint ml_prim | ML_size_t : size_t ml_prim | ML_uchar : uchar ml_prim | ML_bool : bool ml_prim | ML_uint : uint ml_prim | ML_uint16 : uint16 ml_prim | ML_uint32 : uint32 ml_prim | ML_uint64 : uint64 ml_prim | ML_uint8 : uint8 ml_prim | ML_ullong : ullong ml_prim | ML_ulong : ulong ml_prim | ML_ushort : ushort ml_prim let ml_prim : type a. a prim -> a ml_prim = function | Char -> ML_char | Schar -> ML_int | Uchar -> ML_uchar | Bool -> ML_bool | Short -> ML_int | Int -> ML_int | Long -> ML_long | Llong -> ML_llong | Ushort -> ML_ushort | Sint -> ML_sint | Uint -> ML_uint | Ulong -> ML_ulong | Ullong -> ML_ullong | Size_t -> ML_size_t | Int8_t -> ML_int | Int16_t -> ML_int | Int32_t -> ML_int32 | Int64_t -> ML_int64 | Uint8_t -> ML_uint8 | Uint16_t -> ML_uint16 | Uint32_t -> ML_uint32 | Uint64_t -> ML_uint64 | Camlint -> ML_int | Nativeint -> ML_nativeint | Float -> ML_float | Double -> ML_float | LDouble -> ML_ldouble | Complex32 -> ML_complex | Complex64 -> ML_complex | Complexld -> ML_complexld yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_primitive_types.mli000066400000000000000000000033401445631112600253660ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Representation of primitive C types. Internal representation, not for public use. *) open Unsigned open Signed type _ prim = | Char : char prim | Schar : int prim | Uchar : uchar prim | Bool : bool prim | Short : int prim | Int : int prim | Long : long prim | Llong : llong prim | Ushort : ushort prim | Sint : sint prim | Uint : uint prim | Ulong : ulong prim | Ullong : ullong prim | Size_t : size_t prim | Int8_t : int prim | Int16_t : int prim | Int32_t : int32 prim | Int64_t : int64 prim | Uint8_t : uint8 prim | Uint16_t : uint16 prim | Uint32_t : uint32 prim | Uint64_t : uint64 prim | Camlint : int prim | Nativeint : nativeint prim | Float : float prim | Double : float prim | LDouble : LDouble.t prim | Complex32 : Complex.t prim | Complex64 : Complex.t prim | Complexld : ComplexL.t prim type _ ml_prim = | ML_char : char ml_prim | ML_complex : Complex.t ml_prim | ML_complexld : ComplexL.t ml_prim | ML_float : float ml_prim | ML_ldouble : LDouble.t ml_prim | ML_int : int ml_prim | ML_int32 : int32 ml_prim | ML_int64 : int64 ml_prim | ML_llong : llong ml_prim | ML_long : long ml_prim | ML_sint : sint ml_prim | ML_nativeint : nativeint ml_prim | ML_size_t : size_t ml_prim | ML_uchar : uchar ml_prim | ML_bool : bool ml_prim | ML_uint : uint ml_prim | ML_uint16 : uint16 ml_prim | ML_uint32 : uint32 ml_prim | ML_uint64 : uint64 ml_prim | ML_uint8 : uint8 ml_prim | ML_ullong : ullong ml_prim | ML_ulong : ulong ml_prim | ML_ushort : ushort ml_prim val ml_prim : 'a prim -> 'a ml_prim yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_primitives.h000066400000000000000000000133461445631112600240020ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef CTYPES_PRIMITIVES_H #define CTYPES_PRIMITIVES_H #include #include #include #include "ocaml_integers.h" /* The order here must correspond to the constructor order in primitives.ml */ enum ctypes_primitive { Ctypes_Char, Ctypes_Schar, Ctypes_Uchar, Ctypes_Bool, Ctypes_Short, Ctypes_Int, Ctypes_Long, Ctypes_Llong, Ctypes_Ushort, Ctypes_Sint, Ctypes_Uint, Ctypes_Ulong, Ctypes_Ullong, Ctypes_Size_t, Ctypes_Int8_t, Ctypes_Int16_t, Ctypes_Int32_t, Ctypes_Int64_t, Ctypes_Uint8_t, Ctypes_Uint16_t, Ctypes_Uint32_t, Ctypes_Uint64_t, Ctypes_Camlint, Ctypes_Nativeint, Ctypes_Float, Ctypes_Double, Ctypes_LDouble, Ctypes_Complex32, Ctypes_Complex64, Ctypes_Complexld, }; /* short is at least 16 bits. */ #if USHRT_MAX == UINT16_MAX #define ctypes_ushort_val Uint16_val #define ctypes_copy_ushort Integers_val_uint16 #elif USHRT_MAX == UINT32_MAX #define ctypes_ushort_val Uint32_val #define ctypes_copy_ushort integers_copy_uint32 #elif USHRT_MAX == UINT64_MAX #define ctypes_ushort_val Uint64_val #define ctypes_copy_ushort integers_copy_uint64 #else # error "No suitable OCaml type available for representing unsigned short values" #endif /* int is at least 16 bits. */ #if UINT_MAX == UINT16_MAX #error "No suitable OCaml type available for representing signed int values" #define ctypes_uint_val Uint16_val #define ctypes_copy_uint Integers_val_uint16 #elif UINT_MAX == UINT32_MAX #define ctypes_sint_val Int32_val #define ctypes_uint_val Uint32_val #define ctypes_copy_sint caml_copy_int32 #define ctypes_copy_uint integers_copy_uint32 #elif UINT_MAX == UINT64_MAX #define ctypes_sint_val Int64_val #define ctypes_uint_val Uint64_val #define ctypes_copy_sint caml_copy_int64 #define ctypes_copy_uint integers_copy_uint64 #else # error "No suitable OCaml type available for representing unsigned int values" #endif /* long is at least 32 bits. */ #if ULONG_MAX == UINT32_MAX #define ctypes_long_val Int32_val #define ctypes_ulong_val Uint32_val #define ctypes_copy_long caml_copy_int32 #define ctypes_copy_ulong integers_copy_uint32 #elif ULONG_MAX == UINT64_MAX #define ctypes_long_val Int64_val #define ctypes_ulong_val Uint64_val #define ctypes_copy_long caml_copy_int64 #define ctypes_copy_ulong integers_copy_uint64 #else # error "No suitable OCaml type available for representing longs" #endif /* long long is at least 64 bits. */ #if ULLONG_MAX == UINT64_MAX #define ctypes_llong_val Int64_val #define ctypes_ullong_val Uint64_val #define ctypes_copy_llong caml_copy_int64 #define ctypes_copy_ullong integers_copy_uint64 #else # error "No suitable OCaml type available for representing long longs" #endif #if SIZE_MAX == UINT16_MAX #define ctypes_size_t_val Uint16_val #define ctypes_copy_size_t Integers_val_uint16 #elif SIZE_MAX == UINT32_MAX #define ctypes_size_t_val Uint32_val #define ctypes_copy_size_t integers_copy_uint32 #elif SIZE_MAX == UINT64_MAX #define ctypes_size_t_val Uint64_val #define ctypes_copy_size_t integers_copy_uint64 #else # error "No suitable OCaml type available for representing size_t values" #endif /* Detection of arithmetic types */ enum ctypes_arithmetic_type { Ctypes_arith_Int8, Ctypes_arith_Int16, Ctypes_arith_Int32, Ctypes_arith_Int64, Ctypes_arith_Uint8, Ctypes_arith_Uint16, Ctypes_arith_Uint32, Ctypes_arith_Uint64, Ctypes_arith_Float, Ctypes_arith_Double }; #define CTYPES_FLOATING_FLAG_BIT 15 #define CTYPES_UNSIGNED_FLAG_BIT 14 #define CTYPES_FLOATING ((size_t)1u << CTYPES_FLOATING_FLAG_BIT) #define CTYPES_UNSIGNED ((size_t)1u << CTYPES_UNSIGNED_FLAG_BIT) #define CTYPES_CHECK_FLOATING(TYPENAME) \ ((unsigned)(((TYPENAME) 0.5) != 0) << CTYPES_FLOATING_FLAG_BIT) #define CTYPES_CHECK_UNSIGNED(TYPENAME) \ ((unsigned)(((TYPENAME) -1) > 0) << CTYPES_UNSIGNED_FLAG_BIT) #define CTYPES_CLASSIFY(TYPENAME) (CTYPES_CHECK_FLOATING(TYPENAME) \ | CTYPES_CHECK_UNSIGNED(TYPENAME)) #define CTYPES_ARITHMETIC_TYPEINFO(TYPENAME) (CTYPES_CLASSIFY(TYPENAME) \ | sizeof(TYPENAME)) #define CTYPES_CLASSIFY_ARITHMETIC_TYPE(TYPENAME) \ ctypes_classify_arithmetic_type(CTYPES_ARITHMETIC_TYPEINFO(TYPENAME)) static inline enum ctypes_arithmetic_type ctypes_classify_arithmetic_type(size_t typeinfo) { switch (typeinfo) { case CTYPES_FLOATING | sizeof(float): return Ctypes_arith_Float; case CTYPES_FLOATING | sizeof(double): return Ctypes_arith_Double; case CTYPES_UNSIGNED | sizeof(uint8_t): return Ctypes_arith_Uint8; case CTYPES_UNSIGNED | sizeof(uint16_t): return Ctypes_arith_Uint16; case CTYPES_UNSIGNED | sizeof(uint32_t): return Ctypes_arith_Uint32; case CTYPES_UNSIGNED | sizeof(uint64_t): return Ctypes_arith_Uint64; case sizeof(int8_t): return Ctypes_arith_Int8; case sizeof(int16_t): return Ctypes_arith_Int16; case sizeof(int32_t): return Ctypes_arith_Int32; case sizeof(int64_t): return Ctypes_arith_Int64; default: assert(0); } } static inline const char *ctypes_arithmetic_type_name(enum ctypes_arithmetic_type t) { switch (t) { case Ctypes_arith_Int8: return "Int8"; case Ctypes_arith_Int16: return "Int16"; case Ctypes_arith_Int32: return "Int32"; case Ctypes_arith_Int64: return "Int64"; case Ctypes_arith_Uint8: return "Uint8"; case Ctypes_arith_Uint16: return "Uint16"; case Ctypes_arith_Uint32: return "Uint32"; case Ctypes_arith_Uint64: return "Uint64"; case Ctypes_arith_Float: return "Float"; case Ctypes_arith_Double: return "Double"; default: assert(0); } } #endif /* CTYPES_PRIMITIVES_H */ yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_ptr.ml000066400000000000000000000042221445631112600225660ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Boxed pointers to C memory locations . *) [@@@warning "-9"] module Raw = struct include Nativeint let of_nativeint x = x let to_nativeint x = x let null = zero end type voidp = Raw.t module Fat : sig (** A fat pointer, which holds a reference to the reference type, the C memory location, and an OCaml object. *) type (_,_) t (** [make ?managed ~reftyp raw] builds a fat pointer from the reference type [reftyp], the C memory location [raw], and (optionally) an OCaml value, [managed]. The [managed] argument may be used to manage the lifetime of the C object; a typical use it to attach a finaliser to [managed] which releases the memory associated with the C object whose address is stored in [raw_ptr]. *) val make : managed:'m -> reftyp:'typ -> voidp -> ('m,'typ) t val is_null : (_,_) t -> bool val reftype : (_,'typ) t -> 'typ val managed : ('m,_) t -> 'm val set_managed : ('m,_) t -> 'm -> unit val coerce : ('m,_) t -> 'typ -> ('m,'typ) t (** Return the raw pointer address. The function is unsafe in the sense that it dissociates the address from the value which manages the memory, which may trigger associated finalisers, invalidating the address. *) val unsafe_raw_addr : (_,_) t -> voidp val add_bytes : ('m,'typ) t -> int -> ('m,'typ) t val compare : (_,'typ) t -> (_,'typ) t -> int val diff_bytes : (_,'typ) t -> (_,'typ) t -> int end = struct type ('m, 'typ) t = { reftyp : 'typ; raw : voidp; mutable managed : 'm; } let make ~managed ~reftyp raw = { reftyp; raw; managed } let is_null { raw } = Raw.(compare zero) raw = 0 let reftype { reftyp } = reftyp let managed { managed } = managed let set_managed p m = p.managed <- m let coerce p reftyp = { p with reftyp } let unsafe_raw_addr { raw } = raw let add_bytes p bytes = { p with raw = Raw.(add p.raw (of_int bytes)) } let compare l r = Raw.compare l.raw r.raw let diff_bytes l r = Raw.(to_int (sub r.raw l.raw)) end yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_raw_pointer.h000066400000000000000000000010651445631112600241330ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef CTYPES_RAW_POINTER_STUBS_H #define CTYPES_RAW_POINTER_STUBS_H #include #include #include #define CTYPES_FROM_PTR(P) caml_copy_nativeint((intptr_t)P) #define CTYPES_TO_PTR(I) ((void *)Nativeint_val(I)) /* CTYPES_ADDR_OF_FATPTR : _ Ctypes_ptr.Fat.t -> void * */ #define CTYPES_ADDR_OF_FATPTR(P) CTYPES_TO_PTR(Field(P, 1)) #endif /* CTYPES_RAW_POINTER_STUBS_H */ yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_roots.c000066400000000000000000000014421445631112600227420ustar00rootroot00000000000000#include #include #include "ctypes_raw_pointer.h" /* 'a -> voidp */ value ctypes_caml_roots_create(value v) { value *p = caml_stat_alloc(sizeof *p); *p = v; caml_register_generational_global_root(p); return CTYPES_FROM_PTR(p); } /* voidp -> 'a -> unit */ value ctypes_caml_roots_set(value p_, value v) { value *p = CTYPES_TO_PTR(p_); caml_modify_generational_global_root(p, v); return Val_unit; } /* voidp -> 'a */ value ctypes_caml_roots_get(value p_) { value *p = CTYPES_TO_PTR(p_); return *p; } /* voidp -> unit */ value ctypes_caml_roots_release(value p_) { value *p = CTYPES_TO_PTR(p_); caml_remove_generational_global_root(p); caml_stat_free(p); return Val_unit; } /* 'a -> unit */ value ctypes_use(value v) { return Val_unit; } yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_roots_stubs.ml000066400000000000000000000006661445631112600243570ustar00rootroot00000000000000(* * Copyright (c) 2015 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) external root : 'a -> Ctypes_ptr.voidp = "ctypes_caml_roots_create" external set : Ctypes_ptr.voidp -> 'a -> unit = "ctypes_caml_roots_set" external get : Ctypes_ptr.voidp -> 'a = "ctypes_caml_roots_get" external release : Ctypes_ptr.voidp -> unit = "ctypes_caml_roots_release" yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_static.ml000066400000000000000000000240211445631112600232470ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* C type construction *) [@@@warning "-9"] exception IncompleteType exception ModifyingSealedType of string exception Unsupported of string let unsupported fmt = Printf.ksprintf (fun s -> raise (Unsupported s)) fmt type incomplete_size = { mutable isize: int } type structured_spec = { size: int; align: int; } type 'a structspec = Incomplete of incomplete_size | Complete of structured_spec type abstract_type = { aname : string; asize : int; aalignment : int; } type _ ocaml_type = String : string ocaml_type | Bytes : bytes ocaml_type | FloatArray : float array ocaml_type type _ typ = Void : unit typ | Primitive : 'a Ctypes_primitive_types.prim -> 'a typ | Pointer : 'a typ -> 'a ptr typ | Funptr : 'a fn -> 'a static_funptr typ | Struct : 'a structure_type -> 'a structure typ | Union : 'a union_type -> 'a union typ | Abstract : abstract_type -> 'a abstract typ | View : ('a, 'b) view -> 'a typ | Array : 'a typ * int -> 'a carray typ | Bigarray : (_, 'a, _) Ctypes_bigarray.t -> 'a typ | OCaml : 'a ocaml_type -> 'a ocaml typ and 'a carray = { astart : 'a ptr; alength : int } and ('a, 'kind) structured = { structured : ('a, 'kind) structured ptr } [@@unboxed] and 'a union = ('a, [`Union]) structured and 'a structure = ('a, [`Struct]) structured and 'a abstract = ('a, [`Abstract]) structured and (_, _) pointer = CPointer : (Obj.t option,'a typ) Ctypes_ptr.Fat.t -> ('a, [`C]) pointer | OCamlRef : int * 'a * 'a ocaml_type -> ('a, [`OCaml]) pointer and 'a ptr = ('a, [`C]) pointer and 'a ocaml = ('a, [`OCaml]) pointer and 'a static_funptr = Static_funptr : (Obj.t option, 'a fn) Ctypes_ptr.Fat.t -> 'a static_funptr and ('a, 'b) view = { read : 'b -> 'a; write : 'a -> 'b; format_typ: ((Format.formatter -> unit) -> Format.formatter -> unit) option; format: (Format.formatter -> 'a -> unit) option; ty: 'b typ; } and ('a, 's) field = { ftype: 'a typ; foffset: int; fname: string; } and 'a structure_type = { tag: string; mutable spec: 'a structspec; (* fields are in reverse order iff the struct type is incomplete *) mutable fields : 'a structure boxed_field list; } and 'a union_type = { utag: string; mutable uspec: structured_spec option; (* fields are in reverse order iff the union type is incomplete *) mutable ufields : 'a union boxed_field list; } and 's boxed_field = BoxedField : ('a, 's) field -> 's boxed_field and _ fn = | Returns : 'a typ -> 'a fn | Function : 'a typ * 'b fn -> ('a -> 'b) fn type _ bigarray_class = Genarray : < element: 'a; layout: 'l; dims: int array; ba_repr: 'b; bigarray: ('a, 'b, 'l) Bigarray_compat.Genarray.t; carray: 'a carray > bigarray_class | Array1 : < element: 'a; layout: 'l; dims: int; ba_repr: 'b; bigarray: ('a, 'b, 'l) Bigarray_compat.Array1.t; carray: 'a carray > bigarray_class | Array2 : < element: 'a; layout: 'l; dims: int * int; ba_repr: 'b; bigarray: ('a, 'b, 'l) Bigarray_compat.Array2.t; carray: 'a carray carray > bigarray_class | Array3 : < element: 'a; layout: 'l; dims: int * int * int; ba_repr: 'b; bigarray: ('a, 'b, 'l) Bigarray_compat.Array3.t; carray: 'a carray carray carray > bigarray_class type boxed_typ = BoxedType : 'a typ -> boxed_typ let rec sizeof : type a. a typ -> int = function Void -> raise IncompleteType | Primitive p -> Ctypes_primitives.sizeof p | Struct { spec = Incomplete _ } -> raise IncompleteType | Struct { spec = Complete { size } } -> size | Union { uspec = None } -> raise IncompleteType | Union { uspec = Some { size } } -> size | Array (t, i) -> i * sizeof t | Bigarray ba -> Ctypes_bigarray.sizeof ba | Abstract { asize } -> asize | Pointer _ -> Ctypes_primitives.pointer_size | Funptr _ -> Ctypes_primitives.pointer_size | OCaml _ -> raise IncompleteType | View { ty } -> sizeof ty let rec alignment : type a. a typ -> int = function Void -> raise IncompleteType | Primitive p -> Ctypes_primitives.alignment p | Struct { spec = Incomplete _ } -> raise IncompleteType | Struct { spec = Complete { align } } -> align | Union { uspec = None } -> raise IncompleteType | Union { uspec = Some { align } } -> align | Array (t, _) -> alignment t | Bigarray ba -> Ctypes_bigarray.alignment ba | Abstract { aalignment } -> aalignment | Pointer _ -> Ctypes_primitives.pointer_alignment | Funptr _ -> Ctypes_primitives.pointer_alignment | OCaml _ -> raise IncompleteType | View { ty } -> alignment ty let rec passable : type a. a typ -> bool = function Void -> true | Primitive _ -> true | Struct { spec = Incomplete _ } -> raise IncompleteType | Struct { spec = Complete _ } -> true | Union { uspec = None } -> raise IncompleteType | Union { uspec = Some _ } -> true | Array _ -> false | Bigarray _ -> false | Pointer _ -> true | Funptr _ -> true | Abstract _ -> false | OCaml _ -> true | View { ty } -> passable ty (* Whether a value resides in OCaml-managed memory. Values that reside in OCaml memory cannot be accessed when the runtime lock is not held. *) let rec ocaml_value : type a. a typ -> bool = function Void -> false | Primitive _ -> false | Struct _ -> false | Union _ -> false | Array _ -> false | Bigarray _ -> false | Pointer _ -> false | Funptr _ -> false | Abstract _ -> false | OCaml _ -> true | View { ty } -> ocaml_value ty let rec has_ocaml_argument : type a. a fn -> bool = function Returns _ -> false | Function (t, _) when ocaml_value t -> true | Function (_, t) -> has_ocaml_argument t let void = Void let char = Primitive Ctypes_primitive_types.Char let schar = Primitive Ctypes_primitive_types.Schar let float = Primitive Ctypes_primitive_types.Float let double = Primitive Ctypes_primitive_types.Double let ldouble = Primitive Ctypes_primitive_types.LDouble let complex32 = Primitive Ctypes_primitive_types.Complex32 let complex64 = Primitive Ctypes_primitive_types.Complex64 let complexld = Primitive Ctypes_primitive_types.Complexld let short = Primitive Ctypes_primitive_types.Short let int = Primitive Ctypes_primitive_types.Int let sint = Primitive Ctypes_primitive_types.Sint let long = Primitive Ctypes_primitive_types.Long let llong = Primitive Ctypes_primitive_types.Llong let nativeint = Primitive Ctypes_primitive_types.Nativeint let int8_t = Primitive Ctypes_primitive_types.Int8_t let int16_t = Primitive Ctypes_primitive_types.Int16_t let int32_t = Primitive Ctypes_primitive_types.Int32_t let int64_t = Primitive Ctypes_primitive_types.Int64_t let camlint = Primitive Ctypes_primitive_types.Camlint let uchar = Primitive Ctypes_primitive_types.Uchar let bool = Primitive Ctypes_primitive_types.Bool let uint8_t = Primitive Ctypes_primitive_types.Uint8_t let uint16_t = Primitive Ctypes_primitive_types.Uint16_t let uint32_t = Primitive Ctypes_primitive_types.Uint32_t let uint64_t = Primitive Ctypes_primitive_types.Uint64_t let size_t = Primitive Ctypes_primitive_types.Size_t let ushort = Primitive Ctypes_primitive_types.Ushort let uint = Primitive Ctypes_primitive_types.Uint let ulong = Primitive Ctypes_primitive_types.Ulong let ullong = Primitive Ctypes_primitive_types.Ullong let array i t = Array (t, i) let ocaml_string = OCaml String let ocaml_bytes = OCaml Bytes let ocaml_float_array = OCaml FloatArray let ptr t = Pointer t let ( @->) f t = if not (passable f) then raise (Unsupported "Unsupported argument type") else Function (f, t) let abstract ~name ~size ~alignment = Abstract { aname = name; asize = size; aalignment = alignment } let view ?format_typ ?format ~read ~write ty = View { read; write; format_typ; format; ty } let id v = v let typedef old name = view ~format_typ:(fun k fmt -> Format.fprintf fmt "%s%t" name k) ~read:id ~write:id old let bigarray_ : type a b c d e l. < element: a; layout: l; dims: b; ba_repr: c; bigarray: d; carray: e > bigarray_class -> b -> (a, c) Bigarray_compat.kind -> l Bigarray_compat.layout -> d typ = fun spec dims kind l -> match spec with | Genarray -> Bigarray (Ctypes_bigarray.bigarray dims kind l) | Array1 -> Bigarray (Ctypes_bigarray.bigarray1 dims kind l) | Array2 -> let d1, d2 = dims in Bigarray (Ctypes_bigarray.bigarray2 d1 d2 kind l) | Array3 -> let d1, d2, d3 = dims in Bigarray (Ctypes_bigarray.bigarray3 d1 d2 d3 kind l) let bigarray spec c k = bigarray_ spec c k Bigarray_compat.c_layout let fortran_bigarray spec c k = bigarray_ spec c k Bigarray_compat.fortran_layout let returning v = if not (passable v) then raise (Unsupported "Unsupported return type") else Returns v let static_funptr fn = Funptr fn let structure tag = Struct { spec = Incomplete { isize = 0 }; tag; fields = [] } let union utag = Union { utag; uspec = None; ufields = [] } let offsetof { foffset } = foffset let field_type { ftype } = ftype let field_name { fname } = fname (* This corresponds to the enum in ctypes_primitives.h *) type arithmetic = Int8 | Int16 | Int32 | Int64 | Uint8 | Uint16 | Uint32 | Uint64 | Float | Double yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_static.mli000066400000000000000000000141001445631112600234150ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* C type construction. Internal representation, not for public use. *) type abstract_type = { aname : string; asize : int; aalignment : int; } type _ ocaml_type = String : string ocaml_type | Bytes : bytes ocaml_type | FloatArray : float array ocaml_type type incomplete_size = { mutable isize: int } type structured_spec = { size: int; align: int; } type 'a structspec = Incomplete of incomplete_size | Complete of structured_spec type _ typ = Void : unit typ | Primitive : 'a Ctypes_primitive_types.prim -> 'a typ | Pointer : 'a typ -> 'a ptr typ | Funptr : 'a fn -> 'a static_funptr typ | Struct : 'a structure_type -> 'a structure typ | Union : 'a union_type -> 'a union typ | Abstract : abstract_type -> 'a abstract typ | View : ('a, 'b) view -> 'a typ | Array : 'a typ * int -> 'a carray typ | Bigarray : (_, 'a, _) Ctypes_bigarray.t -> 'a typ | OCaml : 'a ocaml_type -> 'a ocaml typ and 'a carray = { astart : 'a ptr; alength : int } and ('a, 'kind) structured = { structured : ('a, 'kind) structured ptr } [@@unboxed] and 'a union = ('a, [`Union]) structured and 'a structure = ('a, [`Struct]) structured and 'a abstract = ('a, [`Abstract]) structured and (_, _) pointer = CPointer : (Obj.t option,'a typ) Ctypes_ptr.Fat.t -> ('a, [`C]) pointer | OCamlRef : int * 'a * 'a ocaml_type -> ('a, [`OCaml]) pointer and 'a ptr = ('a, [`C]) pointer and 'a ocaml = ('a, [`OCaml]) pointer and 'a static_funptr = Static_funptr : (Obj.t option, 'a fn) Ctypes_ptr.Fat.t -> 'a static_funptr and ('a, 'b) view = { read : 'b -> 'a; write : 'a -> 'b; format_typ: ((Format.formatter -> unit) -> Format.formatter -> unit) option; format: (Format.formatter -> 'a -> unit) option; ty: 'b typ; } and ('a, 's) field = { ftype: 'a typ; foffset: int; fname: string; } and 'a structure_type = { tag: string; mutable spec: 'a structspec; mutable fields : 'a structure boxed_field list; } and 'a union_type = { utag: string; mutable uspec: structured_spec option; mutable ufields : 'a union boxed_field list; } and 's boxed_field = BoxedField : ('a, 's) field -> 's boxed_field and _ fn = | Returns : 'a typ -> 'a fn | Function : 'a typ * 'b fn -> ('a -> 'b) fn type _ bigarray_class = Genarray : < element: 'a; layout: 'l; dims: int array; ba_repr: 'b; bigarray: ('a, 'b, 'l) Bigarray_compat.Genarray.t; carray: 'a carray > bigarray_class | Array1 : < element: 'a; layout: 'l; dims: int; ba_repr: 'b; bigarray: ('a, 'b, 'l) Bigarray_compat.Array1.t; carray: 'a carray > bigarray_class | Array2 : < element: 'a; layout: 'l; dims: int * int; ba_repr: 'b; bigarray: ('a, 'b, 'l) Bigarray_compat.Array2.t; carray: 'a carray carray > bigarray_class | Array3 : < element: 'a; layout: 'l; dims: int * int * int; ba_repr: 'b; bigarray: ('a, 'b, 'l) Bigarray_compat.Array3.t; carray: 'a carray carray carray > bigarray_class type boxed_typ = BoxedType : 'a typ -> boxed_typ val sizeof : 'a typ -> int val alignment : 'a typ -> int val passable : 'a typ -> bool val ocaml_value : 'a typ -> bool val has_ocaml_argument : 'a fn -> bool val void : unit typ val char : char typ val schar : int typ val float : float typ val double : float typ val ldouble : LDouble.t typ val complex32 : Complex.t typ val complex64 : Complex.t typ val complexld : ComplexL.t typ val short : int typ val int : int typ val sint : Signed.sint typ val long : Signed.long typ val llong : Signed.llong typ val nativeint : nativeint typ val int8_t : int typ val int16_t : int typ val int32_t : Signed.Int32.t typ val int64_t : Signed.Int64.t typ val camlint : int typ val uchar : Unsigned.uchar typ val bool : bool typ val uint8_t : Unsigned.UInt8.t typ val uint16_t : Unsigned.UInt16.t typ val uint32_t : Unsigned.UInt32.t typ val uint64_t : Unsigned.UInt64.t typ val size_t : Unsigned.size_t typ val ushort : Unsigned.ushort typ val uint : Unsigned.uint typ val ulong : Unsigned.ulong typ val ullong : Unsigned.ullong typ val array : int -> 'a typ -> 'a carray typ val ocaml_string : string ocaml typ val ocaml_bytes : bytes ocaml typ val ocaml_float_array : float array ocaml typ val ptr : 'a typ -> 'a ptr typ val ( @-> ) : 'a typ -> 'b fn -> ('a -> 'b) fn val abstract : name:string -> size:int -> alignment:int -> 'a abstract typ val view : ?format_typ:((Format.formatter -> unit) -> Format.formatter -> unit) -> ?format: (Format.formatter -> 'b -> unit) -> read:('a -> 'b) -> write:('b -> 'a) -> 'a typ -> 'b typ val typedef: 'a typ -> string -> 'a typ val bigarray : < ba_repr : 'c; bigarray : 'd; carray : 'e; dims : 'b; layout: Bigarray_compat.c_layout; element : 'a > bigarray_class -> 'b -> ('a, 'c) Bigarray_compat.kind -> 'd typ val fortran_bigarray : < ba_repr : 'c; bigarray : 'd; carray : 'e; dims : 'b; layout: Bigarray_compat.fortran_layout; element : 'a > bigarray_class -> 'b -> ('a, 'c) Bigarray_compat.kind -> 'd typ val returning : 'a typ -> 'a fn val static_funptr : 'a fn -> 'a static_funptr typ val structure : string -> 'a structure typ val union : string -> 'a union typ val offsetof : ('a, 'b) field -> int val field_type : ('a, 'b) field -> 'a typ val field_name : ('a, 'b) field -> string exception IncompleteType exception ModifyingSealedType of string exception Unsupported of string val unsupported : ('a, unit, string, _) format4 -> 'a (* This corresponds to the enum in ctypes_primitives.h *) type arithmetic = Int8 | Int16 | Int32 | Int64 | Uint8 | Uint16 | Uint32 | Uint64 | Float | Double yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_std_view_stubs.ml000066400000000000000000000014411445631112600250250ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stubs for standard views. *) (* Convert a C string to an OCaml string *) external string_of_cstring : (_, char Ctypes_static.typ) Ctypes_ptr.Fat.t -> string = "ctypes_string_of_cstring" (* Convert an OCaml string to a C string *) external cstring_of_string : string -> Ctypes_memory_stubs.managed_buffer = "ctypes_cstring_of_string" (* Size information for uintptr_t *) external uintptr_t_size : unit -> int = "integers_uintptr_t_size" (* Size information for uintptr_t *) external intptr_t_size : unit -> int = "integers_intptr_t_size" (* Size information for ptrdiff_t *) external ptrdiff_t_size : unit -> int = "integers_ptrdiff_t_size" yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_std_views.ml000066400000000000000000000072751445631112600240030ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) let string_of_char_ptr (Ctypes_static.CPointer p) = Ctypes_std_view_stubs.string_of_cstring p let char_ptr_of_string s = let p = Ctypes_std_view_stubs.cstring_of_string s in Ctypes_static.CPointer (Ctypes_ptr.Fat.make ~managed:(Some (Obj.repr p)) ~reftyp:Ctypes_static.char (Ctypes_memory_stubs.block_address p)) let string = Ctypes_static.(view (ptr char)) ~read:string_of_char_ptr ~write:char_ptr_of_string let read_nullable t reftyp = let coerce = Ctypes_coerce.coerce Ctypes_static.(ptr reftyp) t in fun p -> if Ctypes_memory.is_null p then None else Some (coerce p) let write_nullable t reftyp = let coerce = Ctypes_coerce.coerce t Ctypes_static.(ptr reftyp) in Ctypes_memory.(function None -> from_voidp reftyp null | Some f -> coerce f) let nullable_view ?format_typ ?format t reftyp = let read = read_nullable t reftyp and write = write_nullable t reftyp in Ctypes_static.(view ~read ~write ?format_typ ?format (ptr reftyp)) let read_nullable_funptr t reftyp = let coerce = Ctypes_coerce.coerce (Ctypes_static.static_funptr reftyp) t in fun (Ctypes_static.Static_funptr p as ptr) -> if Ctypes_ptr.Fat.is_null p then None else Some (coerce ptr) let write_nullable_funptr t reftyp = let coerce = Ctypes_coerce.coerce t Ctypes_static.(static_funptr reftyp) in function None -> Ctypes_static.Static_funptr (Ctypes_ptr.Fat.make ~managed:None ~reftyp Ctypes_ptr.Raw.null) | Some f -> coerce f let nullable_funptr_view ?format_typ ?format t reftyp = let read = read_nullable_funptr t reftyp and write = write_nullable_funptr t reftyp in Ctypes_static.(view ~read ~write ?format_typ ?format (static_funptr reftyp)) let ptr_opt t = nullable_view (Ctypes_static.ptr t) t let string_opt = nullable_view string Ctypes_static.char module type Signed_type = sig include Signed.S val t : t Ctypes_static.typ end module type Unsigned_type = sig include Unsigned.S val t : t Ctypes_static.typ end let signed_typedef name ~size : (module Signed_type) = match size with 1 -> (module struct include Signed.Int let t = Ctypes_static.(typedef int8_t name) end) | 2 -> (module struct include Signed.Int let t = Ctypes_static.(typedef int16_t name) end) | 4 -> (module struct include Signed.Int32 let t = Ctypes_static.(typedef int32_t name) end) | 8 -> (module struct include Signed.Int64 let t = Ctypes_static.(typedef int64_t name) end) | n -> Printf.ksprintf failwith "size %d not supported for %s\n" n name let unsigned_typedef name ~size : (module Unsigned_type) = match size with | 1 -> (module struct include Unsigned.UInt8 let t = Ctypes_static.(typedef uint8_t name) end) | 2 -> (module struct include Unsigned.UInt16 let t = Ctypes_static.(typedef uint16_t name) end) | 4 -> (module struct include Unsigned.UInt32 let t = Ctypes_static.(typedef uint32_t name) end) | 8 -> (module struct include Unsigned.UInt64 let t = Ctypes_static.(typedef uint64_t name) end) | n -> Printf.ksprintf failwith "size %d not supported for %s\n" n name module Intptr = (val signed_typedef "intptr_t" ~size:(Ctypes_std_view_stubs.intptr_t_size ())) module Uintptr = (val unsigned_typedef "uintptr_t" ~size:(Ctypes_std_view_stubs.uintptr_t_size ())) let intptr_t = Intptr.t let uintptr_t = Uintptr.t module Ptrdiff = (val signed_typedef "ptrdiff_t" ~size:(Ctypes_std_view_stubs.ptrdiff_t_size ())) let ptrdiff_t = Ptrdiff.t yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_structs.ml000066400000000000000000000006301445631112600234670ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes_static module type S = sig type (_, _) field val field : 't typ -> string -> 'a typ -> ('a, (('s, [<`Struct | `Union]) structured as 't)) field val seal : (_, [< `Struct | `Union]) Ctypes_static.structured Ctypes_static.typ -> unit end yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_structs.mli000066400000000000000000000006301445631112600236400ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes_static module type S = sig type (_, _) field val field : 't typ -> string -> 'a typ -> ('a, (('s, [<`Struct | `Union]) structured as 't)) field val seal : (_, [< `Struct | `Union]) Ctypes_static.structured Ctypes_static.typ -> unit end yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_structs_computed.ml000066400000000000000000000044521445631112600253750ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@warning "-9"] open Ctypes_static let max_field_alignment fields = List.fold_left (fun align (BoxedField {ftype}) -> max align (alignment ftype)) 0 fields let max_field_size fields = List.fold_left (fun size (BoxedField {ftype}) -> max size (sizeof ftype)) 0 fields let aligned_offset offset alignment = match offset mod alignment with 0 -> offset | overhang -> offset - overhang + alignment let rec field : type t a. t typ -> string -> a typ -> (a, t) field = fun structured label ftype -> match structured with | Struct ({ spec = Incomplete spec } as s) -> let foffset = aligned_offset spec.isize (alignment ftype) in let field = { ftype; foffset; fname = label } in begin spec.isize <- foffset + sizeof ftype; s.fields <- BoxedField field :: s.fields; field end | Union ({ uspec = None } as u) -> let field = { ftype; foffset = 0; fname = label } in u.ufields <- BoxedField field :: u.ufields; field | Struct { tag; spec = Complete _ } -> raise (ModifyingSealedType tag) | Union { utag } -> raise (ModifyingSealedType utag) | View { ty } -> let { ftype; foffset; fname } = field ty label ftype in { ftype; foffset; fname } | _ -> raise (Unsupported "Adding a field to non-structured type") let rec seal : type a. a typ -> unit = function | Struct { fields = [] } -> raise (Unsupported "struct with no fields") | Struct { spec = Complete _; tag } -> raise (ModifyingSealedType tag) | Struct ({ spec = Incomplete { isize } } as s) -> s.fields <- List.rev s.fields; let align = max_field_alignment s.fields in let size = aligned_offset isize align in s.spec <- Complete { (* sraw_io; *)size; align } | Union { utag; uspec = Some _ } -> raise (ModifyingSealedType utag) | Union { ufields = [] } -> raise (Unsupported "union with no fields") | Union u -> begin u.ufields <- List.rev u.ufields; let size = max_field_size u.ufields and align = max_field_alignment u.ufields in u.uspec <- Some { align; size = aligned_offset size align } end | View { ty } -> seal ty | _ -> raise (Unsupported "Sealing a non-structured type") yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_structs_computed.mli000066400000000000000000000005551445631112600255460ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** Structs and unions whose layouts are computed from the sizes and alignment requirements of the constituent field types. *) include Ctypes_structs.S with type ('a, 's) field := ('a, 's) Ctypes_static.field yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_type_info_stubs.h000066400000000000000000000011041445631112600250100ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef CTYPES_TYPE_INFO_STUBS_H #define CTYPES_TYPE_INFO_STUBS_H #include /* Read a C value from a block of memory */ /* read : 'a prim -> raw_pointer -> 'a */ extern value ctypes_read(value ctype, value buffer); /* Write a C value to a block of memory */ /* write : 'a prim -> 'a -> raw_pointer -> unit */ extern value ctypes_write(value ctype, value v, value buffer); #endif /* CTYPES_TYPE_INFO_STUBS_H */ yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_type_printing.ml000066400000000000000000000110231445631112600246510ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@warning "-9-27"] open Ctypes_static (* See type_printing.mli for the documentation of [format context]. *) type format_context = [ `toplevel | `array | `nonarray ] let rec format_typ' : type a. a typ -> (format_context -> Format.formatter -> unit) -> (format_context -> Format.formatter -> unit) = let fprintf = Format.fprintf in fun t k context fmt -> match t with | Void -> fprintf fmt "void%t" (k `nonarray) | Primitive p -> let name = Ctypes_primitives.name p in fprintf fmt "%s%t" name (k `nonarray) | View { format_typ = Some format } -> format (k `nonarray) fmt | View { ty } -> format_typ' ty k context fmt | Abstract { aname } -> fprintf fmt "%s%t" aname (k `nonarray) | Struct { tag = "" ; fields } -> fprintf fmt "struct {@;<1 2>@["; format_fields fields fmt; fprintf fmt "@]@;}%t" (k `nonarray) | Struct { tag ; spec; fields } -> begin match spec, context with | Complete _, `toplevel -> begin fprintf fmt "struct %s {@;<1 2>@[" tag; format_fields fields fmt; fprintf fmt "@]@;}%t" (k `nonarray) end | _ -> fprintf fmt "struct %s%t" tag (k `nonarray) end | Union { utag = ""; ufields } -> fprintf fmt "union {@;<1 2>@["; format_fields ufields fmt; fprintf fmt "@]@;}%t" (k `nonarray) | Union { utag; uspec; ufields } -> begin match uspec, context with | Some _, `toplevel -> begin fprintf fmt "union %s {@;<1 2>@[" utag; format_fields ufields fmt; fprintf fmt "@]@;}%t" (k `nonarray) end | _ -> fprintf fmt "union %s%t" utag (k `nonarray) end | Pointer ty -> format_typ' ty (fun context fmt -> match context with | `array -> fprintf fmt "(*%t)" (k `nonarray) | _ -> fprintf fmt "*%t" (k `nonarray)) `nonarray fmt | Funptr fn -> format_fn' fn (fun fmt -> Format.fprintf fmt "(*%t)" (k `nonarray)) fmt | Array (ty, n) -> format_typ' ty (fun _ fmt -> fprintf fmt "%t[%d]" (k `array) n) `nonarray fmt | Bigarray ba -> let elem = Ctypes_bigarray.element_type ba and dims = Ctypes_bigarray.dimensions ba in let name = Ctypes_primitives.name elem in fprintf fmt "%s%t%t" name (k `array) (fun fmt -> (Array.iter (Format.fprintf fmt "[%d]") dims)) | OCaml String -> format_typ' (ptr char) k context fmt | OCaml Bytes -> format_typ' (ptr uchar) k context fmt | OCaml FloatArray -> format_typ' (ptr double) k context fmt and format_fields : type a. a boxed_field list -> Format.formatter -> unit = fun fields fmt -> let open Format in List.iteri (fun i (BoxedField {ftype=t; fname}) -> fprintf fmt "@["; format_typ' t (fun _ fmt -> fprintf fmt " %s" fname) `nonarray fmt; fprintf fmt "@];@;") fields and format_parameter_list parameters k fmt = Format.fprintf fmt "%t(@[@[" k; if parameters = [] then Format.fprintf fmt "void" else List.iteri (fun i (BoxedType t) -> if i <> 0 then Format.fprintf fmt "@], @["; format_typ' t (fun _ _ -> ()) `nonarray fmt) parameters; Format.fprintf fmt "@]@])" and format_fn' : 'a. 'a fn -> (Format.formatter -> unit) -> (Format.formatter -> unit) = let rec gather : type a. a fn -> boxed_typ list * boxed_typ = function | Returns ty -> [], BoxedType ty | Function (Void, fn) -> gather fn | Function (p, fn) -> let ps, r = gather fn in BoxedType p :: ps, r in fun fn k fmt -> let ps, BoxedType r = gather fn in format_typ' r (fun context fmt -> format_parameter_list ps k fmt) `nonarray fmt let format_name ?name fmt = match name with | Some name -> Format.fprintf fmt " %s" name | None -> () let format_typ : ?name:string -> Format.formatter -> 'a typ -> unit = fun ?name fmt typ -> Format.fprintf fmt "@["; format_typ' typ (fun context -> format_name ?name) `toplevel fmt; Format.fprintf fmt "@]" let format_fn : ?name:string -> Format.formatter -> 'a fn -> unit = fun ?name fmt fn -> Format.fprintf fmt "@["; format_fn' fn (format_name ?name) fmt; Format.fprintf fmt "@]" let string_of_typ ?name ty = Format.asprintf "%a" (format_typ ?name) ty let string_of_fn ?name fn = Format.asprintf "%a" (format_fn ?name) fn yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_type_printing.mli000066400000000000000000000026771445631112600250410ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes_static (* The format context affects the formatting of pointer, struct and union types. There are three printing contexts: *) type format_context = [ (* In the top-level context struct and union types are printed in full, with member lists. Pointer types are unparenthesized; for example, pointer-to-void is printed as "void *", not as "void ( * )". *) | `toplevel (* In the array context, struct and union types are printed in abbreviated form, which consists of just a keyword and the tag name. Pointer types are parenthesized; for example, pointer-to-array-of-int is printed as "int ( * )[]", not as "int *[]". *) | `array (* In the non-array context, struct and union types are printed in abbreviated form and pointer types are unparenthesized. *) | `nonarray] val format_name : ?name:string -> Format.formatter -> unit val format_typ' : 'a Ctypes_static.typ -> (format_context -> Format.formatter -> unit) -> format_context -> Format.formatter -> unit val format_typ : ?name:string -> Format.formatter -> 'a typ -> unit val format_fn' : 'a fn -> (Format.formatter -> unit) -> Format.formatter -> unit val format_fn : ?name:string -> Format.formatter -> 'a fn -> unit val string_of_typ : ?name:string -> 'a typ -> string val string_of_fn : ?name:string -> 'a fn -> string yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_types.mli000066400000000000000000000322121445631112600232760ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Signed open Unsigned (** Abstract interface to C object type descriptions *) module type TYPE = sig (** {2:types Values representing C types} *) type 'a typ (** The type of values representing C types. There are two types associated with each [typ] value: the C type used to store and pass values, and the corresponding OCaml type. The type parameter indicates the OCaml type, so a value of type [t typ] is used to read and write OCaml values of type [t]. There are various uses of [typ] values, including - constructing function types for binding native functions using {!Foreign.foreign} - constructing pointers for reading and writing locations in C-managed storage using {!ptr} - describing the fields of structured types built with {!structure} and {!union}. *) (** {3 The void type} *) val void : unit typ (** Value representing the C void type. Void values appear in OCaml as the unit type, so using void in an argument or result type specification produces a function which accepts or returns unit. Dereferencing a pointer to void is an error, as in C, and will raise {!IncompleteType}. *) (** {3 Scalar types} The scalar types consist of the {!arithmetic_types} and the {!pointer_types}. *) (** {4:arithmetic_types Arithmetic types} The arithmetic types consist of the signed and unsigned integer types (including character types) and the floating types. There are values representing both exact-width integer types (of 8, 16, 32 and 64 bits) and types whose size depend on the platform (signed and unsigned short, int, long, long long). *) val char : char typ (** Value representing the C type [char]. *) (** {5 Signed integer types} *) val schar : int typ (** Value representing the C type [signed char]. *) val short : int typ (** Value representing the C type ([signed]) [short]. *) val int : int typ (** Value representing the C type ([signed]) [int]. *) val long : long typ (** Value representing the C type ([signed]) [long]. *) val llong : llong typ (** Value representing the C type ([signed]) [long long]. *) val nativeint : nativeint typ (** Value representing the C type ([signed]) [int]. *) val int8_t : int typ (** Value representing an 8-bit signed integer C type. *) val int16_t : int typ (** Value representing a 16-bit signed integer C type. *) val int32_t : int32 typ (** Value representing a 32-bit signed integer C type. *) val int64_t : int64 typ (** Value representing a 64-bit signed integer C type. *) module Intptr : Signed.S val intptr_t : Intptr.t typ (** Value representing the C type [intptr_t]. *) module Ptrdiff : Signed.S val ptrdiff_t : Ptrdiff.t typ (** Value representing the C type [ptrdiff_t]. *) val camlint : int typ (** Value representing an integer type with the same storage requirements as an OCaml [int]. *) (** {5 Unsigned integer types} *) val uchar : uchar typ (** Value representing the C type [unsigned char]. *) val bool : bool typ (** Value representing the C type [bool]. *) val uint8_t : uint8 typ (** Value representing an 8-bit unsigned integer C type. *) val uint16_t : uint16 typ (** Value representing a 16-bit unsigned integer C type. *) val uint32_t : uint32 typ (** Value representing a 32-bit unsigned integer C type. *) val uint64_t : uint64 typ (** Value representing a 64-bit unsigned integer C type. *) val size_t : size_t typ (** Value representing the C type [size_t], an alias for one of the unsigned integer types. The actual size and alignment requirements for [size_t] vary between platforms. *) val ushort : ushort typ (** Value representing the C type [unsigned short]. *) val sint : sint typ (** Value representing the C type [int]. *) val uint : uint typ (** Value representing the C type [unsigned int]. *) val ulong : ulong typ (** Value representing the C type [unsigned long]. *) val ullong : ullong typ (** Value representing the C type [unsigned long long]. *) module Uintptr : Unsigned.S val uintptr_t : Uintptr.t typ (** Value representing the C type [uintptr_t]. *) (** {5 Floating types} *) val float : float typ (** Value representing the C single-precision [float] type. *) val double : float typ (** Value representing the C type [double]. *) val ldouble : LDouble.t typ (** Value representing the C type [long double]. *) (** {5 Complex types} *) val complex32 : Complex.t typ (** Value representing the C99 single-precision [float complex] type. *) val complex64 : Complex.t typ (** Value representing the C99 double-precision [double complex] type. *) val complexld : ComplexL.t typ (** Value representing the C99 long-double-precision [long double complex] type. *) (** {4:pointer_types Pointer types} *) (** {5 C-compatible pointers} *) val ptr : 'a typ -> 'a Ctypes_static.ptr typ (** Construct a pointer type from an existing type (called the {i reference type}). *) val ptr_opt : 'a typ -> 'a Ctypes_static.ptr option typ (** Construct a pointer type from an existing type (called the {i reference type}). This behaves like {!ptr}, except that null pointers appear in OCaml as [None]. *) val string : string typ (** A high-level representation of the string type. On the C side this behaves like [char *]; on the OCaml side values read and written using {!string} are simply native OCaml strings. To avoid problems with the garbage collector, values passed using {!string} are copied into immovable C-managed storage before being passed to C. When the memory is not owned by the C code, -- i.e. when creating or initializing a struct in OCaml before passing it to C -- then the {!string} view isn't a good choice, because there's no way to manage the lifetime of the C copy of the generated OCaml string. *) val string_opt : string option typ (** A high-level representation of the string type. This behaves like {!string}, except that null pointers appear in OCaml as [None]. *) (** {5 OCaml pointers} *) val ocaml_string : string Ctypes_static.ocaml typ (** Value representing the directly mapped storage of an OCaml string. *) val ocaml_bytes : bytes Ctypes_static.ocaml typ (** Value representing the directly mapped storage of an OCaml byte array. *) (** {3 Array types} *) (** {4 C array types} *) val array : int -> 'a typ -> 'a Ctypes_static.carray typ (** Construct a sized array type from a length and an existing type (called the {i element type}). *) (** {4 Bigarray types} *) val bigarray : < element: 'a; layout: Bigarray_compat.c_layout; ba_repr: 'b; dims: 'dims; bigarray: 'bigarray; carray: _ > Ctypes_static.bigarray_class -> 'dims -> ('a, 'b) Bigarray_compat.kind -> 'bigarray typ (** Construct a sized C-layout bigarray type representation from a bigarray class, the dimensions, and the {!Bigarray_compat.kind}. *) val fortran_bigarray : < element: 'a; layout: Bigarray_compat.fortran_layout; ba_repr: 'b; dims: 'dims; bigarray: 'bigarray; carray: _ > Ctypes_static.bigarray_class -> 'dims -> ('a, 'b) Bigarray_compat.kind -> 'bigarray typ (** Construct a sized Fortran-layout bigarray type representation from a bigarray class, the dimensions, and the {!Bigarray_compat.kind}. *) val typ_of_bigarray_kind : ('a, 'b) Bigarray_compat.kind -> 'a typ (** [typ_of_bigarray_kind k] is the type corresponding to the Bigarray kind [k]. *) (** {3 Struct and union types} *) type ('a, 't) field val structure : string -> 's Ctypes_static.structure typ (** Construct a new structure type. The type value returned is incomplete and can be updated using {!field} until it is passed to {!seal}, at which point the set of fields is fixed. The type (['_s structure typ]) of the expression returned by the call [structure tag] includes a weak type variable, which can be explicitly instantiated to ensure that the OCaml values representing different C structure types have incompatible types. Typical usage is as follows: [type tagname] [let tagname : tagname structure typ = structure "tagname"] *) val union : string -> 's Ctypes_static.union typ (** Construct a new union type. This behaves analogously to {!structure}; fields are added with {!field}. *) val field : 't typ -> string -> 'a typ -> ('a, (('s, [<`Struct | `Union]) Ctypes_static.structured as 't)) field (** [field ty label ty'] adds a field of type [ty'] with label [label] to the structure or union type [ty] and returns a field value that can be used to read and write the field in structure or union instances (e.g. using {!getf} and {!setf}). Attempting to add a field to a union type that has been sealed with [seal] is an error, and will raise {!ModifyingSealedType}. *) val seal : (_, [< `Struct | `Union]) Ctypes_static.structured typ -> unit (** [seal t] completes the struct or union type [t] so that no further fields can be added. Struct and union types must be sealed before they can be used in a way that involves their size or alignment; see the documentation for {!IncompleteType} for further details. *) (** {3 View types} *) val view : ?format_typ:((Format.formatter -> unit) -> Format.formatter -> unit) -> ?format:(Format.formatter -> 'b -> unit) -> read:('a -> 'b) -> write:('b -> 'a) -> 'a typ -> 'b typ (** [view ~read:r ~write:w t] creates a C type representation [t'] which behaves like [t] except that values read using [t'] are subsequently transformed using the function [r] and values written using [t'] are first transformed using the function [w]. For example, given suitable definitions of [string_of_char_ptr] and [char_ptr_of_string], the type representation [view ~read:string_of_char_ptr ~write:char_ptr_of_string (ptr char)] can be used to pass OCaml strings directly to and from bound C functions, or to read and write string members in structs and arrays. (In fact, the {!string} type representation is defined in exactly this way.) The optional argument [format_typ] is used by the {!Ctypes.format_typ} and {!string_of_typ} functions to print the type at the top level and elsewhere. If [format_typ] is not supplied the printer for [t] is used instead. The optional argument [format] is used by the {!Ctypes.format} and {!string_of} functions to print the values. If [format_val] is not supplied the printer for [t] is used instead. *) val typedef : 'a typ -> string -> 'a typ (** [typedef t name] creates a C type representation [t'] which is equivalent to [t] except its name is printed as [name]. This is useful when generating C stubs involving "anonymous" types, for example: [typedef struct { int f } typedef_name;] *) (** {3 Abstract types} *) val abstract : name:string -> size:int -> alignment:int -> 'a Ctypes_static.abstract typ (** Create an abstract type specification from the size and alignment requirements for the type. *) (** {3 Injection of concrete types} *) val lift_typ : 'a Ctypes_static.typ -> 'a typ (** [lift_typ t] turns a concrete type representation into an abstract type representation. For example, retrieving struct layout from C involves working with an abstract representation of types which do not support operations such as [sizeof]. The [lift_typ] function makes it possible to use concrete type representations wherever such abstract type representations are needed. *) (** {3 Function types} *) (** Abstract interface to C function type descriptions *) type 'a fn = 'a Ctypes_static.fn (** The type of values representing C function types. A value of type [t fn] can be used to bind to C functions and to describe type of OCaml functions passed to C. *) val ( @-> ) : 'a typ -> 'b fn -> ('a -> 'b) fn (** Construct a function type from a type and an existing function type. This corresponds to prepending a parameter to a C function parameter list. For example, [int @-> ptr void @-> returning float] describes a function type that accepts two arguments -- an integer and a pointer to void -- and returns a float. *) val returning : 'a typ -> 'a fn (** Give the return type of a C function. Note that [returning] is intended to be used together with {!(@->)}; see the documentation for {!(@->)} for an example. *) (** {3 Function pointer types} *) type 'a static_funptr = 'a Ctypes_static.static_funptr (** The type of values representing C function pointer types. *) val static_funptr : 'a fn -> 'a Ctypes_static.static_funptr typ (** Construct a function pointer type from an existing function type (called the {i reference type}). *) end yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_value_printing.ml000066400000000000000000000065661445631112600250240ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@warning "-9-27"] open Ctypes_static open Ctypes_memory let rec format : type a. a typ -> Format.formatter -> a -> unit = fun typ fmt v -> match typ with Void -> Format.pp_print_string fmt "" | Primitive p -> Format.pp_print_string fmt (Ctypes_value_printing_stubs.string_of_prim p v) | Pointer _ -> format_ptr fmt v | Funptr _ -> format_funptr fmt v | Struct _ -> format_structured fmt v | Union _ -> format_structured fmt v | Array (a, n) -> format_array fmt v | Bigarray ba -> Format.fprintf fmt "" (fun fmt -> Ctypes_type_printing.format_typ fmt) typ | Abstract _ -> format_structured fmt v | OCaml _ -> format_ocaml fmt v | View {write; ty; format=f} -> begin match f with | None -> format ty fmt (write v) | Some f -> f fmt v end and format_structured : type a b. Format.formatter -> (a, b) structured -> unit = fun fmt ({structured = CPointer p} as s) -> let open Format in match Ctypes_ptr.Fat.reftype p with | Struct {fields} -> fprintf fmt "{@;<1 2>@["; format_fields "," fields fmt s; fprintf fmt "@]@;<1 0>}" | Union {ufields} -> fprintf fmt "{@;<1 2>@["; format_fields " |" ufields fmt s; fprintf fmt "@]@;<1 0>}" | Abstract abs -> pp_print_string fmt "" | _ -> raise (Unsupported "unknown structured type") and format_array : type a. Format.formatter -> a carray -> unit = fun fmt ({astart = CPointer p; alength} as arr) -> let open Format in fprintf fmt "{@;<1 2>@["; for i = 0 to alength - 1 do format (Ctypes_ptr.Fat.reftype p) fmt (CArray.get arr i); if i <> alength - 1 then fprintf fmt ",@;" done; fprintf fmt "@]@;<1 0>}" and format_ocaml : type a. Format.formatter -> a ocaml -> unit = let offset fmt = function | 0 -> () | n -> Format.fprintf fmt "@ @[[offset:%d]@]" n and float_array fmt arr = Format.fprintf fmt "[|@;<1 2>@["; let len = Array.length arr in for i = 0 to len - 1 do Format.pp_print_float fmt arr.(i); if i <> len - 1 then Format.fprintf fmt ",@;" done; Format.fprintf fmt "@]@;<1 0>|]" in fun fmt (OCamlRef (off, obj, ty)) -> match ty with | String -> Format.fprintf fmt "%S%a" obj offset off | Bytes -> Format.fprintf fmt "%S%a" (Bytes.to_string obj) offset off | FloatArray -> Format.fprintf fmt "%a%a" float_array obj offset off and format_fields : type a b. string -> (a, b) structured boxed_field list -> Format.formatter -> (a, b) structured -> unit = fun sep fields fmt s -> let last_field = List.length fields - 1 in let open Format in List.iteri (fun i (BoxedField ({ftype; foffset; fname} as f)) -> fprintf fmt "@[%s@] = @[%a@]%s@;" fname (format ftype) (getf s f) (if i <> last_field then sep else "")) fields and format_ptr : type a. Format.formatter -> a ptr -> unit = fun fmt (CPointer p) -> Format.fprintf fmt "%s" (Ctypes_value_printing_stubs.string_of_pointer p) and format_funptr : type a. Format.formatter -> a static_funptr -> unit = fun fmt (Static_funptr p) -> Format.fprintf fmt "%s" (Ctypes_value_printing_stubs.string_of_pointer p) let string_of typ v = Format.asprintf "%a" (format typ) v yallop-ocaml-ctypes-3f8211a/src/ctypes/ctypes_value_printing_stubs.ml000066400000000000000000000006541445631112600262340ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stubs for formatting C values. *) (* Return a string representation of a C value *) external string_of_prim : 'a Ctypes_primitive_types.prim -> 'a -> string = "ctypes_string_of_prim" external string_of_pointer : _ Ctypes_ptr.Fat.t -> string = "ctypes_string_of_pointer" yallop-ocaml-ctypes-3f8211a/src/ctypes/dune000066400000000000000000000015361445631112600207230ustar00rootroot00000000000000(rule (with-stdout-to ctypes_primitives.ml (run ../configure/gen_c_primitives.exe))) (rule (deps (:header %{lib:integers:ocaml_integers.h})) (target ocaml_integers.h) (action (copy %{header} %{target}))) (library (name ctypes) (public_name ctypes) (wrapped false) (libraries integers bigarray-compat) (modules_without_implementation ctypes_types) (instrumentation (backend bisect_ppx)) (install_c_headers ctypes_raw_pointer ctypes_primitives ctypes_cstubs_internals ctypes_managed_buffer_stubs ctypes_complex_compatibility cstubs_internals ctypes_ldouble_stubs ctypes_complex_stubs ctypes_type_info_stubs ocaml_integers) (foreign_stubs (language c) (names complex_stubs ctypes_bigarrays ctypes_roots ldouble_stubs managed_buffer_stubs posix_types_stubs raw_pointer_stubs type_info_stubs))) yallop-ocaml-ctypes-3f8211a/src/ctypes/lDouble.ml000066400000000000000000000061401445631112600217610ustar00rootroot00000000000000(* * Copyright (c) 2016 Andy Ray. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@warning "-3"] external init : unit -> unit = "ldouble_init" let () = init () type t external to_float : t -> float = "ctypes_ldouble_to_float" external of_float : float -> t = "ctypes_ldouble_of_float" external to_int : t -> int = "ctypes_ldouble_to_int" external of_int : int -> t = "ctypes_ldouble_of_int" external format : int -> int -> t -> string = "ctypes_ldouble_format" let to_string ?(width=0) ?(prec=6) d = format width prec d external of_string : string -> t = "ctypes_ldouble_of_string" (* debug *) (*external to_hex_string : t -> string = "ctypes_ldouble_to_hex"*) external add : t -> t -> t = "ctypes_ldouble_add" external sub : t -> t -> t = "ctypes_ldouble_sub" external mul : t -> t -> t = "ctypes_ldouble_mul" external div : t -> t -> t = "ctypes_ldouble_div" external neg : t -> t = "ctypes_ldouble_neg" external pow : t -> t -> t = "ctypes_ldouble_powl" external sqrt : t -> t = "ctypes_ldouble_sqrtl" external exp : t -> t = "ctypes_ldouble_expl" external log : t -> t = "ctypes_ldouble_logl" external log10 : t -> t = "ctypes_ldouble_log10l" external expm1 : t -> t = "ctypes_ldouble_expm1l" external log1p : t -> t = "ctypes_ldouble_log1pl" external cos : t -> t = "ctypes_ldouble_cosl" external sin : t -> t = "ctypes_ldouble_sinl" external tan : t -> t = "ctypes_ldouble_tanl" external acos : t -> t = "ctypes_ldouble_acosl" external asin : t -> t = "ctypes_ldouble_asinl" external atan : t -> t = "ctypes_ldouble_atanl" external atan2 : t -> t -> t = "ctypes_ldouble_atan2l" external hypot : t -> t -> t = "ctypes_ldouble_hypotl" external cosh : t -> t = "ctypes_ldouble_coshl" external sinh : t -> t = "ctypes_ldouble_sinhl" external tanh : t -> t = "ctypes_ldouble_tanhl" external acosh : t -> t = "ctypes_ldouble_acoshl" external asinh : t -> t = "ctypes_ldouble_asinhl" external atanh : t -> t = "ctypes_ldouble_atanhl" external ceil : t -> t = "ctypes_ldouble_ceill" external floor : t -> t = "ctypes_ldouble_floorl" external abs : t -> t = "ctypes_ldouble_fabsl" external rem : t -> t -> t = "ctypes_ldouble_remainderl" external copysign : t -> t -> t = "ctypes_ldouble_copysignl" external frexp : t -> t * int = "ctypes_ldouble_frexp" external ldexp : t -> int -> t = "ctypes_ldouble_ldexp" external modf : t -> t * t = "ctypes_ldouble_modf" external classify : t -> fpclass = "ctypes_ldouble_classify" external min_ : unit -> t = "ctypes_ldouble_min" let min_float = min_ () external max_ : unit -> t = "ctypes_ldouble_max" let max_float = max_ () external epsilon_ : unit -> t = "ctypes_ldouble_epsilon" let epsilon = epsilon_ () external nan_ : unit -> t = "ctypes_ldouble_nan" let nan = nan_ () external inf_ : unit -> t = "ctypes_ldouble_inf" let infinity = inf_ () external ninf_ : unit -> t = "ctypes_ldouble_ninf" let neg_infinity = ninf_ () let zero = of_int 0 let one = of_int 1 external size_ : unit -> (int * int) = "ctypes_ldouble_size" let byte_sizes = size_ () external mant_dig_ : unit -> int = "ctypes_ldouble_mant_dig" [@@noalloc] let mant_dig = mant_dig_ () yallop-ocaml-ctypes-3f8211a/src/ctypes/lDouble.mli000066400000000000000000000100371445631112600221320ustar00rootroot00000000000000(* * Copyright (c) 2016 Andy Ray. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) type t (** The type of long doubles. *) val to_float : t -> float (** Convert a long double to a float. The result is unspecified if the argument is either too large or too small to be represented as a [float].*) val of_float : float -> t (** Create a long double from a float *) val to_int : t -> int (** Convert a long double to an int. The result is unspecified if the argument is NAN or falls outside the range of representable integers. *) val of_int : int -> t (** Create a long double from an int *) val to_string : ?width:int -> ?prec: int -> t -> string (** Convert a long double to a string. [width] specifies the minimum number of digits to format the string with. A negative value left aligns. The default is 0. [prec] specifies the number of digits after the decimal point. The default is 6. *) val of_string : string -> t (** Create a long double from a string *) val add : t -> t -> t (** Addition *) val sub : t -> t -> t (** Subtraction *) val mul : t -> t -> t (** Multiplication *) val div : t -> t -> t (** Division *) val neg : t -> t (** Negation *) val pow : t -> t -> t (** Exponentiation *) val sqrt : t -> t (** Square root *) val exp : t -> t (** Exponential *) val log : t -> t (** Natural logarithm *) val log10 : t -> t (** Base 10 logarithm *) val expm1 : t -> t (** [expm1 x] computes [exp x -. 1.0], giving numerically-accurate results even if [x] is close to [0.0]. *) val log1p : t -> t (** [log1p x] computes [log(1.0 +. x)] (natural logarithm), giving numerically-accurate results even if [x] is close to [0.0]. *) val cos : t -> t (** Cosine. Argument is in radians. *) val sin : t -> t (** Sine. Argument is in radians. *) val tan : t -> t (** Tangent. Argument is in radians. *) val acos : t -> t (** Arc cosine *) val asin : t -> t (** Arc sine *) val atan : t -> t (** Arc tangent *) val atan2 : t -> t -> t (** [atan2 y x] returns the arc tangent of [y /. x]. *) val hypot : t -> t -> t val cosh : t -> t (** Hyperbolic cosine *) val sinh : t -> t (** Hyperbolic sine *) val tanh : t -> t (** Hyperbolic tangent *) val acosh : t -> t (** Inverse hyperbolic cosine *) val asinh : t -> t (** Inverse hyperbolic sine *) val atanh : t -> t (** Inverse hyperbolic tangent *) val ceil : t -> t (** Round above to an integer value. *) val floor : t -> t (** Round below to an integer value. *) val abs : t -> t (** [abs f] returns absolute value of [f] *) val rem : t -> t -> t (** [rem x y] is the remainder of dividing x by y *) val copysign : t -> t -> t (** [copysign x y] returns a float whose absolute value is that of [x] and whose sign is that of [y]. *) val frexp : t -> t * int (** [frexp f] returns the pair of the significant and the exponent of [f]. *) val ldexp : t -> int -> t (** [ldexp x n] returns [x *. 2 ** n]. *) val modf : t -> t * t (** return [(fractional,integer)] parts of number. Known fatal bug on mingw32; see https://sourceforge.net/p/mingw-w64/bugs/478 *) val classify : t -> fpclass (** Return the class of the given floating-point number: normal, subnormal, zero, infinite, or not a number. *) val min_float : t (** The smallest positive, non-zero, non-denormalized value *) val max_float : t (** The largest positive finite value *) val epsilon : t (** The difference between [1.0] and the smallest exactly representable floating-point number greater than [1.0]. *) val nan : t (** A special floating-point value denoting the result of an undefined operation such as [0.0 /. 0.0]. Stands for 'not a number'. *) val infinity : t (** Positive infinity *) val neg_infinity : t (** Negative infinity *) val zero : t (** 0.0 *) val one : t (** 1.0 *) val byte_sizes : int * int (** size, in bytes, used for storing long doubles, and the actual number of bytes used by the value. (unused bytes may contain undefined values) *) val mant_dig : int (** size of mantissa *) yallop-ocaml-ctypes-3f8211a/src/ctypes/ldouble_stubs.c000066400000000000000000000423431445631112600230600ustar00rootroot00000000000000/* * Copyright (c) 2016 Andy Ray. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #if !__USE_MINGW_ANSI_STDIO && (defined(__MINGW32__) || defined(__MINGW64__)) #define __USE_MINGW_ANSI_STDIO 1 #endif #include #include #include #include #include #include #include #include #include #include #include #include #include "ctypes_ldouble_stubs.h" #include "ctypes_complex_compatibility.h" /*********************** long double *************************/ /* * long double comes in various different flavours on different * platforms/architectures. * * 8 byte double - arm, msvc * 10 byte extended - intel gcc. can be packed into 12 or 16 bytes. * 16 byte - powerpc, either IEEE quad float or __ibm128 double double * * We make a best guess as to the format based on LDBL_MANT_DIG. * This only affects the operation of hashing and serialization. * * For deserialization we consider it an error if the stored * value is a different format. Doing such conversions would * get very complicated. * * Regarding endianness - the 8 and 16 byte formats should * interwork between big and little endian systems. The * intel extended 10 byte format only seems to occurs on * x86 so we dont need to consider endianness. * * In case a format is encountered that we do not understand, * then we fall back to casting the value to a double. * */ #define LDOUBLE_STORAGE_BYTES sizeof(long double) #if (LDBL_MANT_DIG == 53) // 64 bit - same as double #define LDOUBLE_VALUE_BYTES 8 #elif (LDBL_MANT_DIG == 64) // intel 80 bit extended #define LDOUBLE_VALUE_BYTES 10 #elif (LDBL_MANT_DIG == 106) // __ibm128 (pair of doubles) #define LDOUBLE_VALUE_BYTES 16 #elif (LDBL_MANT_DIG == 113) // ieee __float128 #define LDOUBLE_VALUE_BYTES 16 #else #define LDOUBLE_VALUE_BYTES LDOUBLE_STORAGE_BYTES #endif static inline long double ldouble_custom_val(value v) { long double r; memcpy(&r, Data_custom_val(v), sizeof(r)); return r; } // initialized in ldouble_init static long double nan_; static long double norm(long double x) { switch (fpclassify(x)){ case FP_ZERO : return 0.0L; // if -0 force to +0. case FP_NAN : return nan_; // cannonical nan default : return x; } } static int ldouble_cmp(long double u1, long double u2) { if (u1 < u2) return -1; if (u1 > u2) return 1; if (u1 != u2) { caml_compare_unordered = 1; if (u1 == u1) return 1; // u2 is nan if (u2 == u2) return -1; // u1 is nan // both nan ==> equal } return 0; } static int ldouble_cmp_val(value v1, value v2) { long double u1 = ldouble_custom_val(v1); long double u2 = ldouble_custom_val(v2); return ldouble_cmp(u1, u2); } static uint32_t ldouble_mix_hash(uint32_t hash, long double d) { union { long double d; uint32_t a[(LDOUBLE_STORAGE_BYTES+3)/4]; } u; u.d = norm(d); if (LDOUBLE_VALUE_BYTES == 16) { // ieee quad or __ibm128 #ifdef ARCH_BIG_ENDIAN hash = caml_hash_mix_uint32(hash, u.a[0]); hash = caml_hash_mix_uint32(hash, u.a[1]); hash = caml_hash_mix_uint32(hash, u.a[2]); hash = caml_hash_mix_uint32(hash, u.a[3]); #else hash = caml_hash_mix_uint32(hash, u.a[1]); hash = caml_hash_mix_uint32(hash, u.a[0]); hash = caml_hash_mix_uint32(hash, u.a[3]); hash = caml_hash_mix_uint32(hash, u.a[2]); #endif } else if (LDOUBLE_VALUE_BYTES == 10) { // intel extended hash = caml_hash_mix_uint32(hash, u.a[0]); hash = caml_hash_mix_uint32(hash, u.a[1]); hash = caml_hash_mix_uint32(hash, u.a[2] & 0xFFFF); } else { // either LDOUBLE_VALUE_BYTES == 8, or we dont know what else to do. hash = caml_hash_mix_double(hash, (double) d); } return hash; } static intnat ldouble_hash(value v) { return ldouble_mix_hash(0, ldouble_custom_val(v)); } static void ldouble_serialize_data(long double *q) { unsigned char *p = (unsigned char *)q; if (LDOUBLE_VALUE_BYTES == 16) { caml_serialize_block_8(p, 2); } else if (LDOUBLE_VALUE_BYTES == 10) { caml_serialize_block_8(p, 1); caml_serialize_block_2(p+8, 1); } else { double d = (double) *q; if (sizeof(double) == 4) caml_serialize_float_4(d); else caml_serialize_float_8(d); } } static void ldouble_serialize(value v, uintnat *wsize_32, uintnat *wsize_64) { long double p = norm(ldouble_custom_val(v)); caml_serialize_int_1(LDBL_MANT_DIG); ldouble_serialize_data(&p); *wsize_32 = *wsize_64 = sizeof(long double); } static void ldouble_deserialize_data(long double *q) { unsigned char *p = (unsigned char *)q; if (LDOUBLE_VALUE_BYTES == 16) { caml_deserialize_block_8(p, 2); } else if (LDOUBLE_VALUE_BYTES == 10) { caml_deserialize_block_8(p, 1); caml_deserialize_block_2(p+8, 1); } else { double d; if (sizeof(double) == 4) d = caml_deserialize_float_4(); else d = caml_deserialize_float_8(); *q = (long double) d; } } static uintnat ldouble_deserialize(void *d) { if (caml_deserialize_uint_1() != LDBL_MANT_DIG) caml_deserialize_error("invalid long double size"); ldouble_deserialize_data((long double *) d); return (sizeof(long double)); } static struct custom_operations caml_ldouble_ops = { "ctypes:ldouble", custom_finalize_default, ldouble_cmp_val, ldouble_hash, ldouble_serialize, ldouble_deserialize, custom_compare_ext_default }; value ctypes_copy_ldouble(long double u) { value res = caml_alloc_custom(&caml_ldouble_ops, sizeof(long double), 0, 1); memcpy(Data_custom_val(res), &u, sizeof(u)); return res; } long double ctypes_ldouble_val(value v) { return ldouble_custom_val(v); } CAMLprim value ctypes_ldouble_of_float(value a) { CAMLparam1(a); CAMLreturn(ctypes_copy_ldouble(Double_val(a))); } CAMLprim value ctypes_ldouble_to_float(value a) { CAMLparam1(a); CAMLreturn(caml_copy_double(ldouble_custom_val(a))); } CAMLprim value ctypes_ldouble_of_int(value a) { CAMLparam1(a); CAMLreturn(ctypes_copy_ldouble(Long_val(a))); } CAMLprim value ctypes_ldouble_to_int(value a) { CAMLparam1(a); long double b = ldouble_custom_val(a); intnat c = b; CAMLreturn(Val_long(c)); } #define OP2(OPNAME, OP) \ CAMLprim value ctypes_ldouble_ ## OPNAME(value a, value b) { \ CAMLparam2(a, b); \ CAMLreturn(ctypes_copy_ldouble( ldouble_custom_val(a) OP ldouble_custom_val(b))); \ } OP2(add, +) OP2(sub, -) OP2(mul, *) OP2(div, /) CAMLprim value ctypes_ldouble_neg(value a) { CAMLparam1(a); CAMLreturn(ctypes_copy_ldouble( - ldouble_custom_val(a))); } #define FN1(OP) \ CAMLprim value ctypes_ldouble_ ## OP (value a) { \ CAMLparam1(a); \ CAMLreturn(ctypes_copy_ldouble( OP (ldouble_custom_val(a)))); \ } #define FN2(OP) \ CAMLprim value ctypes_ldouble_ ## OP (value a, value b) { \ CAMLparam2(a, b); \ CAMLreturn(ctypes_copy_ldouble( OP (ldouble_custom_val(a), ldouble_custom_val(b)))); \ } #define FN1FAIL(OP) \ CAMLprim value ctypes_ldouble_ ## OP (value a) { \ CAMLparam1(a); \ caml_failwith("ctypes: " #OP " does not exist on current platform"); \ } #define FN2FAIL(OP) \ CAMLprim value ctypes_ldouble_ ## OP (value a, value b) { \ CAMLparam2(a, b); \ caml_failwith("ctypes: " #OP " does not exist on current platform"); \ } FN2(powl) FN1(sqrtl) FN1(expl) FN1(logl) FN1(log10l) #ifdef __NetBSD__ FN1FAIL(expm1l) FN1FAIL(log1pl) #else FN1(expm1l) FN1(log1pl) #endif FN1(cosl) FN1(sinl) FN1(tanl) FN1(acosl) FN1(asinl) FN1(atanl) FN2(atan2l) FN2(hypotl) FN1(coshl) FN1(sinhl) FN1(tanhl) FN1(acoshl) FN1(asinhl) FN1(atanhl) FN1(ceill) FN1(floorl) FN1(fabsl) #ifdef __NetBSD__ FN2FAIL(remainderl) #else FN2(remainderl) #endif FN2(copysignl) #undef OP2 #undef FN1 #undef FN2 #undef FN1FAIL #undef FN2FAIL CAMLprim value ctypes_ldouble_frexp(value v) { CAMLparam1(v); CAMLlocal2(r, rfv); long double f = ldouble_custom_val(v); int ri; long double rf; r = caml_alloc_tuple(2); rf = frexpl(f, &ri); rfv = ctypes_copy_ldouble(rf); Store_field(r,0, rfv); Store_field(r,1, Val_int(ri)); CAMLreturn(r); } CAMLprim value ctypes_ldouble_ldexp(value vf, value vi) { CAMLparam2(vf, vi); CAMLlocal1(r); long double f = ldouble_custom_val(vf); int i = Int_val(vi); long double rf = ldexpl(f, i); r = ctypes_copy_ldouble(rf); CAMLreturn(r); } CAMLprim value ctypes_ldouble_modf(value v) { CAMLparam1(v); CAMLlocal1(r); long double f = ldouble_custom_val(v); long double rf2; long double rf1 = modfl(f, &rf2); r = caml_alloc_tuple(2); Store_field(r, 0, ctypes_copy_ldouble(rf1)); Store_field(r, 1, ctypes_copy_ldouble(rf2)); CAMLreturn(r); } enum { ml_FP_NORMAL = 0, ml_FP_SUBNORMAL, ml_FP_ZERO, ml_FP_INFINITE, ml_FP_NAN, }; CAMLprim value ctypes_ldouble_classify(value v){ CAMLparam1(v); CAMLlocal1(r); long double f = ldouble_custom_val(v); switch (fpclassify(f)){ case FP_NORMAL : r = Val_int(ml_FP_NORMAL); break; case FP_SUBNORMAL : r = Val_int(ml_FP_SUBNORMAL); break; case FP_ZERO : r = Val_int(ml_FP_ZERO); break; case FP_INFINITE : r = Val_int(ml_FP_INFINITE); break; case FP_NAN : default : r = Val_int(ml_FP_NAN); break; } CAMLreturn(r); } static char *format_ldouble(int width, int prec, long double d) { size_t print_len; char *buf = NULL; // find length print_len = snprintf(NULL, 0, "%*.*Lf", width, prec, d); if (0 == print_len) // this shouldn't happen caml_invalid_argument("bad ldouble format"); // allocate buffer buf = malloc(print_len+1); if (NULL == buf) caml_raise_out_of_memory(); // format string buf[0] = '\0'; snprintf(buf, print_len+1, "%*.*Lf", width, prec, d); return buf; } CAMLprim value ctypes_ldouble_format(value width, value prec, value d) { CAMLparam3(width, prec, d); CAMLlocal1(s); char *str = format_ldouble(Int_val(width), Int_val(prec), ldouble_custom_val(d)); s = caml_copy_string(str); free(str); CAMLreturn(s); } CAMLprim value ctypes_ldouble_of_string(value v) { CAMLparam1(v); const char *str = String_val(v); int len = caml_string_length(v); char *end; long double r; if (0 == len) caml_invalid_argument("LDouble.of_string"); r = strtold(str, &end); if (*end != '\0') caml_invalid_argument("LDouble.of_string"); CAMLreturn(ctypes_copy_ldouble(r)); } /* debug code */ /*static char hex_char(char x) { if (x < 10) return '0' + x; return 'a' + x - 10; } CAMLprim value ctypes_ldouble_to_hex(value v) { CAMLparam1(v); static char x[LDOUBLE_STORAGE_BYTES*2 + 1]; char *p = (char *) Data_custom_val(v); int i; for (i=0; i> 0) & 0xf); x[i*2+1] = hex_char(((*(p+i)) >> 4) & 0xf); } x[LDOUBLE_STORAGE_BYTES*2] = 0; CAMLreturn(caml_copy_string(x)); }*/ value ctypes_ldouble_min(value unit) { return ctypes_copy_ldouble(-LDBL_MAX); } value ctypes_ldouble_max(value unit) { return ctypes_copy_ldouble(LDBL_MAX); } value ctypes_ldouble_epsilon(value unit) { return ctypes_copy_ldouble(LDBL_EPSILON); } value ctypes_ldouble_nan(value unit) { return ctypes_copy_ldouble(nan_); } // XXX note; -(log 0) gives +ve inf (and vice versa). Is this consistent? *) value ctypes_ldouble_inf(value unit) { return ctypes_copy_ldouble(-log(0)); } value ctypes_ldouble_ninf(value unit) { return ctypes_copy_ldouble(log(0)); } value ctypes_ldouble_size(value unit) { CAMLparam1(unit); CAMLlocal1(r); r = caml_alloc_tuple(2); Store_field(r,0, Val_int(LDOUBLE_STORAGE_BYTES)); Store_field(r,1, Val_int(LDOUBLE_VALUE_BYTES)); CAMLreturn(r); } /*********************** complex *************************/ static inline long double _Complex ldouble_complex_custom_val(value v) { long double _Complex r; memcpy(&r, Data_custom_val(v), sizeof(r)); return r; } static int ldouble_complex_cmp_val(value v1, value v2) { long double _Complex u1 = ldouble_complex_custom_val(v1); long double _Complex u2 = ldouble_complex_custom_val(v2); int cmp_real = ldouble_cmp(ctypes_compat_creall(u1), ctypes_compat_creall(u2)); return cmp_real == 0 ? ldouble_cmp(ctypes_compat_cimagl(u1), ctypes_compat_cimagl(u2)) : cmp_real; } static intnat ldouble_complex_hash(value v) { long double _Complex c = ldouble_complex_custom_val(v); return ldouble_mix_hash(ldouble_mix_hash(0, ctypes_compat_creall(c)), ctypes_compat_cimagl(c)); } static void ldouble_complex_serialize(value v, uintnat *wsize_32, uintnat *wsize_64) { long double re,im; long double _Complex c; void * p = Data_custom_val(v); #if defined(__GNUC__) && __GNUC__ == 6 && __GNUC_MINOR__ == 4 /* workaround gcc bug. gcc tries to inline the memcpy calls, but * fails with an internal compiler error. I've observed this error * only under Alpine Linux, other distros have already imported a * patch from upstream. */ void *(*volatile mymemcpy)(void*,const void*,size_t) = memcpy; mymemcpy(&c, p, sizeof(c)); #else memcpy(&c, p, sizeof(c)); #endif caml_serialize_int_1(LDBL_MANT_DIG); re = ctypes_compat_creall(c); ldouble_serialize_data(&re); im = ctypes_compat_cimagl(c); ldouble_serialize_data(&im); *wsize_32 = *wsize_64 = sizeof(long double _Complex); } static uintnat ldouble_complex_deserialize(void *d) { long double re, im; long double _Complex c; if (caml_deserialize_uint_1() != LDBL_MANT_DIG) caml_deserialize_error("invalid long double size"); ldouble_deserialize_data(&re); ldouble_deserialize_data(&im); c = ctypes_compat_make_complexl(re, im); memcpy(d, &c, sizeof(c)); return (sizeof(long double _Complex)); } static struct custom_operations caml_ldouble_complex_ops = { "ctypes:ldouble_complex", custom_finalize_default, ldouble_complex_cmp_val, ldouble_complex_hash, ldouble_complex_serialize, ldouble_complex_deserialize, custom_compare_ext_default }; value ctypes_copy_ldouble_complex(long double _Complex u) { value res = caml_alloc_custom(&caml_ldouble_complex_ops, sizeof(long double _Complex), 0, 1); memcpy(Data_custom_val(res), &u, sizeof(u)); return res; } long double _Complex ctypes_ldouble_complex_val(value v) { return ldouble_complex_custom_val(v); } /* make : t -> t -> complex */ CAMLprim value ctypes_ldouble_complex_make(value r, value i) { CAMLparam2(r, i); long double re = ldouble_custom_val(r); long double im = ldouble_custom_val(i); CAMLreturn(ctypes_copy_ldouble_complex(ctypes_compat_make_complexl(re, im))); } /* real : complex -> t */ CAMLprim value ctypes_ldouble_complex_real(value v) { CAMLparam1(v); CAMLreturn(ctypes_copy_ldouble(ctypes_compat_creall(ldouble_complex_custom_val(v)))); } /* imag : complex -> t */ CAMLprim value ctypes_ldouble_complex_imag(value v) { CAMLparam1(v); CAMLreturn(ctypes_copy_ldouble(ctypes_compat_cimagl(ldouble_complex_custom_val(v)))); } #define OP2(OPNAME, OP) \ CAMLprim value ctypes_ldouble_complex_ ## OPNAME(value a, value b) { \ CAMLparam2(a, b); \ CAMLreturn(ctypes_copy_ldouble_complex( \ ldouble_complex_custom_val(a) OP ldouble_complex_custom_val(b) )); \ } OP2(add, +) OP2(sub, -) OP2(mul, *) OP2(div, /) CAMLprim value ctypes_ldouble_complex_neg(value a) { CAMLparam1(a); CAMLreturn(ctypes_copy_ldouble_complex( - ldouble_complex_custom_val(a) )); } #define FN1(OP) \ CAMLprim value ctypes_ldouble_complex_ ## OP (value a) { \ CAMLparam1(a); \ CAMLreturn(ctypes_copy_ldouble_complex( ctypes_compat_ ## OP (ldouble_complex_custom_val(a)))); \ } #define FN2(OP) \ CAMLprim value ctypes_ldouble_complex_ ## OP (value a, value b) { \ CAMLparam2(a, b); \ CAMLreturn(ctypes_copy_ldouble_complex( \ ctypes_compat_ ## OP (ldouble_complex_custom_val(a), ldouble_complex_custom_val(b)))); \ } FN1(conjl) FN1(csqrtl) FN1(cexpl) FN1(clogl) FN2(cpowl) CAMLprim value ctypes_ldouble_complex_cargl(value a) { CAMLparam1(a); CAMLreturn(ctypes_copy_ldouble( ctypes_compat_cargl(ldouble_complex_custom_val(a)))); } value ldouble_init(value unit) { nan_ = nanl(""); // platform dependant argument - use as cannonical nan caml_register_custom_operations(&caml_ldouble_ops); caml_register_custom_operations(&caml_ldouble_complex_ops); return Val_unit; } CAMLprim value ctypes_ldouble_mant_dig(value unit) { intnat r = LDBL_MANT_DIG; return Val_long(r); } yallop-ocaml-ctypes-3f8211a/src/ctypes/managed_buffer_stubs.c000066400000000000000000000042371445631112600243570ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #include #include #include #include #include #include #include "ctypes_raw_pointer.h" #include "ctypes_managed_buffer_stubs.h" static void finalize_free(value v) { free(*((void **)Data_custom_val(v))); } static int compare_pointers(value l_, value r_) { /* pointer comparison */ intptr_t l = (intptr_t)*(void **)Data_custom_val(l_); intptr_t r = (intptr_t)*(void **)Data_custom_val(r_); return (l > r) - (l < r); } static intnat hash_address(value l) { /* address hashing */ return (intnat)*(void **)Data_custom_val(l); } static struct custom_operations managed_buffer_custom_ops = { "ocaml-ctypes:managed_buffer", finalize_free, compare_pointers, hash_address, /* Managed buffers are not serializable. */ custom_serialize_default, custom_deserialize_default, custom_compare_ext_default }; /* copy_bytes : void * -> size_t -> managed_buffer */ value ctypes_copy_bytes(void *src, size_t size) { CAMLparam0(); CAMLlocal1(block); block = caml_alloc_custom(&managed_buffer_custom_ops, sizeof(void*), 0, 1); void *dst = malloc(size); if (dst == NULL && size != 0) caml_raise_out_of_memory(); *(void **)Data_custom_val(block) = memcpy(dst, src, size); CAMLreturn(block); } /* allocate : int -> int -> managed_buffer */ value ctypes_allocate(value count_, value size_) { CAMLparam2(count_, size_); intnat size = Long_val(size_); intnat count = Long_val(count_); CAMLlocal1(block); block = caml_alloc_custom(&managed_buffer_custom_ops, sizeof(void*), 0, 1); // libc's calloc guarantees the memory is zero-filled // malloc may not be used internally void *p = calloc(count, size); if (p == NULL && count != 0 && size != 0) caml_raise_out_of_memory(); void **d = (void **)Data_custom_val(block); *d = p; CAMLreturn(block); } /* block_address : managed_buffer -> immediate_pointer */ value ctypes_block_address(value managed_buffer) { return CTYPES_FROM_PTR(*(void **)Data_custom_val(managed_buffer)); } yallop-ocaml-ctypes-3f8211a/src/ctypes/posixTypes.ml000066400000000000000000000107611445631112600225660ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) module type Abstract = sig type t val t : t Ctypes.typ end let mkAbstract : 'a. 'a Ctypes.typ -> (module Abstract) = fun (type a) (ty : a Ctypes.typ) -> (module struct type t = a let t = ty end : Abstract) let mkAbstractSized : name:string -> size:int -> alignment:int -> (module Abstract) = fun ~name ~size ~alignment:a -> (module struct open Ctypes type t = unit Ctypes.abstract let t = abstract ~name ~size ~alignment:a end : Abstract) let mkArithmetic_abstract = let open Ctypes in function Ctypes_static.Int8 -> mkAbstract int8_t | Ctypes_static.Int16 -> mkAbstract int16_t | Ctypes_static.Int32 -> mkAbstract int32_t | Ctypes_static.Int64 -> mkAbstract int64_t | Ctypes_static.Uint8 -> mkAbstract uint8_t | Ctypes_static.Uint16 -> mkAbstract uint16_t | Ctypes_static.Uint32 -> mkAbstract uint32_t | Ctypes_static.Uint64 -> mkAbstract uint64_t | Ctypes_static.Float -> mkAbstract float | Ctypes_static.Double -> mkAbstract double let mkSigned name = function | Ctypes_static.Int8 -> Ctypes_std_views.signed_typedef name ~size:1 | Ctypes_static.Int16 -> Ctypes_std_views.signed_typedef name ~size:2 | Ctypes_static.Int32 -> Ctypes_std_views.signed_typedef name ~size:4 | Ctypes_static.Int64 -> Ctypes_std_views.signed_typedef name ~size:8 | _ -> assert false let mkUnsigned name = function | Ctypes_static.Uint8 -> Ctypes_std_views.unsigned_typedef name ~size:1 | Ctypes_static.Uint16 -> Ctypes_std_views.unsigned_typedef name ~size:2 | Ctypes_static.Uint32 -> Ctypes_std_views.unsigned_typedef name ~size:4 | Ctypes_static.Uint64 -> Ctypes_std_views.unsigned_typedef name ~size:8 | _ -> assert false let mkArithmetic name : _ -> (module Ctypes_std_views.Unsigned_type) = let open Ctypes_static in function | Uint8 | Uint16 | Uint32 | Uint64 as u -> let module U = (val mkUnsigned name u) in (module U) | Int8 | Int16 | Int32 | Int64 as u -> let module S = (val mkSigned name u) in (module S) | _ -> assert false (* Arithmetic types *) external typeof_clock_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_clock_t" external typeof_dev_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_dev_t" external typeof_ino_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_ino_t" external typeof_mode_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_mode_t" external typeof_nlink_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_nlink_t" external typeof_off_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_off_t" external typeof_pid_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_pid_t" external typeof_ssize_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_ssize_t" external typeof_time_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_time_t" external typeof_useconds_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_useconds_t" module Clock = (val mkArithmetic_abstract (typeof_clock_t ()) : Abstract) module Dev = (val mkArithmetic "dev_t" (typeof_dev_t ())) module Ino = (val mkArithmetic "ino_t" (typeof_ino_t ())) module Mode = (val mkArithmetic "mode_t" (typeof_mode_t ())) module Nlink = (val mkArithmetic "nlink_t" (typeof_nlink_t ())) module Off = (val mkSigned "off_t" (typeof_off_t ())) module Pid = (val mkSigned "pid_t" (typeof_pid_t ())) module Size = struct type t = Unsigned.size_t let t = Ctypes.size_t end module Ssize = (val mkSigned "ssize_t" (typeof_ssize_t ())) module Time = (val mkArithmetic "time_t" (typeof_time_t ())) module Useconds = (val mkArithmetic_abstract (typeof_useconds_t ()) : Abstract) type clock_t = Clock.t type dev_t = Dev.t type ino_t = Ino.t type mode_t = Mode.t type nlink_t = Nlink.t type off_t = Off.t type pid_t = Pid.t type size_t = Size.t type ssize_t = Ssize.t type time_t = Time.t type useconds_t = Useconds.t let clock_t = Clock.t let dev_t = Dev.t let ino_t = Ino.t let mode_t = Mode.t let nlink_t = Nlink.t let off_t = Off.t let pid_t = Pid.t let size_t = Size.t let ssize_t = Ssize.t let time_t = Time.t let useconds_t = Useconds.t (* Non-arithmetic types *) external sizeof_sigset_t : unit -> int = "ctypes_sizeof_sigset_t" external alignmentof_sigset_t : unit -> int = "ctypes_alignmentof_sigset_t" module Sigset = (val mkAbstractSized ~name:"sigset_t" ~size:(sizeof_sigset_t ()) ~alignment:(alignmentof_sigset_t ()) : Abstract) type sigset_t = Sigset.t let sigset_t = Sigset.t yallop-ocaml-ctypes-3f8211a/src/ctypes/posixTypes.mli000066400000000000000000000023531445631112600227350ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes (** Some POSIX types. *) (* arithmetic types from *) (** {2 POSIX arithmetic types} *) module Dev : Unsigned.S module Ino : Unsigned.S module Mode : Unsigned.S module Nlink : Unsigned.S module Off : Signed.S module Pid : Signed.S module Ssize : Signed.S module Time : Unsigned.S type clock_t type dev_t = Dev.t type ino_t = Ino.t type mode_t = Mode.t type nlink_t = Nlink.t type off_t = Off.t type pid_t = Pid.t type size_t = Unsigned.size_t type ssize_t = Ssize.t type time_t = Time.t type useconds_t (** {3 Values representing POSIX arithmetic types} *) val clock_t : clock_t typ val dev_t : dev_t typ val ino_t : ino_t typ val mode_t : mode_t typ val nlink_t : nlink_t typ val off_t : off_t typ val pid_t : pid_t typ val size_t : size_t typ val ssize_t : ssize_t typ val time_t : time_t typ val useconds_t : useconds_t typ (* non-arithmetic types from *) (** {2 POSIX non-arithmetic types} *) type sigset_t (** {3 Values representing POSIX non-arithmetic types} *) val sigset_t : sigset_t typ yallop-ocaml-ctypes-3f8211a/src/ctypes/posix_types_stubs.c000066400000000000000000000052331445631112600240150ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #include "ctypes_primitives.h" #define _XOPEN_SOURCE 500 #include #include #include #include #include #if (!defined _WIN32 || defined __CYGWIN__) && !defined MINIOS #include #endif #include #include #define EXPOSE_TYPEINFO_COMMON(TYPENAME,STYPENAME) \ value ctypes_typeof_ ## TYPENAME(value unit) \ { \ enum ctypes_arithmetic_type underlying = \ CTYPES_CLASSIFY_ARITHMETIC_TYPE(STYPENAME); \ return Val_int(underlying); \ } #define EXPOSE_ALIGNMENT_COMMON(TYPENAME,STYPENAME) \ value ctypes_alignmentof_ ## TYPENAME(value unit) \ { \ struct s { char c; STYPENAME t; }; \ return Val_int(offsetof(struct s, t)); \ } #define EXPOSE_TYPESIZE_COMMON(TYPENAME,STYPENAME) \ value ctypes_sizeof_ ## TYPENAME(value unit) \ { \ return Val_int(sizeof(STYPENAME)); \ } #if !defined _WIN32 || defined __CYGWIN__ #define UNDERSCORE(X) X #else #define UNDERSCORE(X) _## X #endif #define EXPOSE_TYPEINFO(X) EXPOSE_TYPEINFO_COMMON(X, X) #define EXPOSE_TYPEINFO_S(X) EXPOSE_TYPEINFO_COMMON(X, UNDERSCORE(X)) #define EXPOSE_TYPESIZE(X) EXPOSE_TYPESIZE_COMMON(X, X) #define EXPOSE_TYPESIZE_S(X) EXPOSE_TYPESIZE_COMMON(X, UNDERSCORE(X)) #define EXPOSE_ALIGNMENT(X) EXPOSE_ALIGNMENT_COMMON(X, X) #define EXPOSE_ALIGNMENT_S(X) EXPOSE_ALIGNMENT_COMMON(X, UNDERSCORE(X)) #ifdef __NetBSD__ /* NetBSD defines these types as macros, which expands to the wrong thing * in the EXPOSE_* macros above. I have no idea how to prevent cpp from * expanding macro arguments, so just hack around it for now. */ #undef off_t #undef mode_t #undef pid_t typedef __off_t off_t; typedef __mode_t mode_t; typedef __pid_t pid_t; #endif EXPOSE_TYPEINFO(clock_t) EXPOSE_TYPEINFO_S(dev_t) EXPOSE_TYPEINFO_S(ino_t) EXPOSE_TYPEINFO_S(mode_t) EXPOSE_TYPEINFO_S(off_t) EXPOSE_TYPEINFO_S(pid_t) EXPOSE_TYPEINFO(ssize_t) EXPOSE_TYPEINFO(time_t) EXPOSE_TYPEINFO(useconds_t) #if !defined _WIN32 || defined __CYGWIN__ EXPOSE_TYPEINFO(nlink_t) #else /* the mingw port of fts uses an int for nlink_t */ EXPOSE_TYPEINFO_COMMON(nlink_t, int) #endif EXPOSE_TYPESIZE_S(sigset_t) EXPOSE_ALIGNMENT_S(sigset_t) yallop-ocaml-ctypes-3f8211a/src/ctypes/raw_pointer_stubs.c000066400000000000000000000027351445631112600237640ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #include #include #include #include "ctypes_managed_buffer_stubs.h" #include "ctypes_type_info_stubs.h" #include "ctypes_raw_pointer.h" /* memcpy : dst:fat_pointer -> src:fat_pointer -> size:int -> unit */ value ctypes_memcpy(value dst, value src, value size) { CAMLparam3(dst, src, size); memcpy(CTYPES_ADDR_OF_FATPTR(dst), CTYPES_ADDR_OF_FATPTR(src), Long_val(size)); CAMLreturn(Val_unit); } /* string_of_cstring : raw_ptr -> int -> string */ value ctypes_string_of_cstring(value p) { return caml_copy_string(CTYPES_ADDR_OF_FATPTR(p)); } /* string_of_array : fat_ptr -> len:int -> string */ value ctypes_string_of_array(value p, value vlen) { CAMLparam2(p, vlen); CAMLlocal1(dst); intnat len = Long_val(vlen); if (len < 0) caml_invalid_argument("ctypes_string_of_array"); dst = caml_alloc_string(len); memcpy((char *)String_val(dst), CTYPES_ADDR_OF_FATPTR(p), len); CAMLreturn(dst); } /* cstring_of_string : string -> managed_buffer */ value ctypes_cstring_of_string(value s) { CAMLparam1(s); CAMLlocal1(buffer); size_t len = caml_string_length(s); buffer = ctypes_allocate(Val_int(1), Val_long(len + 1)); char *dst = CTYPES_TO_PTR(ctypes_block_address(buffer)); const char *ss = String_val(s); memcpy(dst, ss, len); dst[len] = '\0'; CAMLreturn(buffer); } yallop-ocaml-ctypes-3f8211a/src/ctypes/type_info_stubs.c000066400000000000000000000232301445631112600234200ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #if !__USE_MINGW_ANSI_STDIO && (defined(__MINGW32__) || defined(__MINGW64__)) #define __USE_MINGW_ANSI_STDIO 1 #endif #include #include #include #include #include #include #include #include "ocaml_integers.h" #include "ctypes_type_info_stubs.h" #include "ctypes_complex_compatibility.h" #include "ctypes_complex_stubs.h" #include "ctypes_ldouble_stubs.h" #include "ctypes_raw_pointer.h" #include "ctypes_primitives.h" #if __USE_MINGW_ANSI_STDIO && defined(__MINGW64__) #define REAL_ARCH_INTNAT_PRINTF_FORMAT "ll" #else #define REAL_ARCH_INTNAT_PRINTF_FORMAT ARCH_INTNAT_PRINTF_FORMAT #endif /* Read a C value from a block of memory */ /* read : 'a prim -> fat_pointer -> 'a */ value ctypes_read(value prim_, value buffer_) { CAMLparam2(prim_, buffer_); CAMLlocal1(b); void *buf = CTYPES_ADDR_OF_FATPTR(buffer_); switch (Int_val(prim_)) { case Ctypes_Char: b = Val_int(*(unsigned char*)buf); break; case Ctypes_Schar: b = Val_int(*(signed char *)buf); break; case Ctypes_Uchar: b = Integers_val_uint8(*(unsigned char *)buf); break; case Ctypes_Bool: b = Val_bool(*(bool *)buf); break; case Ctypes_Short: b = Val_int(*(short *)buf); break; case Ctypes_Int: b = Val_int(*(int *)buf); break; case Ctypes_Long: b = ctypes_copy_long(*(long *)buf); break; case Ctypes_Llong: b = ctypes_copy_llong(*(long long *)buf); break; case Ctypes_Ushort: b = ctypes_copy_ushort(*(unsigned short *)buf); break; case Ctypes_Sint: b = ctypes_copy_sint(*(int *)buf); break; case Ctypes_Uint: b = ctypes_copy_uint(*(unsigned int *)buf); break; case Ctypes_Ulong: b = ctypes_copy_ulong(*(unsigned long *)buf); break; case Ctypes_Ullong: b = ctypes_copy_ullong(*(unsigned long long *)buf); break; case Ctypes_Size_t: b = ctypes_copy_size_t(*(size_t *)buf); break; case Ctypes_Int8_t: b = Val_int(*(int8_t *)buf); break; case Ctypes_Int16_t: b = Val_int(*(int16_t *)buf); break; case Ctypes_Int32_t: b = caml_copy_int32(*(int32_t *)buf); break; case Ctypes_Int64_t: b = caml_copy_int64(*(int64_t *)buf); break; case Ctypes_Uint8_t: b = Integers_val_uint8(*(uint8_t *)buf); break; case Ctypes_Uint16_t: b = Integers_val_uint16(*(uint16_t *)buf); break; case Ctypes_Uint32_t: b = integers_copy_uint32(*(uint32_t *)buf); break; case Ctypes_Uint64_t: b = integers_copy_uint64(*(uint64_t *)buf); break; case Ctypes_Camlint: b = Val_long(*(intnat *)buf); break; case Ctypes_Nativeint: b = caml_copy_nativeint(*(intnat *)buf); break; case Ctypes_Float: b = caml_copy_double(*(float *)buf); break; case Ctypes_Double: b = caml_copy_double(*(double *)buf); break; case Ctypes_LDouble: b = ctypes_copy_ldouble(*(long double *)buf); break; case Ctypes_Complex32: b = ctypes_copy_float_complex(*(float _Complex *)buf); break; case Ctypes_Complex64: b = ctypes_copy_double_complex(*(double _Complex *)buf); break; case Ctypes_Complexld: b = ctypes_copy_ldouble_complex(*(long double _Complex *)buf); break; default: assert(0); } CAMLreturn(b); } /* Read a C value from a block of memory */ /* write : 'a prim -> 'a -> fat_pointer -> unit */ value ctypes_write(value prim_, value v, value buffer_) /* noalloc */ { CAMLparam3(prim_, v, buffer_); void *buf = CTYPES_ADDR_OF_FATPTR(buffer_); switch (Int_val(prim_)) { case Ctypes_Char: *(unsigned char *)buf = Int_val(v); break; case Ctypes_Schar: *(signed char *)buf = Int_val(v); break; case Ctypes_Uchar: *(unsigned char *)buf = Uint8_val(v); break; case Ctypes_Bool: *(bool *)buf = Bool_val(v); break; case Ctypes_Short: *(short *)buf = Int_val(v); break; case Ctypes_Int: *(int *)buf = Int_val(v); break; case Ctypes_Long: *(long *)buf = ctypes_long_val(v); break; case Ctypes_Llong: *(long long *)buf = ctypes_llong_val(v); break; case Ctypes_Ushort: *(unsigned short *)buf = ctypes_ushort_val(v); break; case Ctypes_Sint: *(int *)buf = ctypes_sint_val(v); break; case Ctypes_Uint: *(unsigned int *)buf = ctypes_uint_val(v); break; case Ctypes_Ulong: *(unsigned long *)buf = ctypes_ulong_val(v); break; case Ctypes_Ullong: *(unsigned long long *)buf = ctypes_ullong_val(v); break; case Ctypes_Size_t: *(size_t *)buf = ctypes_size_t_val(v); break; case Ctypes_Int8_t: *(int8_t *)buf = Int_val(v); break; case Ctypes_Int16_t: *(int16_t *)buf = Int_val(v); break; case Ctypes_Int32_t: *(int32_t *)buf = Int32_val(v); break; case Ctypes_Int64_t: *(int64_t *)buf = Int64_val(v); break; case Ctypes_Uint8_t: *(uint8_t *)buf = Uint8_val(v); break; case Ctypes_Uint16_t: *(uint16_t *)buf = Uint16_val(v); break; case Ctypes_Uint32_t: *(uint32_t *)buf = Uint32_val(v); break; case Ctypes_Uint64_t: *(uint64_t *)buf = Uint64_val(v); break; case Ctypes_Camlint: *(intnat *)buf = Long_val(v); break; case Ctypes_Nativeint: *(intnat *)buf = Nativeint_val(v); break; case Ctypes_Float: *(float *)buf = Double_val(v); break; case Ctypes_Double: *(double *)buf = Double_val(v); break; case Ctypes_LDouble: *(long double *)buf = ctypes_ldouble_val(v); break; case Ctypes_Complex32: *(float _Complex *)buf = ctypes_float_complex_val(v); break; case Ctypes_Complex64: *(double _Complex *)buf = ctypes_double_complex_val(v); break; case Ctypes_Complexld: *(long double _Complex *)buf = ctypes_ldouble_complex_val(v); break; default: assert(0); } CAMLreturn(Val_unit); } /* Format a C value */ /* string_of_prim : 'a prim -> 'a -> string */ value ctypes_string_of_prim(value prim_, value v) { CAMLparam2(prim_, v); CAMLlocal1(s); char buf[64]; int len = 0; switch (Int_val(prim_)) { case Ctypes_Char: len = snprintf(buf, sizeof buf, "'%c'", Int_val(v)); break; case Ctypes_Schar: len = snprintf(buf, sizeof buf, "%d", Int_val(v)); break; case Ctypes_Uchar: len = snprintf(buf, sizeof buf, "%d", (unsigned char)Uint8_val(v)); break; case Ctypes_Bool: len = snprintf(buf, sizeof buf, "%s", Bool_val(v) ? "true" : "false"); break; case Ctypes_Short: len = snprintf(buf, sizeof buf, "%hd", (short)Int_val(v)); break; case Ctypes_Int: len = snprintf(buf, sizeof buf, "%d", Int_val(v)); break; case Ctypes_Long: len = snprintf(buf, sizeof buf, "%ld", (long)ctypes_long_val(v)); break; case Ctypes_Llong: len = snprintf(buf, sizeof buf, "%lld", (long long)ctypes_llong_val(v)); break; case Ctypes_Ushort: len = snprintf(buf, sizeof buf, "%hu", (unsigned short)ctypes_ushort_val(v)); break; case Ctypes_Sint: len = snprintf(buf, sizeof buf, "%d", ctypes_sint_val(v)); break; case Ctypes_Uint: len = snprintf(buf, sizeof buf, "%u", (unsigned)ctypes_uint_val(v)); break; case Ctypes_Ulong: len = snprintf(buf, sizeof buf, "%lu", (unsigned long)ctypes_ulong_val(v)); break; case Ctypes_Ullong: len = snprintf(buf, sizeof buf, "%llu", (unsigned long long)ctypes_ullong_val(v)); break; case Ctypes_Size_t: len = snprintf(buf, sizeof buf, "%zu", (size_t)ctypes_size_t_val(v)); break; case Ctypes_Int8_t: len = snprintf(buf, sizeof buf, "%" PRId8, (int8_t)Int_val(v)); break; case Ctypes_Int16_t: len = snprintf(buf, sizeof buf, "%" PRId16, (int16_t)Int_val(v)); break; case Ctypes_Int32_t: len = snprintf(buf, sizeof buf, "%" PRId32, Int32_val(v)); break; case Ctypes_Int64_t: len = snprintf(buf, sizeof buf, "%" PRId64, (int64_t)Int64_val(v)); break; case Ctypes_Uint8_t: len = snprintf(buf, sizeof buf, "%" PRIu8, Uint8_val(v)); break; case Ctypes_Uint16_t: len = snprintf(buf, sizeof buf, "%" PRIu16, Uint16_val(v)); break; case Ctypes_Uint32_t: len = snprintf(buf, sizeof buf, "%" PRIu32, Uint32_val(v)); break; case Ctypes_Uint64_t: len = snprintf(buf, sizeof buf, "%" PRIu64, Uint64_val(v)); break; case Ctypes_Camlint: len = snprintf(buf, sizeof buf, "%" REAL_ARCH_INTNAT_PRINTF_FORMAT "d", (intnat)Long_val(v)); break; case Ctypes_Nativeint: len = snprintf(buf, sizeof buf, "%" REAL_ARCH_INTNAT_PRINTF_FORMAT "d", (intnat)Nativeint_val(v)); break; case Ctypes_Float: len = snprintf(buf, sizeof buf, "%.12g", Double_val(v)); break; case Ctypes_Double: len = snprintf(buf, sizeof buf, "%.12g", Double_val(v)); break; case Ctypes_LDouble: len = snprintf(buf, sizeof buf, "%.12Lg", ctypes_ldouble_val(v)); break; case Ctypes_Complex32: { float _Complex c = ctypes_float_complex_val(v); len = snprintf(buf, sizeof buf, "%.12g+%.12gi", ctypes_compat_crealf(c), ctypes_compat_cimagf(c)); break; } case Ctypes_Complex64: { double _Complex c = ctypes_double_complex_val(v); len = snprintf(buf, sizeof buf, "%.12g+%.12gi", ctypes_compat_creal(c), ctypes_compat_cimag(c)); break; } case Ctypes_Complexld: { long double _Complex c = ctypes_ldouble_complex_val(v); len = snprintf(buf, sizeof buf, "%.12Lg+%.12Lgi", ctypes_compat_creall(c), ctypes_compat_cimagl(c)); break; } default: assert(0); } s = caml_alloc_string(len); memcpy((char *)String_val(s), buf, len); CAMLreturn (s); } /* read_pointer : fat_pointer -> raw_pointer */ value ctypes_read_pointer(value src_) { CAMLparam1(src_); void *src = CTYPES_ADDR_OF_FATPTR(src_); CAMLreturn(CTYPES_FROM_PTR(*(void **)src)); } /* write_pointer : fat_pointer -> dst:fat_pointer -> unit */ value ctypes_write_pointer(value p_, value dst_) { CAMLparam2(p_, dst_); void *dst = CTYPES_ADDR_OF_FATPTR(dst_); *(void **)dst = CTYPES_ADDR_OF_FATPTR(p_); CAMLreturn(Val_unit); } /* string_of_pointer : fat_pointer -> string */ value ctypes_string_of_pointer(value p_) { char buf[32]; CAMLparam1(p_); snprintf(buf, sizeof buf, "%p", CTYPES_ADDR_OF_FATPTR(p_)); CAMLreturn (caml_copy_string(buf)); } yallop-ocaml-ctypes-3f8211a/tests/000077500000000000000000000000001445631112600171045ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/bench-micro/000077500000000000000000000000001445631112600212725ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/bench-micro/Makefile000066400000000000000000000031761445631112600227410ustar00rootroot00000000000000.PHONY: build bench clean CFLAGS=-Wall -O2 CTYPES_INCLUDE=`ocamlfind query ctypes`/.. BENCH_MICRO_STUBS=bench_micro_stubs.h bench_micro_lib.c bench_micro_stubs.c BENCH_MICRO_GENERATED=bench_micro_generated_stubs.c bench_micro_generated.ml build: bench_micro bench: build LD_LIBRARY_PATH=. ./bench_micro -ascii -q 10 +time +cycles \ -clear-columns -no-compactions -v -ci-absolute -all-values \ -overheads -save > summary.txt ocaml process_summary.ml summary.txt gnuplot bench_micro.gnuplot gnuplot bench_micro_interpreted.gnuplot libbench_micro.so: $(BENCH_MICRO_STUBS) gcc -o libbench_micro.so -shared -fPIC $(CFLAGS) bench_micro_stubs.c bench_micro_gen: $(BENCH_MICRO_STUBS) bench_micro_bindings.ml bench_micro_gen.ml ocamlfind opt -o bench_micro_gen \ -linkpkg -package ctypes.foreign,ctypes.stubs \ bench_micro_lib.c bench_micro_stubs.c \ bench_micro_bindings.ml bench_micro_gen.ml bench_micro_generated.ml bench_micro_generated_stubs.c: bench_micro_gen ./bench_micro_gen bench_micro: $(BENCH_MICRO_STUBS) $(BENCH_MICRO_GENERATED) libbench_micro.so bench_micro_bindings.ml bench_micro.ml ocamlfind opt -o bench_micro $(patsubst %,-ccopt %,$(CFLAGS)) \ -cclib -lbench_micro -cclib -L. \ -thread -linkpkg -I $(CTYPES_INCLUDE) \ -package ctypes.foreign,ctypes.stubs,core,core_bench \ bench_micro_lib.c bench_micro_stubs.c \ bench_micro_generated_stubs.c \ bench_micro_bindings.ml bench_micro_generated.ml bench_micro.ml clean: rm -f bench_micro bench_micro_gen libbench_micro.so rm -f bench_micro_generated.ml bench_micro_generated_stubs.c rm -f bench_micro.eps bench_micro_interpreted.eps rm -f *.o *.cmo *.cmx *.cmi yallop-ocaml-ctypes-3f8211a/tests/bench-micro/bench_micro.gnuplot000066400000000000000000000006241445631112600251560ustar00rootroot00000000000000set terminal eps set output 'bench_micro.eps' set key left top set xlabel "Arity" set autoscale set yrange [0:] set ylabel "Time (ns)" #set title "Mean FFI Call Latency by Arity" set style data linespoints plot "staged_functor.txt" using 1:2 title "Cmeleon Staged", \ "traditional.txt" using 1:2 title "OCaml Manual", \ "cowboy.txt" using 1:2 title "OCaml Expert" yallop-ocaml-ctypes-3f8211a/tests/bench-micro/bench_micro.ml000066400000000000000000000073721445631112600241050ustar00rootroot00000000000000open Core.Std open Core_bench.Std module Bindings = Bench_micro_bindings module Make(Bench : Bindings.API with type 'a fn = 'a) = struct let call = function | 0 -> Staged.stage (fun () -> ignore (Bench.f_i0 ())) | 1 -> Staged.stage (fun () -> ignore (Bench.f_i1 1)) | 2 -> Staged.stage (fun () -> ignore (Bench.f_i2 1 2)) | 3 -> Staged.stage (fun () -> ignore (Bench.f_i3 1 2 3)) | 4 -> Staged.stage (fun () -> ignore (Bench.f_i4 1 2 3 4)) | 5 -> Staged.stage (fun () -> ignore (Bench.f_i5 1 2 3 4 5)) | 6 -> Staged.stage (fun () -> ignore (Bench.f_i6 1 2 3 4 5 6)) | 7 -> Staged.stage (fun () -> ignore (Bench.f_i7 1 2 3 4 5 6 7)) | 8 -> Staged.stage (fun () -> ignore (Bench.f_i8 1 2 3 4 5 6 7 8)) | 9 -> Staged.stage (fun () -> ignore (Bench.f_i9 1 2 3 4 5 6 7 8 9)) | 10-> Staged.stage (fun () -> ignore (Bench.f_i10 1 2 3 4 5 6 7 8 9 10)) | 11-> Staged.stage (fun () -> ignore (Bench.f_i11 1 2 3 4 5 6 7 8 9 10 11)) | 12-> Staged.stage (fun () -> ignore (Bench.f_i12 1 2 3 4 5 6 7 8 9 10 11 12)) | 13-> Staged.stage (fun () -> ignore (Bench.f_i13 1 2 3 4 5 6 7 8 9 10 11 12 13)) | 14-> Staged.stage (fun () -> ignore (Bench.f_i14 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) | 15-> Staged.stage (fun () -> ignore (Bench.f_i15 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) | _ -> assert false end module Interpreted_local = Make(Bindings.Make(Bindings.Interpreter_local)) module Interpreted_shared = Make(Bindings.Make(Bindings.Interpreter_shared)) module Staged_bench = Bindings.Make(Bench_micro_generated) module Staged_functor = Make(Staged_bench) module Staged_no_functor = struct let call = function | 0 -> Staged.stage (fun () -> ignore (Staged_bench.f_i0 ())) | 1 -> Staged.stage (fun () -> ignore (Staged_bench.f_i1 1)) | 2 -> Staged.stage (fun () -> ignore (Staged_bench.f_i2 1 2)) | 3 -> Staged.stage (fun () -> ignore (Staged_bench.f_i3 1 2 3)) | 4 -> Staged.stage (fun () -> ignore (Staged_bench.f_i4 1 2 3 4)) | 5 -> Staged.stage (fun () -> ignore (Staged_bench.f_i5 1 2 3 4 5)) | 6 -> Staged.stage (fun () -> ignore (Staged_bench.f_i6 1 2 3 4 5 6)) | 7 -> Staged.stage (fun () -> ignore (Staged_bench.f_i7 1 2 3 4 5 6 7)) | 8 -> Staged.stage (fun () -> ignore (Staged_bench.f_i8 1 2 3 4 5 6 7 8)) | 9 -> Staged.stage (fun () -> ignore (Staged_bench.f_i9 1 2 3 4 5 6 7 8 9)) | 10-> Staged.stage (fun () -> ignore (Staged_bench.f_i10 1 2 3 4 5 6 7 8 9 10)) | 11-> Staged.stage (fun () -> ignore (Staged_bench.f_i11 1 2 3 4 5 6 7 8 9 10 11)) | 12-> Staged.stage (fun () -> ignore (Staged_bench.f_i12 1 2 3 4 5 6 7 8 9 10 11 12)) | 13-> Staged.stage (fun () -> ignore (Staged_bench.f_i13 1 2 3 4 5 6 7 8 9 10 11 12 13)) | 14-> Staged.stage (fun () -> ignore (Staged_bench.f_i14 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) | 15-> Staged.stage (fun () -> ignore (Staged_bench.f_i15 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) | _ -> assert false end module Traditional = Make(Bindings.Traditional) module Cowboy = Make(Bindings.Cowboy) let zero_to_nine = [0;1;2;3;4;5;6;7;8;9;10;11;12;13;14;15] let () = Command.run (Bench.make_command [ Bench.Test.create_indexed ~name:"interpreted_local" ~args:zero_to_nine Interpreted_local.call; Bench.Test.create_indexed ~name:"interpreted_shared" ~args:zero_to_nine Interpreted_local.call; Bench.Test.create_indexed ~name:"staged_functor" ~args:zero_to_nine Staged_functor.call; Bench.Test.create_indexed ~name:"staged_no_functor" ~args:zero_to_nine Staged_no_functor.call; Bench.Test.create_indexed ~name:"traditional" ~args:zero_to_nine Traditional.call; Bench.Test.create_indexed ~name:"cowboy" ~args:zero_to_nine Cowboy.call; ]) yallop-ocaml-ctypes-3f8211a/tests/bench-micro/bench_micro_bindings.ml000066400000000000000000000164151445631112600257600ustar00rootroot00000000000000module type FOREIGN = sig type 'a fn val foreign : string -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) fn end type int5 = int -> int -> int -> int -> int -> int type int10 = int -> int -> int -> int -> int -> int5 module type API = sig type 'a fn val f_i0 : (unit -> int) fn val f_i1 : (int -> int) fn val f_i2 : (int -> int -> int) fn val f_i3 : (int -> int -> int -> int) fn val f_i4 : (int -> int -> int -> int -> int) fn val f_i5 : int5 fn val f_i6 : (int -> int5) fn val f_i7 : (int -> int -> int5) fn val f_i8 : (int -> int -> int -> int5) fn val f_i9 : (int -> int -> int -> int -> int5) fn val f_i10: int10 fn val f_i11: (int -> int10) fn val f_i12: (int -> int -> int10) fn val f_i13: (int -> int -> int -> int10) fn val f_i14: (int -> int -> int -> int -> int10) fn val f_i15: (int -> int -> int -> int -> int -> int10) fn end module Interpreter_local : FOREIGN with type 'a fn = 'a = struct type 'a fn = 'a external f_i0_ptr : unit -> nativeint = "f_i0_ptr" external f_i1_ptr : unit -> nativeint = "f_i1_ptr" external f_i2_ptr : unit -> nativeint = "f_i2_ptr" external f_i3_ptr : unit -> nativeint = "f_i3_ptr" external f_i4_ptr : unit -> nativeint = "f_i4_ptr" external f_i5_ptr : unit -> nativeint = "f_i5_ptr" external f_i6_ptr : unit -> nativeint = "f_i6_ptr" external f_i7_ptr : unit -> nativeint = "f_i7_ptr" external f_i8_ptr : unit -> nativeint = "f_i8_ptr" external f_i9_ptr : unit -> nativeint = "f_i9_ptr" external f_i10_ptr: unit -> nativeint = "f_i10_ptr" external f_i11_ptr: unit -> nativeint = "f_i11_ptr" external f_i12_ptr: unit -> nativeint = "f_i12_ptr" external f_i13_ptr: unit -> nativeint = "f_i13_ptr" external f_i14_ptr: unit -> nativeint = "f_i14_ptr" external f_i15_ptr: unit -> nativeint = "f_i15_ptr" let foreign name fn = let f_addr = match name with | "f_i0" -> f_i0_ptr () | "f_i1" -> f_i1_ptr () | "f_i2" -> f_i2_ptr () | "f_i3" -> f_i3_ptr () | "f_i4" -> f_i4_ptr () | "f_i5" -> f_i5_ptr () | "f_i6" -> f_i6_ptr () | "f_i7" -> f_i7_ptr () | "f_i8" -> f_i8_ptr () | "f_i9" -> f_i9_ptr () | "f_i10"-> f_i10_ptr () | "f_i11"-> f_i11_ptr () | "f_i12"-> f_i12_ptr () | "f_i13"-> f_i13_ptr () | "f_i14"-> f_i14_ptr () | "f_i15"-> f_i15_ptr () | _ -> assert false in Ctypes.(coerce (ptr void) (Foreign.funptr fn) (ptr_of_raw_address f_addr)) end module Interpreter_shared : FOREIGN with type 'a fn = 'a = struct type 'a fn = 'a let foreign name fn = Foreign.foreign name fn end module Make (F : FOREIGN) : API with type 'a fn = 'a F.fn = struct open Ctypes type 'a fn = 'a F.fn let plus_int5 r = int @-> int @-> int @-> int @-> int @-> r let int5 = plus_int5 (returning int) let int10= plus_int5 int5 let f_i0 = F.foreign "f_i0" @@ void @-> returning int let f_i1 = F.foreign "f_i1" @@ int @-> returning int let f_i2 = F.foreign "f_i2" @@ int @-> int @-> returning int let f_i3 = F.foreign "f_i3" @@ int @-> int @-> int @-> returning int let f_i4 = F.foreign "f_i4" @@ int @-> int @-> int @-> int @-> returning int let f_i5 = F.foreign "f_i5" @@ int5 let f_i6 = F.foreign "f_i6" @@ int @-> int5 let f_i7 = F.foreign "f_i7" @@ int @-> int @-> int5 let f_i8 = F.foreign "f_i8" @@ int @-> int @-> int @-> int5 let f_i9 = F.foreign "f_i9" @@ int @-> int @-> int @-> int @-> int5 let f_i10= F.foreign "f_i10"@@ int10 let f_i11= F.foreign "f_i11"@@ int @-> int10 let f_i12= F.foreign "f_i12"@@ int @-> int @-> int10 let f_i13= F.foreign "f_i13"@@ int @-> int @-> int @-> int10 let f_i14= F.foreign "f_i14"@@ int @-> int @-> int @-> int @-> int10 let f_i15= F.foreign "f_i15"@@ int @-> int @-> int @-> int @-> int @-> int10 end module Traditional : API with type 'a fn = 'a = struct type 'a fn = 'a external f_i0 : unit -> int = "f_i0_caml" external f_i1 : int -> int = "f_i1_caml" external f_i2 : int -> int -> int = "f_i2_caml" external f_i3 : int -> int -> int -> int = "f_i3_caml" external f_i4 : int -> int -> int -> int -> int = "f_i4_caml" external f_i5 : int -> int -> int -> int -> int -> int = "f_i5_caml" external f_i6 : int -> int -> int -> int -> int -> int -> int = "f_i6_caml_byte" "f_i6_caml" external f_i7 : int -> int -> int -> int -> int -> int -> int -> int = "f_i7_caml_byte" "f_i7_caml" external f_i8 : int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i8_caml_byte" "f_i8_caml" external f_i9 : int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i9_caml_byte" "f_i9_caml" external f_i10: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i10_caml_byte" "f_i10_caml" external f_i11: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i11_caml_byte" "f_i11_caml" external f_i12: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i12_caml_byte" "f_i12_caml" external f_i13: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i13_caml_byte" "f_i13_caml" external f_i14: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i14_caml_byte" "f_i14_caml" external f_i15: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i15_caml_byte" "f_i15_caml" end module Cowboy : API with type 'a fn = 'a = struct type 'a fn = 'a external f_i0 : unit -> int = "f_i0_cowboy" "noalloc" external f_i1 : int -> int = "f_i1_cowboy" "noalloc" external f_i2 : int -> int -> int = "f_i2_cowboy" "noalloc" external f_i3 : int -> int -> int -> int = "f_i3_cowboy" "noalloc" external f_i4 : int -> int -> int -> int -> int = "f_i4_cowboy" "noalloc" external f_i5 : int -> int -> int -> int -> int -> int = "f_i5_cowboy" "noalloc" external f_i6 : int -> int -> int -> int -> int -> int -> int = "f_i6_cowboy_byte" "f_i6_cowboy" "noalloc" external f_i7 : int -> int -> int -> int -> int -> int -> int -> int = "f_i7_cowboy_byte" "f_i7_cowboy" "noalloc" external f_i8 : int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i8_cowboy_byte" "f_i8_cowboy" "noalloc" external f_i9 : int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i9_cowboy_byte" "f_i9_cowboy" "noalloc" external f_i10: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i10_cowboy_byte" "f_i10_cowboy" "noalloc" external f_i11: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i11_cowboy_byte" "f_i11_cowboy" "noalloc" external f_i12: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i12_cowboy_byte" "f_i12_cowboy" "noalloc" external f_i13: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i13_cowboy_byte" "f_i13_cowboy" "noalloc" external f_i14: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i14_cowboy_byte" "f_i14_cowboy" "noalloc" external f_i15: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i15_cowboy_byte" "f_i15_cowboy" "noalloc" end yallop-ocaml-ctypes-3f8211a/tests/bench-micro/bench_micro_gen.ml000066400000000000000000000007451445631112600247330ustar00rootroot00000000000000let with_formatter ~path f = let chan = open_out path in f Format.(formatter_of_out_channel chan); close_out chan ;; with_formatter ~path:"bench_micro_generated_stubs.c" (fun fmt -> Format.fprintf fmt "#include \"bench_micro_stubs.h\"\n\n"; Cstubs.write_c fmt ~prefix:"bench_micro" (module Bench_micro_bindings.Make)); with_formatter ~path:"bench_micro_generated.ml" (fun fmt -> Cstubs.write_ml fmt ~prefix:"bench_micro" (module Bench_micro_bindings.Make)) yallop-ocaml-ctypes-3f8211a/tests/bench-micro/bench_micro_interpreted.gnuplot000066400000000000000000000005551445631112600275660ustar00rootroot00000000000000set terminal eps set output 'bench_micro_interpreted.eps' set key left top set xlabel "Arity" set autoscale set yrange [0:] set ylabel "Time (ns)" # set title "Mean FFI Call Latency by Arity" set style data linespoints plot "interpreted_shared.txt" using 1:2 title "Cmeleon libffi Interpreted", \ "traditional.txt" using 1:2 title "OCaml Manual" yallop-ocaml-ctypes-3f8211a/tests/bench-micro/bench_micro_lib.c000066400000000000000000000026131445631112600245360ustar00rootroot00000000000000#include "bench_micro_stubs.h" int f_i0() { return 0; } int f_i1(int i0) { return i0; } int f_i2(int i0, int i1) { return i1; } int f_i3(int i0, int i1, int i2) { return i2; } int f_i4(int i0, int i1, int i2, int i3) { return i3; } int f_i5(int i0, int i1, int i2, int i3, int i4) { return i4; } int f_i6(int i0, int i1, int i2, int i3, int i4, int i5) { return i5; } int f_i7(int i0, int i1, int i2, int i3, int i4, int i5, int i6) { return i6; } int f_i8(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7) { return i7; } int f_i9(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8) { return i8; } int f_i10(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9) { return i9; } 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) { return i10; } 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) { return i11; } 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) { return i12; } 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) { return i13; } 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) { return i14; } yallop-ocaml-ctypes-3f8211a/tests/bench-micro/bench_micro_stubs.c000066400000000000000000000321451445631112600251330ustar00rootroot00000000000000#include #include #include #include #include "bench_micro_stubs.h" value f_i0_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i0); } value f_i1_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i1); } value f_i2_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i2); } value f_i3_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i3); } value f_i4_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i4); } value f_i5_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i5); } value f_i6_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i6); } value f_i7_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i7); } value f_i8_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i8); } value f_i9_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i9); } value f_i10_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i10); } value f_i11_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i11); } value f_i12_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i12); } value f_i13_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i13); } value f_i14_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i14); } value f_i15_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i15); } value f_i0_caml(value unit) { CAMLparam1(unit); CAMLreturn(Val_int(f_i0())); } value f_i1_caml(value i0) { CAMLparam1(i0); int ii0 = Int_val(i0); CAMLreturn(Val_int(f_i1(ii0))); } value f_i2_caml(value i0, value i1) { CAMLparam2(i0,i1); int ii0 = Int_val(i0); int ii1 = Int_val(i1); CAMLreturn(Val_int(f_i2(ii0,ii1))); } value f_i3_caml(value i0, value i1, value i2) { CAMLparam3(i0,i1,i2); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); CAMLreturn(Val_int(f_i3(ii0,ii1,ii2))); } value f_i4_caml(value i0, value i1, value i2, value i3) { CAMLparam4(i0,i1,i2,i3); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); CAMLreturn(Val_int(f_i4(ii0,ii1,ii2,ii3))); } value f_i5_caml(value i0, value i1, value i2, value i3, value i4) { CAMLparam5(i0,i1,i2,i3,i4); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); CAMLreturn(Val_int(f_i5(ii0,ii1,ii2,ii3,ii4))); } value f_i6_caml(value i0, value i1, value i2, value i3, value i4, value i5) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam1(i5); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); CAMLreturn(Val_int(f_i6(ii0,ii1,ii2,ii3,ii4,ii5))); } value f_i7_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam2(i5,i6); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); CAMLreturn(Val_int(f_i7(ii0,ii1,ii2,ii3,ii4,ii5,ii6))); } value f_i8_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam3(i5,i6,i7); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); CAMLreturn(Val_int(f_i8(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7))); } value f_i9_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam4(i5,i6,i7,i8); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); CAMLreturn(Val_int(f_i9(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8))); } value f_i10_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam5(i5,i6,i7,i8,i9); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); CAMLreturn(Val_int(f_i10(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9))); } value f_i11_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam5(i5,i6,i7,i8,i9); CAMLxparam1(i10); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); CAMLreturn(Val_int(f_i11(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10))); } value f_i12_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10, value i11) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam5(i5,i6,i7,i8,i9); CAMLxparam2(i10,i11); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); int ii11= Int_val(i11); CAMLreturn(Val_int(f_i12(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10,ii11))); } value f_i13_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10, value i11, value i12) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam5(i5,i6,i7,i8,i9); CAMLxparam3(i10,i11,i12); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); int ii11= Int_val(i11); int ii12= Int_val(i12); CAMLreturn(Val_int(f_i13(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10,ii11,ii12))); } value f_i14_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10, value i11, value i12, value i13) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam5(i5,i6,i7,i8,i9); CAMLxparam4(i10,i11,i12,i13); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); int ii11= Int_val(i11); int ii12= Int_val(i12); int ii13= Int_val(i13); CAMLreturn(Val_int(f_i14(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10,ii11,ii12,ii13))); } value f_i15_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10, value i11, value i12, value i13, value i14) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam5(i5,i6,i7,i8,i9); CAMLxparam5(i10,i11,i12,i13,i14); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); int ii11= Int_val(i11); int ii12= Int_val(i12); int ii13= Int_val(i13); int ii14= Int_val(i14); CAMLreturn(Val_int(f_i15(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10,ii11,ii12,ii13,ii14))); } value f_i0_cowboy(value unit) { return Val_int(f_i0()); } value f_i1_cowboy(value i0) { int ii0 = Int_val(i0); return Val_int(f_i1(ii0)); } value f_i2_cowboy(value i0, value i1) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); return Val_int(f_i2(ii0,ii1)); } value f_i3_cowboy(value i0, value i1, value i2) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); return Val_int(f_i3(ii0,ii1,ii2)); } value f_i4_cowboy(value i0, value i1, value i2, value i3) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); return Val_int(f_i4(ii0,ii1,ii2,ii3)); } value f_i5_cowboy(value i0, value i1, value i2, value i3, value i4) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); return Val_int(f_i5(ii0,ii1,ii2,ii3,ii4)); } value f_i6_cowboy(value i0, value i1, value i2, value i3, value i4, value i5) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); return Val_int(f_i6(ii0,ii1,ii2,ii3,ii4,ii5)); } value f_i7_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); return Val_int(f_i7(ii0,ii1,ii2,ii3,ii4,ii5,ii6)); } value f_i8_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); return Val_int(f_i8(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7)); } value f_i9_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); return Val_int(f_i9(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8)); } value f_i10_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); return Val_int(f_i10(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9)); } value f_i11_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); return Val_int(f_i11(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10)); } value f_i12_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10, value i11) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); int ii11= Int_val(i11); return Val_int(f_i12(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10,ii11)); } value f_i13_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10, value i11, value i12) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); int ii11= Int_val(i11); int ii12= Int_val(i12); return Val_int(f_i13(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10,ii11,ii12)); } value f_i14_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10, value i11, value i12, value i13) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); int ii11= Int_val(i11); int ii12= Int_val(i12); int ii13= Int_val(i13); return Val_int(f_i14(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10,ii11,ii12,ii13)); } value f_i15_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10, value i11, value i12, value i13, value i14) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); int ii11= Int_val(i11); int ii12= Int_val(i12); int ii13= Int_val(i13); int ii14= Int_val(i14); return Val_int(f_i15(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10,ii11,ii12,ii13,ii14)); } yallop-ocaml-ctypes-3f8211a/tests/bench-micro/bench_micro_stubs.h000066400000000000000000000022111445631112600251270ustar00rootroot00000000000000 int f_i0 (); int f_i1 (int i0); int f_i2 (int i0, int i1); int f_i3 (int i0, int i1, int i2); int f_i4 (int i0, int i1, int i2, int i3); int f_i5 (int i0, int i1, int i2, int i3, int i4); int f_i6 (int i0, int i1, int i2, int i3, int i4, int i5); int f_i7 (int i0, int i1, int i2, int i3, int i4, int i5, int i6); int f_i8 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7); int f_i9 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8); int f_i10 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9); 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); 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); 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); 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); 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); yallop-ocaml-ctypes-3f8211a/tests/bench-micro/process_summary.ml000066400000000000000000000047551445631112600250720ustar00rootroot00000000000000type point = { configuration : string; parameter : int; time : float; time_err : float * float; cycles : float; cycles_err : float * float; } let split_on_colon s = let i = String.index s ':' in String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1) let early_float s = Scanf.sscanf s "%f" (fun x -> x) let point_of_row row = let configuration, parameter = split_on_colon row.(0) in let parameter = int_of_string parameter in { configuration; parameter; time=early_float row.(2); time_err=early_float row.(3), early_float row.(4); cycles=early_float row.(6); cycles_err=early_float row.(7), early_float row.(8); } let split_on_spaces s = let rec acc lst s = let t = String.trim s in match String.index t ' ' with | si -> let f = String.sub t 0 si in let r = String.sub t si (String.length t - si) in acc (f::lst) r | exception Not_found -> List.rev (t::lst) in acc [] s let print_pretty_point ({ configuration; parameter; time; time_err; cycles; cycles_err }) = Printf.printf "Configuration: %s\nParameter: %d\n" configuration parameter; Printf.printf "Time: %f %f %+f\nCycles: %f %f %+f\n\n" time (fst time_err) (snd time_err) cycles (fst cycles_err) (snd cycles_err) ;; let benchmark_names = [ "interpreted_local"; "interpreted_shared"; "staged_functor"; "staged_no_functor"; "traditional"; "cowboy"; ] in let columns = 9 in if Array.length Sys.argv < 2 then failwith "must provide benchmark summary file" else let data = ref [] in let path = Sys.argv.(1) in let ic = open_in path in try while true do let line = input_line ic in let prefix = String.sub line 0 6 in if prefix = " -----" then while true do let line = input_line ic in data := line :: !data done done with End_of_file -> close_in ic; let table = List.rev_map split_on_spaces !data in let table = List.filter (fun row -> List.length row = columns) table in let points = List.map (fun row -> point_of_row (Array.of_list row)) table in List.iter (fun c -> let points = List.filter (function | { configuration } when configuration = c -> true | _ -> false ) points in let data_file = c ^ ".txt" in let oc = open_out data_file in List.iter (fun { parameter; time; cycles } -> Printf.fprintf oc "%d\t%f\t%f\n" parameter time cycles ) points; close_out oc ) benchmark_names yallop-ocaml-ctypes-3f8211a/tests/clib/000077500000000000000000000000001445631112600200155ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/clib/dune000066400000000000000000000006211445631112600206720ustar00rootroot00000000000000(library (name test_functions) (install_c_headers test_functions) (foreign_stubs (language c) (names test_functions)) (c_library_flags -pthread) (libraries ctypes)) (rule (target clib%{ext_dll}) (deps (source_tree ../../src/ctypes) test_functions.h) (action (run %{cc} -I ../../src/ctypes -I %{ocaml_where} -o %{target} -shared %{dep:test_functions.c}))) yallop-ocaml-ctypes-3f8211a/tests/clib/test_functions.c000066400000000000000000000510561445631112600232370ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #include #include #include #include #include #include #include #include #include #include #include #if defined _WIN32 && !defined __CYGWIN__ #include #else #include #include #if defined(__APPLE__) #include #else #include #endif #endif #include "ctypes_complex_compatibility.h" #include "test_functions.h" static int add(int x, int y) { return x + y; } static int times(int x, int y) { return x * y; } int higher_order_1(intfun *f, int x, int y) { return f(x, y) == x + y; } int higher_order_3(acceptor *f, intfun *fn, int x, int y) { return f(fn, x, y); } int higher_order_simplest(vintfun *f) { return f(22); } intfun *returning_funptr(int v) { switch (v) { case 0: return add; case 1: return times; default: return NULL; } } int accepting_possibly_null_funptr(intfun *f, int x, int y) { return f != NULL ? f(x, y) : -1; } int global = 100; int *return_global_address(void) { return &global; } double float_pointer_callback(void (*f)(double *), double v) { f(&v); return v * 2.0; } int write_through_callback(int (*f)(int *)) { int x = 42; return f(&x) + x; } int write_through_callback_pointer_pointer(int (*f)(int **, int *)) { int x = 10, y = 20; int *p =&x; return f(&p, &y) + *p + x + y; } int is_null(void *p) { return p == NULL; } int callback_returns_funptr(vintfun *(*f)(int), int x) { vintfun *v1 = f(x); vintfun *v2 = f(x + 1); return v1(10) + v2(20); } int *pass_pointer_through(int *a, int *b, int i) { return (i >= 0) ? a : b; } int accept_struct(struct simple simple) { return simple.i + (int)simple.f + (simple.self == NULL ? 1 : 0); } struct simple return_struct(void) { struct simple *t = malloc(sizeof *t); t->i = 10; t->f = 12.5; t->self = t; struct simple s = { 20, 35.0, t }; return s; } int64_t sum_union_components(union padded *padded, size_t len) { size_t i; int64_t acc = 0; for (i = 0; i < len; i++) { acc += padded[i].i; } return acc; } union padded add_unions(union padded l, union padded r) { union padded result, args[] = { l, r }; result.i = sum_union_components(args, sizeof args / sizeof *args); return result; } void concat_strings(const char **sv, int sc, char *buffer) { int i = 0; for (; i < sc; i++) { const char *s = sv[i]; while (*s) { *buffer++ = *s++; } } *buffer = '\0'; } struct tagged add_tagged_numbers(struct tagged l, struct tagged r) { struct tagged result = { 'd' }; switch (l.tag) { case 'i': switch (r.tag) { case 'i': result.num.d = l.num.i + r.num.i; return result; case 'd': result.num.d = l.num.i + r.num.d; return result; default: assert(0); } case 'd': switch (r.tag) { case 'i': result.num.d = l.num.d + r.num.i; return result; case 'd': result.num.d = l.num.d + r.num.d; return result; default: assert(0); } default: assert(0); } } double accepts_pointer_to_array_of_structs(struct tagged(*arr)[5]) { double sum = 0.0; int i = 0; struct tagged *s = &(*arr[0]); for (; i < 5; i++) { switch (s[i].tag) { case 'i': { sum += s[i].num.i; break; } case 'd': { sum += s[i].num.d; break; } default: assert(0); } } return sum; } struct global_struct global_struct = { sizeof GLOBAL_STRING - 1, GLOBAL_STRING }; struct triple add_triples(struct triple l, struct triple r) { int i = 0; struct triple result; for (; i < 3; i++) { result.elements[i] = l.elements[i] + r.elements[i]; } return result; } /* OO-style example */ struct animal_methods; struct animal { struct animal_methods *vtable; }; struct animal_methods { char *(*say)(struct animal *); char *(*identify)(struct animal *); }; int check_name(struct animal *a, char *name) { return strcmp(a->vtable->identify(a), name) == 0; } enum colour { white, red, black, pale }; struct chorse_methods; struct chorse { struct chorse_methods *vtable; enum colour colour; }; struct chorse_methods { struct animal_methods base; char *(*colour)(struct chorse *); }; char *chorse_colour(struct chorse *chorse) { switch (chorse->colour) { case white : return "white"; case red : return "red"; case black : return "black"; case pale : return "pale"; default: assert(0); } } char *chorse_say(struct animal *c) { return "neigh"; } char *chorse_identify(struct animal *a) { static char buffer[30]; /* static allocation is adequate for the test */ sprintf(buffer, "%s horse", chorse_colour((struct chorse *)a)); return buffer; } static struct chorse_methods chorse_vtable = { { chorse_say, chorse_identify, }, chorse_colour, }; struct chorse *new_chorse(int colour) { struct chorse *h = malloc(sizeof *h); h->vtable = &chorse_vtable; h->colour = (enum colour)colour; return h; } /* (End of OO-style example) */ int accept_pointers(float *float_p, double *double_p, short *short_p, int *int_p, long *long_p, long long *llong_p, intnat *nativeint_p, int8_t *int8_t_p, int16_t *int16_t_p, int32_t *int32_t_p, int64_t *int64_t_p, uint8_t *uint8_t_p, uint16_t *uint16_t_p, uint32_t *uint32_t_p, uint64_t *uint64_t_p, size_t *size_t_p, unsigned short *ushort_p, unsigned *uint_p, unsigned long *ulong_p, unsigned long long *ullong_p) { return (*float_p + *double_p + *short_p + *int_p + *long_p + *llong_p + *nativeint_p + *int8_t_p + *int16_t_p + *int32_t_p + *int64_t_p + *uint8_t_p + *uint16_t_p + *uint32_t_p + *uint64_t_p + *size_t_p + *ushort_p + *uint_p + *ulong_p + *ullong_p); } int accept_pointers_to_pointers(int *p, int **pp, int ***ppp, int ****pppp) { return *p + **pp + ***ppp + ****pppp; } intfun **returning_pointer_to_function_pointer(void) { static intfun *f = times; return &f; } int accepting_pointer_to_function_pointer(intfun **pfp) { return (*pfp)(20, 4); } int passing_pointers_to_callback(pintfun1 *f) { int x = 3, y = 4; return f(&x, &y); } int accepting_pointer_from_callback(pintfun2 *f) { int *p = f(7, 8); int q = *p; *p = 12; return q; } signed char retrieve_SCHAR_MIN(void) { return SCHAR_MIN; } signed char retrieve_SCHAR_MAX(void) { return SCHAR_MAX; } unsigned char retrieve_UCHAR_MAX(void) { return UCHAR_MAX; } char retrieve_CHAR_MIN(void) { return CHAR_MIN; } char retrieve_CHAR_MAX(void) { return CHAR_MAX; } short retrieve_SHRT_MIN(void) { return SHRT_MIN; } short retrieve_SHRT_MAX(void) { return SHRT_MAX; } unsigned short retrieve_USHRT_MAX(void) { return USHRT_MAX; } int retrieve_INT_MIN(void) { return INT_MIN; } int retrieve_INT_MAX(void) { return INT_MAX; } unsigned int retrieve_UINT_MAX(void) { return UINT_MAX; } long retrieve_LONG_MAX(void) { return LONG_MAX; } long retrieve_LONG_MIN(void) { return LONG_MIN; } unsigned long retrieve_ULONG_MAX(void) { return ULONG_MAX; } long long retrieve_LLONG_MAX(void) { return LLONG_MAX; } long long retrieve_LLONG_MIN(void) { return LLONG_MIN; } unsigned long long retrieve_ULLONG_MAX(void) { return ULLONG_MAX; } int8_t retrieve_INT8_MIN(void) { return INT8_MIN; } int16_t retrieve_INT16_MIN(void) { return INT16_MIN; } int32_t retrieve_INT32_MIN(void) { return INT32_MIN; } int64_t retrieve_INT64_MIN(void) { return INT64_MIN; } int8_t retrieve_INT8_MAX(void) { return INT8_MAX; } int16_t retrieve_INT16_MAX(void) { return INT16_MAX; } int32_t retrieve_INT32_MAX(void) { return INT32_MAX; } int64_t retrieve_INT64_MAX(void) { return INT64_MAX; } uint8_t retrieve_UINT8_MAX(void) { return UINT8_MAX; } uint16_t retrieve_UINT16_MAX(void) { return UINT16_MAX; } uint32_t retrieve_UINT32_MAX(void) { return UINT32_MAX; } uint64_t retrieve_UINT64_MAX(void) { return UINT64_MAX; } size_t retrieve_SIZE_MAX(void) { return SIZE_MAX; } float retrieve_FLT_MIN(void) { return FLT_MIN; } float retrieve_FLT_MAX(void) { return FLT_MAX; } double retrieve_DBL_MIN(void) { return DBL_MIN; } double retrieve_DBL_MAX(void) { return DBL_MAX; } void add_complexd(double _Complex *l, double _Complex *r, double _Complex *out) { *out = *l + *r; } void mul_complexd(double _Complex *l, double _Complex *r, double _Complex *out) { *out = *l * *r; } void rotdist_complexd(double _Complex *c, double *r, double *out) { double _Complex x = *c * (ctypes_compat_make_complex(cos(*r), sin(*r))); *out = fabs(ctypes_compat_creal(x)) + fabs(ctypes_compat_cimag(x)); } void add_complexld(long double _Complex *l, long double _Complex *r, long double _Complex *out) { *out = *l + *r; } void mul_complexld(long double _Complex *l, long double _Complex *r, long double _Complex *out) { *out = *l * *r; } void rotdist_complexld(long double _Complex *c, long double *r, long double *out) { long double _Complex x = *c * (ctypes_compat_make_complexl(cosl(*r), sinl(*r))); *out = fabsl(ctypes_compat_creall(x)) + fabsl(ctypes_compat_cimagl(x)); } void add_complexf(float _Complex *l, float _Complex *r, float _Complex *out) { *out = *l + *r; } void mul_complexf(float _Complex *l, float _Complex *r, float _Complex *out) { *out = *l * *r; } void rotdist_complexf(float _Complex *c, float *r, float *out) { float _Complex x = *c * (ctypes_compat_make_complexf(cosf(*r), sinf(*r))); *out = fabsf(ctypes_compat_crealf(x)) + fabsf(ctypes_compat_cimagf(x)); } long double _Complex add_complexld_val(long double _Complex l, long double _Complex r) { return l + r; } long double _Complex mul_complexld_val(long double _Complex l, long double _Complex r) { return l * r; } long double rotdist_complexld_val(long double _Complex c, long double r) { long double _Complex x = c * (ctypes_compat_make_complexl(cosl(r), sinl(r))); return fabsl(ctypes_compat_creall(x)) + fabsl(ctypes_compat_cimagl(x)); } double _Complex add_complexd_val(double _Complex l, double _Complex r) { return l + r; } double _Complex mul_complexd_val(double _Complex l, double _Complex r) { return l * r; } double rotdist_complexd_val(double _Complex c, double r) { double _Complex x = c * (ctypes_compat_make_complex(cos(r), sin(r))); return fabs(ctypes_compat_creal(x)) + fabs(ctypes_compat_cimag(x)); } float _Complex add_complexf_val(float _Complex l, float _Complex r) { return l + r; } float _Complex mul_complexf_val(float _Complex l, float _Complex r) { return l * r; } float rotdist_complexf_val(float _Complex c, float r) { float _Complex x = c * (ctypes_compat_make_complexf(cosf(r), sinf(r))); return fabsf(ctypes_compat_crealf(x)) + fabsf(ctypes_compat_cimagf(x)); } static int (*global_stored_callback)(int) = NULL; void store_callback(int (*f)(int)) { global_stored_callback = f; } int invoke_stored_callback(int x) { return global_stored_callback(x); } vintfun *return_callback(vintfun *f) { return f; } struct one_int return_struct_by_value(void) { struct one_int v = { 3 }; return v; } /* naive matrix operations */ void matrix_mul(int lrows, int lcols, int rcols, double *l, double *r, double *prod) { int i, j, k; for (i = 0; i < lrows; i++) { for (j = 0; j < rcols; j++) { prod[i * rcols + j] = 0.0; for (k = 0; k < lcols; k++) { prod[i * rcols + j] += l[i * lcols + k] * r[k * rcols + j]; } } } } double *matrix_transpose(int rows, int cols, double *matrix) { int i, j; double *rv = malloc(rows * cols * sizeof *rv); for (i = 0; i < rows; i++) for (j = 0; j < cols; j++) rv[j * rows + i] = matrix[i * cols + j]; return rv; } int (*plus_callback)(int) = NULL; /* Sum the range [a, b] */ int sum_range_with_plus_callback(int a, int b) { int sum = 0, i = 0; for (i = a; i <= b; i++) { sum += i; } return sum; } static callback_t *registered_callback = NULL; void register_callback(callback_t *f) { registered_callback = f; } void call_registered_callback(int times, int starting_value) { int i; for (i = 0; i < times; i++) { int result = registered_callback(); assert (result == starting_value++); } } #ifdef __APPLE__ #define sem_t dispatch_semaphore_t #define sem_init(sem, sem_attr1, sem_init_value) \ ((*sem = dispatch_semaphore_create(sem_init_value)) == NULL) #define sem_wait(sem) \ dispatch_semaphore_wait(*sem, DISPATCH_TIME_FOREVER) #define sem_post(sem) \ (dispatch_semaphore_signal(*sem),0) #define sem_destroy(sem) \ (dispatch_release(*sem),0) #elif defined(_WIN32) && !defined(__CYGWIN__) #define sem_t HANDLE #define sem_init(sem, sem_attr1, sem_init_value) \ ((*sem = CreateSemaphore(NULL,0,32768,NULL)) == NULL) #define sem_wait(sem) \ (WAIT_OBJECT_0 != WaitForSingleObject(*sem,INFINITE)) #define sem_post(sem) (ReleaseSemaphore(*sem,1,NULL) == 0) #define sem_destroy(sem) (CloseHandle(*sem) == 0 ) #endif static sem_t semaphore1; static sem_t semaphore2; static int semaphores_intialized; void initialize_waiters(void) { if ( semaphores_intialized ) { assert ( sem_destroy(&semaphore1) == 0 ); assert ( sem_destroy(&semaphore2) == 0 ); } assert ( sem_init(&semaphore1, 0, 0) == 0 ); assert ( sem_init(&semaphore2, 0, 0) == 0 ); semaphores_intialized = 1; } void post1_wait2(void) { int e; assert ( sem_post(&semaphore1) == 0 ); errno = 0; do { e = sem_wait(&semaphore2); } while ( e && errno == EINTR ); assert ( e == 0 ); } void post2_wait1(void) { int e; assert ( sem_post(&semaphore2) == 0 ); errno = 0; do { e = sem_wait(&semaphore1); } while ( e && errno == EINTR ); assert ( e == 0 ); } size_t sizeof_s1(void) { return sizeof(struct s1); } size_t alignmentof_s1(void) { return offsetof(struct { char c; struct s1 x; }, x); } size_t offsetof_x1(void) { return offsetof(struct s1, x1); } size_t offsetof_x2(void) { return offsetof(struct s1, x2); } size_t offsetof_x3(void) { return offsetof(struct s1, x3); } size_t offsetof_x4(void) { return offsetof(struct s1, x4); } size_t sizeof_s2(void) { return sizeof(struct s2); } size_t alignmentof_s2(void) { return offsetof(struct { char c; struct s2 x; }, x); } size_t offsetof_y1(void) { return offsetof(struct s2, y1); } size_t offsetof_y2(void) { return offsetof(struct s2, y2); } size_t offsetof_y3(void) { return offsetof(struct s2, y3); } size_t offsetof_y4(void) { return offsetof(struct s2, y4); } size_t sizeof_s3(void) { return sizeof(struct s3); } size_t alignmentof_s3(void) { return offsetof(struct { char c; struct s3 x; }, x); } size_t offsetof_z1(void) { return offsetof(struct s3, z1); } size_t offsetof_z2(void) { return offsetof(struct s3, z2); } size_t sizeof_s4(void) { return sizeof(struct s4); } size_t alignmentof_s4(void) { return offsetof(struct { char c; struct s4 x; }, x); } size_t offsetof_z3(void) { return offsetof(struct s4, z3); } size_t offsetof_z4(void) { return offsetof(struct s4, z4); } size_t sizeof_s6(void) { return sizeof(s6); } size_t alignmentof_s6(void) { return offsetof(struct { char c; s6 x; }, x); } size_t offsetof_v1(void) { return offsetof(s6, v1); } size_t offsetof_v2(void) { return offsetof(s6, v2); } size_t sizeof_u1(void) { return sizeof(union u1); } size_t alignmentof_u1(void) { return offsetof (struct { char c; union u1 x; }, x); } size_t sizeof_u2(void) { return sizeof(u2); } size_t alignmentof_u2(void) { return offsetof (struct { char c; u2 x; }, x); } bool bool_and(bool l, bool r) { return l && r; } int call_s5(struct s1 *s1, struct s5 *s5) { return s5->w1(s1); } enum signed_enum classify_integer(int x) { return (x < 0) ? minus_one : plus_one; } enum signed_enum out_of_range(void) { return (enum signed_enum)2; } enum fruit next_fruit(enum fruit f) { switch (f) { case Orange: return Apple; case Apple: return Banana; case Banana: return Pear; case Pear: return Orange; default: assert(0); } } int32_t sum_int_array(int32_t *arr, size_t len) { int32_t sum = 0; size_t i = 0; for (; i < len; i++) { sum += arr[i]; } return sum; } void *global_ocaml_value = NULL; void save_ocaml_value(void *p) { global_ocaml_value = p; } void *retrieve_ocaml_value(void) { return global_ocaml_value; } int sixargs(int x1, int x2, int x3, int x4, int x5, int x6) { return x1 + x2 + x3 + x4 + x5 + x6; } int return_10(void) { return 10; } void return_void(int *x) { *x = 10; return; } int callback_returns_char_a(char (*f)(void)) { return f() == 'a' ? 1 : 0; } #define GEN_RETURN_F(type) \ type callback_returns_ ## type (type (*f)(void)) \ { \ type x = f(); \ return x; \ } \ GEN_RETURN_F(uint8_t) GEN_RETURN_F(uint16_t) GEN_RETURN_F(uint32_t) GEN_RETURN_F(uint64_t) GEN_RETURN_F(int8_t) GEN_RETURN_F(int16_t) GEN_RETURN_F(int32_t) GEN_RETURN_F(int64_t) GEN_RETURN_F(float) GEN_RETURN_F(double) GEN_RETURN_F(bool) char *string_array[2] = { "Hello", "world" }; int32_t int_array[5] = { 0, 1, 2, 3, 4 }; void check_ones(const int *p, size_t sz) { unsigned i = 0; for (; i < sz; i++) { assert (p[i] == 1); } } intnat max_caml_int(void) { return (intnat)(((uintnat)-1) / 4); } static uint64_t thread_id(void) { #ifdef _WIN32 return (GetCurrentThreadId()); #else /* if pthread_t is a struct greater than uint64_t, the test could fail ... */ union { uint64_t i; pthread_t t; } u; memset(&u, 0, sizeof(u)); u.t = pthread_self(); return u.i; #endif } #ifndef _WIN32 typedef pthread_t thread_t; typedef void *(*start_routine)(void *); #else typedef HANDLE thread_t; typedef DWORD WINAPI (*start_routine)(void *); #endif static int thread_create(thread_t *t, start_routine f, void * param) { #ifndef _WIN32 return (pthread_create(t, NULL, f, param)); #else HANDLE h = CreateThread(NULL,0,f,param,0,NULL); *t = h; return ( h == NULL ); #endif } static int thread_join(thread_t t) { #ifndef _WIN32 return ( pthread_join(t, NULL) ); #else WaitForSingleObject(t, INFINITE); return 0; #endif } typedef struct { void (*f)(uint64_t); const unsigned n_callback; } t_info; static void call_multiple_times_r(void *fp) { const t_info * t = fp; void (*f)(uint64_t) = t->f; const unsigned n_callback = t->n_callback; const uint64_t tid = thread_id(); unsigned i; for ( i = 0 ; i < n_callback ; ++i ) { f(tid); } } #ifndef _WIN32 static void *call_multiple_times(void *fp) { call_multiple_times_r(fp); return NULL; } #else static DWORD WINAPI call_multiple_times(void *fp) { call_multiple_times_r(fp); return 0; } #endif int foreign_thread_registration_test(void (*test_f)(uint64_t), unsigned n_threads, unsigned n_callback) { thread_t * h_thread; unsigned i; int ret_code = 0; unsigned i_max = 0; t_info thread_info = { .f = test_f , .n_callback = n_callback }; const uint64_t tid = thread_id(); h_thread = malloc(n_threads * (sizeof *h_thread)); if ( h_thread == NULL ){ fputs("malloc failed\n",stderr); return 1; } for ( i = 0 ; i < n_threads ; ++i ) { if ( thread_create(&h_thread[i], call_multiple_times, &thread_info) ) { fputs("Error creating thread\n",stderr); ret_code = 1; break; } } i_max = i; for ( i = 0 ; i < i_max ; ++i ) { if ( i < n_callback ) { test_f(tid); } if ( thread_join(h_thread[i]) ) { fputs("Error joining thread\n",stderr); ret_code = 1; } } for ( i = n_threads ; i < n_callback ; ++i ) { test_f(tid); } free(h_thread); return ret_code; } int call_dynamic_funptr(int (*f)(int), int n) { if (f == NULL) return 0; else return f(n); } int(*saved_dynamic_funptr)(int) = NULL; void save_dynamic_funptr(int (*f)(int)) { saved_dynamic_funptr = f; } int call_saved_dynamic_funptr(int n) { return call_dynamic_funptr(saved_dynamic_funptr, n); } int call_dynamic_funptr_struct(struct simple_closure x) { return x.f(x.n); } int call_dynamic_funptr_struct_ptr(struct simple_closure *x) { return x->f(x->n); } yallop-ocaml-ctypes-3f8211a/tests/clib/test_functions.h000066400000000000000000000217771445631112600232530ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef TEST_FUNCTIONS_H #define TEST_FUNCTIONS_H #include #include #include #include #include typedef int intfun(int, int); extern int higher_order_1(intfun *, int, int); typedef int acceptor(intfun *, int, int); extern int higher_order_3(acceptor *, intfun *, int, int); typedef int vintfun(int); extern int higher_order_simplest(vintfun *); extern intfun *returning_funptr(int); extern int accepting_possibly_null_funptr(intfun *, int, int); extern int global; extern int *return_global_address(void); extern double float_pointer_callback(void (*)(double *), double); extern int write_through_callback(int (*)(int *)); extern int write_through_callback_pointer_pointer(int (*)(int **, int *)); extern int is_null(void *); extern int callback_returns_funptr(vintfun *(*)(int), int); extern int *pass_pointer_through(int *, int *, int); struct simple { int i; double f; struct simple *self; }; extern int accept_struct(struct simple); extern struct simple return_struct(void); union padded { int64_t i; char a[sizeof(int64_t) + 1]; }; extern int64_t sum_union_components(union padded *, size_t); extern union padded add_unions(union padded, union padded); extern void concat_strings(const char **, int, char *); union number { int i; double d; }; struct tagged { char tag; union number num; }; extern struct tagged add_tagged_numbers(struct tagged, struct tagged); extern double accepts_pointer_to_array_of_structs(struct tagged(*)[5]); #define GLOBAL_STRING "global string" struct global_struct { size_t len; const char str[sizeof GLOBAL_STRING]; }; extern struct global_struct global_struct; struct triple { double elements[3]; }; extern struct triple add_triples(struct triple, struct triple); struct animal; struct chorse; extern int check_name(struct animal *, char *); extern char *chorse_colour(struct chorse *); extern char *chorse_say(struct animal *); extern char *chorse_identify(struct animal *); extern struct chorse *new_chorse(int); extern int accept_pointers(float *, double *, short *, int *, long *, long long *, intnat *, int8_t *, int16_t *, int32_t *, int64_t *, uint8_t *, uint16_t *, uint32_t *, uint64_t *, size_t *, unsigned short *, unsigned *, unsigned long *, unsigned long long *); int accept_pointers_to_pointers(int *, int **, int ***, int ****); intfun **returning_pointer_to_function_pointer(void); int accepting_pointer_to_function_pointer(intfun **); typedef int pintfun1(int *, int *); int passing_pointers_to_callback(pintfun1 *); typedef int *pintfun2(int, int); int accepting_pointer_from_callback(pintfun2 *); signed char retrieve_SCHAR_MIN(void); signed char retrieve_SCHAR_MAX(void); unsigned char retrieve_UCHAR_MAX(void); char retrieve_CHAR_MIN(void); char retrieve_CHAR_MAX(void); short retrieve_SHRT_MIN(void); short retrieve_SHRT_MAX(void); unsigned short retrieve_USHRT_MAX(void); int retrieve_INT_MIN(void); int retrieve_INT_MAX(void); unsigned int retrieve_UINT_MAX(void); long retrieve_LONG_MAX(void); long retrieve_LONG_MIN(void); unsigned long retrieve_ULONG_MAX(void); long long retrieve_LLONG_MAX(void); long long retrieve_LLONG_MIN(void); unsigned long long retrieve_ULLONG_MAX(void); int8_t retrieve_INT8_MIN(void); int16_t retrieve_INT16_MIN(void); int32_t retrieve_INT32_MIN(void); int64_t retrieve_INT64_MIN(void); int8_t retrieve_INT8_MAX(void); int16_t retrieve_INT16_MAX(void); int32_t retrieve_INT32_MAX(void); int64_t retrieve_INT64_MAX(void); uint8_t retrieve_UINT8_MAX(void); uint16_t retrieve_UINT16_MAX(void); uint32_t retrieve_UINT32_MAX(void); uint64_t retrieve_UINT64_MAX(void); size_t retrieve_SIZE_MAX(void); float retrieve_FLT_MIN(void); float retrieve_FLT_MAX(void); double retrieve_DBL_MIN(void); double retrieve_DBL_MAX(void); void add_complexd(double _Complex *, double _Complex *, double _Complex *); void mul_complexd(double _Complex *, double _Complex *, double _Complex *); void rotdist_complexd(double _Complex *, double *, double *); void add_complexld(long double _Complex *, long double _Complex *, long double _Complex *); void mul_complexld(long double _Complex *, long double _Complex *, long double _Complex *); void rotdist_complexld(long double _Complex *, long double *, long double *); void add_complexf(float _Complex *, float _Complex *, float _Complex *); void mul_complexf(float _Complex *, float _Complex *, float _Complex *); void rotdist_complexf(float _Complex *, float *, float *); double _Complex add_complexd_val(double _Complex, double _Complex); double _Complex mul_complexd_val(double _Complex, double _Complex); double rotdist_complexd_val(double _Complex, double); long double _Complex add_complexld_val(long double _Complex, long double _Complex); long double _Complex mul_complexld_val(long double _Complex, long double _Complex); long double rotdist_complexld_val(long double _Complex, long double); float _Complex add_complexf_val(float _Complex, float _Complex); float _Complex mul_complexf_val(float _Complex, float _Complex); float rotdist_complexf_val(float _Complex, float); void store_callback(int (*)(int)); int invoke_stored_callback(int); vintfun *return_callback(vintfun *); struct one_int { int i; }; struct one_int return_struct_by_value(void); void matrix_mul(int, int, int, double *, double *, double *); double *matrix_transpose(int, int, double *); extern int (*plus_callback)(int); int sum_range_with_plus_callback(int, int); typedef int callback_t(void); void register_callback(callback_t *); void call_registered_callback(int, int); void initialize_waiters(void); void post1_wait2(void); void post2_wait1(void); struct s1 { int x1, x2, x3, x4; }; struct s2 { int y1, y2, y3, y4; }; struct s3 { int z1; struct s3 *z2; }; struct s4 { struct s3 z3; struct s3 *z4; }; struct s5 { int (*w1)(struct s1 *); }; typedef struct { int v1; float v2; } s6; size_t sizeof_s1(void); size_t alignmentof_s1(void); size_t offsetof_x1(void); size_t offsetof_x2(void); size_t offsetof_x3(void); size_t offsetof_x4(void); size_t sizeof_s2(void); size_t alignmentof_s2(void); size_t offsetof_y1(void); size_t offsetof_y2(void); size_t offsetof_y3(void); size_t offsetof_y4(void); size_t sizeof_s3(void); size_t alignmentof_s3(void); size_t offsetof_z1(void); size_t offsetof_z2(void); size_t sizeof_s4(void); size_t alignmentof_s4(void); size_t offsetof_z3(void); size_t offsetof_z4(void); size_t sizeof_s6(void); size_t alignmentof_s6(void); size_t offsetof_v1(void); size_t offsetof_v2(void); union u1 { char x1; float x2; double x3; char x4[13]; }; typedef union { int t1; float t2; } u2; size_t sizeof_u1(void); size_t alignmentof_u1(void); size_t sizeof_u2(void); size_t alignmentof_u2(void); bool bool_and(bool, bool); int call_s5(struct s1 *, struct s5 *); enum letter { A, B, C = 10, D }; enum fruit { Orange, Apple, Banana, Pear }; enum bears { Edward, Winnie, Paddington }; enum signed_enum { minus_one = -1, plus_one = 1 }; enum fruit next_fruit(enum fruit); enum signed_enum classify_integer(int); enum signed_enum out_of_range(void); struct fruit_cell { enum fruit frt; struct fruit_cell *next; }; typedef enum letter letter_t; typedef enum bears bears_t; int32_t sum_int_array(int32_t *, size_t); void save_ocaml_value(void *); void *retrieve_ocaml_value(void); int sixargs(int, int, int, int, int, int); int return_10(void); void return_void(int *); int callback_returns_char_a(char (*)(void)); uint8_t callback_returns_uint8_t(uint8_t (*f)(void)); uint16_t callback_returns_uint16_t(uint16_t (*f)(void)); uint32_t callback_returns_uint32_t(uint32_t (*f)(void)); uint64_t callback_returns_uint64_t(uint64_t (*f)(void)); int8_t callback_returns_int8_t(int8_t (*f)(void)); int16_t callback_returns_int16_t(int16_t (*f)(void)); int32_t callback_returns_int32_t(int32_t (*f)(void)); int64_t callback_returns_int64_t(int64_t (*f)(void)); float callback_returns_float(float (*f)(void)); double callback_returns_double(double (*f)(void)); bool callback_returns_bool(bool (*f)(void)); extern char *string_array[2]; extern int32_t int_array[5]; void check_ones(const int *, size_t); intnat max_caml_int(void); int foreign_thread_registration_test(void (*)(uint64_t),unsigned,unsigned); int call_dynamic_funptr(int (*)(int),int); void save_dynamic_funptr(int (*)(int)); int call_saved_dynamic_funptr(int); struct simple_closure { int (*f)(int); int n; }; int call_dynamic_funptr_struct(struct simple_closure); int call_dynamic_funptr_struct_ptr(struct simple_closure*); #endif /* TEST_FUNCTIONS_H */ yallop-ocaml-ctypes-3f8211a/tests/config/000077500000000000000000000000001445631112600203515ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/config/dune000066400000000000000000000011761445631112600212340ustar00rootroot00000000000000(executable (name test_config) (libraries dune.configurator)) (rule (targets test-cflags) (deps test_config.exe %{lib:ctypes:cstubs_internals.h} %{lib:ctypes:ctypes_complex_compatibility.h} %{lib:ctypes:ctypes_complex_stubs.h} %{lib:ctypes:ctypes_cstubs_internals.h} %{lib:ctypes:ctypes_ldouble_stubs.h} %{lib:ctypes:ctypes_managed_buffer_stubs.h} %{lib:ctypes:ctypes_primitives.h} %{lib:ctypes:ctypes_raw_pointer.h} %{lib:ctypes:ctypes_type_info_stubs.h}) (action (run %{exe:test_config.exe} -integers-dir %{lib:integers:ocaml_integers.h} -ctypes-dir %{lib:ctypes:ctypes_cstubs_internals.h}))) yallop-ocaml-ctypes-3f8211a/tests/config/test_config.ml000066400000000000000000000007151445631112600232120ustar00rootroot00000000000000module C = Configurator.V1 let () = let ifile = ref "" in let cfile = ref "" in let args = [ "-integers-dir", Arg.Set_string ifile, "location of ocaml_integers.h"; "-ctypes-dir", Arg.Set_string cfile, "location of ctypes_cstubs_internals.h"] in C.main ~args ~name:"ctypes-tests" (fun _c -> let idir = ["-I";Filename.dirname !ifile] in let cdir = ["-I";Filename.dirname !cfile] in C.Flags.write_lines "test-cflags" (idir @ cdir) ) yallop-ocaml-ctypes-3f8211a/tests/flags/000077500000000000000000000000001445631112600202005ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/flags/dune000066400000000000000000000001271445631112600210560ustar00rootroot00000000000000(rule (with-stdout-to link-flags.sexp (run ./gen.exe))) (executable (name gen)) yallop-ocaml-ctypes-3f8211a/tests/flags/gen.ml000066400000000000000000000004071445631112600213040ustar00rootroot00000000000000let () = let ocaml_version_str = Sys.ocaml_version in let ocaml_version = Scanf.sscanf ocaml_version_str "%u.%u" (fun a b -> (a, b)) in if ocaml_version >= (4, 6) then print_endline ":standard" else print_endline "(:standard -ccopt -Wl,-E)" yallop-ocaml-ctypes-3f8211a/tests/flags/gen.mli000066400000000000000000000000141445631112600214470ustar00rootroot00000000000000(* empty *) yallop-ocaml-ctypes-3f8211a/tests/test-alignment/000077500000000000000000000000001445631112600220375ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-alignment/dune000066400000000000000000000001421445631112600227120ustar00rootroot00000000000000(test (package ctypes-foreign) (name test_alignment) (libraries ounit2 ctypes ctypes-foreign)) yallop-ocaml-ctypes-3f8211a/tests/test-alignment/test_alignment.ml000066400000000000000000000205051445631112600254100ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes [@@@warning "-32-34"] (* Test some relationships between the alignment requirements of primitive types. *) let test_primitive_alignment _ = begin assert_equal ~msg:"alignmentof(char) == 1" (alignment char) 1; assert_equal ~msg:"alignmentof(signed char) == 1" (alignment schar) 1; assert_equal ~msg:"alignmentof(unsigned char) == 1" (alignment uchar) 1; assert_equal ~msg:"alignmentof(short) == alignmentof(unsigned short)" (alignment short) (alignment ushort); assert_equal ~msg:"alignmentof(int) == alignmentof(unsigned int)" (alignment int) (alignment uint); assert_equal ~msg:"alignmentof(long) == alignmentof(unsigned long)" (alignment long) (alignment ulong); assert_equal ~msg:"alignmentof(long long) == alignmentof(unsigned long long)" (alignment llong) (alignment ullong); assert_equal ~msg:"alignmentof(int8_t) == alignmentof(uint8_t)" (alignment int8_t) (alignment uint8_t); assert_equal ~msg:"alignmentof(int16_t) == alignmentof(uint16_t)" (alignment int16_t) (alignment uint16_t); assert_equal ~msg:"alignmentof(int32_t) == alignmentof(uint32_t)" (alignment int32_t) (alignment uint32_t); assert_equal ~msg:"alignmentof(int64_t) == alignmentof(uint64_t)" (alignment int64_t) (alignment uint64_t); assert_equal ~msg:"alignmentof(complex32) == alignmentof(float)" (alignment complex32) (alignment float); assert_equal ~msg:"alignmentof(complex64) == alignmentof(double)" (alignment complex64) (alignment double); assert_equal ~msg:"alignmentof(complexld) == alignmentof(ldouble)" (alignment complexld) (alignment ldouble); end (* Test the alignment of abstract types *) let test_abstract_alignment _ = for i = 1 to 10 do assert_equal i (alignment (abstract ~name:"abstract" ~size:(11 - i) ~alignment:i)) done (* Test that requesting the alignment of an incomplete type raises an exception. *) let test_incomplete_alignment _ = assert_raises IncompleteType (fun () -> alignment void); let module M = struct let t = structure "t" let i = field t "i" int let () = assert_raises IncompleteType (fun () -> alignment t) end in let module M = struct let u = union "u" let i = field u "i" int let () = assert_raises IncompleteType (fun () -> alignment u) end in () (* Test that [alignment] treats OCaml types as incomplete. *) let test_alignment_ocaml_string _ = assert_raises IncompleteType (fun () -> alignment ocaml_string) (* Test that the alignment of a struct is equal to the maximum alignment of its members. *) let test_struct_alignment _ = let module M = struct type a and b and u let maximum = List.fold_left max 0 let struct_a = structure "A" let (-:) ty label = field struct_a label ty let _ = char -: "_" let _ = int -: "_" let _ = double -: "_" let () = seal struct_a let () = assert_equal (maximum [alignment char; alignment int; alignment double]) (alignment struct_a) let abs = abstract ~name:"abs" ~size:33 ~alignment:33 let charish = view ~read:(fun _ -> ()) ~write:(fun () -> 'c') char let struct_b = structure "A" let (-:) ty label = field struct_b label ty let _ = charish -: "_" let _ = Foreign.funptr (int @-> returning int) -: "_" let _ = abs -: "_" let _ = double -: "_" let () = seal struct_b let () = assert_equal (maximum [alignment charish; alignment (Foreign.funptr (int @-> returning int)); alignment abs; alignment double]) (alignment struct_b) end in () (* Test that structs are properly tail-padded. For example, suppose a 32-bit architecture with 8-bit bytes and word-aligned ints and the following definitions: struct A { char a; int b; char c; }; struct B { struct A d; char e; } Then we should have the following layouts: A: a---bbbbc--- B: A-----------e--- and the following sizes: sizeof (struct A) == 12 sizeof (struct B) == 16 *) let test_struct_tail_padding _ = let module M = struct type a and b and u let struct_a = structure "A" let (-:) ty label = field struct_a label ty let a = char -: "a" let b = int -: "b" let c = char -: "c" let () = seal (struct_a : a structure typ) let u = union "U" let (-:) ty label = field u label ty let x = char -: "x" let () = seal (u : u union typ) let struct_b = structure "B" let (-:) ty label = field struct_b label ty let d = struct_a -: "d" let e = u -: "e" let () = seal (struct_b : b structure typ) let char_ptr p = from_voidp char (to_voidp p) let va = make struct_a and vb = make struct_b let pa = addr va and pb = addr vb let () = begin assert_equal ~msg:"offsetof (A, a) == 0" (offsetof a) 0 ~printer:string_of_int; assert_equal ~msg:"offsetof(A, b) == alignmentof(int)" (offsetof b) (alignment int) ~printer:string_of_int; assert_equal ~msg:"((char *)&pa->b - (char *)&pa->a) == alignmentof(int)" (ptr_diff (char_ptr (pa |-> a)) (char_ptr (pa |-> b))) (alignment int) ~printer:string_of_int; assert_equal ~msg:"offsetof(A, c) == 2 * alignmentof(int)" (offsetof c) (2 * alignment int) ~printer:string_of_int; assert_equal ~msg:"sizeof(struct A) == 3 * alignmentof(int)" (sizeof struct_a) (3 * alignment int) ~printer:string_of_int; assert_equal ~msg:"offsetof(B, e) == 3 * alignmentof(int)" (offsetof e) (3 * alignment int) ~printer:string_of_int; assert_equal ~msg:"((char *)&pb->e - (char *)&pb->d) == 3 * alignmentof(int)" (ptr_diff (char_ptr (pb |-> d)) (char_ptr (pb |-> e))) (3 * alignment int) ~printer:string_of_int; assert_equal ~msg:"sizeof(struct B) == 4 * alignmentof(int)" (sizeof struct_b) (4 * alignment int) ~printer:string_of_int; end end in () (* Test that the alignment of a bigarray is the same as the alignment of its element type. *) let test_bigarray_alignment _ = let module M = struct module B = Bigarray_compat type k = K : ('a, 'b) Bigarray_compat.kind * int -> k let kind_alignments = [ K (B.float32, alignment float); K (B.float64, alignment double); K (B.int8_signed, alignment int8_t); K (B.int8_unsigned, alignment uint8_t); K (B.int16_signed, alignment int16_t); K (B.int16_unsigned, alignment uint16_t); K (B.int32, alignment int32_t); K (B.int64, alignment int64_t); K (B.int, alignment (ptr void)); K (B.nativeint, alignment (ptr void)); K (B.complex32, alignment complex32); K (B.complex64, alignment complex64); K (B.char, alignment char); ] let () = begin (* Genarray.t alignments *) List.iter (fun (K (kind, ealign)) -> assert_equal ealign (alignment (bigarray genarray [|2; 3; 5|] kind))) kind_alignments; (* Array1.t alignments *) List.iter (fun (K (kind, ealign)) -> assert_equal ealign (alignment (bigarray array1 7 kind))) kind_alignments; (* Array2.t alignments *) List.iter (fun (K (kind, ealign)) -> assert_equal ealign (alignment (bigarray array1 7 kind))) kind_alignments; (* Array3.t alignments *) List.iter (fun (K (kind, ealign)) -> assert_equal ealign (alignment (bigarray array3 (2, 3, 5) kind))) kind_alignments; end end in () let suite = "Alignment tests" >::: ["struct tail padding" >:: test_struct_tail_padding; "primitive alignment" >:: test_primitive_alignment; "struct alignment" >:: test_struct_alignment; "alignment of abstract types" >:: test_abstract_alignment; "alignment of incomplete types" >:: test_incomplete_alignment; "alignment considers ocaml_string incomplete" >:: test_alignment_ocaml_string; "alignment of bigarray types" >:: test_bigarray_alignment; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-arrays/000077500000000000000000000000001445631112600213625ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-arrays/dune000066400000000000000000000004171445631112600222420ustar00rootroot00000000000000(test (name test_array) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_arrays_stubs test_arrays_bindings tests_common stdlib-shims)) yallop-ocaml-ctypes-3f8211a/tests/test-arrays/stub-generator/000077500000000000000000000000001445631112600243235ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-arrays/stub-generator/driver.ml000066400000000000000000000004051445631112600261470ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the arrays tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-arrays/stub-generator/dune000066400000000000000000000007241445631112600252040ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_arrays_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_arrays_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-arrays/stubs/000077500000000000000000000000001445631112600225225ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-arrays/stubs/dune000066400000000000000000000001111445631112600233710ustar00rootroot00000000000000(library (name test_arrays_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-arrays/stubs/functions.ml000066400000000000000000000015621445631112600250700ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the arrays tests. *) open Ctypes module Stubs (F: Ctypes.FOREIGN) = struct open F (* union u { int i; double d; } *) type number let u : number union typ = union "number" let (-:) ty label = field u label ty let i = int -: "i" let d = double -: "d" let () = seal u (* struct s { char tag; union u data; } *) type tagged let s : tagged structure typ = structure "tagged" let (-:) ty label = field s label ty let tag = char -: "tag" let data = u -: "num" let () = seal s let accepts_pointer_to_array_of_structs = foreign "accepts_pointer_to_array_of_structs" (ptr (array 5 s) @-> returning double) end yallop-ocaml-ctypes-3f8211a/tests/test-arrays/test_array.ml000066400000000000000000000233511445631112600240750ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 module Float_ = struct let float = float end (*has to be above the module Ctypes*) open Ctypes let _ = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) (* Creating multidimensional arrays, and reading and writing elements. *) let test_multidimensional_arrays _ = let module Array = CArray in (* one dimension *) let one = Array.make int 10 in for i = 0 to Array.length one - 1 do one.(i) <- i done; for i = 0 to Array.length one - 1 do assert_equal i one.(i) done; (* two dimensions *) let two = Array.make (array 5 char) 10 in let s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" in for i = 0 to 9 do for j = 0 to 4 do two.(i).(j) <- s.[i + j] done done; for i = 0 to 9 do for j = 0 to 4 do assert_equal two.(i).(j) s.[i + j] ~printer:(String.make 1) done done; (* three dimensions *) let three = Array.make (array 2 (array 5 float)) 10 in let float = Float_.float in for i = 0 to 9 do for j = 0 to 1 do for k = 0 to 4 do three.(i).(j).(k) <- float i *. float j -. float k done done done; for i = 0 to 9 do for j = 0 to 1 do for k = 0 to 4 do assert_equal three.(i).(j).(k) (float i *. float j -. float k) ~printer:string_of_float done done done; (* four *) let four = Array.make (array 3 (array 2 (array 5 int32_t))) 10 in for i = 0 to 9 do for j = 0 to 2 do for k = 0 to 1 do for l = 0 to 4 do four.(i).(j).(k).(l) <- Int32.(mul (sub (of_int i) (of_int j)) (add (of_int k) (of_int l))) done done done done; for i = 0 to 9 do for j = 0 to 2 do for k = 0 to 1 do for l = 0 to 4 do assert_equal four.(i).(j).(k).(l) Int32.(mul (sub (of_int i) (of_int j)) (add (of_int k) (of_int l))) ~printer:Int32.to_string done done done done (* Test the CArray.iter function *) let test_iter _ = let r = ref 0 in let a = CArray.of_list int [1; 2; 3] in let () = CArray.iter (fun v -> r := !r + v) a in assert_equal !r 6; let r = ref 0 in let a = CArray.of_list int [] in let () = CArray.iter (fun _ -> assert false) a in assert_equal !r 0 (* Test the CArray.map function *) let test_map _ = let a = CArray.of_list int [1; 2; 3] in let r = CArray.map float float_of_int a in assert_equal [1.0; 2.0; 3.0] (CArray.to_list r); let a = CArray.of_list int [] in let r = CArray.map string (fun _ -> assert false) a in assert_equal (CArray.length r) 0 (* Test the CArray.mapi function *) let test_mapi _ = let a = CArray.of_list int [1; 2; 3] in let r = CArray.mapi int (+) a in assert_equal [1; 3; 5] (CArray.to_list r); let a = CArray.of_list int [] in let r = CArray.mapi string (fun _ _ -> assert false) a in assert_equal (CArray.length r) 0 (* Test the CArray.fold_left function *) let test_fold_left _ = let a = CArray.of_list int [1; 2; 3] in let r = CArray.fold_left (Printf.sprintf "%s%d") "." a in assert_equal ".123" r; let a = CArray.of_list int [] in let r = CArray.fold_left (fun _ -> assert false) [] a in assert_equal r [] (* Test the CArray.fold_right function *) let test_fold_right _ = let a = CArray.of_list int [1; 2; 3] in let r = CArray.fold_right (Printf.sprintf "%d%s") a "." in assert_equal "123." r; let a = CArray.of_list int [] in let r = CArray.fold_right (fun _ -> assert false) a [] in assert_equal r [] (* Test the CArray.copy function *) let test_copy _ = let a = CArray.of_list int [1; 2; 3] in let r = CArray.copy a in begin assert_equal [1; 2; 3] (CArray.to_list a); assert_equal [1; 2; 3] (CArray.to_list r); CArray.set r 0 10; assert_equal [1; 2; 3] (CArray.to_list a); assert_equal [10; 2; 3] (CArray.to_list r); CArray.set a 1 20; assert_equal [1; 20; 3] (CArray.to_list a); assert_equal [10; 2; 3] (CArray.to_list r); end (* Test the CArray.sub function *) let test_sub _ = let a = CArray.of_list int [1; 2; 3] in assert_raises (Invalid_argument "CArray.sub") begin fun () -> CArray.sub a ~pos:(-1) ~length:1 end; assert_raises (Invalid_argument "CArray.sub") begin fun () -> CArray.sub a ~pos:1 ~length:4 end; assert_raises (Invalid_argument "CArray.sub") begin fun () -> CArray.sub a ~pos:1 ~length:(-1) end; let r = CArray.sub a ~pos:1 ~length:2 in assert_equal [2; 3] (CArray.to_list r); let r = CArray.sub a ~pos:1 ~length:0 in assert_equal [] (CArray.to_list r); let a = CArray.of_list int [1; 2; 3] in let r = CArray.sub a ~pos:1 ~length:2 in begin CArray.set r 0 10; assert_equal [1; 2; 3] (CArray.to_list a); assert_equal [10; 3] (CArray.to_list r); end (* Test the CArray.of_string function *) let test_of_string _ = let s = "abcdefghiABCDEFGHI" in let a = CArray.of_string s in let s' = coerce (ptr char) string (CArray.start a) in assert_equal s s'; let s = "" in let a = CArray.of_string s in let s' = coerce (ptr char) string (CArray.start a) in assert_equal s s' (* Test that creating an array initializes all elements appropriately. *) let test_array_initialiation _ = let module Array = CArray in let int_array = Array.make int ~initial:33 10 in for i = 0 to Array.length int_array - 1 do assert_equal 33 int_array.(i) done; let int_array_array = Array.make (array 10 int) ~initial:int_array 5 in for i = 0 to Array.length int_array_array - 1 do for j = 0 to Array.length int_array_array.(i) - 1 do assert_equal 33 int_array_array.(i).(j) done done (* Test that creating arrays of elements of incomplete type fails. *) let test_arrays_of_incomplete_type _ = let module M = struct let () = assert_raises IncompleteType (fun () -> CArray.make void 10) let s = structure "s" let () = assert_raises IncompleteType (fun () -> CArray.make s 10) end in () (* Test that OCaml types cannot be used to build arrays. *) let test_ocaml_types_rejected_as_array_elements _ = assert_raises IncompleteType (fun () -> CArray.make ocaml_string 10) (* Test that creating an array initializes all elements appropriately. *) let test_pointer_to_array_arithmetic _ = let module Array = CArray in (* int ( * )[3] *) let p = allocate_n (array 3 int) ~count:4 in p <-@ Array.of_list int [1; 2; 3]; (p +@ 1) <-@ Array.of_list int [4; 5; 6]; (p +@ 2) <-@ Array.of_list int [7; 8; 9]; (p +@ 3) <-@ Array.of_list int [10; 11; 12]; let q = p in assert_equal 8 (!@(q +@ 2)).(1); assert_equal 12 (!@(q +@ 3)).(2); assert_equal 1 (!@(q +@ 0)).(0); let a = Array.from_ptr p 4 in assert_equal 8 a.(2).(1); assert_equal 12 a.(3).(2); assert_equal 1 a.(0).(0) (* Test bounds checks for CArray.get *) let test_bounds_checks_get _ = let module Array = CArray in let c = CArray.of_list int [1;2;3] in assert_raises (Invalid_argument "index out of bounds") begin fun () -> c.(-1); end; assert_raises (Invalid_argument "index out of bounds") begin fun () -> c.(CArray.length c); end (* Test bounds checks for CArray.set *) let test_bounds_checks_set _ = let module Array = CArray in let c = CArray.of_list int [1;2;3] in assert_raises (Invalid_argument "index out of bounds") begin fun () -> c.(-1) <- 0; end; assert_raises (Invalid_argument "index out of bounds") begin fun () -> c.(CArray.length c) <- 0; end module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Test passing pointer to array of structs. *) let test_passing_pointer_to_array_of_structs _ = let box_int x = let v = make s in setf v tag 'i'; let pd = v @. data in (pd |-> i) <-@ x; v in let box_double x = let v = make s in setf v tag 'd'; let pd = v @. data in (pd |-> d) <-@ x; v in let sum = accepts_pointer_to_array_of_structs (from_voidp (array 5 s) (to_voidp (CArray.start (CArray.of_list s [box_int 10; box_double 3.5; box_int 12; box_double (-14.1); box_double (103.25)])))) in assert_equal (103.25 +. (-14.1) +. 12.0 +. 3.5 +. 10.0) sum end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Array tests" >::: ["multidimensional arrays" >:: test_multidimensional_arrays; "CArray.iter " >:: test_iter; "CArray.map " >:: test_map; "CArray.mapi " >:: test_mapi; "CArray.fold_left" >:: test_fold_left; "CArray.fold_right" >:: test_fold_right; "CArray.copy" >:: test_copy; "CArray.sub" >:: test_sub; "CArray.of_string" >:: test_of_string; "array initialization" >:: test_array_initialiation; "arrays of incomplete type" >:: test_arrays_of_incomplete_type; "ocaml_string cannot be used to build arrays" >:: test_ocaml_types_rejected_as_array_elements; "pointer to array arithmetic" >:: test_pointer_to_array_arithmetic; "bounds checks (get)" >:: test_bounds_checks_get; "bounds checks (set)" >:: test_bounds_checks_set; "passing pointer to array of structs (foreign)" >:: Foreign_tests.test_passing_pointer_to_array_of_structs; "passing pointer to array of structs (stubs)" >:: Stub_tests.test_passing_pointer_to_array_of_structs; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-bigarrays/000077500000000000000000000000001445631112600220445ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-bigarrays/dune000066400000000000000000000004121445631112600227170ustar00rootroot00000000000000(test (name test_bigarrays) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_bigarrays_stubs test_bigarrays_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-bigarrays/stub-generator/000077500000000000000000000000001445631112600250055ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-bigarrays/stub-generator/driver.ml000066400000000000000000000004101445631112600266250ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the bigarrays tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-bigarrays/stub-generator/dune000066400000000000000000000007321445631112600256650ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_bigarrays_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_bigarrays_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-bigarrays/stubs/000077500000000000000000000000001445631112600232045ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-bigarrays/stubs/dune000066400000000000000000000001141445631112600240560ustar00rootroot00000000000000(library (name test_bigarrays_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-bigarrays/stubs/functions.ml000066400000000000000000000010211445631112600255400ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the bigarrays tests. *) open Ctypes module Stubs (F: Ctypes.FOREIGN) = struct open F let matrix_mul = foreign "matrix_mul" (int @-> int @-> int @-> ptr double @-> ptr double @-> ptr double @-> returning void) let matrix_transpose = foreign "matrix_transpose" (int @-> int @-> ptr double @-> returning (ptr double)) end yallop-ocaml-ctypes-3f8211a/tests/test-bigarrays/test_bigarrays.ml000066400000000000000000000427001445631112600254230ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) module Std_array = Array type 'a std_array = 'a array let _ = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) open OUnit2 open Ctypes module BA = Bigarray_compat let array_of_list2 typ list2 = let dim2 = List.length (List.hd list2) in let atyp = array dim2 typ in CArray.of_list atyp (List.map (CArray.of_list typ) list2) let array_of_list3 typ list3 = let dim2 = List.length (List.hd list3) and dim3 = List.length (List.hd (List.hd list3)) in let atyp = array dim2 (array dim3 typ) in CArray.of_list atyp (List.map (array_of_list2 typ) list3) let list2_of_array array = List.map CArray.to_list (CArray.to_list array) let matrix l = bigarray_of_array array2 BA.float64 (array_of_list2 double l) let unmatrix m = list2_of_array (array_of_bigarray array2 m) let castp typ p = from_voidp typ (to_voidp p) (* View ctypes-managed memory through a bigarray lens. *) let test_bigarray_of_ctypes_array _ = (* One-dimensional Genarrays *) let module Array = CArray in let a1 = Array.of_list int8_t [10; 20; 30; 40] in let b1 = bigarray_of_array genarray BA.int8_signed a1 in let () = begin assert_equal (Array.length a1) (BA.Genarray.nth_dim b1 0); for i = 0 to Array.length a1 - 1 do assert_equal a1.(i) (BA.Genarray.get b1 [|i|]) done end in (* Array1 *) let eps32 = 1e-6 in let complex32_eq = let open Complex in fun { re = lre; im = lim } { re = rre; im = rim } -> abs_float (lre -. rre) < eps32 && abs_float (lim -. rim) < eps32 in let a2 = Array.of_list complex32 Complex.([{re = 0.1; im = 1.0}; {re = 0.2; im = 2.0}; {re = 0.3; im = 3.0}; {re = 0.4; im = 4.0}]) in let b2 = bigarray_of_array array1 BA.complex32 a2 in let () = begin assert_equal (Array.length a2) (BA.Array1.dim b2); for i = 0 to Array.length a2 - 1 do assert_equal a2.(i) b2.{i} ~cmp:complex32_eq done end in (* Two-dimensional Genarrays *) let uint16 = view uint16_t ~read:Unsigned.UInt16.to_int ~write:Unsigned.UInt16.of_int in let a3 = array_of_list2 uint16 [[5; 10; 15]; [3; 6; 9]; [2; 4; 6]; [1; 2; 3]] in let b3 = BA.reshape (bigarray_of_array genarray BA.int16_unsigned (Array.from_ptr (castp uint16 (Array.start a3)) 12)) [| 4; 3 |] in let () = begin assert_equal (Array.length a3) (BA.Genarray.nth_dim b3 0); assert_equal (Array.length a3.(0)) (BA.Genarray.nth_dim b3 1); for i = 0 to Array.length a3 - 1 do for j = 0 to Array.length a3.(0) - 1 do assert_equal a3.(i).(j) (BA.Genarray.get b3 [|i; j|]) done done end in (* Array2 *) let a4 = array_of_list2 nativeint [[5n; 10n]; [3n; 6n]; [1n; 2n]] in let b4 = bigarray_of_array array2 BA.nativeint a4 in let () = begin assert_equal (Array.length a4) (BA.Array2.dim1 b4); assert_equal (Array.length a4.(0)) (BA.Array2.dim2 b4); for i = 0 to Array.length a4 - 1 do for j = 0 to Array.length a4.(0) - 1 do assert_equal a4.(i).(j) b4.{i, j} done done end in (* Three-dimensional Genarrays *) let a5 = array_of_list3 int64_t [[[1L; 2L; 3L; 4L; 5L]; [2L; 4L; 6L; 8L; 10L]]; [[10L; 20L; 30L; 40L; 50L]; [20L; 40L; 60L; 80L; 100L]]; [[100L; 200L; 300L; 400L; 500L]; [200L; 400L; 600L; 800L; 1000L]]] in let b5 = BA.reshape (bigarray_of_array genarray BA.int64 (Array.from_ptr (castp int64_t (Array.start a5)) 30)) [| 3; 2; 5 |] in let () = begin assert_equal (Array.length a5) (BA.Genarray.nth_dim b5 0); assert_equal (Array.length a5.(0)) (BA.Genarray.nth_dim b5 1); assert_equal (Array.length a5.(0).(0)) (BA.Genarray.nth_dim b5 2); for i = 0 to Array.length a5 - 1 do for j = 0 to Array.length a5.(0) - 1 do for k = 0 to Array.length a5.(0).(0) - 1 do assert_equal a5.(i).(j).(k) (BA.Genarray.get b5 [|i; j; k|]) done done done end in (* Array3 *) let a6 = array_of_list3 double [[[1.; 2.; 3.; 4.]; [2.; 4.; 6.; 8.]]; [[10.; 20.; 30.; 40.]; [20.; 40.; 60.; 80.]]; [[100.; 200.; 300.; 400.]; [200.; 400.; 600.; 800.]]] in let b6 = bigarray_of_array array3 BA.float64 a6 in let () = begin assert_equal (Array.length a6) (BA.Array3.dim1 b6); assert_equal (Array.length a6.(0)) (BA.Array3.dim2 b6); assert_equal (Array.length a6.(0).(0)) (BA.Array3.dim3 b6); for i = 0 to Array.length a6 - 1 do for j = 0 to Array.length a6.(0) - 1 do for k = 0 to Array.length a6.(0).(0) - 1 do assert_equal a6.(i).(j).(k) b6.{i, j, k} done done done end in () (* View bigarray-managed memory through a ctypes lens *) let test_ctypes_array_of_bigarray _ = let module Array = CArray in (* One-dimensional Genarrays *) let b1_dim = 6 in let b1 = BA.(Genarray.create float32 c_layout) [| b1_dim |] in let a1 = array_of_bigarray genarray b1 in begin assert_equal (BA.Genarray.nth_dim b1 0) (Array.length a1); List.iteri (fun i -> BA.Genarray.set b1 [| i |]) [ 6.; 5.; 4.; 3.; 2.; 1. ]; for i = 0 to b1_dim - 1 do assert_equal (BA.Genarray.get b1 [| i |]) a1.(i) done end; (* Array1 *) let b2_dim = 7 in let b2 = BA.(Array1.create int8_unsigned c_layout) b2_dim in let a2 = array_of_bigarray array1 b2 in begin assert_equal (BA.Array1.dim b2) (Array.length a2); List.iteri (fun i -> fun v -> b2.{i} <- v) [ 2; 4; 6; 8; 10; 12; 14 ]; for i = 0 to b2_dim - 1 do assert_equal b2.{i} a2.(i) done end; (* Two-dimensional Genarrays *) let b3_dim1 = 4 and b3_dim2 = 2 in let b3 = BA.(Genarray.create int16_signed c_layout) [| b3_dim1; b3_dim2 |] in let a3 = Array.from_ptr (castp (array b3_dim2 int16_t) (bigarray_start genarray b3)) b3_dim1 in begin assert_equal (BA.Genarray.nth_dim b3 0) (Array.length a3); assert_equal (BA.Genarray.nth_dim b3 1) (Array.length a3.(0)); List.iteri (fun i -> List.iteri (fun j -> BA.Genarray.set b3 [| i; j |])) [[-1; -2]; [-3; -4]; [-5; -6]; [-7; -8]]; for i = 0 to b3_dim1 - 1 do for j = 0 to b3_dim2 - 1 do assert_equal (BA.Genarray.get b3 [| i; j |]) a3.(i).(j) done done end; (* Array2 *) let b4_dim1 = 3 and b4_dim2 = 4 in let b4 = BA.(Array2.create int32 c_layout) b4_dim1 b4_dim2 in let a4 = array_of_bigarray array2 b4 in begin assert_equal (BA.Array2.dim1 b4) (Array.length a4); assert_equal (BA.Array2.dim2 b4) (Array.length a4.(0)); List.iteri (fun i -> List.iteri (fun j -> fun v -> b4.{i, j} <- v)) [[17l; 15l; 13l; 11l]; [9l; 7l; 5l; 3l]; [1l; -1l; -3l; -5l]]; for i = 0 to b4_dim1 - 1 do for j = 0 to b4_dim2 - 1 do assert_equal b4.{i, j} a4.(i).(j) done done end; (* Three-dimensional Genarrays *) let b5_dim1 = 4 and b5_dim2 = 2 and b5_dim3 = 5 in let b5 = BA.(Genarray.create int c_layout) [| b5_dim1; b5_dim2; b5_dim3 |] in let a5 = Array.from_ptr (castp (array b5_dim2 (array b5_dim3 camlint)) (bigarray_start genarray b5)) b5_dim1 in begin assert_equal (BA.Genarray.nth_dim b5 0) (Array.length a5); assert_equal (BA.Genarray.nth_dim b5 1) (Array.length a5.(0)); assert_equal (BA.Genarray.nth_dim b5 2) (Array.length a5.(0).(0)); List.iteri (fun i -> List.iteri (fun j -> List.iteri (fun k -> BA.Genarray.set b5 [| i; j; k |]))) [[[1; 2; 3; 4; 5]; [6; 7; 8; 9; 10]]; [[11; 12; 13; 14; 15]; [16; 17; 18; 19; 20]]; [[21; 22; 23; 24; 25]; [26; 27; 28; 29; 30]]; [[31; 32; 33; 34; 35]; [36; 37; 38; 39; 40]]]; for i = 0 to b5_dim1 - 1 do for j = 0 to b5_dim2 - 1 do for k = 0 to b5_dim3 - 1 do assert_equal (BA.Genarray.get b5 [| i; j; k |]) a5.(i).(j).(k) done done done end; (* Array3 *) let eps64 = 1e-12 in let complex64_eq = let open Complex in fun { re = lre; im = lim } { re = rre; im = rim } -> abs_float (lre -. rre) < eps64 && abs_float (lim -. rim) < eps64 in let b6_dim1 = 3 and b6_dim2 = 4 and b6_dim3 = 2 in let b6 = BA.(Array3.create complex64 c_layout) b6_dim1 b6_dim2 b6_dim3 in let a6 = array_of_bigarray array3 b6 in begin assert_equal (BA.Array3.dim1 b6) (Array.length a6); assert_equal (BA.Array3.dim2 b6) (Array.length a6.(0)); assert_equal (BA.Array3.dim3 b6) (Array.length a6.(0).(0)); let open Complex in List.iteri (fun i -> List.iteri (fun j -> List.iteri (fun k -> fun v -> b6.{i, j, k} <- v))) [[[{re = 1.; im = 10.}; {re = 1e2; im = 0.0}]; [{re = 2.; im = 20.}; {re = 2e2; im = 0.0}]; [{re = 3.; im = 30.}; {re = 3e2; im = 0.0}]; [{re = 4.; im = 40.}; {re = 4e2; im = 0.0}]]; [[{re = 5.; im = 50.}; {re = 5e2; im = 0.1}]; [{re = 6.; im = 60.}; {re = 6e2; im = 0.1}]; [{re = 7.; im = 70.}; {re = 7e2; im = 0.1}]; [{re = 8.; im = 80.}; {re = 8e2; im = 0.1}]]; [[{re = 9.; im = 90.}; {re = 9e2; im = 0.2}]; [{re = 10.; im = 100.}; {re = 1e3; im = 0.2}]; [{re = 11.; im = 110.}; {re = 1.1e3; im = 0.2}]; [{re = 12.; im = 120.}; {re = 1.2e3; im = 0.2}]]]; for i = 0 to b6_dim1 - 1 do for j = 0 to b6_dim2 - 1 do for k = 0 to b6_dim3 - 1 do assert_equal b6.{i, j, k} a6.(i).(j).(k) ~cmp:complex64_eq done done done end (* Conversions between C-layout and Fortran-layout bigarrays. *) let test_fortran_layout_bigarrays _ = (* array1 *) let a1c = bigarray_of_array array1 Bigarray_compat.int32 (CArray.of_list int32_t [10l; 20l; 30l; 40l]) in let p1 = bigarray_start array1 a1c in let a1f = fortran_bigarray_of_ptr array1 4 Bigarray_compat.int32 p1 in begin assert_equal 4 (Bigarray_compat.Array1.dim a1f); assert_equal Bigarray_compat.int32 (Bigarray_compat.Array1.kind a1f); assert_equal Bigarray_compat.fortran_layout (Bigarray_compat.Array1.layout a1f); assert_equal a1f.{1} 10l; assert_equal a1f.{2} 20l; assert_equal a1f.{3} 30l; assert_equal a1f.{4} 40l; end; (* array2 *) let a2c = bigarray_of_array array2 Bigarray_compat.int32 (CArray.of_list (array 2 int32_t) [CArray.of_list int32_t [10l; 20l]; CArray.of_list int32_t [30l; 40l]; CArray.of_list int32_t [50l; 60l]; CArray.of_list int32_t [70l; 80l]]) in let p2 = bigarray_start array2 a2c in let a2f = fortran_bigarray_of_ptr array2 (4,2) Bigarray_compat.int32 p2 in begin assert_equal 4 (Bigarray_compat.Array2.dim1 a2f); assert_equal 2 (Bigarray_compat.Array2.dim2 a2f); assert_equal Bigarray_compat.int32 (Bigarray_compat.Array2.kind a2f); assert_equal Bigarray_compat.fortran_layout (Bigarray_compat.Array2.layout a2f); assert_equal a2f.{1,1} 10l; assert_equal a2f.{2,1} 20l; assert_equal a2f.{3,1} 30l; assert_equal a2f.{4,1} 40l; assert_equal a2f.{1,2} 50l; assert_equal a2f.{2,2} 60l; assert_equal a2f.{3,2} 70l; assert_equal a2f.{4,2} 80l; end; (* genarray *) let agc = bigarray_of_array genarray Bigarray_compat.int32 (CArray.of_list int32_t [10l; 20l; 30l; 40l; 50l; 60l; 70l; 80l]) in let pg = bigarray_start genarray agc in let agf = fortran_bigarray_of_ptr genarray [|4;2|] Bigarray_compat.int32 pg in begin assert_equal [|4;2|] (Bigarray_compat.Genarray.dims agf); assert_equal Bigarray_compat.int32 (Bigarray_compat.Genarray.kind agf); assert_equal Bigarray_compat.fortran_layout (Bigarray_compat.Genarray.layout agf); assert_equal (Bigarray_compat.Genarray.get agf [|1;1|]) 10l; assert_equal (Bigarray_compat.Genarray.get agf [|2;1|]) 20l; assert_equal (Bigarray_compat.Genarray.get agf [|3;1|]) 30l; assert_equal (Bigarray_compat.Genarray.get agf [|4;1|]) 40l; assert_equal (Bigarray_compat.Genarray.get agf [|1;2|]) 50l; assert_equal (Bigarray_compat.Genarray.get agf [|2;2|]) 60l; assert_equal (Bigarray_compat.Genarray.get agf [|3;2|]) 70l; assert_equal (Bigarray_compat.Genarray.get agf [|4;2|]) 80l; end module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Test passing bigarrays to c functions. *) let test_passing_bigarrays _ = let mul l r = let m = BA.Array2.dim1 l and n = BA.Array2.dim2 l in let o = BA.Array2.dim1 r and p = BA.Array2.dim2 r in assert (n = o); let product = BA.(Array2.(create (kind l)) c_layout) m p in let addr = bigarray_start array2 in matrix_mul m n p (addr l) (addr r) (addr product); product in assert_equal [[-6.; 11.]; [-3.; -3.]] (unmatrix (mul (matrix [[1.; 6.]; [9.; 3.]]) (matrix [[ 0.; -1.]; [-1.; 2.]]))); assert_equal [[460.; 520.; 580.; 640.; 700.]; [1000.; 1150.; 1300.; 1450.; 1600.]] (unmatrix (mul (matrix [[10.; 20.; 30.]; [40.; 50.; 60.]]) (matrix [[ 1.; 2.; 3.; 4.; 5.]; [ 6.; 7.; 8.; 9.; 10.]; [11.; 12.; 13.; 14.; 15.]]))) (* Test returning bigarrays from c functions. *) let test_returning_bigarrays _ = let transpose m = (* For the purposes of the test we'll just leak the allocated memory. *) let rows = BA.Array2.dim1 m and cols = BA.Array2.dim2 m in bigarray_of_ptr array2 (cols, rows) BA.float64 (matrix_transpose rows cols (bigarray_start array2 m)) in assert_equal [[25.; 1.]; [15.; 2.]; [10.; 3.]; [ 5.; 4.]; [ 0.; 5.]] (unmatrix (transpose (matrix [[25.; 15.; 10.; 5.; 0.]; [ 1.; 2.; 3.; 4.; 5.]]))) end (* Test that bigarrays are not collected while there's a ctypes pointer pointing into them. *) let test_bigarray_lifetime_with_ctypes_reference _ = let state = ref `Not_safe_to_collect in let finalise ba = begin assert_equal `Safe_to_collect !state; assert_equal 1 ba.{0, 0}; state := `Collected; end in let () = let pointer = (* Allocate a bigarray and attach a ctypes pointer *) let ba = Bigarray_compat.(Array2.create int c_layout) 1024 1024 in begin ba.{0,0} <- 1; Gc.finalise finalise ba; bigarray_start array2 ba end in (* The bigarray is out of scope, but the ctypes object is still live, so the memory shouldn't be reclaimed. *) begin Gc.full_major (); Gc.full_major (); assert_equal !state `Not_safe_to_collect; assert_equal 1 !@pointer; end in (* Both the bigarray and the ctypes object are unreachable, so the finaliser should (or, at least, could) run. *) begin state := `Safe_to_collect; Gc.full_major (); Gc.full_major (); assert_equal !state `Collected end (* Test that ctypes-allocated memory is not collected while there's a bigarray associated with it. *) let test_ctypes_memory_lifetime_with_bigarray_reference _ = let module Array = CArray in let state = ref `Not_safe_to_collect in let finalise a = begin assert_equal `Safe_to_collect !state; assert_equal [1L; 2L; 3L; 4L; 5L] (Array.to_list a); state := `Collected end in let () = (* Allocate a chunk of ctypes-managed memory, and view it as a bigarray *) let ba = let a = Array.make ~finalise int64_t 5 in begin for i = 0 to 4 do a.(i) <- Int64.(add (of_int i) one) done; bigarray_of_array array1 BA.int64 a end in (* The ctypes object is out of scope, but the bigarray is still live, so the memory shouldn't be reclaimed. *) begin Gc.full_major (); Gc.full_major (); assert_equal !state `Not_safe_to_collect; assert_equal ba.{0} 1L; assert_equal ba.{3} 4L; end in (* Both the ctypes object and the bigarray are unreachable, so the finaliser should (or, at least, could) run. *) begin state := `Safe_to_collect; Gc.full_major (); Gc.full_major (); assert_equal !state `Collected end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Bigarray tests" >::: ["View ctypes-managed memory using bigarrays" >:: test_bigarray_of_ctypes_array; "View bigarray-managed memory using ctypes" >:: test_ctypes_array_of_bigarray; "Bigarrays live at least as long as ctypes references to them" >:: test_bigarray_lifetime_with_ctypes_reference; "Ctypes-allocated memory lives while there's a bigarray reference to it" >:: test_ctypes_memory_lifetime_with_bigarray_reference; "Fortran-layout bigarrays" >:: test_fortran_layout_bigarrays; "Passing bigarrays to C (foreign)" >:: Foreign_tests.test_passing_bigarrays; "Passing bigarrays to C (stubs)" >:: Stub_tests.test_passing_bigarrays; "Returning bigarrays from C (foreign)" >:: Foreign_tests.test_returning_bigarrays; "Returning bigarrays from C (stubs)" >:: Stub_tests.test_returning_bigarrays; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-bools/000077500000000000000000000000001445631112600211775ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-bools/dune000066400000000000000000000003761445631112600220630ustar00rootroot00000000000000(test (name test_bools) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_bools_stubs test_bools_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-bools/stub-generator/000077500000000000000000000000001445631112600241405ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-bools/stub-generator/driver.ml000066400000000000000000000004131445631112600257630ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the bool number tests. *) let () = Tests_common.run Sys.argv (module Functions.Common) yallop-ocaml-ctypes-3f8211a/tests/test-bools/stub-generator/dune000066400000000000000000000007221445631112600250170ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_bools_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_bools_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-bools/stubs/000077500000000000000000000000001445631112600223375ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-bools/stubs/dune000066400000000000000000000001101445631112600232050ustar00rootroot00000000000000(library (name test_bools_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-bools/stubs/functions.ml000066400000000000000000000006751445631112600247110ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the bool tests. *) open Ctypes (* These functions can be bound either dynamically using Foreign or statically using stub generation. *) module Common(F : Ctypes.FOREIGN) = struct let bool_and = F.(foreign "bool_and" (bool @-> bool @-> returning bool)) end yallop-ocaml-ctypes-3f8211a/tests/test-bools/test_bools.ml000066400000000000000000000017721445631112600237150ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 let _ = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Common(S) (* Test passing bool values. *) let test_passing_bools _ = begin assert_equal false (M.bool_and false false); assert_equal false (M.bool_and false true); assert_equal false (M.bool_and true false); assert_equal true (M.bool_and true true); end end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Bool tests" >::: ["passing bools (foreign)" >:: Foreign_tests.test_passing_bools; "passing bools (stubs)" >:: Stub_tests.test_passing_bools; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-builtins/000077500000000000000000000000001445631112600217125ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-builtins/dune000066400000000000000000000002641445631112600225720ustar00rootroot00000000000000(test (name test_builtins) (package ctypes-foreign) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_builtins_stubs test_builtins_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-builtins/stub-generator/000077500000000000000000000000001445631112600246535ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-builtins/stub-generator/driver.ml000066400000000000000000000004071445631112600265010ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the builtins tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-builtins/stub-generator/dune000066400000000000000000000007301445631112600255310ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_builtins_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_builtins_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-builtins/stubs/000077500000000000000000000000001445631112600230525ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-builtins/stubs/dune000066400000000000000000000001131445631112600237230ustar00rootroot00000000000000(library (name test_builtins_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-builtins/stubs/functions.ml000066400000000000000000000011051445631112600254110ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the builtins tests. *) open Ctypes module Stubs (F: Ctypes.FOREIGN) = struct open F (* *ptr |= value; return *ptr; *) let __sync_or_and_fetch = foreign "__sync_or_and_fetch" (ptr uint8_t @-> uint8_t @-> returning uint8_t) (* tmp = *ptr; *ptr &= value; return tmp; *) let __sync_fetch_and_and = foreign "__sync_fetch_and_and" (ptr uint8_t @-> uint8_t @-> returning uint8_t) end yallop-ocaml-ctypes-3f8211a/tests/test-builtins/test_builtins.ml000066400000000000000000000013641445631112600251400ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes module Bindings = Functions.Stubs(Generated_bindings) (* Test calling builtins. *) let test_calling_builtins _ = let open Unsigned.UInt8 in let open Bindings in let u1 = of_int 0x77 and u2 = of_int 0x8 in let expected = Infix.(u1 lor u2) in let p = allocate uint8_t u1 in assert (__sync_or_and_fetch p u2 = expected); assert (!@p = expected); p <-@ u1; assert (__sync_fetch_and_and p u2 = u1); assert (!@p = Infix.(u1 land u2)) let suite = "Builtin tests" >::: ["calling builtins" >:: test_calling_builtins; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-callback_lifetime/000077500000000000000000000000001445631112600234735ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-callback_lifetime/dune000066400000000000000000000004441445631112600243530ustar00rootroot00000000000000(test (name test_callback_lifetime) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_callback_lifetimes_stubs test_callback_lifetimes_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-callback_lifetime/stub-generator/000077500000000000000000000000001445631112600264345ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-callback_lifetime/stub-generator/driver.ml000066400000000000000000000004201445631112600302550ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the callback lifetime tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-callback_lifetime/stub-generator/dune000066400000000000000000000007541445631112600273200ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_callback_lifetimes_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_callback_lifetimes_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-callback_lifetime/stubs/000077500000000000000000000000001445631112600246335ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-callback_lifetime/stubs/dune000066400000000000000000000001441445631112600255100ustar00rootroot00000000000000(library (name test_callback_lifetimes_stubs) (wrapped false) (libraries ctypes ctypes-foreign)) yallop-ocaml-ctypes-3f8211a/tests/test-callback_lifetime/stubs/functions.ml000066400000000000000000000012151445631112600271740ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the callback lifetime tests. *) open Ctypes open Foreign module Stubs (F: Ctypes.FOREIGN) = struct open F let callback_type_ptr = funptr Ctypes.(int @-> returning int) let store_callback = foreign "store_callback" (callback_type_ptr @-> returning void) let invoke_stored_callback = foreign "invoke_stored_callback" (int @-> returning int) let return_callback = foreign "return_callback" (callback_type_ptr @-> returning callback_type_ptr) end yallop-ocaml-ctypes-3f8211a/tests/test-callback_lifetime/test_callback_lifetime.ml000066400000000000000000000126321445631112600305020ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@warning "-9"] open OUnit2 open Foreign let _ = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Check that we can store a reference to an OCaml function in a C global and invoke it later. *) let test_storing_function_reference _ = (* This shouldn't be collected in the code that follows. *) let double x = x * 2 in begin store_callback double; Gc.full_major (); assert_equal 10 (invoke_stored_callback 5) end (* Check that if a closure passed to C is collected before it's called then CallToExpiredClosure is raised. The value of this test is questionable: calling an expired closure does not have defined behaviour, since the structures needed to make the call may have been garbage collected. *) let test_calling_collected_closure_raises_exception _ = let closure x y = x * y in begin (* The closure should be collected in the next GC *) store_callback (closure (int_of_string "2")); (* The first GC collects the closure itself, which frees the associated object to be collected on the next GC. *) Gc.full_major (); Gc.full_major (); assert_raises CallToExpiredClosure (fun () -> invoke_stored_callback 5) end (* Check that we have fairly fine-grained control over the lifetime of closures passed to C. *) let test_controlling_closure_lifetime _ = (* The return_callback function simply returns its argument. However, since that involves converting an OCaml function ("arg") to a C function pointer and back to an OCaml function ("ret"), there are potential problems with memory management. More precisely, ret holds a reference to a C/libffi closure, which in turn holds a reference to arg that is not visible to the GC. We'd like to ensure that arg is not collected before ret is called, which requires that we store ret and arg together. This test demonstrate the behaviour of naive and more careful implementations. *) let module Sig = struct module type S = sig type t val make : arg:(int -> int) -> t val get : t -> (int -> int) end end in let module Naive : Sig.S = struct type t = { ret : int -> int ; } let make ~arg = { ret = return_callback arg } let get { ret } = ret end in let module Better : Sig.S = struct type t = { ret : int -> int ; arg : int -> int ; } let make ~arg = { arg ; ret = return_callback arg } let get { ret } = ret end in let module Careful : Sig.S = struct type t = { ret : int -> int ; arg : int -> int ; } let make ~arg = { arg ; ret = return_callback arg } let get { ret } c = ret c end in let closure x y = x * y in (* First, the naive implementation. This should fail, because arg is collected before ret is called. Here and below, Sys.opaque_identity prevents the optimizer from moving any part of the closure creation across the call to Gc.full_major. *) let ret = Sys.opaque_identity (Naive.make ~arg:(closure (int_of_string "3"))) in Gc.full_major (); assert_raises CallToExpiredClosure (fun () -> Naive.get ret 5); (* Now a more careful implementation. This succeeds, because we keep a reference to arg around with the reference to ret *) let ret = Sys.opaque_identity (Better.make ~arg:(closure (int_of_string "3"))) in Gc.full_major (); assert_equal 15 (Better.get ret 5); let _ = Ctypes_memory_stubs.use_value ret in (* However, even with the careful implementation things can go wrong if we keep a reference to ret beyond the lifetime of the pair. *) let ret = Sys.opaque_identity (Better.get (Better.make ~arg:(closure (int_of_string "3")))) in Gc.full_major (); assert_raises CallToExpiredClosure (fun () -> ret 5); (* The most careful implementation calls ret rather than returning it, so arg cannot be collected prematurely. *) let ret = Careful.get (Careful.make ~arg:(closure (int_of_string "3"))) in Gc.full_major (); assert_equal 15 (ret 5); let _ = Ctypes_memory_stubs.use_value ret in () end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Callback lifetime tests" >::: ["storing references to OCaml functions (foreign)" >:: Foreign_tests.test_storing_function_reference; "storing references to OCaml functions (stubs)" >:: Stub_tests.test_storing_function_reference; "calling expired closures (foreign)" >:: Foreign_tests.test_calling_collected_closure_raises_exception; "calling expired closures (stubs)" >:: Stub_tests.test_calling_collected_closure_raises_exception; "controlling the lifetime of closures passed to C (foreign)" >:: Foreign_tests.test_controlling_closure_lifetime; "controlling the lifetime of closures passed to C (stubs)" >:: Stub_tests.test_controlling_closure_lifetime; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-closure-type-promotion/000077500000000000000000000000001445631112600245405ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-closure-type-promotion/dune000066400000000000000000000004631445631112600254210ustar00rootroot00000000000000(test (name test_closure_type_promotion) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_closure_type_promotions_stubs test_closure_type_promotions_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-closure-type-promotion/stub-generator/000077500000000000000000000000001445631112600275015ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-closure-type-promotion/stub-generator/driver.ml000066400000000000000000000004131445631112600313240ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the higher order tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-closure-type-promotion/stub-generator/dune000066400000000000000000000007661445631112600303700ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_closure_type_promotions_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_closure_type_promotions_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-closure-type-promotion/stubs/000077500000000000000000000000001445631112600257005ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-closure-type-promotion/stubs/dune000066400000000000000000000001511445631112600265530ustar00rootroot00000000000000(library (name test_closure_type_promotions_stubs) (wrapped false) (libraries ctypes ctypes-foreign)) yallop-ocaml-ctypes-3f8211a/tests/test-closure-type-promotion/stubs/functions.ml000066400000000000000000000033101445631112600302370ustar00rootroot00000000000000(* * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open Foreign module Stubs (F: Ctypes.FOREIGN) = struct open F let callback_returns_int8_t = foreign "callback_returns_int8_t" (funptr Ctypes.(void @-> returning int8_t) @-> returning int8_t) let callback_returns_int16_t = foreign "callback_returns_int16_t" (funptr Ctypes.(void @-> returning int16_t) @-> returning int16_t) let callback_returns_int32_t = foreign "callback_returns_int32_t" (funptr Ctypes.(void @-> returning int32_t) @-> returning int32_t) let callback_returns_int64_t = foreign "callback_returns_int64_t" (funptr Ctypes.(void @-> returning int64_t) @-> returning int64_t) let callback_returns_uint8_t = foreign "callback_returns_uint8_t" (funptr Ctypes.(void @-> returning uint8_t) @-> returning uint8_t) let callback_returns_uint16_t = foreign "callback_returns_uint16_t" (funptr Ctypes.(void @-> returning uint16_t) @-> returning uint16_t) let callback_returns_uint32_t = foreign "callback_returns_uint32_t" (funptr Ctypes.(void @-> returning uint32_t) @-> returning uint32_t) let callback_returns_uint64_t = foreign "callback_returns_uint64_t" (funptr Ctypes.(void @-> returning uint64_t) @-> returning uint64_t) let callback_returns_float = foreign "callback_returns_float" (funptr Ctypes.(void @-> returning float) @-> returning float) let callback_returns_double = foreign "callback_returns_double" (funptr Ctypes.(void @-> returning double) @-> returning double) let callback_returns_bool = foreign "callback_returns_bool" (funptr Ctypes.(void @-> returning bool) @-> returning bool) end yallop-ocaml-ctypes-3f8211a/tests/test-closure-type-promotion/test_closure_type_promotion.ml000066400000000000000000000061201445631112600327530ustar00rootroot00000000000000(* * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 let _testlib = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) (* * Using the closure API of libffi is error prone due to differences * in endianess and calling conventions. *) module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M let test x f = assert_equal x (f (fun () -> x)) let test_signed_ints _ = test 127 callback_returns_int8_t; test (-128) callback_returns_int8_t; test (-1) callback_returns_int8_t; test 32767 callback_returns_int16_t; test (-32768) callback_returns_int16_t; test (-1) callback_returns_int16_t; test Int32.max_int callback_returns_int32_t; test Int32.min_int callback_returns_int32_t; test (Int32.of_int (-1)) callback_returns_int32_t; test Int64.max_int callback_returns_int64_t; test Int64.min_int callback_returns_int64_t; test (Int64.of_int (-1)) callback_returns_int64_t let test_unsigned_ints _ = test Unsigned.UInt8.max_int callback_returns_uint8_t; test Unsigned.UInt8.one callback_returns_uint8_t; test Unsigned.UInt16.max_int callback_returns_uint16_t; test Unsigned.UInt16.one callback_returns_uint16_t; test Unsigned.UInt32.max_int callback_returns_uint32_t; test Unsigned.UInt32.one callback_returns_uint32_t; test Unsigned.UInt64.max_int callback_returns_uint64_t; test Unsigned.UInt64.one callback_returns_uint64_t let float_cmp a b = if a = b then 0 else let abs_a = abs_float a in let abs_b = abs_float b in let diff = abs_float ( a -. b ) in let epsilon = 1.1e-7 in if diff /. (min (abs_a +. abs_b) max_float) < epsilon then 0 else compare a b let test_float _ = let test x = assert_equal 0 (float_cmp x (callback_returns_float (fun () -> x ) )) in test 1.e7; test 1.e-3; test 3.e+38 let test_double _ = let test x = assert_equal 0 (float_cmp x (callback_returns_double (fun () -> x ) )) in test 1.e7; test 1.e-3; test 1.e+307 let test_bool _ = test true callback_returns_bool; test false callback_returns_bool end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Closure endianess tests" >::: ["test_signed_ints (foreign)" >:: Foreign_tests.test_signed_ints; "test_signed_ints (stubs)" >:: Stub_tests.test_signed_ints; "test_unsigned_ints (foreign)" >:: Foreign_tests.test_unsigned_ints; "test_unsigned_ints (stubs)" >:: Stub_tests.test_unsigned_ints; "test_float (foreign)" >:: Foreign_tests.test_float; "test_float (stubs)" >:: Stub_tests.test_float; "test_double (foreign)" >:: Foreign_tests.test_double; "test_double (stubs)" >:: Stub_tests.test_double; "test_bool (foreign)" >:: Foreign_tests.test_bool; "test_bool (stubs)" >:: Stub_tests.test_bool; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-coercions/000077500000000000000000000000001445631112600220455ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-coercions/dune000066400000000000000000000002711445631112600227230ustar00rootroot00000000000000(test (name test_coercions) (package ctypes-foreign) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_coercionss_stubs test_coercionss_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-coercions/stub-generator/000077500000000000000000000000001445631112600250065ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-coercions/stub-generator/driver.ml000066400000000000000000000004661445631112600266410ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the coercions tests. *) let cheader = "#include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-coercions/stub-generator/dune000066400000000000000000000007341445631112600256700ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_coercionss_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_coercionss_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-coercions/stubs/000077500000000000000000000000001445631112600232055ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-coercions/stubs/dune000066400000000000000000000001151445631112600240600ustar00rootroot00000000000000(library (name test_coercionss_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-coercions/stubs/functions.ml000066400000000000000000000005561445631112600255550ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the coercion tests. *) open Ctypes module Stubs (F: Ctypes.FOREIGN) = struct open F let memchr = foreign "memchr" (ptr void @-> int @-> size_t @-> returning (ptr void)) end yallop-ocaml-ctypes-3f8211a/tests/test-coercions/test_coercions.ml000066400000000000000000000214111445631112600254210ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes (* Check coercions between pointers. *) let test_pointer_coercions _ = let module M = struct type boxed_type = T : 'a typ -> boxed_type let types = [ T void; T int8_t; T uint16_t; T int; T float; T short; T complex64; T (ptr double); T string; T (bigarray array1 10 Bigarray_compat.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4); ] (* Check that we can construct a coercion between any two pointer types *) let () = ListLabels.iter types ~f:(fun (T t1) -> ListLabels.iter types ~f:(fun (T t2) -> let _fn = coerce (ptr t1) (ptr t2) in ())) (* Check that pointer coercions are value-preserving. *) let v = 10 let p = allocate int v let p' = coerce (ptr float) (ptr int) (coerce (ptr int) (ptr float) p) let () = assert_equal p p' end in () (* Check that coercions between a pointer to a struct and a pointer to its first member succeed. *) let test_struct_first_member_coercions _ = let module M = struct let s = structure "s" let f = field s "f" double let _i = field s "i" int let () = seal s let () = begin let v = make s in let p = coerce (ptr s) (ptr double) (addr v) in setf v f 5.5; assert_equal !@p 5.5; p <-@ 6.6; assert_equal (getf v f) 6.6 end end in () (* Check that coercions between a pointer to a union and a pointer to a member succeed. *) let test_union_coercions _ = let module M = struct let u = union "u" let f = field u "f" double let i = field u "i" int let () = seal u let () = begin let v = make u in let pf = coerce (ptr u) (ptr double) (addr v) in let pi = coerce (ptr u) (ptr int) (addr v) in setf v f 5.5; assert_equal !@pf 5.5; pi <-@ 12; assert_equal (getf v i) 12; setf v i 14; assert_equal !@pi 14; pf <-@ 6.6; assert_equal (getf v f) 6.6; end end in () (* Check coercions between views. *) let test_view_coercions _ = let module M = struct type 'a variant = V of 'a let unV (V v) = v and inV v = V v let variant_view v = view v ~read:inV ~write:unV type 'a record = { r : 'a } let record_view v = view v ~read:(fun r -> {r}) ~write:(fun {r} -> r) let pintvv = variant_view (variant_view (ptr int)) let pintr = record_view (ptr int) let () = begin let pi = allocate int 100 in let v = allocate pintvv (V (V pi)) in assert_equal !@((coerce pintvv pintr !@v).r) 100 end end in () module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Check coercions between functions. *) let test_function_coercions _ = let isize_t = view size_t ~read:Unsigned.Size_t.to_int ~write:Unsigned.Size_t.of_int in let memchr' = coerce_fn (ptr void @-> int @-> size_t @-> returning (ptr void)) (string @-> int8_t @-> isize_t @-> returning string_opt) memchr in begin assert_equal (memchr' "foobar" (Char.code 'b') 4) (Some "bar") ; assert_equal (memchr' "foobar" (Char.code 'b') 2) None ; end end (* Check that identity coercions are cost-free. *) let test_identity_coercions _ = let f = fun x _y -> x in let fn = int @-> float @-> returning int in let f' = coerce_fn fn fn f in assert_bool "identity coercions are free" (f' == f) let test_unsigned_coercions _ = assert_equal (Unsigned.UInt8.of_int 256) (Unsigned.UInt8.of_int 0); assert_equal (Unsigned.UInt16.of_int (1 lsl 16)) (Unsigned.UInt16.of_int 0) (* Check that coercions between unsupported types raise an exception *) let test_unsupported_coercions _ = let module M = struct type boxed_type = T : 'a typ -> boxed_type let types = [ T int8_t, [T uint16_t; T float; T complex64; T (bigarray array1 10 Bigarray_compat.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T uint16_t, [T int8_t; T int; T float; T short; T complex64; T (bigarray array1 10 Bigarray_compat.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T int, [T uint16_t; T float; T complex64; T (bigarray array1 10 Bigarray_compat.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T float, [T int8_t; T uint16_t; T int; T short; T complex64; T (bigarray array1 10 Bigarray_compat.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T ldouble, [T int8_t; T uint16_t; T int; T short; T complex64; T (bigarray array1 10 Bigarray_compat.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T short, [T uint16_t; T float; T complex64; T (bigarray array1 10 Bigarray_compat.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T complex64, [T int8_t; T uint16_t; T int; T float; T short; T (bigarray array1 10 Bigarray_compat.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T complexld, [T int8_t; T uint16_t; T int; T short; T (bigarray array1 10 Bigarray_compat.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T (bigarray array1 10 Bigarray_compat.int32), [T int8_t; T uint16_t; T int; T float; T short; T complex64; T (bigarray array1 10 Bigarray_compat.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T (array 5 int32_t), [T int8_t; T uint16_t; T int; T float; T short; T complex64; T (bigarray array1 10 Bigarray_compat.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T (structure "s"), [T int8_t; T uint16_t; T int; T float; T short; T complex64; T (bigarray array1 10 Bigarray_compat.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T (union "u"), [T int8_t; T uint16_t; T int; T float; T short; T complex64; T (bigarray array1 10 Bigarray_compat.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T (abstract ~name:"a" ~size:12 ~alignment:4), [T int8_t; T uint16_t; T int; T float; T short; T complex64; T (bigarray array1 10 Bigarray_compat.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T ocaml_string, [T int8_t; T uint16_t; T int; T float; T short; T complex64; T (bigarray array1 10 Bigarray_compat.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; ] (* None of the types in the list are currently intercoercible. *) let () = ListLabels.iter types ~f:(fun (T t1, ts) -> ListLabels.iter ts ~f:(fun (T t2) -> try let _ : _ -> _ = coerce t1 t2 in assert_failure "coercion unexpectedly succeeded" with Uncoercible _ -> ())) end in () module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Coercsion tests" >::: ["test pointer coercions" >:: test_pointer_coercions; "test struct first member coercions" >:: test_struct_first_member_coercions; "test union coercions" >:: test_union_coercions; "test view coercions" >:: test_view_coercions; "test function coercions (foreign)" >:: Foreign_tests.test_function_coercions; "test function coercions (stubs)" >:: Stub_tests.test_function_coercions; "test identity coercions" >:: test_identity_coercions; "test unsupported coercions" >:: test_unsupported_coercions; "test unsigned integer coersions" >:: test_unsigned_coercions ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-complex/000077500000000000000000000000001445631112600215305ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-complex/dune000066400000000000000000000004061445631112600224060ustar00rootroot00000000000000(test (name test_complex) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_complexs_stubs test_complexs_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-complex/stub-generator/000077500000000000000000000000001445631112600244715ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-complex/stub-generator/driver.ml000066400000000000000000000004151445631112600263160ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the complex number tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-complex/stub-generator/dune000066400000000000000000000007301445631112600253470ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_complexs_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_complexs_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-complex/stubs/000077500000000000000000000000001445631112600226705ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-complex/stubs/dune000066400000000000000000000001131445631112600235410ustar00rootroot00000000000000(library (name test_complexs_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-complex/stubs/functions.ml000066400000000000000000000037631445631112600252430ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the complex number tests. *) open Ctypes (* These functions can be bound either dynamically using Foreign or statically using stub generation. *) module Common(F : Ctypes.FOREIGN) = struct let bind' typ1 typ2 name = F.(foreign name (ptr typ1 @-> ptr typ2 @-> ptr typ2 @-> returning void)) let bind typ name = bind' typ typ name let add_complexd = bind complex64 "add_complexd" let mul_complexd = bind complex64 "mul_complexd" let rotdist_complexd = bind' complex64 double "rotdist_complexd" let add_complexld = bind complexld "add_complexld" let mul_complexld = bind complexld "mul_complexld" let rotdist_complexld = bind' complexld ldouble "rotdist_complexld" let add_complexf = bind complex32 "add_complexf" let mul_complexf = bind complex32 "mul_complexf" let rotdist_complexf = bind' complex32 float "rotdist_complexf" end (* These functions can only be bound using stub generation, since Foreign doesn't support passing complex numbers by value. *) module Stubs_only(F : Ctypes.FOREIGN) = struct let bind' typ1 typ2 name = F.(foreign name (typ1 @-> typ2 @-> returning typ2)) let bind typ name = bind' typ typ name let add_complexd_val = bind complex64 "add_complexd_val" let mul_complexd_val = bind complex64 "mul_complexd_val" let rotdist_complexd_val = bind' complex64 double "rotdist_complexd_val" let add_complexld_val = bind complexld "add_complexld_val" let mul_complexld_val = bind complexld "mul_complexld_val" let rotdist_complexld_val = bind' complexld ldouble "rotdist_complexld_val" let add_complexf_val = bind complex32 "add_complexf_val" let mul_complexf_val = bind complex32 "mul_complexf_val" let rotdist_complexf_val = bind' complex32 float "rotdist_complexf_val" end module Stubs (F: Ctypes.FOREIGN) = struct include Common(F) include Stubs_only(F) end yallop-ocaml-ctypes-3f8211a/tests/test-complex/test_complex.ml000066400000000000000000000152521445631112600245750ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes let _ = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Common(S) open M (* Test primitive operations on complex numbers. Arguments and return values are currently mediated through pointers, since libffi doesn't support passing complex numbers. *) let test_complex_primitive_operations _ = let wrap' typ1 typ2 f l r = let rv = allocate_n ~count:1 typ2 in f (allocate typ1 l) (allocate typ2 r) rv; !@rv in let wrap typ f l r = wrap' typ typ f l r in let addz64 = wrap complex64 add_complexd and mulz64 = wrap complex64 mul_complexd and rotz64 = wrap' complex64 double rotdist_complexd and addz32 = wrap complex32 add_complexf and mulz32 = wrap complex32 mul_complexf and rotz32 = wrap' complex32 float rotdist_complexf and addzld = wrap complexld add_complexld and mulzld = wrap complexld mul_complexld and rotzld = wrap' complexld ldouble rotdist_complexld in begin let open Complex in let eps64 = 1e-12 in let complex64_eq { re = lre; im = lim } { re = rre; im = rim } = abs_float (lre -. rre) < eps64 && abs_float (lim -. rim) < eps64 in let eps32 = 1e-6 in let complex32_eq { re = lre; im = lim } { re = rre; im = rim } = abs_float (lre -. rre) < eps32 && abs_float (lim -. rim) < eps32 in let l = { re = 3.5; im = -1.0 } and r = { re = 2.0; im = 2.7 } in assert_equal ~cmp:complex64_eq (Complex.add l r) (addz64 l r); assert_equal ~cmp:complex64_eq (Complex.mul l r) (mulz64 l r); assert_equal ~cmp:complex32_eq (Complex.add l r) (addz32 l r); assert_equal ~cmp:complex32_eq (Complex.mul l r) (mulz32 l r); (* test long double complex *) let re x = LDouble.(to_float (ComplexL.re x)) in let im x = LDouble.(to_float (ComplexL.im x)) in let to_complexld c = LDouble.(ComplexL.make (of_float c.re) (of_float c.im)) in let of_complexld c = { re = re c; im = im c } in let l', r' = to_complexld l, to_complexld r in assert_equal ~cmp:complex64_eq (Complex.add l r) (of_complexld @@ addzld l' r'); assert_equal ~cmp:complex64_eq (Complex.mul l r) (of_complexld @@ mulzld l' r'); (* The rotdist test is designed to check passing and returning long doubles. The function rotates a complex number by the given angle in radians, then returns the manhatten distance (sum of absolute value of real and imaginary parts) *) let rot x a = let open Complex in let y = mul x { re = cos a; im = sin a } in abs_float y.re +. abs_float y.im in let rotzld x r = let open LDouble in to_float (rotzld (ComplexL.make (of_float x.re) (of_float x.im)) (of_float r)) in let test_rotdist f eps x r = let a = rot x r in let b = f x r in assert_bool "rotdist" (abs_float (a -. b) < eps) in test_rotdist rotzld eps64 { re = 2.3; im = -0.6; } 1.4; test_rotdist rotz64 eps64 { re = 2.3; im = -0.6; } 1.4; test_rotdist rotz32 eps32 { re = 2.3; im = -0.6; } 1.4; end end module Build_stub_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module N = Functions.Stubs(S) open N include Common_tests(S) (* Test primitive operations on complex numbers passed by value. *) let test_complex_primitive_value_operations _ = begin let open Complex in let eps64 = 1e-12 in let complex64_eq { re = lre; im = lim } { re = rre; im = rim } = abs_float (lre -. rre) < eps64 && abs_float (lim -. rim) < eps64 in let eps32 = 1e-6 in let complex32_eq { re = lre; im = lim } { re = rre; im = rim } = abs_float (lre -. rre) < eps32 && abs_float (lim -. rim) < eps32 in let l = { re = 3.5; im = -1.0 } and r = { re = 2.0; im = 2.7 } in assert_equal ~cmp:complex64_eq (Complex.add l r) (add_complexd_val l r); assert_equal ~cmp:complex64_eq (Complex.mul l r) (mul_complexd_val l r); assert_equal ~cmp:complex32_eq (Complex.add l r) (add_complexf_val l r); assert_equal ~cmp:complex32_eq (Complex.mul l r) (mul_complexf_val l r); let zinf = { re = 0.; im = infinity } in let res = add_complexd_val zinf zinf in assert_equal 0. res.re; assert_equal 0. (add_complexf_val zinf zinf).re; let ozinf = Obj.repr zinf in let ores = Obj.repr res in assert_equal (Obj.tag ozinf) (Obj.tag ores); assert_equal (Obj.size ozinf) (Obj.size ores); (* test long double complex *) let re x = LDouble.(to_float (ComplexL.re x)) in let im x = LDouble.(to_float (ComplexL.im x)) in let to_complexld c = LDouble.(ComplexL.make (of_float c.re) (of_float c.im)) in let of_complexld c = { re = re c; im = im c } in let l', r' = to_complexld l, to_complexld r in assert_equal ~cmp:complex64_eq (Complex.add l r) (of_complexld @@ add_complexld_val l' r'); assert_equal ~cmp:complex64_eq (Complex.mul l r) (of_complexld @@ mul_complexld_val l' r'); assert_equal 0. (re (to_complexld zinf)); (* rot-dist test *) let rot x a = let open Complex in let y = mul x { re = cos a; im = sin a } in abs_float y.re +. abs_float y.im in let rotdist_complexld_val x r = let open LDouble in to_float (rotdist_complexld_val (ComplexL.make (of_float x.re) (of_float x.im)) (of_float r)) in let test_rotdist f eps x r = let a = rot x r in let b = f x r in assert_bool "rotdist" (abs_float (a -. b) < eps) in test_rotdist rotdist_complexld_val eps64 { re = 2.3; im = -0.6; } 1.4; test_rotdist rotdist_complexd_val eps64 { re = 2.3; im = -0.6; } 1.4; test_rotdist rotdist_complexf_val eps32 { re = 2.3; im = -0.6; } 1.4; end end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Build_stub_tests(Generated_bindings) let suite = "Complex number tests" >::: ["basic operations on complex numbers (foreign)" >:: Foreign_tests.test_complex_primitive_operations; "basic operations on complex numbers (stubs)" >:: Stub_tests.test_complex_primitive_operations; "basic operations on complex numbers passed by value(stubs)" >:: Stub_tests.test_complex_primitive_value_operations; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-constants/000077500000000000000000000000001445631112600220755ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-constants/dune000066400000000000000000000023371445631112600227600ustar00rootroot00000000000000(rule (targets generated_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) (rule (targets generated_struct_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) (rule (targets ml-stub-generator.exe) (deps generated_struct_stubs.c ../clib/test_functions.h ../config/test-cflags) (action (run %{cc} %{read-lines:../config/test-cflags} -I ../clib -I %{ocaml-config:standard_library} -o %{targets} generated_struct_stubs.c))) (rule (targets generated_struct_bindings.ml) (deps ml-stub-generator.exe) (action (with-stdout-to %{targets} (run %{deps})))) (library (name test_constants_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings generated_struct_bindings) (libraries ctypes test_functions)) (test (name test_constants) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (modules test_constants) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_constants_stubs test_functions test_constants_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-constants/stub-generator/000077500000000000000000000000001445631112600250365ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-constants/stub-generator/driver.ml000066400000000000000000000006241445631112600266650ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the constants tests. *) let cheader = "#include \n#include " let () = Tests_common.run Sys.argv ~cheader ~structs:(module Types.Struct_stubs) (module functor (S: Cstubs.FOREIGN) -> struct end) yallop-ocaml-ctypes-3f8211a/tests/test-constants/stub-generator/dune000066400000000000000000000001441445631112600257130ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_constants_stubs tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-constants/stubs/000077500000000000000000000000001445631112600232355ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-constants/stubs/dune000066400000000000000000000001141445631112600241070ustar00rootroot00000000000000(library (name test_constants_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-constants/stubs/types.ml000066400000000000000000000036511445631112600247400ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) module Struct_stubs(S : Ctypes.TYPE) = struct open S let _SCHAR_MIN = constant "SCHAR_MIN" schar let _SCHAR_MAX = constant "SCHAR_MAX" schar let _UCHAR_MAX = constant "UCHAR_MAX" uchar let _CHAR_MIN = constant "CHAR_MIN" char let _CHAR_MAX = constant "CHAR_MAX" char let _SHRT_MIN = constant "SHRT_MIN" short let _SHRT_MAX = constant "SHRT_MAX" short let _USHRT_MAX = constant "USHRT_MAX" ushort let _INT_MIN = constant "INT_MIN" sint let _INT_MAX = constant "INT_MAX" sint let _UINT_MAX = constant "UINT_MAX" uint let _LONG_MAX = constant "LONG_MAX" long let _LONG_MIN = constant "LONG_MIN" long let _ULONG_MAX = constant "ULONG_MAX" ulong let _LLONG_MAX = constant "LLONG_MAX" llong let _LLONG_MIN = constant "LLONG_MIN" llong let _ULLONG_MAX = constant "ULLONG_MAX" ullong let _INT8_MIN = constant "INT8_MIN" int8_t let _INT16_MIN = constant "INT16_MIN" int16_t let _INT32_MIN = constant "INT32_MIN" int32_t let _INT64_MIN = constant "INT64_MIN" int64_t let _INT8_MAX = constant "INT8_MAX" int8_t let _INT16_MAX = constant "INT16_MAX" int16_t let _INT32_MAX = constant "INT32_MAX" int32_t let _INT64_MAX = constant "INT64_MAX" int64_t let _UINT8_MAX = constant "UINT8_MAX" uint8_t let _UINT16_MAX = constant "UINT16_MAX" uint16_t let _UINT32_MAX = constant "UINT32_MAX" uint32_t let _UINT64_MAX = constant "UINT64_MAX" uint64_t let _SIZE_MAX = constant "SIZE_MAX" size_t let _true = constant "true" bool let _false = constant "false" bool let i32_inverted = view int32_t ~read:Int32.neg ~write:Int32.neg let neg_INT16_MAX = constant "INT16_MAX" i32_inverted let neg_INT16_MIN = constant "INT16_MIN" i32_inverted let _A = constant "A" int let _B = constant "B" int let _C = constant "C" int let _D = constant "D" int end yallop-ocaml-ctypes-3f8211a/tests/test-constants/test_constants.ml000066400000000000000000000103671445631112600255110ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes let testlib = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) module Constants = Types.Struct_stubs(Generated_struct_bindings) let constant name typ = Foreign.foreign ~from:testlib ("retrieve_"^ name) (void @-> returning typ) () let test_retrieve_constants _ = begin assert_equal (constant "UCHAR_MAX" Ctypes.uchar |> Unsigned.UChar.to_int) 255; assert_equal (Constants._UCHAR_MAX |> Unsigned.UChar.to_int) 255; assert_equal (constant "USHRT_MAX" Ctypes.ushort |> Unsigned.UShort.to_int) 65535; assert_equal (Constants._USHRT_MAX |> Unsigned.UShort.to_int) 65535; assert_equal (constant "UINT8_MAX" Ctypes.uint8_t |> Unsigned.UInt8.to_int) 255; assert_equal (Constants._UINT8_MAX |> Unsigned.UInt8.to_int) 255; assert_equal (constant "UINT16_MAX" Ctypes.uint16_t |> Unsigned.UInt16.to_int) 65535; assert_equal (Constants._UINT16_MAX |> Unsigned.UInt16.to_int) 65535; assert_equal (Unsigned.UInt8.to_int (Unsigned.UInt8.of_string "255")) 255; assert_equal Constants._LONG_MIN (constant "LONG_MIN" long); assert_equal Constants._SCHAR_MIN (constant "SCHAR_MIN" Ctypes.schar); assert_equal Constants._SCHAR_MAX (constant "SCHAR_MAX" Ctypes.schar); assert_equal Constants._UCHAR_MAX (constant "UCHAR_MAX" Ctypes.uchar); assert_equal Constants._CHAR_MIN (constant "CHAR_MIN" Ctypes.char); assert_equal Constants._CHAR_MAX (constant "CHAR_MAX" Ctypes.char); assert_equal Constants._SHRT_MIN (constant "SHRT_MIN" Ctypes.short); assert_equal Constants._SHRT_MAX (constant "SHRT_MAX" Ctypes.short); assert_equal Constants._USHRT_MAX (constant "USHRT_MAX" Ctypes.ushort); assert_equal Constants._INT_MIN (constant "INT_MIN" Ctypes.sint); assert_equal Constants._INT_MAX (constant "INT_MAX" Ctypes.sint); assert_equal Constants._UINT_MAX (constant "UINT_MAX" Ctypes.uint); assert_equal Constants._LONG_MAX (constant "LONG_MAX" Ctypes.long); assert_equal Constants._LONG_MIN (constant "LONG_MIN" Ctypes.long); assert_equal Constants._ULONG_MAX (constant "ULONG_MAX" Ctypes.ulong); assert_equal Constants._LLONG_MAX (constant "LLONG_MAX" Ctypes.llong); assert_equal Constants._LLONG_MIN (constant "LLONG_MIN" Ctypes.llong); assert_equal Constants._ULLONG_MAX (constant "ULLONG_MAX" Ctypes.ullong); assert_equal Constants._INT8_MIN (constant "INT8_MIN" Ctypes.int8_t); assert_equal Constants._INT16_MIN (constant "INT16_MIN" Ctypes.int16_t); assert_equal Constants._INT32_MIN (constant "INT32_MIN" Ctypes.int32_t); assert_equal Constants._INT64_MIN (constant "INT64_MIN" Ctypes.int64_t); assert_equal Constants._INT8_MAX (constant "INT8_MAX" Ctypes.int8_t); assert_equal Constants._INT16_MAX (constant "INT16_MAX" Ctypes.int16_t); assert_equal Constants._INT32_MAX (constant "INT32_MAX" Ctypes.int32_t); assert_equal Constants._INT64_MAX (constant "INT64_MAX" Ctypes.int64_t); assert_equal Constants._UINT8_MAX (constant "UINT8_MAX" Ctypes.uint8_t); assert_equal Constants._UINT16_MAX (constant "UINT16_MAX" Ctypes.uint16_t); assert_equal Constants._UINT32_MAX (constant "UINT32_MAX" Ctypes.uint32_t); assert_equal Constants._UINT64_MAX (constant "UINT64_MAX" Ctypes.uint64_t); assert_equal Constants._SIZE_MAX (constant "SIZE_MAX" Ctypes.size_t); assert_equal Constants._true true; assert_equal Constants._false false; end let test_retrieve_views _ = begin assert_equal Constants.neg_INT16_MAX (Int32.(neg (of_int (constant "INT16_MAX" Ctypes.int16_t)))) ; assert_equal Constants.neg_INT16_MIN (Int32.(neg (of_int (constant "INT16_MIN" Ctypes.int16_t)))) ; end let test_retrieve_enums _ = begin assert_equal [0; 1; 10; 11] Constants.([_A; _B; _C; _D]) end let suite = "Constant tests" >::: ["retrieving values of various integer types" >:: test_retrieve_constants; "retrieving values of view type" >:: test_retrieve_views; "retrieving enumeration constants" >:: test_retrieve_enums; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-cstdlib/000077500000000000000000000000001445631112600215055ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-cstdlib/dune000066400000000000000000000003001445631112600223540ustar00rootroot00000000000000(test (name test_cstdlib) (package ctypes-foreign) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_cstdlib_stubs test_cstdlib_bindings tests_common stdlib-shims)) yallop-ocaml-ctypes-3f8211a/tests/test-cstdlib/stub-generator/000077500000000000000000000000001445631112600244465ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-cstdlib/stub-generator/driver.ml000066400000000000000000000005501445631112600262730ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the C standard library tests. *) let cheader = " #include #include #include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-cstdlib/stub-generator/dune000066400000000000000000000007261445631112600253310ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_cstdlib_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_cstdlib_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-cstdlib/stubs/000077500000000000000000000000001445631112600226455ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-cstdlib/stubs/dune000066400000000000000000000001311445631112600235160ustar00rootroot00000000000000(library (name test_cstdlib_stubs) (wrapped false) (libraries ctypes ctypes-foreign)) yallop-ocaml-ctypes-3f8211a/tests/test-cstdlib/stubs/functions.ml000066400000000000000000000035331445631112600252130ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the C standard library tests. *) open Ctypes open Foreign module Stubs (F: Ctypes.FOREIGN) = struct open F let cchar = view ~read:Char.chr ~write:Char.code int let bool = view ~read:((<>)0) ~write:(fun b -> if b then 1 else 0) int let t = (cchar @-> returning bool) let isalnum = foreign "isalnum" t and isalpha = foreign "isalpha" t and iscntrl = foreign "iscntrl" t and isdigit = foreign "isdigit" t and isgraph = foreign "isgraph" t and islower = foreign "islower" t and isprint = foreign "isprint" t and ispunct = foreign "ispunct" t and isspace = foreign "isspace" t and isupper = foreign "isupper" t and isxdigit = foreign "isxdigit" t (* char *strchr(const char *str, int c); *) let strchr = foreign "strchr" (string @-> int @-> returning string) (* int strcmp(const char *str1, const char *str2); *) let strcmp = foreign "strcmp" (string @-> string @-> returning int) (* int memcmp(const void *ptr1, const void *ptr2, size_t num) *) let memcmp = foreign "memcmp" (ptr void @-> ptr void @-> size_t @-> returning int) (* void *memset(void *ptr, int value, size_t num) *) let memset = foreign "memset" (ptr void @-> int @-> size_t @-> returning (ptr void)) (* let div = foreign "div" (int @-> int @-> returning div_t) *) let qsort = foreign "qsort" (ptr void @-> size_t @-> size_t @-> funptr Ctypes.(ptr void @-> ptr void @-> returning int) @-> returning void) let bsearch = foreign "bsearch" (ptr void @-> ptr void @-> size_t @-> size_t @-> funptr Ctypes.(ptr void @-> ptr void @-> returning int) @-> returning (ptr void)) let strlen = foreign "strlen" (ptr char @-> returning size_t) end yallop-ocaml-ctypes-3f8211a/tests/test-cstdlib/test_cstdlib.ml000066400000000000000000000206301445631112600245230ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes open Unsigned open Foreign module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Call the functions int isisalnum(int) int isisalpha(int) int isiscntrl(int) int isisdigit(int) int isisgraph(int) int isislower(int) int isisprint(int) int isispunct(int) int isisspace(int) int isisupper(int) int isisxdigit(int) *) let test_isX_functions _ = begin assert_bool "" (isalnum 'a'); assert_bool "" (not (isalnum ' ')); assert_bool "" (isalpha 'x'); assert_bool "" (not (isalpha ';')); assert_bool "" (iscntrl '\r'); assert_bool "" (not (iscntrl 'a')); assert_bool "" (isdigit '2'); assert_bool "" (not (isdigit 'a')); assert_bool "" (isgraph '?'); assert_bool "" (not (isgraph ' ')); assert_bool "" (islower 's'); assert_bool "" (not (islower 'S')); assert_bool "" (isprint ' '); assert_bool "" (not (isprint '\b')); assert_bool "" (ispunct '.'); assert_bool "" (not (ispunct 'a')); assert_bool "" (isspace '\t'); assert_bool "" (not (isspace '~')); assert_bool "" (isupper 'X'); assert_bool "" (not (isupper 'x')); assert_bool "" (isxdigit 'f'); assert_bool "" (not (isxdigit 'g')); end (* Call the functions char *strchr(const char *str, int c); int strcmp(const char *str1, const char *str2); *) let test_string_functions _ = assert_equal "efg" (strchr "abcdefg" (Char.code 'e')) ~printer:(fun x -> x); (* non-word-aligned pointers do not trigger exceptions *) assert_equal "defg" (strchr "abcdefg" (Char.code 'd')); assert_bool "strcmp('abc', 'def') < 0" (strcmp "abc" "def" < 0); assert_bool "strcmp('def', 'abc') > 0" (strcmp "def" "abc" > 0); assert_bool "strcmp('abc', 'abc') == 0" (strcmp "abc" "abc" = 0); let p1 = allocate int 10 and p2 = allocate int 20 in assert_bool "memcmp(&10, &20) < 0" (memcmp (to_voidp p1) (to_voidp p2) (Size_t.of_int (sizeof int)) < 0); let p = allocate_n uchar ~count:12 in let i = 44 in let u = UChar.of_int i in begin ignore (memset (to_voidp p) i (Size_t.of_int 12)); for i = 0 to 11 do assert_equal u !@(p +@ i) done end (* Call the function void qsort(void *base, size_t nmemb, size_t size, int(*compar)(const void *, const void *)); *) let test_qsort _ = let sortby (type a) (typ : a typ) (f : a -> a -> int) (l : a list) = let open CArray in let open Size_t in let arr = of_list typ l in let len = of_int (length arr) in let size = of_int (sizeof typ) in let cmp xp yp = let x = !@(from_voidp typ xp) and y = !@(from_voidp typ yp) in f x y in let () = qsort (to_voidp (start arr)) len size cmp in let _ = Ctypes_memory_stubs.use_value cmp in to_list arr in assert_equal [5; 4; 3; 2; 1] (sortby int (fun x y -> - (compare x y)) [3; 4; 1; 2; 5]); assert_equal ['o'; 'q'; 'r'; 's'; 't'] (sortby char compare ['q'; 's'; 'o'; 'r'; 't']) (* Call the function void *bsearch(const void *key, const void *base, size_t nmemb, size_t size, int (*compar)(const void *, const void *)); *) let test_bsearch _ = let module M = struct (* struct mi { int nr; char *name; } months[] = { { 1, "jan" }, { 2, "feb" }, { 3, "mar" }, { 4, "apr" }, { 5, "may" }, { 6, "jun" }, { 7, "jul" }, { 8, "aug" }, { 9, "sep" }, {10, "oct" }, {11, "nov" }, {12, "dec" } }; *) type mi let mi = structure "mi" let (-:) ty label = field mi label ty let mr = int -: "mr" let name = ptr char -: "name" let () = seal (mi : mi structure typ) let of_string : string -> char carray = fun s -> CArray.from_ptr (coerce string (ptr char) s) (String.length s) let as_string : char ptr -> string = coerce (ptr char) string let mkmi n s = let m = make mi in setf m mr n; setf m name (CArray.start s); m let cmpi m1 m2 = let mi1 = from_voidp mi m1 in let mi2 = from_voidp mi m2 in compare (as_string (!@(mi1 |-> name))) (as_string (!@(mi2 |-> name))) let jan = of_string "jan" let feb = of_string "feb" let mar = of_string "mar" let apr = of_string "apr" let may = of_string "may" let jun = of_string "jun" let jul = of_string "jul" let aug = of_string "aug" let sep = of_string "sep" let oct = of_string "oct" let nov = of_string "nov" let dec = of_string "dec" let months = CArray.of_list mi [ mkmi 1 jan; mkmi 2 feb; mkmi 3 mar; mkmi 4 apr; mkmi 5 may; mkmi 6 jun; mkmi 7 jul; mkmi 8 aug; mkmi 9 sep; mkmi 10 oct; mkmi 11 nov; mkmi 12 dec; ] let () = qsort (to_voidp (CArray.start months)) (Size_t.of_int (CArray.length months)) (Size_t.of_int (sizeof mi)) cmpi let search : mi structure -> mi structure carray -> mi structure option = fun key array -> let len = Size_t.of_int (CArray.length array) in let size = Size_t.of_int (sizeof mi) in let r : unit ptr = bsearch (to_voidp (addr key)) (to_voidp (CArray.start array)) len size cmpi in if r = null then None else Some (!@(from_voidp mi r)) let find_month_by_name : char carray -> mi structure option = fun s -> search (mkmi 0 s) months let () = match find_month_by_name dec with Some m -> assert_equal 12 (getf m mr) | _ -> assert false let () = match find_month_by_name feb with Some m -> assert_equal 2 (getf m mr) | _ -> assert false let () = match find_month_by_name jan with Some m -> assert_equal 1 (getf m mr) | _ -> assert false let () = match find_month_by_name may with Some m -> assert_equal 5 (getf m mr) | _ -> assert false let missing = of_string "missing" let () = assert_equal None (find_month_by_name missing) let empty = of_string "" let () = assert_equal None (find_month_by_name empty) let _ = Ctypes_memory_stubs.use_value [jan; feb; mar; apr; may; jun; jul; aug; sep; oct; nov; dec] end in () end (* Call the functions div_t div(int numerator, int denominator) where div_t is defined as follows: typedef struct { int quot; /* Quotient. */ int rem; /* Remainder. */ } div_t; *) let test_div _ = let module M = struct type div_t let div_t : div_t structure typ = structure "div_t" let (-:) ty label = field div_t label ty let quot = int -: "quot" let rem = int -: "rem" let () = seal div_t let div = foreign "div" (int @-> int @-> returning div_t) let test ~num ~dem ~quotient ~remainder = let v = div num dem in let () = assert_equal quotient (getf v quot) in let () = assert_equal remainder (getf v rem) in () let () = test ~num:10 ~dem:2 ~quotient:5 ~remainder:0 let () = test ~num:11 ~dem:2 ~quotient:5 ~remainder:1 end in () module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "C standard library tests" >::: ["test isX functions (foreign)" >:: Foreign_tests.test_isX_functions; "test isX functions (stubs)" >:: Stub_tests.test_isX_functions; "test string function (foreign)" >:: Foreign_tests.test_string_functions; "test string function (stubs)" >:: Stub_tests.test_string_functions; "test div function" >:: test_div; "test qsort function (foreign)" >:: Foreign_tests.test_qsort; "test qsort function (stubs)" >:: Stub_tests.test_qsort; "test bsearch function (foreign)" >:: Foreign_tests.test_bsearch; "test bsearch function (stubs)" >:: Stub_tests.test_bsearch; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-custom_ops/000077500000000000000000000000001445631112600222545ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-custom_ops/dune000066400000000000000000000000721445631112600231310ustar00rootroot00000000000000(test (name test_custom_ops) (libraries ounit2 ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-custom_ops/test_custom_ops.ml000066400000000000000000000051131445631112600260400ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes let hash = Hashtbl.hash (* Test hashing and equality for managed buffers. Hashing and equality are based on the addresses of malloc-allocated objects, so even structurally-equal values should have different hashes and compare unequal. *) let test_managed_buffer_hashing_and_equality _ = let i1 = allocate int 20 in let i2 = allocate int 20 in assert_equal !@i1 !@i2; assert_equal (hash i1) (hash i1); assert_bool "equal-but-not-identical objects have distinct hashes" (hash i1 <> hash i2); assert_bool "equal-but-not-identical objects do not compare equal" (i1 <> i2) (* Test type info hashing and equality. Equality is structural, so distinct but structurally-equal values should have equal hashes and compare equal. *) let test_type_info_hashing_and_equality _ = let module M = struct type s let s : s structure typ = structure "s" let _ = begin ignore (field s "d" double); ignore (field s "p" (ptr void)); seal s end type t let t : t structure typ = structure "s" let _ = begin ignore (field t "d" double); ignore (field t "p" (ptr void)); seal t end let () = begin (* Pointer equality is structural. *) assert_equal ~msg:"Equal pointer types have equal hashes" (hash (ptr double)) (hash (ptr double)); assert_equal ~msg:"Equal pointer types compare equal" (ptr double) (ptr double); (* Array equality is structural. *) assert_equal ~msg:"Equal array types have equal hashes" (hash (array 3 (array 4 int))) (hash (array 3 (array 4 int))); assert_equal ~msg:"Equal array types compare equal" (array 3 (array 4 int)) (array 3 (array 4 int)); assert_bool "Distinct array types do not compare equal" (array 3 (array 4 int) <> array 3 (array 5 int)); (* Structure equality is structural *) assert_equal (hash s) (hash s); assert_bool "equal-but-not-identical structure types have equal hashes" (hash s = hash t); assert_bool "equal-but-not-identical structure types compare equal" (Obj.repr s = Obj.repr t); end end in () let suite = "Custom ops tests" >::: ["managed buffer hashing and equality" >:: test_managed_buffer_hashing_and_equality; "type info hashing and equality" >:: test_type_info_hashing_and_equality; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-enums/000077500000000000000000000000001445631112600212105ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-enums/dune000066400000000000000000000017061445631112600220720ustar00rootroot00000000000000(rule (targets generated_struct_stubs.c) (action (run %{exe:struct-stub-generator/driver.exe} --c-struct-file %{targets}))) (rule (targets struct-stub-generator.exe) (deps generated_struct_stubs.c ../clib/test_functions.h ../config/test-cflags) (action (run %{cc} %{read-lines:../config/test-cflags} -I ../clib -I %{ocaml-config:standard_library} -o %{targets} generated_struct_stubs.c))) (rule (targets generated_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) (library (name test_enums_generated) (modules generated_bindings) (foreign_stubs (language c) (names generated_stubs)) (libraries test_functions) (wrapped false)) (test (name test_enums) (modules test_enums) (package ctypes-foreign) (libraries ounit2 ctypes test_enums_generated test_enums_stubs)) yallop-ocaml-ctypes-3f8211a/tests/test-enums/struct-stub-generator/000077500000000000000000000000001445631112600254735ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-enums/struct-stub-generator/driver.ml000066400000000000000000000005171445631112600273230ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Struct stub generation driver for the enum tests. *) let () = Tests_common.run Sys.argv ~structs:(module Types.Struct_stubs) (module functor (X: Cstubs.FOREIGN) -> struct end) yallop-ocaml-ctypes-3f8211a/tests/test-enums/struct-stub-generator/dune000066400000000000000000000001471445631112600263530ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_enums_struct_stubs tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-enums/struct-stubs/000077500000000000000000000000001445631112600236725ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-enums/struct-stubs/dune000066400000000000000000000001171445631112600245470ustar00rootroot00000000000000(library (name test_enums_struct_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-enums/struct-stubs/types.ml000066400000000000000000000024151445631112600253720ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes type fruit = Orange | Apple | Banana | Pear module Struct_stubs(S : Ctypes.TYPE) = struct open S let orange = constant "Orange" int64_t let apple = constant "Apple" int64_t let pear = constant "Pear" int64_t let banana = constant "Banana" int64_t let fruit = enum "fruit" [ Orange , orange ; Apple , apple ; Pear , pear ; Banana , banana ; ] let minus_one = constant "minus_one" int64_t let plus_one = constant "plus_one" int64_t let signed = enum "signed_enum" ~unexpected:(fun _ -> 0) [ -1, minus_one ; 1 , plus_one ; ] let fruit_cell : [`fruit_cell] structure typ = structure "fruit_cell" let frt = field fruit_cell "frt" fruit let next = field fruit_cell "next" (ptr_opt fruit_cell) let () = seal fruit_cell let edward = constant "Edward" int64_t let winnie = constant "Winnie" int64_t let paddington = constant "Paddington" int64_t let bears : [`Edward|`Winnie|`Paddington] typ = enum "bears" [ `Edward , edward ; `Winnie , winnie ; `Paddington , paddington ; ] end yallop-ocaml-ctypes-3f8211a/tests/test-enums/stub-generator/000077500000000000000000000000001445631112600241515ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-enums/stub-generator/driver.ml000066400000000000000000000004031445631112600257730ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the enum tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-enums/stub-generator/dune000066400000000000000000000001401445631112600250220ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_enums_stubs tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-enums/stubs/000077500000000000000000000000001445631112600223505ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-enums/stubs/dune000066400000000000000000000003561445631112600232320ustar00rootroot00000000000000(library (name test_enums_stubs) (wrapped false) (libraries ctypes.stubs test_enums_struct_stubs)) (rule (targets generated_struct_bindings.ml) (action (with-stdout-to %{targets} (run %{exe:../struct-stub-generator.exe})))) yallop-ocaml-ctypes-3f8211a/tests/test-enums/stubs/functions.ml000066400000000000000000000012611445631112600247120ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the enum tests. *) open Ctypes (* These functions can only be bound using stub generation, since Foreign doesn't support passing enums. *) module Stubs(F : Ctypes.FOREIGN) = struct open F module T = Types.Struct_stubs(Generated_struct_bindings) let classify_integer = foreign "classify_integer" (int @-> returning T.signed) let out_of_range = foreign "out_of_range" (void @-> returning T.signed) let next_fruit = foreign "next_fruit" (T.fruit @-> returning T.fruit) end yallop-ocaml-ctypes-3f8211a/tests/test-enums/test_enums.ml000066400000000000000000000057611445631112600237410ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@warning "-33"] open OUnit2 open Ctypes module Build_enum_stub_tests (S : Cstubs.Types.TYPE with type 'a typ = 'a Ctypes.typ and type ('a, 's) field = ('a, 's) Ctypes.field) = struct module M = Types.Struct_stubs(S) open M let test_enum_struct_members _ = let reverse cell = let rec loop prev cell = match cell with None -> prev | Some c -> let n = getf !@c next in let () = setf !@c next prev in loop cell n in loop None cell in let as_list cell = let rec loop l = function None -> List.rev l | Some c -> loop (getf !@c frt :: l) (getf !@c next) in loop [] cell in let rec of_list l = match l with [] -> None | f :: fs -> let c = make fruit_cell in let n = of_list fs in let () = setf c frt f in let () = setf c next n in Some (addr c) in begin let open Types in let l = of_list [Apple; Apple; Pear; Banana] in assert_equal [Apple; Apple; Pear; Banana] (as_list l); assert_equal [Banana; Pear; Apple; Apple] (as_list (reverse l)); assert_equal [] (as_list None); end let test_enum_arrays _ = let module Array = CArray in let a = Array.make bears 4 in begin a.(0) <- `Edward; a.(1) <- `Winnie; a.(2) <- `Paddington; a.(3) <- `Edward; assert_equal [`Edward; `Winnie; `Paddington; `Edward] (Array.to_list a) end module Build_call_tests (F : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module F = Functions.Stubs(F) open F open M let test_passing_returning_enums _ = let open Types in begin assert_equal Apple (next_fruit Orange); assert_equal Banana (next_fruit Apple); assert_equal Pear (next_fruit Banana); assert_equal Orange (next_fruit Pear); end let test_signed_enums _ = begin assert_equal (-1) (classify_integer (-3)); assert_equal 1 (classify_integer 4); end let test_default_enums _ = begin assert_equal 0 (out_of_range ()) end end end module Enum_stubs_tests = Build_enum_stub_tests(Generated_struct_bindings) module Combined_stub_tests = Enum_stubs_tests.Build_call_tests(Generated_bindings) let suite = "Enum tests" >::: [ "passing and returning enums" >:: Combined_stub_tests.test_passing_returning_enums; "enums with signed values" >:: Combined_stub_tests.test_signed_enums; "enums with default values" >:: Combined_stub_tests.test_default_enums; "enums as struct members" >:: Enum_stubs_tests.test_enum_struct_members; "arrays of enums" >:: Enum_stubs_tests.test_enum_arrays; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-finalisers/000077500000000000000000000000001445631112600222205ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-finalisers/dune000066400000000000000000000000721445631112600230750ustar00rootroot00000000000000(test (name test_finalisers) (libraries ctypes ounit2)) yallop-ocaml-ctypes-3f8211a/tests/test-finalisers/test_finalisers.ml000066400000000000000000000040171445631112600257520ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes (* Simple finalisation test for arrays. *) let test_array_finaliser _ = let module Array = CArray in let finaliser_completed = ref false in let finalise a = begin assert_equal 10 (Array.length a); assert_equal [1;2;3;4;5;6;7;8;9;10] (Array.to_list a); finaliser_completed := true; end in let () = let p = let a = Array.make ~finalise int 10 in begin for i = 0 to 9 do a.(i) <- i + 1 done; Array.start a end in begin Gc.full_major (); assert_equal ~msg:"The finaliser was not run" false !finaliser_completed; assert_equal 1 !@p; end in begin Gc.full_major (); assert_equal ~msg:"The finaliser was run" true !finaliser_completed; end (* Simple finalisation test for structs. *) let test_struct_finaliser _ = let module M = struct type s let s : s structure typ = structure "s" let i = field s "i" int32_t let c = field s "c" char let () = seal s let finaliser_completed = ref false let finalise s = begin assert_equal 10l (getf s i); assert_equal 'e' (getf s c); finaliser_completed := true; end let () = let p = let s = make ~finalise s in begin setf s i 10l; setf s c 'e'; addr s end in begin Gc.full_major (); assert_equal ~msg:"The finaliser was not run" false !finaliser_completed; assert_equal 10l !@(from_voidp int32_t (to_voidp p)); end let () = begin Gc.full_major (); assert_equal ~msg:"The finaliser was run" true !finaliser_completed; end end in () let suite = "Finaliser tests" >::: ["array finalisation" >:: test_array_finaliser; "struct finalisation" >:: test_struct_finaliser; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-foreign-errno/000077500000000000000000000000001445631112600226355ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-foreign-errno/dune000066400000000000000000000001361445631112600235130ustar00rootroot00000000000000(test (name test_errno) (package ctypes-foreign) (libraries ounit2 ctypes ctypes-foreign)) yallop-ocaml-ctypes-3f8211a/tests/test-foreign-errno/test_errno.ml000066400000000000000000000041201445631112600253500ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes let us x = if Sys.os_type <> "Win32" then x else "_" ^ x (* Call close() with a bogus file descriptor and check that an exception is raised. *) let test_errno_exception_raised _ = let close = Foreign.foreign (us "close") ~check_errno:true (int @-> returning int) in assert_raises (Unix.Unix_error(Unix.EBADF, us "close", "")) (fun () -> close (-300)) (* Call chdir() with a valid directory path and check that zero is returned. *) let test_int_return_errno_exception_raised _ = let unlikely_to_exist = if Sys.os_type <> "Win32" then "/unlikely_to_exist" else "C:\\unlikely_to_exist" in let chdir = Foreign.foreign (us "chdir") ~check_errno:true (string @-> returning int) in assert_raises (Unix.Unix_error(Unix.ENOENT, us "chdir", "")) (fun () -> chdir unlikely_to_exist) (* Call chdir() with a valid directory path and check that zero is returned. *) let test_errno_no_exception_raised _ = let chdir = Foreign.foreign (us "chdir") ~check_errno:true (string @-> returning int) in assert_equal 0 (chdir (Sys.getcwd ())) let suite = "foreign+errno tests" >::: ["Exception from close" >:: test_errno_exception_raised; "Exception from chdir" >:: test_int_return_errno_exception_raised; "No exception from chdir" >:: test_errno_no_exception_raised; ] let _ = if Sys.os_type = "Win32" then (* Ugly workaround because oUnit raises an error, if there are any changes in the environment. There are two ways to access the environments on windows: - through the native Windows API. - through the crt lib. The crt uses the environment for interprocess communication, but hides it from the end user. Since OCaml 4.07 the native Windows API is used by Unix.environment, therefore the tricks of the crt lib are visible. *) Sys.chdir "."; (* udpate environment *) run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-foreign_values/000077500000000000000000000000001445631112600230715ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-foreign_values/dune000066400000000000000000000004311445631112600237450ustar00rootroot00000000000000(test (name test_foreign_values) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_foreign_values_stubs test_foreign_values_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-foreign_values/stub-generator/000077500000000000000000000000001445631112600260325ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-foreign_values/stub-generator/driver.ml000066400000000000000000000004751445631112600276650ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the foreign value tests. *) let cheader = "extern char **environ;" let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-foreign_values/stub-generator/dune000066400000000000000000000007441445631112600267150ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_foreign_values_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_foreign_values_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-foreign_values/stubs/000077500000000000000000000000001445631112600242315ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-foreign_values/stubs/dune000066400000000000000000000001401445631112600251020ustar00rootroot00000000000000(library (name test_foreign_values_stubs) (wrapped false) (libraries ctypes ctypes-foreign)) yallop-ocaml-ctypes-3f8211a/tests/test-foreign_values/stubs/functions.ml000066400000000000000000000017761445631112600266060ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Bindings for the foreign value tests. *) open Ctypes module Common (F: Ctypes.FOREIGN) = struct let s : [`global_struct] structure typ = structure "global_struct" let (-:) ty label = field s label ty let len = size_t -: "len" let str = array 1 char -: "str" let () = seal s let global_struct = F.foreign_value "global_struct" s let plus = F.(foreign_value "plus_callback" (Foreign.funptr_opt Ctypes.(int @-> int @-> returning int))) let sum = F.(foreign "sum_range_with_plus_callback" (int @-> int @-> returning int)) let string_array = F.(foreign_value "string_array" (array 2 string)) let int_array = F.(foreign_value "int_array" (bigarray array1 5 Bigarray_compat.int32)) end module Stubs (F: Ctypes.FOREIGN) = struct include Common(F) let environ = F.(foreign_value "environ" (ptr string_opt)) end yallop-ocaml-ctypes-3f8211a/tests/test-foreign_values/test_foreign_values.ml000066400000000000000000000062771445631112600275060ustar00rootroot00000000000000(* * Copyright (c) 2013-2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes let _ = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Common(S) open M (* Retrieve a struct exposed as a global value. *) let test_retrieving_struct _ = let p = CArray.start (getf !@global_struct str) in let stringp = from_voidp string (to_voidp (allocate (ptr char) p)) in begin let expected = "global string" in assert_equal expected !@stringp; assert_equal (Unsigned.Size_t.of_int (String.length expected)) (getf !@global_struct len) end (* Store a reference to an OCaml function as a global function pointer. *) let test_global_callback _ = begin assert_equal !@plus None; plus <-@ Some (+); assert_equal (sum 1 10) 55; plus <-@ None; end (* Access an array exposed as a global value *) let test_retrieving_array _ = let sarr = !@string_array in begin assert_equal "Hello" (CArray.get sarr 0); assert_equal "world" (CArray.get sarr 1); end; let iarr = !@int_array in begin let expected_ints = Bigarray_compat.(Array1.create int32 c_layout 5) in for i = 0 to 4 do Bigarray_compat.Array1.set expected_ints i (Int32.of_int i) done; assert_equal expected_ints iarr end end module Make_stub_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module N = Functions.Stubs(S) open N (* Read environment variables from the 'environ' global. *) let test_environ _ = let parse_entry s = match Str.(bounded_split (regexp "=") s 2), "" with [k; v], _ | [k], v -> (String.uppercase_ascii k, v) | _ -> Printf.ksprintf failwith "Parsing %S failed" s in let rec copy_environ acc env = match !@env with None -> acc | Some s -> copy_environ (parse_entry s :: acc) (env +@ 1) in begin let environment = copy_environ [] !@environ in assert_equal ~printer:(fun x -> x) (List.assoc "HOME" environment) (Sys.getenv "HOME") end end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = struct include Common_tests(Generated_bindings) include Make_stub_tests(Generated_bindings) end let suite = "Foreign value tests" >::: ["retrieving global struct (foreign)" >:: Foreign_tests.test_retrieving_struct; "global callback function (foreign)" >:: Foreign_tests.test_global_callback; "retrieving global array (foreign)" >:: Foreign_tests.test_retrieving_array; "retrieving global struct (stubs)" >:: Stub_tests.test_retrieving_struct; "retrieving global array (stubs)" >:: Stub_tests.test_retrieving_array; "global callback function (stubs)" >:: Stub_tests.test_global_callback; "reading from 'environ' (stubs)" >:: Stub_tests.test_environ; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-funptrs/000077500000000000000000000000001445631112600215625ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-funptrs/dune000066400000000000000000000003451445631112600224420ustar00rootroot00000000000000(test (name test_funptrs) (package ctypes-foreign) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes ctypes-foreign test_funptrs_stubs ctypes.stubs tests_common test_funptrs_bindings)) yallop-ocaml-ctypes-3f8211a/tests/test-funptrs/stub-generator/000077500000000000000000000000001445631112600245235ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-funptrs/stub-generator/driver.ml000066400000000000000000000004751445631112600263560ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the foreign value tests. *) let cheader = "extern char **environ;" let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-funptrs/stub-generator/dune000066400000000000000000000007511445631112600254040ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries test_funptrs_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_funptrs_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (flags :standard -w -11) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-funptrs/stubs/000077500000000000000000000000001445631112600227225ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-funptrs/stubs/dune000066400000000000000000000001311445631112600235730ustar00rootroot00000000000000(library (name test_funptrs_stubs) (wrapped false) (libraries ctypes ctypes-foreign)) yallop-ocaml-ctypes-3f8211a/tests/test-funptrs/stubs/functions.ml000066400000000000000000000021531445631112600252650ustar00rootroot00000000000000open Ctypes module Callback = (val Foreign.dynamic_funptr (int @-> returning int)) module Stubs (F: Ctypes.FOREIGN) = struct open F let call_dynamic_funptr = foreign "call_dynamic_funptr" (Callback.t @-> int @-> returning int) let save_dynamic_funptr = foreign "save_dynamic_funptr" (Callback.t @-> returning void) let call_saved_dynamic_funptr = foreign "call_saved_dynamic_funptr" (int @-> returning int) let call_dynamic_funptr_opt = foreign "call_dynamic_funptr" (Callback.t_opt @-> int @-> returning int) let save_dynamic_funptr_opt = foreign "save_dynamic_funptr" (Callback.t_opt @-> returning void) type simple_closure let simple_closure : simple_closure structure typ = structure "simple_closure" let simple_closure_f = field simple_closure "f" Callback.t let simple_closure_n = field simple_closure "n" int let () = seal simple_closure let call_dynamic_funptr_struct = foreign "call_dynamic_funptr_struct" (simple_closure @-> returning int) let call_dynamic_funptr_struct_ptr = foreign "call_dynamic_funptr_struct_ptr" (ptr simple_closure @-> returning int) end yallop-ocaml-ctypes-3f8211a/tests/test-funptrs/test_funptrs.ml000066400000000000000000000136341445631112600246630ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes let _ = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) (* Explicitly raise on leaked funptrs. *) let detect_funptr_leaks ?(expected_number_of_leaked_funptrs=0) f = let number_of_leaked_funptrs = ref 0 in Foreign.report_leaked_funptr := (fun _msg -> number_of_leaked_funptrs := !number_of_leaked_funptrs + 1); Gc.full_major (); Gc.full_major (); assert_equal 0 !number_of_leaked_funptrs; let res = f () in Gc.full_major (); Gc.full_major (); assert_equal expected_number_of_leaked_funptrs !number_of_leaked_funptrs; res ;; module Callback = Functions.Callback module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) let make_f () : (int -> int) * ([`Live|`Released] -> unit) = let closure_status = ref `Live in let f = !(ref (+)) 1 in Gc.finalise (fun _ -> closure_status := `Released) f; f, (fun status -> Gc.full_major (); Gc.full_major (); assert_equal status !closure_status) ;; let test_of_fun_and_free _ = detect_funptr_leaks (fun () -> let f, assert_closure = let f, assert_closure = make_f () in Callback.of_fun f, assert_closure in assert_closure `Live; assert_equal 3 (M.call_dynamic_funptr f 2); Callback.free f; assert_closure `Released) ;; let test_of_fun_and_leak _ = let assert_closure = detect_funptr_leaks ~expected_number_of_leaked_funptrs:1 (fun () -> let f, assert_closure = let f, assert_closure = make_f () in Callback.of_fun f, assert_closure in assert_closure `Live; assert_equal 3 (M.call_dynamic_funptr f 2); assert_closure) in assert_closure `Live ;; let test_with_fun _ = detect_funptr_leaks (fun () -> let assert_closure = let f, assert_closure = make_f () in assert_equal 3 (Callback.with_fun f (fun f -> M.call_dynamic_funptr f 2)); assert_closure in assert_closure `Released) ;; let test_opt_none _ = detect_funptr_leaks (fun () -> assert_equal 0 (M.call_dynamic_funptr_opt None 2)) ;; let test_opt_some _ = detect_funptr_leaks (fun () -> assert_equal 3 (Callback.with_fun ((+) 1) (fun f -> M.call_dynamic_funptr_opt (Some f) 2))) ;; let test_save_and_free _ = detect_funptr_leaks (fun () -> M.save_dynamic_funptr_opt (None); assert_equal 0 (M.call_saved_dynamic_funptr 2); let f, assert_closure = let f, assert_closure = make_f () in Callback.of_fun f, assert_closure in assert_closure `Live; M.save_dynamic_funptr_opt (Some f); assert_closure `Live; assert_equal 3 (M.call_saved_dynamic_funptr 2); assert_closure `Live; Callback.free f; assert_closure `Released; ); M.save_dynamic_funptr_opt (None) ;; let test_save_and_leak _ = let assert_closure = detect_funptr_leaks ~expected_number_of_leaked_funptrs:1 (fun () -> M.save_dynamic_funptr_opt (None); assert_equal 0 (M.call_saved_dynamic_funptr 2); let f, assert_closure = let f, assert_closure = make_f () in Callback.of_fun f, assert_closure in assert_closure `Live; M.save_dynamic_funptr_opt (Some f); assert_closure) in (* Technically this is undefined behaviour, but the library should handle this in the least surprising way possible (leaking but not crashing). *) assert_closure `Live; assert_equal 3 (M.call_saved_dynamic_funptr 2); M.save_dynamic_funptr_opt (None); assert_equal 0 (M.call_saved_dynamic_funptr 2); assert_closure `Live; ;; let test_struct _ = detect_funptr_leaks (fun () -> let t = make M.simple_closure in let f = Callback.of_fun ((+)1) in setf t M.simple_closure_f f; setf t M.simple_closure_n 2; assert_equal 3 (M.call_dynamic_funptr_struct t); Callback.free f ) let test_struct_ptr _ = detect_funptr_leaks (fun () -> let t = make M.simple_closure in let p = addr t in let f = Callback.of_fun ((+)1) in p |-> M.simple_closure_f <-@ f; p |-> M.simple_closure_n <-@ 2; assert_equal 3 (M.call_dynamic_funptr_struct_ptr p); Callback.free f ) end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Dynamic-Funptr tests" >::: ["test_of_fun_and_free (foreign)" >:: Foreign_tests.test_of_fun_and_free; "test_of_fun_and_free (stubs)" >:: Stub_tests.test_of_fun_and_free; "test_of_fun_and_leak (foreign)" >:: Foreign_tests.test_of_fun_and_leak; "test_of_fun_and_leak (stubs)" >:: Stub_tests.test_of_fun_and_leak; "test_with_fun (foreign)" >:: Foreign_tests.test_with_fun; "test_with_fun (stubs)" >:: Stub_tests.test_with_fun; "test_opt_none (foreign)" >:: Foreign_tests.test_opt_none; "test_opt_none (stubs)" >:: Stub_tests.test_opt_none; "test_opt_some (foreign)" >:: Foreign_tests.test_opt_some; "test_opt_some (stubs)" >:: Stub_tests.test_opt_some; "test_save_and_free (foreign)" >:: Foreign_tests.test_save_and_free; "test_save_and_free (stubs)" >:: Stub_tests.test_save_and_free; "test_save_and_leak (foreign)" >:: Foreign_tests.test_save_and_leak; "test_save_and_leak (stubs)" >:: Stub_tests.test_save_and_leak; "test_struct (foreign)" >:: Foreign_tests.test_struct; "test_struct (stubs)" >:: Stub_tests.test_struct; "test_struct_ptr (foreign)" >:: Foreign_tests.test_struct_ptr; "test_struct_ptr (stubs)" >:: Stub_tests.test_struct_ptr; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-higher_order/000077500000000000000000000000001445631112600225225ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-higher_order/dune000066400000000000000000000004231445631112600233770ustar00rootroot00000000000000(test (name test_higher_order) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_higher_order_stubs test_higher_order_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-higher_order/stub-generator/000077500000000000000000000000001445631112600254635ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-higher_order/stub-generator/driver.ml000066400000000000000000000004131445631112600273060ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the higher order tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-higher_order/stub-generator/dune000066400000000000000000000007401445631112600263420ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_higher_order_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_higher_order_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-higher_order/stubs/000077500000000000000000000000001445631112600236625ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-higher_order/stubs/dune000066400000000000000000000001361445631112600245400ustar00rootroot00000000000000(library (name test_higher_order_stubs) (wrapped false) (libraries ctypes ctypes-foreign)) yallop-ocaml-ctypes-3f8211a/tests/test-higher_order/stubs/functions.ml000066400000000000000000000031361445631112600262270ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the higher order tests. *) open Ctypes open Foreign module Stubs (F: Ctypes.FOREIGN) = struct open F let higher_order_1 = foreign "higher_order_1" (funptr Ctypes.(int @-> int @-> returning int) @-> int @-> int @-> returning int) let higher_order_1_static = foreign "higher_order_1" (static_funptr Ctypes.(int @-> int @-> returning int) @-> int @-> int @-> returning int) let higher_order_3 = foreign "higher_order_3" (funptr Ctypes.(funptr (int @-> int @-> returning int) @-> int @-> int @-> returning int) @-> funptr Ctypes.(int @-> int @-> returning int) @-> int @-> int @-> returning int) let callback_returns_char_a = foreign "callback_returns_char_a" (funptr Ctypes.(void @-> returning char) @-> returning int) let returning_funptr = foreign "returning_funptr" (int @-> returning (funptr Ctypes.(int @-> int @-> returning int))) let returning_funptr_static = foreign "returning_funptr" (int @-> returning (static_funptr Ctypes.(int @-> int @-> returning int))) let callback_returns_funptr = foreign "callback_returns_funptr" (funptr Ctypes.(int @-> returning (funptr (int @-> returning int))) @-> int @-> returning int) let register_callback = foreign "register_callback" (funptr Ctypes.(void @-> returning int) @-> returning void) let call_registered_callback = foreign "call_registered_callback" (int @-> int @-> returning void) end yallop-ocaml-ctypes-3f8211a/tests/test-higher_order/test_higher_order.ml000066400000000000000000000114051445631112600265550ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 let _ = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Call a C function of type int (int ( * )(int, int), int, int) passing various OCaml functions of type int -> int -> int as the first argument. *) let test_higher_order_basic _ = (* higher_order_1 f x y returns true iff f x y == x + y *) assert_equal 1 (higher_order_1 ( + ) 2 3); assert_equal 0 (higher_order_1 ( * ) 2 3); assert_equal 0 (higher_order_1 min 2 3); assert_equal 1 (higher_order_1 min (-3) 0) (* Call a C function of type int (int ( * )(int ( * )(int, int), int, int), int ( * )(int, int), int, int) passing OCaml functions of type (int -> int -> int) -> int -> int -> int int -> int -> int as the first and second arguments. *) let test_higher_higher_order _ = let acceptor op x y = op x (op x y) in assert_equal 10 (higher_order_3 acceptor ( + ) 3 4); assert_equal 36 (higher_order_3 acceptor ( * ) 3 4) (* Call a C function of type int (char( * )(void)) and check that the char returned by the function pointer is handled correctly *) let test_function_pointer_returning_char _ = assert_equal 1 (callback_returns_char_a (fun () -> 'a')) (* Call a C function of type int ( *(int))(int) (i.e. a function that returns a pointer-to-function) and ensure that we can call the returned function from OCaml. *) let test_returning_pointer_to_function _ = let add = returning_funptr 0 in let times = returning_funptr 1 in assert_equal 22 (add 10 12); assert_equal 15 (times 3 5); assert_equal 101 (add 100 1); assert_equal 0 (times 0 12) (* Call a C function of type int (int ( * ( * )(int))(int), int) (i.e. a function whose first argument is a pointer-to-function returning a pointer-to-function.) *) let test_callback_returns_pointer_to_function _ = let callback = function | 0 -> ( + ) 10 | 1 -> ( * ) 13 | _ -> invalid_arg "callback" in assert_equal 280 (callback_returns_funptr callback 0) (* Call an OCaml function through a C function pointer of type void ( * )(void) *) let test_zero_argument_callbacks _ = let counter = ref 0 in let callback () = let c = !counter in incr counter; c in let () = register_callback callback in begin assert_equal !counter 0; call_registered_callback 5 !counter; assert_equal !counter 5; call_registered_callback 3 !counter; assert_equal !counter 8; end (* Retrieve a function pointer from C and pass it back to C using static_funptr. *) let test_static_funptr _ = let add = returning_funptr_static 0 and mul = returning_funptr_static 1 in begin assert_equal 1 (higher_order_1_static add 2 3); assert_equal 0 (higher_order_1_static mul 2 3); end end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Higher-order tests" >::: ["test_higher_order_basic (foreign)" >:: Foreign_tests.test_higher_order_basic; "test_higher_order_basic (stubs)" >:: Stub_tests.test_higher_order_basic; "test_higher_higher_order (foreign)" >:: Foreign_tests.test_higher_higher_order; "test_higher_higher_order (stubs)" >:: Stub_tests.test_higher_higher_order; "test_function_pointer_returning_char (stubs)" >:: Stub_tests.test_function_pointer_returning_char; "test_function_pointer_returning_char (foreign)" >:: Foreign_tests.test_function_pointer_returning_char; "test_returning_pointer_to_function (foreign)" >:: Foreign_tests.test_returning_pointer_to_function; "test_returning_pointer_to_function (stubs)" >:: Stub_tests.test_returning_pointer_to_function; "test_callback_returns_pointer_to_function (foreign)" >:: Foreign_tests.test_callback_returns_pointer_to_function; "test_callback_returns_pointer_to_function (stubs)" >:: Stub_tests.test_callback_returns_pointer_to_function; "test_zero_argument_callbacks (foreign)" >:: Foreign_tests.test_zero_argument_callbacks; "test_zero_argument_callbacks (stubs)" >:: Stub_tests.test_zero_argument_callbacks; "test_static_funptr (foreign)" >:: Foreign_tests.test_static_funptr; "test_static_funptr (stubs)" >:: Stub_tests.test_static_funptr; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-integers/000077500000000000000000000000001445631112600217015ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-integers/dune000066400000000000000000000004071445631112600225600ustar00rootroot00000000000000(test (name test_integers) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_integers_stubs test_integers_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-integers/stub-generator/000077500000000000000000000000001445631112600246425ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-integers/stub-generator/driver.ml000066400000000000000000000004061445631112600264670ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the integer tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-integers/stub-generator/dune000066400000000000000000000007301445631112600255200ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_integers_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_integers_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-integers/stubs/000077500000000000000000000000001445631112600230415ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-integers/stubs/dune000066400000000000000000000001131445631112600237120ustar00rootroot00000000000000(library (name test_integers_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-integers/stubs/functions.ml000066400000000000000000000005371445631112600254100ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the integer tests. *) open Ctypes module Stubs (F: Ctypes.FOREIGN) = struct open F let max_caml_int = foreign "max_caml_int" (void @-> returning camlint) end yallop-ocaml-ctypes-3f8211a/tests/test-integers/test_integers.ml000066400000000000000000000025241445631112600251150ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes open Unsigned let _ = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Test retrieving max caml ints from C. *) let test_max_caml_int _ = assert_equal max_int (max_caml_int ()) ~printer:string_of_int end (* Test UInt64.of_int. *) let test_uint64_of_int _ = begin assert_equal max_int (UInt64.to_int (UInt64.of_int max_int)) ~printer:string_of_int end (* Test storing and reading camlints. *) let test_store_caml_int _ = begin let p = allocate camlint max_int in assert_equal max_int !@p ~printer:string_of_int end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Integer tests" >::: ["UInt64.of_int" >:: test_uint64_of_int; "max_caml_int (foreign)" >:: Foreign_tests.test_max_caml_int; "max_caml_int (stubs)" >:: Stub_tests.test_max_caml_int; "storing camlint" >:: test_store_caml_int; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-ldouble/000077500000000000000000000000001445631112600215075ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-ldouble/dune000066400000000000000000000000671445631112600223700ustar00rootroot00000000000000(test (name test_ldouble) (libraries ctypes ounit2)) yallop-ocaml-ctypes-3f8211a/tests/test-ldouble/test_ldouble.ml000066400000000000000000000232141445631112600245300ustar00rootroot00000000000000(* * Copyright (c) 2016 Andy Ray. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 let flts = [ 1.1234; -94.1239823897423; 0.000000000000012; 0.12130981239081238973249872349871346123873264876324; -3.92 ] let op1 f a = LDouble.(to_float (f (of_float a))) let op2 f a b = LDouble.(to_float (f (of_float a) (of_float b))) let chk_float x y = match classify_float x, classify_float y with | FP_normal, FP_normal | FP_subnormal, FP_subnormal | FP_zero, FP_normal | FP_zero, FP_subnormal | FP_normal, FP_zero | FP_subnormal, FP_zero -> abs_float (x -. y) < 1e-12 | x, y when x=y -> true (* infinite, zero, nan *) | _ -> false let chk1 fop lop a = let x = fop a in let y = op1 lop a in chk_float x y let chk2 fop lop a b = let x = fop a b in let y = op2 lop a b in chk_float x y let test_op2 _ = let assert_chk2 n f l = List.iter (fun a -> List.iter (fun b -> assert_bool n @@ chk2 f l a b) flts) flts in assert_chk2 "add" (+.) LDouble.add; assert_chk2 "sub" (-.) LDouble.sub; assert_chk2 "mul" ( *. ) LDouble.mul; assert_chk2 "div" ( /. ) LDouble.div; assert_chk2 "pow" ( ** ) LDouble.pow; assert_chk2 "atan2" atan2 LDouble.atan2; assert_chk2 "hypot" hypot LDouble.hypot; (*assert_chk2 "rem" ??? LDouble.rem;*) assert_chk2 "copysign" copysign LDouble.copysign let test_op1 _ = let assert_chk1 n f l = List.iter (fun a -> assert_bool n @@ chk1 f l a) flts in assert_chk1 "neg" (fun x -> -. x) LDouble.neg; assert_chk1 "sqrt" sqrt LDouble.sqrt; assert_chk1 "exp" exp LDouble.exp; assert_chk1 "log" log LDouble.log; assert_chk1 "log10" log10 LDouble.log10; assert_chk1 "expm1" expm1 LDouble.expm1; assert_chk1 "log1p" log1p LDouble.log1p; assert_chk1 "cos" cos LDouble.cos; assert_chk1 "sin" sin LDouble.sin; assert_chk1 "tan" tan LDouble.tan; assert_chk1 "acos" acos LDouble.acos; assert_chk1 "asin" asin LDouble.asin; assert_chk1 "atan" atan LDouble.atan; assert_chk1 "cosh" cosh LDouble.cosh; assert_chk1 "sinh" sinh LDouble.sinh; assert_chk1 "tanh" tanh LDouble.tanh; (*assert_chk1 "acosh" acosh LDouble.acosh; assert_chk1 "asinh" asinh LDouble.asinh; assert_chk1 "atanh" atanh LDouble.atanh;*) assert_chk1 "ceil" ceil LDouble.ceil; assert_chk1 "floor" floor LDouble.floor let test_opw _ = let chk_frexp a = let x, i = frexp a in let y, j = LDouble.(frexp (of_float a)) in let y = LDouble.to_float y in assert_bool "frexp" (chk_float x y && i=j) in let chk_modf a = let w,x = modf a in let y,z = LDouble.(modf (of_float a)) in let y,z = LDouble.(to_float y, to_float z) in assert_bool "modf" (chk_float w y && chk_float x z) in let chk_ldexp a b = let x = ldexp a b in let y = LDouble.(to_float (ldexp (of_float a) b)) in assert_bool "ldexp" (chk_float x y) in List.iter chk_frexp flts; (* XXX work around bug. see comment for LDouble.modf *) (if not Sys.win32 then List.iter chk_modf flts); List.iter (fun a -> List.iter (fun b -> chk_ldexp a b) [2;5;8]) flts let test_classify _ = assert_bool "min" LDouble.(classify min_float = FP_normal); assert_bool "max" LDouble.(classify max_float = FP_normal); assert_bool "epsilon" LDouble.(classify max_float = FP_normal); assert_bool "nan" LDouble.(classify nan = FP_nan); assert_bool "inf" LDouble.(classify infinity = FP_infinite); assert_bool "-inf" LDouble.(classify neg_infinity = FP_infinite) let test_conv _ = List.iter (fun a -> assert_bool "to/of_float" (a = LDouble.(to_float (of_float a)))) flts; assert_bool "to_int" (3 = LDouble.(to_int (of_float 3.45))); assert_bool "to_int" (-34 = LDouble.(to_int (of_float (-34.999)))); assert_bool "mant_dig" (LDouble.mant_dig >= 53); if Sys.word_size = 32 then ( let max = float_of_int max_int in let min = float_of_int min_int in assert_bool "to_int" (max_int = LDouble.(to_int (of_float max))); assert_bool "to_int" (min_int = LDouble.(to_int (of_float min))); assert_bool "to_int_max" (max_int = LDouble.(to_int (of_int max_int))); assert_bool "to_int_min" (min_int = LDouble.(to_int (of_int min_int))); ) else ( let max = 9007199254740991. in (* 2^53 - 1. Largest integer that fits into the mantissa of a double *) let min = -9007199254740991. in assert_bool "to_int" (Int64.to_int (-9007199254740991L) = LDouble.(to_int (of_float min))); assert_bool "to_int" (Int64.to_int 9007199254740991L = LDouble.(to_int (of_float max))); let max,min = if LDouble.mant_dig >= 62 then max_int,(-max_int) else let rec iter ac i = if i = 0 then ac else iter (ac * 2) (pred i) in let max = (iter 1 LDouble.mant_dig) - 1 in max,(max * (-1)) in assert_bool "to_int_max" (max = LDouble.(to_int (of_int max))); assert_bool "to_int_min" (min = LDouble.(to_int (of_int min))); ); assert_bool "of_string" (3.5 = LDouble.(to_float (of_string "3.5"))); assert_bool "to_string" ("3.500000" = LDouble.(to_string (of_float 3.5))) let test_complex _ = let module C = Complex in let cplx = [ { C.re = 2.9; im = 4.26 }; { C.re = 0.32; im = -7.6 }; { C.re = -35.1; im = 12.3 }; { C.re = -0.002; im = -9.1 }; ] in let chk_complex ?(prec=1e-12) x y = C.norm (C.sub x y) < prec in let assert_chk2 ?prec name opc opl = List.iter (fun a -> List.iter (fun b -> let open ComplexL in assert_bool name (chk_complex ?prec (opc a b) (to_complex (opl (of_complex a) (of_complex b)))) ) cplx) cplx in let assert_chk1 ?prec name opc opl = List.iter (fun a -> let open ComplexL in assert_bool name (chk_complex ?prec (opc a) (to_complex (opl (of_complex a)))) ) cplx in let assert_chkf name opc opl = List.iter (fun a -> let open ComplexL in assert_bool name (chk_float (opc a) (LDouble.to_float (opl (of_complex a)))) ) cplx in let assert_polar () = let open ComplexL in assert_bool "polar" (chk_complex (C.polar 3.4 1.2) (to_complex (polar (LDouble.of_float 3.4) (LDouble.of_float 1.2)))) in assert_chk2 "add" C.add ComplexL.add; assert_chk2 "sub" C.sub ComplexL.sub; assert_chk2 "mul" C.mul ComplexL.mul; assert_chk2 "div" C.div ComplexL.div; (* fairly large errors accrue here, so reduce precision *) assert_chk2 "pow" ~prec:1e-3 C.pow ComplexL.pow; assert_chk1 "neg" C.neg ComplexL.neg; assert_chk1 "conj" C.conj ComplexL.conj; assert_chk1 "inv" C.inv ComplexL.inv; assert_chk1 "sqrt" C.sqrt ComplexL.sqrt; assert_chk1 "exp" C.exp ComplexL.exp; assert_chk1 "log" C.log ComplexL.log; assert_chkf "norm2" C.norm2 ComplexL.norm2; assert_chkf "norm" C.norm ComplexL.norm; assert_chkf "arg" C.arg ComplexL.arg; assert_polar () let test_marshal _ = let same_repr x y = let open Obj in let x = magic x in let y = magic y in is_block x && is_block y && size x = size y && tag x = tag y in let assert_ldouble x = let (_,xc,_) as x = "foo", LDouble.of_float x, 1 in let s = Marshal.to_string x [] in let ((_,yc,_) : string * LDouble.t * int) as y = Marshal.from_string s 0 in assert_bool "marshal ldouble" (x=y); assert_bool "marshal ldouble repr" (same_repr xc yc) in let assert_complex x = let (_,xc,_) as x = "f00", ComplexL.of_complex x, 1 in let s = Marshal.to_string x [] in let ((_,yc,_) : string * ComplexL.t * int) as y = Marshal.from_string s 0 in assert_bool "marshal ldouble complex" (x=y); assert_bool "marshal ldouble complex repr" (same_repr xc yc) in assert_ldouble 23.11234; assert_ldouble (-23.9345); assert_complex { Complex.re = 11.23; im = -46.7764 }; assert_complex { Complex.re = 0.00037; im = 881.222314 } let test_comparisons _ = let open LDouble in begin (* < *) assert_equal false (neg_infinity < nan); assert_equal false (nan < neg_infinity); assert_equal false (infinity < nan); assert_equal false (nan < infinity); assert_equal false (of_float 1.0 < nan); assert_equal false (nan < of_float 1.0); assert_equal false (of_float (-1.0) < nan); assert_equal false (nan < of_float (-1.0)); end; begin (* = *) assert_equal false (nan = nan); assert_equal false (of_float 1.0 = nan); assert_equal false (infinity = nan); end; begin (* compare *) assert_equal 0 (compare nan nan); assert_equal 1 (compare (of_float 1.0) nan); assert_equal 1 (compare infinity nan); assert_equal 1 (compare neg_infinity nan); assert_equal 0 (compare nan nan); assert_equal (-1) (compare nan (of_float 1.0)); assert_equal (-1) (compare nan infinity); assert_equal (-1) (compare nan neg_infinity); end; begin (* ComplexL compare *) let b re im = ComplexL.of_complex {Complex.re = re; im} in assert_equal false (b 2.0 3.9 = b 2.0 3.7); assert_equal false (b 3.9 2.0 = b 2.1 2.0); assert_equal true (b 0.0 1.0 = b 0.0 1.0) end let test_int_conversions _ = begin let max_ok = 1 lsr 53 in let min_ok = -max_ok in assert_equal max_ok (LDouble.to_int (LDouble.of_int max_ok)) ~printer:string_of_int; assert_equal min_ok (LDouble.to_int (LDouble.of_int min_ok)) ~printer:string_of_int; end let suite = "LDouble tests" >::: [ "test functions with 2 args" >:: test_op2; "test functions with 1 args" >:: test_op1; "test functions with weird args" >:: test_opw; "test classify" >:: test_classify; "test conversion" >:: test_conv; "test complex api" >:: test_complex; "test marshal" >:: test_marshal; "test comparisons" >:: test_comparisons; "test int conversions" >:: test_int_conversions; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-lifetime/000077500000000000000000000000001445631112600216575ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-lifetime/dune000066400000000000000000000004071445631112600225360ustar00rootroot00000000000000(test (name test_lifetime) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_lifetime_stubs test_lifetime_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-lifetime/stub-generator/000077500000000000000000000000001445631112600246205ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-lifetime/stub-generator/driver.ml000066400000000000000000000004461445631112600264510ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the lifetime tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) ~concurrency:Cstubs.unlocked yallop-ocaml-ctypes-3f8211a/tests/test-lifetime/stub-generator/dune000066400000000000000000000007301445631112600254760ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_lifetime_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_lifetime_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-lifetime/stubs/000077500000000000000000000000001445631112600230175ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-lifetime/stubs/dune000066400000000000000000000001321445631112600236710ustar00rootroot00000000000000(library (name test_lifetime_stubs) (wrapped false) (libraries ctypes ctypes-foreign)) yallop-ocaml-ctypes-3f8211a/tests/test-lifetime/stubs/functions.ml000066400000000000000000000005471445631112600253670ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the lifetime tests. *) open Ctypes module Stubs (F: Ctypes.FOREIGN) = struct open F let check_ones = foreign "check_ones" (ptr int @-> size_t @-> returning void) end yallop-ocaml-ctypes-3f8211a/tests/test-lifetime/test_lifetime.ml000066400000000000000000000030621445631112600250470ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@warning "-35"] open OUnit2 open Ctypes let _ = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M let test_object_lifetime _ = let iters = 20000 in let l = [(); (); (); (); (); (); (); (); (); ()] in let alloc = (fun () -> for i = 0 to iters do for i = 0 to 200; do ignore (Array.make 10 ()) done; ignore (Array.make 1000 ()); if i mod 1000 = 0 then (Gc.compact ()); done) in let allocators = List.map (Thread.create alloc) l in let size = 100 in let mutate () = for i = 0 to iters do check_ones (CArray.start (CArray.make int ~initial:1 size)) (Unsigned.Size_t.of_int size); for i = 0 to 200; do ignore (Array.make 10 ()) done; done in let mutators = List.map (Thread.create mutate) l in List.iter Thread.join allocators; List.iter Thread.join mutators end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Lifetime tests" >::: ["objects persist throughout C calls (foreign)" >:: Foreign_tests.test_object_lifetime; "objects persist throughout C calls (stubs)" >:: Stub_tests.test_object_lifetime; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-lwt-jobs/000077500000000000000000000000001445631112600216225ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-lwt-jobs/dune000066400000000000000000000023611445631112600225020ustar00rootroot00000000000000(rule (targets generated_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) (rule (targets generated_struct_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) (rule (targets ml-stub-generator.exe) (deps generated_struct_stubs.c ../clib/test_functions.h ../config/test-cflags) (action (run %{cc} %{read-lines:../config/test-cflags} -I ../clib -I %{ocaml-config:standard_library} -o %{targets} generated_struct_stubs.c))) (rule (targets generated_struct_bindings.ml) (deps ml-stub-generator.exe) (action (with-stdout-to %{targets} (run %{deps})))) (library (name test_lwt_jobs_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings generated_struct_bindings) (libraries ctypes test_functions lwt.unix)) (test (name test_lwt_jobs) (package ctypes-foreign) (modules test_lwt_jobs) (action (run %{test} -runner sequential)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_lwt_jobs_stubs test_functions test_lwt_jobs_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-lwt-jobs/stub-generator/000077500000000000000000000000001445631112600245635ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-lwt-jobs/stub-generator/driver.ml000066400000000000000000000006771445631112600264220ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the Lwt jobs tests. *) let cheader = "#include #include #include #include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) ~structs:(module Types.Struct_stubs) ~concurrency:Cstubs.lwt_jobs yallop-ocaml-ctypes-3f8211a/tests/test-lwt-jobs/stub-generator/dune000066400000000000000000000001431445631112600254370ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_lwt_jobs_stubs tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-lwt-jobs/stubs/000077500000000000000000000000001445631112600227625ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-lwt-jobs/stubs/dune000066400000000000000000000001131445631112600236330ustar00rootroot00000000000000(library (name test_lwt_jobs_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-lwt-jobs/stubs/functions.ml000066400000000000000000000014751445631112600253330ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the Lwt jobs tests. *) open Ctypes module Stubs (F: Ctypes.FOREIGN) = struct open F let sqrt = foreign "sqrt" (double @-> returning double) let sum_int_array = foreign "sum_int_array" (ptr int32_t @-> size_t @-> returning int32_t) let struct_stat : [`stat] structure typ = structure "stat" let stat = foreign "stat" (string @-> ptr struct_stat @-> returning int) let sixargs = foreign "sixargs" (int @-> int @-> int @-> int @-> int @-> int @-> returning int) let return_10 = foreign "return_10" (void @-> returning int) let return_void = foreign "return_void" (ptr int @-> returning void) end yallop-ocaml-ctypes-3f8211a/tests/test-lwt-jobs/stubs/types.ml000066400000000000000000000007261445631112600244650ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open PosixTypes module Struct_stubs(S : Ctypes.TYPE) = struct open S let ifdir = constant "S_IFDIR" (lift_typ mode_t) let ifmt = constant "S_IFMT" (lift_typ mode_t) let stat : [`stat] structure typ = structure "stat" let st_mode = field stat "st_mode" (lift_typ mode_t) let () = seal stat end yallop-ocaml-ctypes-3f8211a/tests/test-lwt-jobs/test_lwt_jobs.ml000066400000000000000000000052501445631112600250400ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes module Structures = Types.Struct_stubs(Generated_struct_bindings) module Bindings = Functions.Stubs(Generated_bindings) (* Test the Lwt binding to "sqrt". *) let test_sqrt _ = Lwt_main.run Lwt.((Bindings.sqrt 9.0).Generated_bindings.lwt >>= fun x -> return (assert (x = 3.0))) (* Test that objects remain alive during the Lwt job call. *) let test_object_lifetime _ = let call = let open Bigarray_compat in let b = Array1.create int32 c_layout 3 in begin b.{0} <- 1l; b.{1} <- 2l; b.{2} <- 3l; end; (Bindings.sum_int_array (bigarray_start array1 b) (Unsigned.Size_t.of_int 3)).Generated_bindings.lwt in begin Gc.compact (); Gc.compact (); Lwt_main.run (Lwt.(call >>= fun n -> assert_equal 6l n ~printer:Int32.to_string; return ())) end (* Test that strings remain alive during the Lwt job call. *) let test_string_lifetime _ = let s = make Structures.stat in let call = (Bindings.stat (Bytes.to_string (Bytes.of_string ".")) (addr s)).Generated_bindings.lwt in begin Gc.compact (); Gc.compact (); Lwt_main.run (Lwt.(call >>= fun i -> assert_equal 0 i; assert_equal Structures.ifdir (PosixTypes.Mode.logand Structures.ifmt (getf s Structures.st_mode)); return ())) end (* Test calling functions with many arguments. *) let test_six_args _ = let open Lwt.Infix in Lwt_main.run ((Bindings.sixargs 1 2 3 4 5 6).Generated_bindings.lwt >>= fun i -> assert_equal (1 + 2 + 3 + 4 + 5 + 6) i; Lwt.return ()) (* Test calling functions with no arguments. *) let test_no_args _ = let open Lwt.Infix in Lwt_main.run ((Bindings.return_10 ()).Generated_bindings.lwt >>= fun i -> assert_equal 10 i; Lwt.return ()) (* Test calling functions that return void. *) let test_return_void _ = let open Lwt.Infix in Lwt_main.run (let x_p = allocate_n ~count:1 int in (Bindings.return_void x_p).Generated_bindings.lwt >>= fun () -> assert_equal 10 (!@ x_p); Lwt.return ()) let suite = "Lwt job tests" >::: ["calling sqrt" >:: test_sqrt; "object lifetime" >:: test_object_lifetime; "string lifetime" >:: test_string_lifetime; "functions with many arguments" >:: test_six_args; "functions with no arguments" >:: test_no_args; "functions that return void" >:: test_return_void; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-lwt-preemptive/000077500000000000000000000000001445631112600230455ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-lwt-preemptive/dune000066400000000000000000000024031445631112600237220ustar00rootroot00000000000000(rule (targets generated_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) (rule (targets generated_struct_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) (rule (targets ml-stub-generator.exe) (deps generated_struct_stubs.c ../clib/test_functions.h ../config/test-cflags) (action (run %{cc} %{read-lines:../config/test-cflags} -I ../clib -I %{ocaml-config:standard_library} -o %{targets} generated_struct_stubs.c))) (rule (targets generated_struct_bindings.ml) (deps ml-stub-generator.exe) (action (with-stdout-to %{targets} (run %{deps})))) (library (name test_lwt_preemptive_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings generated_struct_bindings) (libraries ctypes test_functions lwt.unix)) (test (name test_lwt_jobs) (modules test_lwt_jobs) (package ctypes-foreign) (action (run %{test} -runner sequential)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_lwt_preemptive_stubs test_functions test_lwt_preemptive_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-lwt-preemptive/stub-generator/000077500000000000000000000000001445631112600260065ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-lwt-preemptive/stub-generator/driver.ml000066400000000000000000000007131445631112600276340ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the Lwt preemptive tests. *) let cheader = "#include #include #include #include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) ~structs:(module Types.Struct_stubs) ~concurrency:Cstubs.lwt_preemptive yallop-ocaml-ctypes-3f8211a/tests/test-lwt-preemptive/stub-generator/dune000066400000000000000000000001511445631112600266610ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_lwt_preemptive_stubs tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-lwt-preemptive/stubs/000077500000000000000000000000001445631112600242055ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-lwt-preemptive/stubs/dune000066400000000000000000000001211445631112600250550ustar00rootroot00000000000000(library (name test_lwt_preemptive_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-lwt-preemptive/stubs/functions.ml000066400000000000000000000015031445631112600265460ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the Lwt preemptive tests. *) open Ctypes module Stubs (F: Ctypes.FOREIGN) = struct open F let sqrt = foreign "sqrt" (double @-> returning double) let sum_int_array = foreign "sum_int_array" (ptr int32_t @-> size_t @-> returning int32_t) let struct_stat : [`stat] structure typ = structure "stat" let stat = foreign "stat" (string @-> ptr struct_stat @-> returning int) let sixargs = foreign "sixargs" (int @-> int @-> int @-> int @-> int @-> int @-> returning int) let return_10 = foreign "return_10" (void @-> returning int) let return_void = foreign "return_void" (ptr int @-> returning void) end yallop-ocaml-ctypes-3f8211a/tests/test-lwt-preemptive/stubs/types.ml000066400000000000000000000007261445631112600257100ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open PosixTypes module Struct_stubs(S : Ctypes.TYPE) = struct open S let ifdir = constant "S_IFDIR" (lift_typ mode_t) let ifmt = constant "S_IFMT" (lift_typ mode_t) let stat : [`stat] structure typ = structure "stat" let st_mode = field stat "st_mode" (lift_typ mode_t) let () = seal stat end yallop-ocaml-ctypes-3f8211a/tests/test-lwt-preemptive/test_lwt_jobs.ml000066400000000000000000000052511445631112600262640ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes module Structures = Types.Struct_stubs(Generated_struct_bindings) module Bindings = Functions.Stubs(Generated_bindings) (* Test the Lwt binding to "sqrt". *) let test_sqrt _ = Lwt_main.run Lwt.((Bindings.sqrt 9.0).Generated_bindings.lwt >>= fun x -> return (assert (x = 3.0))) (* Test that objects remain alive during the Lwt job call. *) let test_object_lifetime _ = let call = let open Bigarray_compat in let b = Array1.create int32 c_layout 3 in begin b.{0} <- 1l; b.{1} <- 2l; b.{2} <- 3l; end; (Bindings.sum_int_array (bigarray_start array1 b) (Unsigned.Size_t.of_int 3)).Generated_bindings.lwt in begin Gc.compact (); Gc.compact (); Lwt_main.run (Lwt.(call >>= fun n -> assert_equal 6l n ~printer:Int32.to_string; return ())) end (* Test that strings remain alive during the Lwt job call. *) let test_string_lifetime _ = let s = make Structures.stat in let call = (Bindings.stat (Bytes.to_string (Bytes.of_string ".")) (addr s)).Generated_bindings.lwt in begin Gc.compact (); Gc.compact (); Lwt_main.run (Lwt.(call >>= fun i -> assert_equal 0 i; assert_equal Structures.ifdir (PosixTypes.Mode.logand Structures.ifmt (getf s Structures.st_mode)); return ())) end (* Test calling functions with many arguments. *) let test_six_args _ = let open Lwt.Infix in Lwt_main.run ((Bindings.sixargs 1 2 3 4 5 6).Generated_bindings.lwt >>= fun i -> assert_equal (1 + 2 + 3 + 4 + 5 + 6) i; Lwt.return ()) (* Test calling functions with no arguments. *) let test_no_args _ = let open Lwt.Infix in Lwt_main.run ((Bindings.return_10 ()).Generated_bindings.lwt >>= fun i -> assert_equal 10 i; Lwt.return ()) (* Test calling functions that return void. *) let test_return_void _ = let open Lwt.Infix in Lwt_main.run (let x_p = allocate_n ~count:1 int in (Bindings.return_void x_p).Generated_bindings.lwt >>= fun () -> assert_equal 10 (!@ x_p); Lwt.return ()) let suite = "Lwt job tests" >::: ["calling sqrt" >:: test_sqrt; "object lifetime" >:: test_object_lifetime; "string lifetime" >:: test_string_lifetime; "functions with many arguments" >:: test_six_args; "functions with no arguments" >:: test_no_args; "functions that return void" >:: test_return_void; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-macros/000077500000000000000000000000001445631112600213455ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-macros/dune000066400000000000000000000002561445631112600222260ustar00rootroot00000000000000(test (name test_macros) (package ctypes-foreign) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_macros_stubs test_macros_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-macros/stub-generator/000077500000000000000000000000001445631112600243065ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-macros/stub-generator/driver.ml000066400000000000000000000004641445631112600261370ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the macro tests. *) let cheader = " #include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-macros/stub-generator/dune000066400000000000000000000007241445631112600251670ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_macros_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_macros_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-macros/stubs/000077500000000000000000000000001445631112600225055ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-macros/stubs/dune000066400000000000000000000001111445631112600233540ustar00rootroot00000000000000(library (name test_macros_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-macros/stubs/functions.ml000066400000000000000000000006141445631112600250500ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the macro tests. *) open Ctypes module Stubs (F: Ctypes.FOREIGN) = struct open F let exp_double = foreign "exp" (double @-> returning double) let exp_float = foreign "exp" (float @-> returning float) end yallop-ocaml-ctypes-3f8211a/tests/test-macros/test_macros.ml000066400000000000000000000011731445631112600242240ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 module Bindings = Functions.Stubs(Generated_bindings) (* Test calling type-generic macros. *) let test_tg_macros _ = let open Bindings in assert_bool "calling double version of type-generic exp" (exp_double 1.0 = exp 1.0); assert_bool "calling float version of type-generic exp" (abs_float (exp_float 1.0 -. exp 1.0) <= 0.001) let suite = "Macro tests" >::: ["Calling type-generic macros" >:: test_tg_macros; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-marshal/000077500000000000000000000000001445631112600215105ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-marshal/dune000066400000000000000000000000671445631112600223710ustar00rootroot00000000000000(test (name test_marshal) (libraries ctypes ounit2)) yallop-ocaml-ctypes-3f8211a/tests/test-marshal/test_marshal.ml000066400000000000000000000013701445631112600245310ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Unsigned (* Test marshalling and unmarshalling custom integers *) let test_integer_marshalling _ = let v = ( UInt8.zero, UInt16.zero, UInt32.zero, UInt64.zero, UInt8.one, UInt16.one, UInt32.one, UInt64.one, UInt8.of_string "100", UInt16.of_string "1000", UInt32.of_string "10000", UInt64.of_string "100000", UInt8.max_int, UInt16.max_int, UInt32.max_int, UInt64.max_int ) in assert_equal v Marshal.(from_string (to_string v []) 0) let suite = "Marshal tests" >::: ["integer marshalling" >:: test_integer_marshalling; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-oo_style/000077500000000000000000000000001445631112600217165ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-oo_style/dune000066400000000000000000000004071445631112600225750ustar00rootroot00000000000000(test (name test_oo_style) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_oo_style_stubs test_oo_style_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-oo_style/stub-generator/000077500000000000000000000000001445631112600246575ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-oo_style/stub-generator/driver.ml000066400000000000000000000004071445631112600265050ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the OO-style tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-oo_style/stub-generator/dune000066400000000000000000000007301445631112600255350ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_oo_style_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_oo_style_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-oo_style/stubs/000077500000000000000000000000001445631112600230565ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-oo_style/stubs/dune000066400000000000000000000001321445631112600237300ustar00rootroot00000000000000(library (name test_oo_style_stubs) (wrapped false) (libraries ctypes ctypes-foreign)) yallop-ocaml-ctypes-3f8211a/tests/test-oo_style/stubs/functions.ml000066400000000000000000000051651445631112600254270ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the OO-style tests. *) open Ctypes module Stubs (F: Ctypes.FOREIGN) = struct open F let cast base p = from_voidp base (to_voidp p) (* We'll build part of the hierarchy in C and part in OCaml. animal ^ ^ | | chorse camel *) (** Create the base class and its method table **) type animal and animal_methods let animal_methods : animal_methods structure typ = structure "animal methods" and animal : animal structure typ = structure "animal" (* class layout (vtable pointer, no instance variables) *) let animal_vtable = field animal "animal_vtable" (ptr animal_methods) let () = seal animal (* method table layout (two virtual methods) *) let (-:) ty label = field animal_methods label ty let say = Foreign.funptr Ctypes.(ptr animal @-> returning string) -: "say" let identify = Foreign.funptr Ctypes.(ptr animal @-> returning string) -: "identify" let () = seal animal_methods let call_say cinstance = !@((getf (!@cinstance) animal_vtable) |-> say) cinstance let call_identify cinstance = !@((getf (!@cinstance) animal_vtable) |-> identify) cinstance (* constructor *) class animalc ~cinstance = object method say : string = call_say cinstance method identify : string = call_identify cinstance method cinstance = cinstance end (** Create a sub class and its method table **) type camel and camel_methods let camel_methods : camel_methods structure typ = structure "camel methods" and camel : camel structure typ = structure "camel" (* class layout (vtable pointer, one instance variable) *) let (-:) ty label = field camel label ty let camel_vtable = ptr camel_methods -: "camel_vtable" let nhumps = int -: "nhumps" let () = seal camel (* method table layout (one additional virtual method) *) let (-:) ty label = field camel_methods label ty let _ = animal_methods -: "_" let humps = Foreign.funptr Ctypes.(ptr camel @-> returning int) -: "humps" let () = seal camel_methods let call_humps cinstance = !@((getf (!@cinstance) camel_vtable) |-> humps) cinstance (* constructor *) class camelc ~cinstance = object inherit animalc ~cinstance:(cast animal cinstance) method humps : int = call_humps cinstance end let check_name = foreign "check_name" (ptr animal @-> string @-> returning int) let new_chorse = foreign "new_chorse" (int @-> returning (ptr animal)) end yallop-ocaml-ctypes-3f8211a/tests/test-oo_style/test_oo_style.ml000066400000000000000000000055421445631112600251520ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes let _ = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) [@@@warning "-6-27-37"] module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Establish a hierarchy of "classes", create some "objects" and call some "methods". *) let test_oo_hierarchy _ = let module M = struct let camel_vtable_singleton = make camel_methods let idfn = (fun animal -> let n = call_humps (cast camel animal) in Printf.sprintf "%d-hump camel" n) let humpsfn = (fun camel -> !@(camel |-> nhumps)) let sayfn = (fun animal -> "humph") let () = begin let vt = camel_vtable_singleton in let base_vt = !@(cast animal_methods (addr vt)) in (* say *) setf base_vt say sayfn; (* identify *) setf base_vt identify idfn; (* humps *) setf vt humps humpsfn; end let new_camel ~humps = let c = make camel in begin setf c camel_vtable (addr camel_vtable_singleton); setf c nhumps humps end; new camelc ~cinstance:(addr c) let () = let c = new_camel ~humps:3 in begin (* Test that we can call a virtual method in an OCaml-created subclass from C *) assert_equal 1 (check_name (cast animal c#cinstance) "3-hump camel"); (* Test that we can call virtual methods in an OCaml-created subclass from OCaml *) assert_equal c#identify "3-hump camel"; assert_equal c#say "humph"; assert_equal c#humps 3; end let _ = Ctypes_memory_stubs.use_value (idfn, humpsfn, sayfn) (* Test that we can call a virtual method in a C-created subclass from OCaml *) type colour = White | Red | Black | Pale let colour_num = function White -> 0 | Red -> 1 | Black -> 2 | Pale -> 3 class chorse ~colour = object inherit animalc (new_chorse(colour_num colour)) end let () = let red_horse = new chorse ~colour:Red and pale_horse = new chorse ~colour:Pale in begin assert_equal "red horse" red_horse#identify; assert_equal "pale horse" pale_horse#identify; assert_equal "neigh" pale_horse#say; end end in () end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "OO-style tests" >::: ["OO style (foreign)" >:: Foreign_tests.test_oo_hierarchy; "OO style (stubs)" >:: Stub_tests.test_oo_hierarchy; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-passable/000077500000000000000000000000001445631112600216535ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-passable/dune000066400000000000000000000001561445631112600225330ustar00rootroot00000000000000(test (name test_passable) (package ctypes-foreign) (libraries ctypes ctypes.stubs ctypes-foreign ounit2)) yallop-ocaml-ctypes-3f8211a/tests/test-passable/test_passable.ml000066400000000000000000000343311445631112600250420ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes (* Test that primitives are passable. *) let test_primitives_are_passable _ = let _ = void @-> returning void and _ = char @-> returning char and _ = schar @-> returning schar and _ = float @-> returning float and _ = double @-> returning double and _ = int @-> returning int and _ = nativeint @-> returning nativeint and _ = int8_t @-> returning int8_t and _ = short @-> returning short and _ = int16_t @-> returning int16_t and _ = int32_t @-> returning int32_t and _ = int64_t @-> returning int64_t and _ = uchar @-> returning uchar and _ = uint8_t @-> returning uint8_t and _ = uint16_t @-> returning uint16_t and _ = uint32_t @-> returning uint32_t and _ = uint64_t @-> returning uint64_t and _ = size_t @-> returning size_t and _ = ushort @-> returning ushort and _ = uint @-> returning uint and _ = ulong @-> returning ulong and _ = ullong @-> returning ullong in () (* Test that unions are not passable *) let test_unions_are_not_passable _ = let module M = struct type u let u : u union typ = union "u" let (-:) ty label = field u label ty let _c = int -: "c" let _f = double -: "f" let _p = ptr u -: "p" let () = seal u let _ = begin (* union types can be used as argument types *) ignore (u @-> returning void); assert_raises ~msg:"Foreign rejects union types as argument types" (Unsupported "libffi does not support passing unions") (fun () -> Foreign.funptr (u @-> returning void)); (* union types can be used as return types *) ignore (u @-> returning void); assert_raises ~msg:"Foreign rejects union types as return types" (Unsupported "libffi does not support passing unions") (fun () -> Foreign.funptr (void @-> returning u)); end end in () (* Test the passability of long double values *) let test_ldouble_not_passable _ = assert_raises ~msg:"Foreign rejects ldouble type as argument" (Unsupported "libffi does not support passing long double") (fun () -> Foreign.funptr (ldouble @-> returning void)); assert_raises ~msg:"Foreign rejects ldouble type as return type" (Unsupported "libffi does not support passing long double") (fun () -> Foreign.funptr (void @-> returning ldouble)) (* Test the passability of complex values *) let test_complex_value_passability _ = (* complex32 can be used as an argument type *) ignore (complex32 @-> returning void); (* complex64 can be used as an argument type *) ignore (complex64 @-> returning void); (* complexld can be used as an argument type *) ignore (complexld @-> returning void); assert_raises ~msg:"Foreign rejects complex32 type as argument" (Unsupported "libffi does not support passing float _Complex") (fun () -> Foreign.funptr (complex32 @-> returning void)); assert_raises ~msg:"Foreign rejects complex64 type as argument" (Unsupported "libffi does not support passing double _Complex") (fun () -> Foreign.funptr (complex64 @-> returning void)); assert_raises ~msg:"Foreign rejects complexld type as argument" (Unsupported "libffi does not support passing long double _Complex") (fun () -> Foreign.funptr (complexld @-> returning void)); (* complex32 can be used as a return type *) ignore (void @-> returning complex32); (* complex64 can be used as a return type *) ignore (void @-> returning complex64); (* complexld can be used as a return type *) ignore (void @-> returning complexld); assert_raises ~msg:"Foreign rejects complex32 type as return type" (Unsupported "libffi does not support passing float _Complex") (fun () -> Foreign.funptr (void @-> returning complex32)); assert_raises ~msg:"Foreign rejects complex64 type as return type" (Unsupported "libffi does not support passing double _Complex") (fun () -> Foreign.funptr (void @-> returning complex64)); assert_raises ~msg:"Foreign rejects complexld type as return type" (Unsupported "libffi does not support passing long double _Complex") (fun () -> Foreign.funptr (void @-> returning complexld)) (* Test that arrays are not passable *) let test_arrays_are_not_passable _ = assert_raises ~msg:"Array type rejected as argument" (Unsupported "Unsupported argument type") (fun () -> array 1 int @-> returning void); assert_raises ~msg:"Array type rejected as return type" (Unsupported "Unsupported return type") (fun () -> void @-> returning (array 1 int)) (* Test that bigarrays are not passable *) let test_bigarrays_are_not_passable _ = assert_raises ~msg:"bigarray type rejected as argument" (Unsupported "Unsupported argument type") (fun () -> bigarray genarray [|1|] Bigarray_compat.int @-> returning void); assert_raises ~msg:"bigarray1 type rejected as argument" (Unsupported "Unsupported argument type") (fun () -> bigarray array1 1 Bigarray_compat.int @-> returning void); assert_raises ~msg:"bigarray2 type rejected as argument" (Unsupported "Unsupported argument type") (fun () -> bigarray array2 (1, 2) Bigarray_compat.int @-> returning void); assert_raises ~msg:"bigarray3 type rejected as argument" (Unsupported "Unsupported argument type") (fun () -> bigarray array3 (1, 2, 3) Bigarray_compat.int @-> returning void); assert_raises ~msg:"bigarray type rejected as return type" (Unsupported "Unsupported return type") (fun () -> void @-> returning (bigarray genarray [|1|] Bigarray_compat.int)); assert_raises ~msg:"bigarray1 type rejected as return type" (Unsupported "Unsupported return type") (fun () -> void @-> returning (bigarray array1 1 Bigarray_compat.int)); assert_raises ~msg:"bigarray2 type rejected as return type" (Unsupported "Unsupported return type") (fun () -> void @-> returning (bigarray array2 (1, 2) Bigarray_compat.int)); assert_raises ~msg:"bigarray3 type rejected as return type" (Unsupported "Unsupported return type") (fun () -> void @-> returning (bigarray array3 (1, 2, 3) Bigarray_compat.int)) (* Test that pointers are passable *) let test_pointers_are_passable _ = (* Pointers to primitives are passable *) let _ = ptr void @-> returning (ptr void) and _ = ptr int @-> returning (ptr int) and _ = ptr (ptr int) @-> returning (ptr (ptr int)) in (* Pointers to unpassable types are passable *) let module M = struct type s1 and u let s1 : s1 structure typ = structure "s1" let _ = field s1 "_" int let _ = field s1 "_" (ptr s1) let () = seal s1 let u : u union typ = union "u" let _ = field u "_" int let () = seal u end in let open M in let _ = ptr s1 @-> returning (ptr s1) and _ = ptr u @-> returning (ptr u) in () (* Test that function pointers are passable *) let test_function_pointers_are_passable _ = (* Pointers to primitives are passable *) ignore (Foreign.funptr (int @-> returning int) @-> returning (Foreign.funptr (int @-> returning int))) (* Test that values of abstract types are not passable *) let test_abstract_values_are_not_passable _ = begin assert_raises ~msg:"Abstract type rejected as argument" (Unsupported "Unsupported argument type") (fun () -> (abstract ~name:"abstract" ~size:1 ~alignment:1) @-> returning void); assert_raises ~msg:"Abstract type rejected as return type" (Unsupported "Unsupported return type") (fun () -> void @-> returning (abstract ~name:"abstract" ~size:1 ~alignment:1)); end (* Test struct passability. Structs are passable unless they contain unpassable members (unions, arrays, abstract types, or unpassable structs). *) let test_struct_passability _ = let module M = struct type s1 and s2 and s3 and s4 and s5 and s6 and u let s1 : s1 structure typ = structure "s1" let (-:) ty label = field s1 label ty let _ = int -: "_" let _ = double -: "_" let _ = ptr s1 -: "_" let _ = Foreign.funptr (int @-> returning int) -: "_" let () = seal s1 let s2 : s2 structure typ = structure "s2" let (-:) ty label = field s2 label ty let _ = s1 -: "_" let _ = double -: "_" let _ = ptr (array 10 int) -: "_" let () = seal s2 let s3 : s3 structure typ = structure "s3" let (-:) ty label = field s3 label ty let _ = array 10 (ptr char) -: "_" let () = seal s3 let s4 : s4 structure typ = structure "s4" let (-:) ty label = field s4 label ty let _ = s3 -: "_" let () = seal s4 let u : u union typ = union "u" let (-:) ty label = field u label ty let _ = int -: "_" let () = seal u let s5 : s5 structure typ = structure "s5" let (-:) ty label = field s5 label ty let _ = u -: "_" let () = seal s5 let s6 : s6 structure typ = structure "s6" let (-:) ty label = field s6 label ty let _ = abstract ~name:"abstract" ~size:1 ~alignment:1 -: "_" let () = seal s6 let _ = begin (* Struct types can be argument types *) ignore (s1 @-> returning void); ignore (s2 @-> returning void); (* Struct types can be return types *) ignore (void @-> returning s1); ignore (void @-> returning s2); (* Structs with array members can be arguments *) ignore (s3 @-> returning void); assert_raises ~msg:"Foreign rejects structs with array members as arguments" (Unsupported "libffi does not support passing arrays") (fun () -> Foreign.funptr (s3 @-> returning void)); (* Structs with array members can be return types *) ignore (void @-> returning s3); assert_raises ~msg:"Foreign rejects structs with array members as return types" (Unsupported "libffi does not support passing arrays") (fun () -> Foreign.funptr (void @-> returning s3)); assert_raises ~msg:"Foreign rejects structs with unpassable struct members as arguments" (Unsupported "libffi does not support passing arrays") (fun () -> Foreign.funptr (s4 @-> returning void)); assert_raises ~msg:"Foreign rejects structs with unpassable struct members as return types" (Unsupported "libffi does not support passing arrays") (fun () -> Foreign.funptr (void @-> returning s4)); (* Structs with union members can be arguments *) ignore (s5 @-> returning void); assert_raises ~msg:"Foreign rejects structs with union members as arguments" (Unsupported "libffi does not support passing unions") (fun () -> Foreign.funptr (s5 @-> returning void)); (* Structs with union members can be return types *) ignore (void @-> returning s5); assert_raises ~msg:"Foreign rejects structs with union members as return types" (Unsupported "libffi does not support passing unions") (fun () -> Foreign.funptr (void @-> returning s5)); (* Structs with abstract members can be arguments *) ignore (s6 @-> returning void); assert_raises ~msg:"Foreign rejects structs with abstract members as arguments" (Unsupported "libffi does not support passing values of abstract type") (fun () -> Foreign.funptr (s6 @-> returning void)); ignore (void @-> returning s6); assert_raises ~msg:"Foreign rejects structs with abstract members as return types" (Unsupported "libffi does not support passing values of abstract type") (fun () -> Foreign.funptr (void @-> returning s6)); end end in () (* Test passability of incomplete types. Trying to use an incomplete type in a function specification should give rise to an error. *) let test_incomplete_passability _ = let s = structure "incomplete" and u = union "incomplete" in begin assert_raises IncompleteType (fun () -> s @-> returning void); assert_raises IncompleteType (fun () -> void @-> returning s); assert_raises IncompleteType (fun () -> u @-> returning void); assert_raises IncompleteType (fun () -> void @-> returning u); end (* Test that OCaml values cannot be passed to C functions that are called without the OCaml runtime lock. *) let test_ocaml_values_are_not_passable_when_releasing_the_lock _ = begin assert_raises (Unsupported "Unsupported argument type when releasing runtime lock") (fun () -> Foreign.foreign "puts" (ocaml_string @-> returning int) ~release_runtime_lock:true); let module Bindings (F:Cstubs.FOREIGN) = struct F.(foreign "puts" (ocaml_string @-> returning int)) end in assert_raises (Unsupported "Unsupported argument type when releasing runtime lock") (fun () -> Cstubs.write_c ~prefix:"tests" ~concurrency:Cstubs.unlocked Format.str_formatter (module Bindings)); assert_raises (Unsupported "Unsupported argument type when releasing runtime lock") (fun () -> Cstubs.write_c ~prefix:"tests" ~concurrency:Cstubs.lwt_jobs Format.str_formatter (module Bindings)); assert_raises (Unsupported "Unsupported argument type when releasing runtime lock") (fun () -> Cstubs.write_c ~prefix:"tests" ~concurrency:Cstubs.lwt_preemptive Format.str_formatter (module Bindings)); end let suite = "Passability tests" >::: ["primitives are passable" >:: test_primitives_are_passable; "unions are not passable" >:: test_unions_are_not_passable; "complex values passability" >:: test_complex_value_passability; "long doubles are not passble" >:: test_ldouble_not_passable; "arrays are not passable" >:: test_arrays_are_not_passable; "bigarrays are not passable" >:: test_bigarrays_are_not_passable; "pointers are passable" >:: test_pointers_are_passable; "function pointers are passable" >:: test_function_pointers_are_passable; "abstract values are not passable" >:: test_abstract_values_are_not_passable; "struct passability" >:: test_struct_passability; "incomplete types are not passable" >:: test_incomplete_passability; "ocaml values are not passable when the runtime lock is released" >:: test_ocaml_values_are_not_passable_when_releasing_the_lock; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-passing-ocaml-values/000077500000000000000000000000001445631112600241135ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-passing-ocaml-values/dune000066400000000000000000000003301445631112600247650ustar00rootroot00000000000000(test (name test_passing_ocaml_values) (package ctypes-foreign) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_passing_ocaml_values_stubs test_passing_ocaml_values_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-passing-ocaml-values/stub-generator/000077500000000000000000000000001445631112600270545ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-passing-ocaml-values/stub-generator/driver.ml000066400000000000000000000005001445631112600306740ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the OCaml-value-passing tests. *) let cheader = "#include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-passing-ocaml-values/stub-generator/dune000066400000000000000000000007601445631112600277350ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_passing_ocaml_values_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_passing_ocaml_values_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-passing-ocaml-values/stubs/000077500000000000000000000000001445631112600252535ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-passing-ocaml-values/stubs/dune000066400000000000000000000001271445631112600261310ustar00rootroot00000000000000(library (name test_passing_ocaml_values_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-passing-ocaml-values/stubs/functions.ml000066400000000000000000000014361445631112600276210ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the OCaml-value-passing tests. *) open Ctypes let name_strdup = match Sys.os_type with | "Win32" -> "_strdup" | _ -> "strdup" module Stubs (F: Ctypes.FOREIGN) = struct open F let memcpy_string_string = foreign "memcpy" (ocaml_string @-> ocaml_string @-> size_t @-> returning (ptr void)) let memcpy_bytes_bytes = foreign "memcpy" (ocaml_bytes @-> ocaml_bytes @-> size_t @-> returning (ptr void)) let memcpy_string_ptr = foreign "memcpy" (ocaml_string @-> ptr void @-> size_t @-> returning (ptr void)) let strdup = foreign name_strdup (ocaml_string @-> returning string) end yallop-ocaml-ctypes-3f8211a/tests/test-passing-ocaml-values/test_passing_ocaml_values.ml000066400000000000000000000074151445631112600317110ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes open Foreign module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Test passing OCaml strings directly to C. *) let test_passing_strings _ = let input = "abcdefghijklmnopqrstuvwxyz" in let len = String.length input in let buf = String.make len 'Z' in let _ = memcpy_string_string (ocaml_string_start buf) (ocaml_string_start input) (Unsigned.Size_t.of_int len) in begin assert_equal buf input end; let bbuf = Bytes.create len in let binput = Bytes.of_string input in let _ = memcpy_bytes_bytes (ocaml_bytes_start bbuf) (ocaml_bytes_start binput) (Unsigned.Size_t.of_int len) in begin assert_equal bbuf binput end; let arr = CArray.make char len in let () = String.iteri (CArray.set arr) input in let buf = String.make len 'Z' in let _ = memcpy_string_ptr (ocaml_string_start buf) (coerce (ptr char) (ptr void) (CArray.start arr)) (Unsigned.Size_t.of_int len) in begin assert_equal buf input end (* Test pointer arithmetic on OCaml values. *) let test_pointer_arithmetic _ = let s = ocaml_string_start "abcdefghijklmnopqrstuvwxyz" in begin assert_equal s (s +@ 0); assert_equal (ptr_diff s (s +@ 10)) 10; assert_equal s ((s +@ 10) -@ 10); assert_equal (strdup (ocaml_string_start "klmnopqrstuvwxyz")) (strdup (s +@ 10)) end end (* Test that OCaml values do not reside in addressable memory. *) let test_ocaml_types_rejected_as_pointer_reference_types _ = assert_raises IncompleteType (fun () -> allocate ocaml_string (ocaml_string_start "")) (* Test that OCaml values cannot be used as return types. *) let strdup = if Sys.os_type = "Win32" then "_strdup" else "strdup" let test_ocaml_types_rejected_as_return_types _ = assert_raises IncompleteType (fun () -> Foreign.foreign strdup (string @-> returning ocaml_string)) (* Test that pointers to OCaml values cannot be dereferenced. *) let test_pointers_to_ocaml_types_cannot_be_dereferenced _ = let p = allocate_n char ~count:10 in let po = coerce (ptr char) (ptr ocaml_string) p in begin assert_raises IncompleteType (fun () -> !@po); assert_raises IncompleteType (fun () -> po <-@ ocaml_string_start ""); end (* Test that [funptr] does not support ocaml_string return values. *) let test_no_higher_order_ocaml_string_support _ = begin assert_raises IncompleteType (fun () -> funptr (void @-> returning ocaml_string)) end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Tests passing OCaml values" >::: ["passing strings (foreign)" >:: Foreign_tests.test_passing_strings; "passing strings (stubs)" >:: Stub_tests.test_passing_strings; "pointer arithmetic on OCaml values (foreign)" >:: Foreign_tests.test_pointer_arithmetic; "pointer arithmetic on OCaml values (stubs)" >:: Stub_tests.test_pointer_arithmetic; "ocaml_string values aren't addressable" >:: test_ocaml_types_rejected_as_pointer_reference_types; "ocaml_string can't be used as a return type" >:: test_ocaml_types_rejected_as_return_types; "pointers to ocaml_string values cannot be dereferenced" >:: test_pointers_to_ocaml_types_cannot_be_dereferenced; "no higher-order ocaml_string support" >:: test_no_higher_order_ocaml_string_support; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-pointers/000077500000000000000000000000001445631112600217245ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-pointers/dune000066400000000000000000000004261445631112600226040ustar00rootroot00000000000000(test (name test_pointers) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_pointers_stubs test_pointers_bindings tests_common stdlib-shims)) yallop-ocaml-ctypes-3f8211a/tests/test-pointers/stub-generator/000077500000000000000000000000001445631112600246655ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-pointers/stub-generator/driver.ml000066400000000000000000000004061445631112600265120ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the pointer tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-pointers/stub-generator/dune000066400000000000000000000007301445631112600255430ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_pointers_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_pointers_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-pointers/stubs/000077500000000000000000000000001445631112600230645ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-pointers/stubs/dune000066400000000000000000000001321445631112600237360ustar00rootroot00000000000000(library (name test_pointers_stubs) (wrapped false) (libraries ctypes ctypes-foreign)) yallop-ocaml-ctypes-3f8211a/tests/test-pointers/stubs/functions.ml000066400000000000000000000041111445631112600254230ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the pointer tests. *) open Ctypes module Stubs (F: Ctypes.FOREIGN) = struct open F let accept_pointers = foreign "accept_pointers" (ptr float @-> ptr double @-> ptr short @-> ptr int @-> ptr long @-> ptr llong @-> ptr nativeint @-> ptr int8_t @-> ptr int16_t @-> ptr int32_t @-> ptr int64_t @-> ptr uint8_t @-> ptr uint16_t @-> ptr uint32_t @-> ptr uint64_t @-> ptr size_t @-> ptr ushort @-> ptr uint @-> ptr ulong @-> ptr ullong @-> returning int) let accept_pointers_to_pointers = foreign "accept_pointers_to_pointers" (ptr int @-> ptr (ptr int) @-> ptr (ptr (ptr int)) @-> ptr (ptr (ptr (ptr int))) @-> returning int) let malloc = foreign "malloc" (size_t @-> returning (ptr void)) let realloc = foreign "realloc" (ptr void @-> size_t @-> returning (ptr void)) let free = foreign "free" (ptr void @-> returning void) let return_global_address = foreign "return_global_address" (void @-> returning (ptr int)) let pass_pointer_through = foreign "pass_pointer_through" (ptr int @-> ptr int @-> int @-> returning (ptr int)) let passing_pointers_to_callback = foreign "passing_pointers_to_callback" (Foreign.funptr Ctypes.(ptr int @-> ptr int @-> returning int) @-> returning int) let accepting_pointer_from_callback = foreign "accepting_pointer_from_callback" (Foreign.funptr Ctypes.(int @-> int @-> returning (ptr int)) @-> returning int) let accepting_pointer_to_function_pointer = foreign "accepting_pointer_to_function_pointer" (ptr (Foreign.funptr Ctypes.(int @-> int @-> returning int)) @-> returning int) let returning_pointer_to_function_pointer = foreign "returning_pointer_to_function_pointer" (void @-> returning (ptr (Foreign.funptr Ctypes.(int @-> int @-> returning int)))) end yallop-ocaml-ctypes-3f8211a/tests/test-pointers/test_pointers.ml000066400000000000000000000472201445631112600251650ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@ocaml.warning "-6"] open OUnit2 open Ctypes open Foreign [@@@warning "-6"] let testlib = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Test passing various types of pointers to a function. *) let test_passing_pointers _ = assert_equal ~msg:"Passing pointers to various numeric types" ~printer:string_of_int (1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 11 + 12 + 13 + 14 + 15 + 16 + 17 + 18 + 19 + 20) (let open Signed in let open Unsigned in accept_pointers (allocate float 1.0) (allocate double 2.0) (allocate short 3) (allocate int 4) (allocate long (Long.of_int 5)) (allocate llong (LLong.of_int 6)) (allocate nativeint 7n) (allocate int8_t 8) (allocate int16_t 9) (allocate int32_t 10l) (allocate int64_t 11L) (allocate uint8_t (UInt8.of_int 12)) (allocate uint16_t (UInt16.of_int 13)) (allocate uint32_t (UInt32.of_int 14)) (allocate uint64_t (UInt64.of_int 15)) (allocate size_t (Size_t.of_int 16)) (allocate ushort (UShort.of_int 17)) (allocate uint (UInt.of_int 18)) (allocate ulong (ULong.of_int 19)) (allocate ullong (ULLong.of_int 20))) (* Test passing pointers to pointers. *) let test_passing_pointers_to_pointers _ = let p = allocate int 1 and pp = allocate (ptr int) (allocate int 2) and ppp = allocate (ptr (ptr int)) (allocate (ptr int) (allocate int 3)) and pppp = allocate (ptr (ptr (ptr int))) (allocate (ptr (ptr int)) (allocate (ptr int) (allocate int 4))) in assert_equal ~msg:"Passing pointers to pointers" (1 + 2 + 3 + 4) (accept_pointers_to_pointers p pp ppp pppp) (* Passing a callback that accepts pointers as arguments. *) let test_callback_receiving_pointers _ = assert_equal 7 (passing_pointers_to_callback (fun lp rp -> !@lp + !@rp)) (* Passing a callback that returns a pointer. *) let test_callback_returning_pointers _ = let p = allocate int 17 in begin assert_equal 17 !@p; assert_equal 56 (accepting_pointer_from_callback (fun x y -> p <-@ (x * y); p)); assert_equal 12 !@p end (* Test passing a pointer-to-a-function-pointer as an argument. *) let test_passing_pointer_to_function_pointer _ = assert_equal ~printer:string_of_int 5 (accepting_pointer_to_function_pointer (allocate (funptr (int @-> int @-> returning int)) ( / ))) (* Test returning a pointer to a function pointer *) let test_callback_returning_pointer_to_function_pointer _ = assert_equal 10 (!@(returning_pointer_to_function_pointer ()) 2 5) (* Test bindings for malloc, realloc and free. *) let test_allocation _ = let open Unsigned in let pointer = malloc (Size_t.of_int (sizeof int)) in let int_pointer = from_voidp int pointer in int_pointer <-@ 17; assert_equal !@int_pointer 17; int_pointer <-@ -3; assert_equal !@int_pointer (-3); let pointer' = realloc pointer (Size_t.of_int (20 * sizeof int)) in assert_bool "realloc succeeded" (pointer' <> null); let int_pointer = from_voidp int pointer' in assert_equal ~msg:"realloc copied the existing data over" !@int_pointer (-3); for i = 0 to 19 do (int_pointer +@ i) <-@ i done; for i = 0 to 19 do assert_equal i !@(int_pointer +@ i) done; free pointer' (* Test a function that returns the address of a global variable. *) let test_reading_returned_global _ = assert_equal (!@(return_global_address ())) 100 (* Test a function that returns a pointer passed as argument. *) let test_passing_pointer_through _ = let p1 = allocate int 25 in let p2 = allocate int 32 in let rv = pass_pointer_through p1 p2 10 in assert_equal !@rv !@p1; assert_equal 25 !@rv; let rv = pass_pointer_through p1 p2 (-10) in assert_equal !@rv !@p2; assert_equal 32 !@rv; let p3 = p1 +@ 1 in let rv = pass_pointer_through p3 p1 1 in assert_bool "pointer with (positive) offset successfully passed through" (ptr_compare rv p3 = 0); assert_bool "pointer with positive computed offset compares greater than original" (ptr_compare p1 p3 < 0); assert_bool "pointer with positive computed offset compares greater than original" (ptr_compare p3 p1 > 0); assert_bool "returned pointer with positive computed offset compares greater than original" (ptr_compare p1 rv < 0); assert_bool "returned pointer with positive computed offset compares greater than original" (ptr_compare rv p1 > 0); assert_equal !@(rv -@ 1) !@(p3 -@ 1); let p4 = p1 -@ 1 in let rv = pass_pointer_through p1 p4 (-1) in assert_bool "pointer with (negative) offset successfully passed through" (ptr_compare rv p4 = 0); assert_bool "pointer with negative computed offset compares less than original" (ptr_compare p1 p4 > 0); assert_bool "pointer with negative computed offset compares less than original" (ptr_compare p4 p1 < 0); assert_bool "returned pointer with negative computed offset compares greater than original" (ptr_compare p1 rv > 0); assert_bool "returned pointer with negative computed offset compares greater than original" (ptr_compare rv p1 < 0) end (* Tests for reading and writing primitive values through pointers. *) let test_pointer_assignment_with_primitives _ = let open Signed in let open Unsigned in let p_char = allocate char '1' and p_uchar = allocate uchar (UChar.of_int 2) and p_bool = allocate bool false and p_schar = allocate schar 3 and p_float = allocate float 4.0 and p_double = allocate double 5.0 and p_short = allocate short 6 and p_int = allocate int 7 and p_long = allocate long (Long.of_int 8) and p_llong = allocate llong (LLong.of_int 9) and p_nativeint = allocate nativeint 10n and p_int8_t = allocate int8_t 11 and p_int16_t = allocate int16_t 12 and p_int32_t = allocate int32_t 13l and p_int64_t = allocate int64_t 14L and p_uint8_t = allocate uint8_t (UInt8.of_int 15) and p_uint16_t = allocate uint16_t (UInt16.of_int 16) and p_uint32_t = allocate uint32_t (UInt32.of_int 17) and p_uint64_t = allocate uint64_t (UInt64.of_int 18) and p_size_t = allocate size_t (Size_t.of_int 19) and p_ushort = allocate ushort (UShort.of_int 20) and p_uint = allocate uint (UInt.of_int 21) and p_ulong = allocate ulong (ULong.of_int 22) and p_ullong = allocate ullong (ULLong.of_int 23) in begin assert_equal '1' (!@p_char); assert_equal (UChar.of_int 2) (!@p_uchar); assert_equal false (!@p_bool); assert_equal 3 (!@p_schar); assert_equal 4.0 (!@p_float); assert_equal 5.0 (!@p_double); assert_equal 6 (!@p_short); assert_equal 7 (!@p_int); assert_equal (Long.of_int 8) (!@p_long); assert_equal (LLong.of_int 9) (!@p_llong); assert_equal 10n (!@p_nativeint); assert_equal 11 (!@p_int8_t); assert_equal 12 (!@p_int16_t); assert_equal 13l (!@p_int32_t); assert_equal 14L (!@p_int64_t); assert_equal (UInt8.of_int 15) (!@p_uint8_t); assert_equal (UInt16.of_int 16) (!@p_uint16_t); assert_equal (UInt32.of_int 17) (!@p_uint32_t); assert_equal (UInt64.of_int 18) (!@p_uint64_t); assert_equal (Size_t.of_int 19) (!@p_size_t); assert_equal (UShort.of_int 20) (!@p_ushort); assert_equal (UInt.of_int 21) (!@p_uint); assert_equal (ULong.of_int 22) (!@p_ulong); assert_equal (ULLong.of_int 23) (!@p_ullong); p_char <-@ '2'; p_uchar <-@ (UChar.of_int 102); p_bool <-@ true; p_schar <-@ 103; p_float <-@ 104.0; p_double <-@ 105.0; p_short <-@ 106; p_int <-@ 107; p_long <-@ (Long.of_int 108); p_llong <-@ (LLong.of_int 109); p_nativeint <-@ 110n; p_int8_t <-@ 111; p_int16_t <-@ 112; p_int32_t <-@ 113l; p_int64_t <-@ 114L; p_uint8_t <-@ (UInt8.of_int 115); p_uint16_t <-@ (UInt16.of_int 116); p_uint32_t <-@ (UInt32.of_int 117); p_uint64_t <-@ (UInt64.of_int 118); p_size_t <-@ (Size_t.of_int 119); p_ushort <-@ (UShort.of_int 120); p_uint <-@ (UInt.of_int 121); p_ulong <-@ (ULong.of_int 122); p_ullong <-@ (ULLong.of_int 123); assert_equal '2' (!@p_char); assert_equal (UChar.of_int 102) (!@p_uchar); assert_equal true (!@p_bool); assert_equal 103 (!@p_schar); assert_equal 104.0 (!@p_float); assert_equal 105.0 (!@p_double); assert_equal 106 (!@p_short); assert_equal 107 (!@p_int); assert_equal (Long.of_int 108) (!@p_long); assert_equal (LLong.of_int 109) (!@p_llong); assert_equal 110n (!@p_nativeint); assert_equal 111 (!@p_int8_t); assert_equal 112 (!@p_int16_t); assert_equal 113l (!@p_int32_t); assert_equal 114L (!@p_int64_t); assert_equal (UInt8.of_int 115) (!@p_uint8_t); assert_equal (UInt16.of_int 116) (!@p_uint16_t); assert_equal (UInt32.of_int 117) (!@p_uint32_t); assert_equal (UInt64.of_int 118) (!@p_uint64_t); assert_equal (Size_t.of_int 119) (!@p_size_t); assert_equal (UShort.of_int 120) (!@p_ushort); assert_equal (UInt.of_int 121) (!@p_uint); assert_equal (ULong.of_int 122) (!@p_ulong); assert_equal (ULLong.of_int 123) (!@p_ullong); end (* Dereferencing pointers to incomplete types *) let test_dereferencing_pointers_to_incomplete_types _ = begin assert_raises IncompleteType (fun () -> !@null); assert_raises IncompleteType (fun () -> !@(from_voidp (structure "incomplete") null)); assert_raises IncompleteType (fun () -> !@(from_voidp (union "incomplete") null)); end (* Writing through a pointer to an abstract type *) let test_writing_through_pointer_to_abstract_type _ = let module Array = CArray in let arra = Array.make int 2 in let arrb = Array.make int 2 in let absptr a = from_voidp (abstract ~name:"absptr" ~size:(2 * sizeof int) ~alignment:(alignment (array 2 int))) (to_voidp (Array.start a)) in let () = begin arra.(0) <- 10; arra.(1) <- 20; arrb.(0) <- 30; arrb.(1) <- 40; end in let dest = absptr arra in let src = absptr arrb in begin assert_equal 10 arra.(0); assert_equal 20 arra.(1); assert_equal 30 arrb.(0); assert_equal 40 arrb.(1); dest <-@ !@src; assert_equal 30 arra.(0); assert_equal 40 arra.(1); assert_equal 30 arrb.(0); assert_equal 40 arrb.(1); assert_bool "pointers distinct" (dest <> src); assert_bool "arrays distinct" (arra <> arrb); end (* Test for reading and writing global values using the "foreign_value" function. *) let test_reading_and_writing_global_value _ = let ptr = foreign_value "global" int ~from:testlib in let ptr' = foreign_value "global" int ~from:testlib in assert_equal (!@ptr) 100; ptr <-@ 200; assert_equal (!@ptr) 200; assert_equal (!@ptr') 200; ptr' <-@ 100; assert_equal (!@ptr) 100; assert_equal (!@ptr') 100 (* Tests for reading a string from an address. *) let test_reading_strings _ = let p = allocate_n char 26 in begin StringLabels.iteri "abcdefghijklmnoprwstuvwxyz" ~f:(fun i c -> (p +@ i) <-@ c); assert_equal (string_from_ptr p 5) "abcde"; assert_equal (string_from_ptr p 26) "abcdefghijklmnoprwstuvwxyz"; assert_equal (string_from_ptr p 0) ""; assert_raises (Invalid_argument "Ctypes.string_from_ptr") (fun () -> string_from_ptr p (-1)); end (* Tests for various aspects of pointer arithmetic. *) let test_pointer_arithmetic _ = let module Array = CArray in let arr = Array.of_list int [1;2;3;4;5;6;7;8] in (* Traverse the array using an int pointer *) let p = Array.start arr in for i = 0 to 7 do assert_equal !@(p +@ i) (succ i) done; let twoints = structure "s" in let i1 = field twoints "i" int in let i2 = field twoints "j" int in let () = seal twoints in (* Traverse the array using a 'struct twoints' pointer *) let ps = from_voidp twoints (to_voidp p) in for i = 0 to 3 do assert_equal !@((ps +@ i) |-> i1) (2 * i + 1); assert_equal !@((ps +@ i) |-> i2) (2 * i + 2); done; (* Traverse the array using a char pointer *) let pc = from_voidp char (to_voidp p) in for i = 0 to 7 do let p' = pc +@ i * sizeof int in assert_equal !@(from_voidp int (to_voidp p')) (succ i) done; (* Reverse traversal *) let pend = p +@ 7 in for i = 0 to 7 do assert_equal !@(pend -@ i) (8 - i) done (* Test pointer comparisons. *) let test_pointer_comparison _ = let canonicalize p = (* Ensure that the 'pbyte_offset' component of the pointer is zero by writing the pointer to memory and then reading it back. *) let buf = allocate_n ~count:1 (ptr void) in buf <-@ (to_voidp p); !@buf in let (<) l r = ptr_compare l r < 0 and (>) l r = ptr_compare l r > 0 and (=) l r = ptr_compare l r = 0 in (* equal but not identical pointers compare equal *) let p = allocate int 10 in let p' = from_voidp int (to_voidp p) in assert_bool "equal but not identical poitners compare equal" (p = p'); (* Canonicalization preserves ordering *) assert_bool "p < p+n" (p < (p +@ 10)); assert_bool "canonicalize(p) < canonicalize(p+n)" (canonicalize p < canonicalize (p +@ 10)); assert_bool "p > p-1" (p > (p -@ 1)); assert_bool "canonicalize(p) > canonicalize(p-1)" (canonicalize p > canonicalize (p -@ 1)); let s3 = structure "s3" in let i = field s3 "i" int in let j = field s3 "j" int in let k = field s3 "k" int in let () = seal s3 in let sp = addr (make s3) in let p1 = to_voidp (sp |-> i) and p2 = to_voidp (sp |-> j) and p3 = to_voidp (sp |-> k) in assert_bool "sp |-> i < sp |-> j" (p1 < p2); assert_bool "sp |-> i < canonicalize (sp |-> j)" (p1 < canonicalize p2); assert_bool "canonicalize (sp |-> i) < sp |-> j" (canonicalize p1 < p2); assert_bool "canonicalize (sp |-> i) < canonicalize (sp |-> j)" (canonicalize p1 < canonicalize p2); assert_bool "sp |-> i < sp |-> k" (p1 < p3); assert_bool "sp |-> i < canonicalize (sp |-> k)" (p1 < canonicalize p3); assert_bool "canonicalize (sp |-> i) < sp |-> k" (canonicalize p1 < p3); assert_bool "canonicalize (sp |-> i) < canonicalize (sp |-> k)" (canonicalize p1 < canonicalize p3); assert_bool "sp |-> j < sp |-> k" (p2 < p3); assert_bool "sp |-> j < canonicalize (sp |-> k)" (p2 < canonicalize p3); assert_bool "canonicalize (sp |-> j) < sp |-> k" (canonicalize p2 < p3); assert_bool "canonicalize (sp |-> j) < canonicalize (sp |-> k)" (canonicalize p2 < canonicalize p3); (* Canonicalization preserves equality *) assert_bool "canonicalization preserves equality" (to_voidp p = canonicalize p) (* Test pointer differences. *) let test_pointer_differences _ = let canonicalize p = (* Ensure that the 'pbyte_offset' component of the pointer is zero by writing the pointer to memory and then reading it back. *) let buf = allocate_n ~count:1 (ptr void) in buf <-@ (to_voidp p); !@buf in let s = structure "s" in let (-:) ty label = field s label ty in let i = int -: "i" in let j = array 17 char -: "j" in let k = double -: "k" in let l = char -: "l" in let () = seal s in let v = make s in let p = addr v in let to_charp p = from_voidp char (to_voidp p) in let cp = to_charp p in assert_equal (offsetof i) (ptr_diff cp (to_charp (p |-> i))); assert_equal (offsetof j) (ptr_diff cp (to_charp (p |-> j))); assert_equal (offsetof k) (ptr_diff cp (to_charp (p |-> k))); assert_equal (offsetof l) (ptr_diff cp (to_charp (p |-> l))); assert_equal (-offsetof i) (ptr_diff (to_charp (p |-> i)) cp); assert_equal (-offsetof j) (ptr_diff (to_charp (p |-> j)) cp); assert_equal (-offsetof k) (ptr_diff (to_charp (p |-> k)) cp); assert_equal (-offsetof l) (ptr_diff (to_charp (p |-> l)) cp); assert_equal (offsetof i) (ptr_diff cp (to_charp (canonicalize (p |-> i)))); assert_equal (offsetof j) (ptr_diff cp (to_charp (canonicalize (p |-> j)))); assert_equal (offsetof k) (ptr_diff cp (to_charp (canonicalize (p |-> k)))); assert_equal (offsetof l) (ptr_diff cp (to_charp (canonicalize (p |-> l)))); assert_equal (-offsetof i) (ptr_diff (to_charp (canonicalize (p |-> i))) cp); assert_equal (-offsetof j) (ptr_diff (to_charp (canonicalize (p |-> j))) cp); assert_equal (-offsetof k) (ptr_diff (to_charp (canonicalize (p |-> k))) cp); assert_equal (-offsetof l) (ptr_diff (to_charp (canonicalize (p |-> l))) cp) (* Test raw pointers. *) let test_raw_pointers _ = (* Check that conversions to the raw form commute with arithmetic. *) let p : float ptr = allocate double 1.0 in let p' = p +@ 3 in let praw = raw_address_of_ptr (to_voidp p) in let praw' = raw_address_of_ptr (to_voidp p') in assert_equal praw' Nativeint.(add praw (of_int (3 * sizeof double))) module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Pointer tests" >::: ["passing pointers (foreign)" >:: Foreign_tests.test_passing_pointers; "passing pointers (stubs)" >:: Stub_tests.test_passing_pointers; "passing pointers to pointers (foreign)" >:: Foreign_tests.test_passing_pointers_to_pointers; "passing pointers to pointers (stubs)" >:: Stub_tests.test_passing_pointers_to_pointers; "callback receiving pointers (foreign)" >:: Foreign_tests.test_callback_receiving_pointers; "callback receiving pointers (stubs)" >:: Stub_tests.test_callback_receiving_pointers; "callback returning pointers (foreign)" >:: Foreign_tests.test_callback_returning_pointers; "callback returning pointers (stubs)" >:: Stub_tests.test_callback_returning_pointers; "pointer assignment with primitives" >:: test_pointer_assignment_with_primitives; "passing pointer to function pointer (foreign)" >:: Foreign_tests.test_passing_pointer_to_function_pointer; "passing pointer to function pointer (stubs)" >:: Stub_tests.test_passing_pointer_to_function_pointer; "callback returning pointer to function pointer (foreign)" >:: Foreign_tests.test_callback_returning_pointer_to_function_pointer; "callback returning pointer to function pointer (stubs)" >:: Stub_tests.test_callback_returning_pointer_to_function_pointer; "incomplete types" >:: test_dereferencing_pointers_to_incomplete_types; "abstract types" >:: test_writing_through_pointer_to_abstract_type; "global value" >:: test_reading_and_writing_global_value; "allocation (foreign)" >:: Foreign_tests.test_allocation; "allocation (stubs)" >:: Stub_tests.test_allocation; "passing pointers through functions (foreign)" >:: Foreign_tests.test_passing_pointer_through; "passing pointers through functions (stubs)" >:: Stub_tests.test_passing_pointer_through; "returned globals (foreign)" >:: Foreign_tests.test_reading_returned_global; "returned globals (stubs)" >:: Stub_tests.test_reading_returned_global; "reading strings" >:: test_reading_strings; "arithmetic" >:: test_pointer_arithmetic; "comparisons" >:: test_pointer_comparison; "differences" >:: test_pointer_differences; "raw" >:: test_raw_pointers; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-raw/000077500000000000000000000000001445631112600206525ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-raw/dune000066400000000000000000000001341445631112600215260ustar00rootroot00000000000000(test (name test_raw) (package ctypes-foreign) (libraries ctypes ctypes-foreign ounit2)) yallop-ocaml-ctypes-3f8211a/tests/test-raw/test_raw.ml000066400000000000000000000056571445631112600230510ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@ocaml.warning "-6"] open OUnit2 open Ctypes_memory_stubs [@@@warning "-6-33"] (* Tests for the low-level module on which the public high-level interface is based. *) let make_unmanaged ~reftyp p = Ctypes_ptr.Fat.make ~managed:None ~reftyp p (* Call the C function double fabs(double) *) let test_fabs _ = Ctypes_ffi_stubs.( let double_ffitype = primitive_ffitype Ctypes_primitive_types.Double in let callspec = allocate_callspec ~check_errno:false ~runtime_lock:false ~thread_registration:false in let arg_1_offset = add_argument callspec double_ffitype in let () = prep_callspec callspec Libffi_abi.(abi_code default_abi) double_ffitype in let dlfabs = Ctypes_ptr.Raw.of_nativeint (Dl.dlsym "fabs") in let dlfabs_fat = make_unmanaged dlfabs ~reftyp:Ctypes.(double @-> returning double) in let fabs x = call "fabs" dlfabs_fat callspec (fun p _values -> write Ctypes_primitive_types.Double x Ctypes_ptr.(make_unmanaged ~reftyp:Ctypes_static.Void (Raw.(add p (of_int arg_1_offset))))) (fun p -> read Ctypes_primitive_types.Double (make_unmanaged ~reftyp:Ctypes_static.Void p)) in assert_equal 2.0 (fabs (-2.0)) ~printer:string_of_float; assert_equal 12.0 (fabs (12.0)) ~printer:string_of_float; assert_equal 0.0 (fabs 0.0) ~printer:string_of_float; ) (* Call the C function double pow(double, double) *) let test_pow _ = Ctypes_ffi_stubs.( let double_ffitype = primitive_ffitype Ctypes_primitive_types.Double in let callspec = allocate_callspec ~check_errno:false ~runtime_lock:false ~thread_registration:false in let arg_1_offset = add_argument callspec double_ffitype in let arg_2_offset = add_argument callspec double_ffitype in let () = prep_callspec callspec Libffi_abi.(abi_code default_abi) double_ffitype in let dlpow = Ctypes_ptr.Raw.of_nativeint (Dl.dlsym "pow") in let dlpow_fat = make_unmanaged dlpow ~reftyp:Ctypes.(double @-> double @-> returning double) in let pow x y = call "pow" dlpow_fat callspec (fun buffer _values -> write Ctypes_primitive_types.Double x Ctypes_ptr.(make_unmanaged ~reftyp:Ctypes_static.Void (Raw.(add buffer (of_int arg_1_offset)))); write Ctypes_primitive_types.Double y Ctypes_ptr.(make_unmanaged ~reftyp:Ctypes_static.Void (Raw.(add buffer (of_int arg_2_offset))))) (fun p -> read Ctypes_primitive_types.Double (make_unmanaged ~reftyp:Ctypes_static.Void p)) in assert_equal 8.0 (pow 2.0 3.0); assert_equal 1.0 (pow 10.0 0.0); ) let suite = "Raw interface tests" >::: ["test_abs" >:: test_fabs; "test_pow" >:: test_pow ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-jobs/000077500000000000000000000000001445631112600247605ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-jobs/dune000066400000000000000000000024571445631112600256460ustar00rootroot00000000000000(rule (targets generated_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) (rule (targets generated_struct_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) (rule (targets ml-stub-generator.exe) (deps generated_struct_stubs.c ../clib/test_functions.h ../config/test-cflags) (action (run %{cc} %{read-lines:../config/test-cflags} -I ../clib -I %{ocaml-config:standard_library} -o %{targets} generated_struct_stubs.c))) (rule (targets generated_struct_bindings.ml) (deps ml-stub-generator.exe) (action (with-stdout-to %{targets} (run %{deps})))) (library (name test_returning_errno_lwt_jobs_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings generated_struct_bindings) (libraries ctypes test_functions lwt.unix)) (test (name test_returning_errno) (package ctypes-foreign) (modules test_returning_errno) (action (run %{test} -runner sequential)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_returning_errno_lwt_jobs_stubs test_functions test_returning_errno_lwt_jobs_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-jobs/stub-generator/000077500000000000000000000000001445631112600277215ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-jobs/stub-generator/driver.ml000066400000000000000000000007601445631112600315510ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the errno tests. *) let cheader = "#include #include #include #include #include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) ~structs:(module Types.Struct_stubs) ~concurrency:Cstubs.lwt_jobs ~errno:Cstubs.return_errno yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-jobs/stub-generator/dune000066400000000000000000000001631445631112600305770ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_returning_errno_lwt_jobs_stubs tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-jobs/stubs/000077500000000000000000000000001445631112600261205ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-jobs/stubs/dune000066400000000000000000000001331445631112600267730ustar00rootroot00000000000000(library (name test_returning_errno_lwt_jobs_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-jobs/stubs/functions.ml000066400000000000000000000012331445631112600304610ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the Errno tests. *) open Ctypes module Stubs (F: Ctypes.FOREIGN) = struct open F let struct_stat : [`stat] structure typ = structure "stat" let stat = foreign "stat" (string @-> ptr struct_stat @-> returning int) let sixargs = foreign "sixargs" (int @-> int @-> int @-> int @-> int @-> int @-> returning int) let return_10 = foreign "return_10" (void @-> returning int) let return_void = foreign "return_void" (ptr int @-> returning void) end yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-jobs/stubs/types.ml000066400000000000000000000007751445631112600276270ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open PosixTypes module Struct_stubs(S : Ctypes.TYPE) = struct open S let _ENOENT = constant "ENOENT" sint let ifdir = constant "S_IFDIR" (lift_typ mode_t) let ifmt = constant "S_IFMT" (lift_typ mode_t) let stat : [`stat] structure typ = structure "stat" let st_mode = field stat "st_mode" (lift_typ mode_t) let () = seal stat end yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-jobs/test_returning_errno.ml000066400000000000000000000035541445631112600316020ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes [@@@warning "-27"] module Bindings = Functions.Stubs(Generated_bindings) module Constants = Types.Struct_stubs(Generated_struct_bindings) (* Test the binding to "stat". *) let test_stat _ = let s = make Constants.stat in begin Lwt_main.run Lwt.((Bindings.stat "." (addr s)).Generated_bindings.lwt >>= fun (x, errno) -> assert_equal 0 x; assert_equal Signed.SInt.zero errno; return ()); Lwt_main.run Lwt.((Bindings.stat "/does-not-exist" (addr s)).Generated_bindings.lwt >>= fun (x, errno) -> assert_equal (-1) x; assert_equal Constants._ENOENT errno; return ()) end (* Test calling functions with many arguments. *) let test_six_args _ = let open Lwt.Infix in Lwt_main.run ((Bindings.sixargs 1 2 3 4 5 6).Generated_bindings.lwt >>= fun (i, errno) -> assert_equal (1 + 2 + 3 + 4 + 5 + 6) i; Lwt.return ()) (* Test calling functions with no arguments. *) let test_no_args _ = let open Lwt.Infix in Lwt_main.run ((Bindings.return_10 ()).Generated_bindings.lwt >>= fun (i, errno) -> assert_equal 10 i; Lwt.return ()) (* Test calling functions that return void. *) let test_return_void _ = let open Lwt.Infix in Lwt_main.run (let x_p = allocate_n ~count:1 int in (Bindings.return_void x_p).Generated_bindings.lwt >>= fun ((), errno) -> assert_equal 10 (!@ x_p); Lwt.return ()) let suite = "Errno tests" >::: ["calling stat" >:: test_stat; "functions with many arguments" >:: test_six_args; "functions with no arguments" >:: test_no_args; "functions that return void" >:: test_return_void; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-preemptive/000077500000000000000000000000001445631112600262035ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-preemptive/dune000066400000000000000000000025011445631112600270570ustar00rootroot00000000000000(rule (targets generated_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) (rule (targets generated_struct_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) (rule (targets ml-stub-generator.exe) (deps generated_struct_stubs.c ../clib/test_functions.h ../config/test-cflags) (action (run %{cc} %{read-lines:../config/test-cflags} -I ../clib -I %{ocaml-config:standard_library} -o %{targets} generated_struct_stubs.c))) (rule (targets generated_struct_bindings.ml) (deps ml-stub-generator.exe) (action (with-stdout-to %{targets} (run %{deps})))) (library (name test_returning_errno_lwt_preemptive_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings generated_struct_bindings) (libraries ctypes test_functions lwt.unix)) (test (name test_returning_errno) (modules test_returning_errno) (package ctypes-foreign) (action (run %{test} -runner sequential)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_returning_errno_lwt_preemptive_stubs test_functions test_returning_errno_lwt_preemptive_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-preemptive/stub-generator/000077500000000000000000000000001445631112600311445ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-preemptive/stub-generator/driver.ml000066400000000000000000000010071445631112600327670ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the errno / Lwt_preemptive tests. *) let cheader = "#include #include #include #include #include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) ~structs:(module Types.Struct_stubs) ~concurrency:Cstubs.lwt_preemptive ~errno:Cstubs.return_errno yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-preemptive/stub-generator/dune000066400000000000000000000001711445631112600320210ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_returning_errno_lwt_preemptive_stubs tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-preemptive/stubs/000077500000000000000000000000001445631112600273435ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-preemptive/stubs/dune000066400000000000000000000001411445631112600302150ustar00rootroot00000000000000(library (name test_returning_errno_lwt_preemptive_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-preemptive/stubs/functions.ml000066400000000000000000000012541445631112600317070ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the errno / Lwt_preemptive tests. *) open Ctypes module Stubs (F: Ctypes.FOREIGN) = struct open F let struct_stat : [`stat] structure typ = structure "stat" let stat = foreign "stat" (string @-> ptr struct_stat @-> returning int) let sixargs = foreign "sixargs" (int @-> int @-> int @-> int @-> int @-> int @-> returning int) let return_10 = foreign "return_10" (void @-> returning int) let return_void = foreign "return_void" (ptr int @-> returning void) end yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-preemptive/stubs/types.ml000066400000000000000000000007751445631112600310520ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open PosixTypes module Struct_stubs(S : Ctypes.TYPE) = struct open S let _ENOENT = constant "ENOENT" sint let ifdir = constant "S_IFDIR" (lift_typ mode_t) let ifmt = constant "S_IFMT" (lift_typ mode_t) let stat : [`stat] structure typ = structure "stat" let st_mode = field stat "st_mode" (lift_typ mode_t) let () = seal stat end yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno-lwt-preemptive/test_returning_errno.ml000066400000000000000000000035541445631112600330250ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes [@@@warning "-27"] module Bindings = Functions.Stubs(Generated_bindings) module Constants = Types.Struct_stubs(Generated_struct_bindings) (* Test the binding to "stat". *) let test_stat _ = let s = make Constants.stat in begin Lwt_main.run Lwt.((Bindings.stat "." (addr s)).Generated_bindings.lwt >>= fun (x, errno) -> assert_equal 0 x; assert_equal Signed.SInt.zero errno; return ()); Lwt_main.run Lwt.((Bindings.stat "/does-not-exist" (addr s)).Generated_bindings.lwt >>= fun (x, errno) -> assert_equal (-1) x; assert_equal Constants._ENOENT errno; return ()) end (* Test calling functions with many arguments. *) let test_six_args _ = let open Lwt.Infix in Lwt_main.run ((Bindings.sixargs 1 2 3 4 5 6).Generated_bindings.lwt >>= fun (i, errno) -> assert_equal (1 + 2 + 3 + 4 + 5 + 6) i; Lwt.return ()) (* Test calling functions with no arguments. *) let test_no_args _ = let open Lwt.Infix in Lwt_main.run ((Bindings.return_10 ()).Generated_bindings.lwt >>= fun (i, errno) -> assert_equal 10 i; Lwt.return ()) (* Test calling functions that return void. *) let test_return_void _ = let open Lwt.Infix in Lwt_main.run (let x_p = allocate_n ~count:1 int in (Bindings.return_void x_p).Generated_bindings.lwt >>= fun ((), errno) -> assert_equal 10 (!@ x_p); Lwt.return ()) let suite = "Errno tests" >::: ["calling stat" >:: test_stat; "functions with many arguments" >:: test_six_args; "functions with no arguments" >:: test_no_args; "functions that return void" >:: test_return_void; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno/000077500000000000000000000000001445631112600232215ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno/dune000066400000000000000000000024241445631112600241010ustar00rootroot00000000000000(rule (targets generated_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) (rule (targets generated_struct_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) (rule (targets ml-stub-generator.exe) (deps generated_struct_stubs.c ../clib/test_functions.h ../config/test-cflags) (action (run %{cc} %{read-lines:../config/test-cflags} -I ../clib -I %{ocaml-config:standard_library} -o %{targets} generated_struct_stubs.c))) (rule (targets generated_struct_bindings.ml) (deps ml-stub-generator.exe) (action (with-stdout-to %{targets} (run %{deps})))) (library (name test_returning_errno_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings generated_struct_bindings) (libraries ctypes test_functions lwt.unix)) (test (name test_returning_errno) (modules test_returning_errno) (action (run %{test} -runner sequential)) (package ctypes-foreign) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_returning_errno_stubs test_functions test_returning_errno_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno/stub-generator/000077500000000000000000000000001445631112600261625ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno/stub-generator/driver.ml000066400000000000000000000007171445631112600300140ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the errno tests. *) let cheader = "#include #include #include #include #include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) ~structs:(module Types.Struct_stubs) ~errno:Cstubs.return_errno yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno/stub-generator/dune000066400000000000000000000001521445631112600270360ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_returning_errno_stubs tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno/stubs/000077500000000000000000000000001445631112600243615ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno/stubs/dune000066400000000000000000000001221445631112600252320ustar00rootroot00000000000000(library (name test_returning_errno_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno/stubs/functions.ml000066400000000000000000000006361445631112600267300ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the Errno tests. *) open Ctypes module Stubs (F: Ctypes.FOREIGN) = struct open F let struct_stat : [`stat] structure typ = structure "stat" let stat = foreign "stat" (string @-> ptr struct_stat @-> returning int) end yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno/stubs/types.ml000066400000000000000000000007751445631112600260700ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open PosixTypes module Struct_stubs(S : Ctypes.TYPE) = struct open S let _ENOENT = constant "ENOENT" sint let ifdir = constant "S_IFDIR" (lift_typ mode_t) let ifmt = constant "S_IFMT" (lift_typ mode_t) let stat : [`stat] structure typ = structure "stat" let st_mode = field stat "st_mode" (lift_typ mode_t) let () = seal stat end yallop-ocaml-ctypes-3f8211a/tests/test-returning-errno/test_returning_errno.ml000066400000000000000000000013611445631112600300350ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes module Bindings = Functions.Stubs(Generated_bindings) module Constants = Types.Struct_stubs(Generated_struct_bindings) (* Test the binding to "stat". *) let test_stat _ = let st = make Constants.stat in begin let x, errno = Bindings.stat "." (addr st) in assert_equal 0 x; assert_equal Signed.SInt.zero errno; let x, errno = Bindings.stat "/does-not-exist" (addr st) in assert_equal (-1) x; assert_equal Constants._ENOENT errno; end let suite = "Errno tests" >::: ["calling stat" >:: test_stat; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-roots/000077500000000000000000000000001445631112600212275ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-roots/dune000066400000000000000000000001751445631112600221100ustar00rootroot00000000000000(test (name test_roots) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (libraries ctypes ctypes-foreign ounit2)) yallop-ocaml-ctypes-3f8211a/tests/test-roots/test_roots.ml000066400000000000000000000047361445631112600240000ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes open Foreign let testlib = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) (* Test root lifetime. *) let test_root_lifetime _ = (* Check that values not registered as roots are collected. *) let alive = ref true in let () = let v = [| 1; 2; 3 |] in Gc.finalise (fun _ -> alive := false) v; in Gc.full_major (); assert_equal false !alive ~msg:"values not registered as roots are collected"; (* Check that values registered as roots are not collected. *) let alive = ref true in let _r = let v = [| 1; 2; 3 |] in Gc.finalise (fun _ -> alive := false) v; Root.create v in Gc.full_major (); assert_equal true !alive ~msg:"registered roots are not collected"; (* Check that values unregistered as roots are collected. *) let alive = ref true in let r = let v = [| 1; 2; 3 |] in Gc.finalise (fun _ -> alive := false) v; Root.create v in Root.release r; Gc.full_major (); assert_equal false !alive ~msg:"released roots are collected"; (* Check that values assigned to roots are not collected. *) let alive = ref true in let () = let v = [| 1; 2; 3 |] in Gc.finalise (fun _ -> alive := false) v; let r = Root.create () in Root.set r v; in Gc.full_major (); assert_equal true !alive ~msg:"values assigned to roots are not collected"; (* Check that values registered as roots and then overwritten are collected. *) let alive = ref true in let r = let v = [| 1; 2; 3 |] in Gc.finalise (fun _ -> alive := false) v; Root.create v in Root.set r (); Gc.full_major (); assert_equal false !alive ~msg:"overwritten roots are collected"; () (* Test passing roots to C functions. *) let test_passing_roots _ = let save = foreign ~from:testlib "save_ocaml_value" (ptr void @-> returning void) and retrieve = foreign ~from:testlib "retrieve_ocaml_value" (void @-> returning (ptr void)) in let r = Root.create [| ( + ) 1; ( * ) 2 |] in begin save r; Gc.full_major (); let fs : (int -> int) array = Root.get (retrieve ()) in assert_equal 11 (fs.(0) 10); assert_equal 20 (fs.(1) 10) end let suite = "Root tests" >::: ["root lifetime" >:: test_root_lifetime; "passing roots" >:: test_passing_roots; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-sizeof/000077500000000000000000000000001445631112600213605ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-sizeof/dune000066400000000000000000000001371445631112600222370ustar00rootroot00000000000000(test (name test_sizeof) (package ctypes-foreign) (libraries ctypes ctypes-foreign ounit2)) yallop-ocaml-ctypes-3f8211a/tests/test-sizeof/test_sizeof.ml000066400000000000000000000160621445631112600242550ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes [@@@warning "-27-32"] (* Test some relationships between the sizes of primitive types. *) let test_sizeof_primitives _ = begin assert_equal ~msg:"sizeof (char) == 1" (sizeof char) 1; assert_equal ~msg:"sizeof (unsigned char) == 1" (sizeof uchar) 1; assert_equal ~msg:"sizeof (signed char) == 1" (sizeof schar) 1; assert_bool "sizeof (char) <= sizeof (int)" (sizeof char <= sizeof int); assert_bool "sizeof (float) <= sizeof (double)" (sizeof float <= sizeof double); assert_bool "sizeof (double) <= sizeof (long double)" (sizeof double <= sizeof ldouble); assert_bool "sizeof (short) <= sizeof (int)" (sizeof short <= sizeof int); assert_bool "sizeof (int) <= sizeof (long)" (sizeof int <= sizeof long); assert_bool "sizeof (long) <= sizeof (long long)" (sizeof long <= sizeof llong); assert_bool "sizeof (double complex) <= sizeof (long double complex)" (sizeof complex64 <= sizeof complexld); assert_equal ~msg:"2 * sizeof (int32_t) == sizeof (int64_t)" (2 * sizeof int32_t) (sizeof int64_t); assert_equal ~msg:"2 * sizeof (int16_t) == sizeof (int32_t)" (2 * sizeof int16_t) (sizeof int32_t); assert_equal ~msg:"2 * sizeof (int8_t) == sizeof (int16_t)" (2 * sizeof int8_t) (sizeof int16_t); assert_bool "sizeof (int16_t) <= sizeof (int)" (sizeof int16_t <= sizeof int); assert_bool "sizeof (int32_t) <= sizeof (long)" (sizeof int32_t <= sizeof long); assert_bool "sizeof (int64_t) <= sizeof (long long)" (sizeof int64_t <= sizeof llong); assert_equal ~msg:"sizeof (short) == sizeof (unsigned short)" (sizeof short) (sizeof ushort); assert_equal ~msg:"sizeof (int) == sizeof (unsigned int)" (sizeof int) (sizeof uint); assert_equal ~msg:"sizeof (long) == sizeof (unsigned long)" (sizeof long) (sizeof ulong); assert_equal ~msg:"sizeof (long long) == sizeof (unsigned long long)" (sizeof llong) (sizeof ullong); end (* Test some properties of the sizes of unions. *) let test_sizeof_unions _ = let int_char = union "int_char" in let _ = field int_char "_" int in let _ = field int_char "_" char in let _ = seal int_char in assert_equal (sizeof int) (sizeof int_char); let char17 = union "char17" in let _ = field char17 "_" (array 17 char) in let _ = seal char17 in assert_equal 17 (sizeof char17) (* Test some properties of the sizes of structs. *) let test_sizeof_structs _ = let module M = struct (* We don't expect homogeneous structs consisting of words to have any padding. *) type h let () = for i = 1 to 10 do let homogeneous : h structure typ = structure "h" in for _j = 1 to i do ignore (field homogeneous "_" int); done; seal homogeneous; assert_equal (i * sizeof int) (sizeof homogeneous) done end in () (* Test the size of abstract types. *) let test_sizeof_abstract _ = for i = 1 to 10 do assert_equal i (sizeof (abstract ~name:"abstract" ~size:i ~alignment:(11 - i))) done (* Test that taking the size of an incomplete type is treated as an error. *) let test_sizeof_incomplete _ = begin assert_raises IncompleteType (fun () -> sizeof (structure "incomplete")); assert_raises IncompleteType (fun () -> sizeof (union "incomplete")); end (* Test that taking the size of void is treated as an error. *) let test_sizeof_void _ = assert_raises IncompleteType (fun () -> sizeof void) (* Test that [sizeof] treats OCaml types as incomplete. *) let test_sizeof_ocaml_string _ = assert_raises IncompleteType (fun () -> sizeof ocaml_string) (* Test the behaviour of sizeof on array types. *) let test_sizeof_arrays _ = begin assert_equal ~msg:"The size of an array is the sum of the size of its members" (12 * (sizeof int8_t)) (sizeof (array 12 int8_t)); assert_equal ~msg:"Arrays of arrays are correctly sized" (5 * 7 * (sizeof nativeint)) (sizeof (array 7 (array 5 nativeint))) end (* Test the behaviour of sizeof on bigarray types. *) let test_sizeof_bigarrays _ = let module M = struct module B = Bigarray_compat type k = K : ('a, 'b) Bigarray_compat.kind * int -> k let kind_sizes = [ K (B.float32, 4); K (B.float64, 8); K (B.int8_signed, 1); K (B.int8_unsigned, 1); K (B.int16_signed, 2); K (B.int16_unsigned, 2); K (B.int32, 4); K (B.int64, 8); K (B.int, sizeof (ptr void)); K (B.nativeint, sizeof (ptr void)); K (B.complex32, 8); K (B.complex64, 16); K (B.char, 1); ] let () = begin (* Genarray.t sizes *) List.iter (fun (K (kind, size)) -> assert_equal (2 * 3 * 5 * size) (sizeof (bigarray genarray [|2; 3; 5|] kind))) kind_sizes; (* Array1.t sizes *) List.iter (fun (K (kind, size)) -> assert_equal (7 * size) (sizeof (bigarray array1 7 kind))) kind_sizes; (* Array2.t sizes *) List.iter (fun (K (kind, size)) -> assert_equal (2 * 3 * size) (sizeof (bigarray array2 (2, 3) kind))) kind_sizes; (* Array3.t sizes *) List.iter (fun (K (kind, size)) -> assert_equal (2 * 3 * 5 * size) (sizeof (bigarray array3 (2, 3, 5) kind))) kind_sizes; end end in () (* Test that all pointers have equal size. *) let test_sizeof_pointers _ = begin let pointer_size = sizeof (ptr void) in assert_equal pointer_size (sizeof (ptr void)); assert_equal pointer_size (sizeof (ptr int)); assert_equal pointer_size (sizeof (Foreign.funptr (int @-> returning int))); assert_equal pointer_size (sizeof (ptr (ptr void))); let module M = struct type t let t : t structure typ = structure "t" let c = field t "c" int let f = field t "f" double let () = seal t end in assert_equal pointer_size (sizeof (ptr M.t)) end (* Test that the size of a view type is the same as the underlying type. *) let test_sizeof_views _ = begin let const c x = c in let vint = view ~read:(const [1]) ~write:(const 0) int and vchar = view ~read:(const ["1"]) ~write:(const 'a') char and vvoid = view ~read:(const (fun () -> ())) ~write:(const ()) void in assert_equal (sizeof int) (sizeof vint); assert_equal (sizeof char) (sizeof vchar); assert_raises IncompleteType (fun () -> sizeof vvoid); end let suite = "sizeof tests" >::: ["sizeof primitives" >:: test_sizeof_primitives; "sizeof structs" >:: test_sizeof_structs; "sizeof unions" >:: test_sizeof_unions; "sizeof abstract" >:: test_sizeof_abstract; "sizeof incomplete" >:: test_sizeof_incomplete; "sizeof void" >:: test_sizeof_void; "sizeof considers ocaml_string incomplete" >:: test_sizeof_ocaml_string; "sizeof arrays" >:: test_sizeof_arrays; "sizeof bigarrays" >:: test_sizeof_bigarrays; "sizeof pointers" >:: test_sizeof_pointers; "sizeof views" >:: test_sizeof_views; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-structs/000077500000000000000000000000001445631112600215705ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-structs/dune000066400000000000000000000024771445631112600224600ustar00rootroot00000000000000(rule (targets generated_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) (rule (targets generated_struct_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) (rule (targets ml-stub-generator.exe) (deps generated_struct_stubs.c ../clib/test_functions.h ../config/test-cflags) (action (run %{cc} %{read-lines:../config/test-cflags} -I ../clib -I %{ocaml-config:standard_library} -o %{targets} generated_struct_stubs.c))) (rule (targets generated_struct_bindings.ml) (deps ml-stub-generator.exe) (action (with-stdout-to %{targets} (run %{deps})))) (library (name test_structs_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings generated_struct_bindings) (libraries ctypes test_functions lwt.unix)) (test (name test_structs) (modules test_structs) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (action (run %{test} -runner sequential)) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_structs_stubs test_functions test_structs_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-structs/stub-generator/000077500000000000000000000000001445631112600245315ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-structs/stub-generator/driver.ml000066400000000000000000000004601445631112600263560ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the struct tests. *) let () = Tests_common.run Sys.argv ~structs:(module Types.Struct_stubs) (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-structs/stub-generator/dune000066400000000000000000000001421445631112600254040ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_structs_stubs tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-structs/stubs/000077500000000000000000000000001445631112600227305ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-structs/stubs/dune000066400000000000000000000001311445631112600236010ustar00rootroot00000000000000(library (name test_structs_stubs) (wrapped false) (libraries ctypes ctypes-foreign)) yallop-ocaml-ctypes-3f8211a/tests/test-structs/stubs/functions.ml000066400000000000000000000035631445631112600253010ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the struct tests. *) open Ctypes (* These functions can be bound either dynamically using Foreign or statically using stub generation. *) module Common (F: Ctypes.FOREIGN) = struct open F type simple let simple : simple structure typ = structure "simple" let i = field simple "i" int let f = field simple "f" double let self = field simple "self" (ptr simple) let () = seal simple let accept_struct = foreign "accept_struct" (simple @-> returning int) let return_struct = foreign "return_struct" (void @-> returning simple) (* Forward declarations *) let s1 : [`s1] structure typ = structure "s1" and s5 : [`s5] structure typ = structure "s5" let call_s5 = foreign "call_s5" (ptr s1 @-> ptr s5 @-> returning int); end (* These functions can only be bound using stub generation, since Foreign doesn't support passing structs with union or array members. *) module Stubs_only(F : Ctypes.FOREIGN) = struct open F type number let number : number union typ = union "number" let i = field number "i" int let d = field number "d" double let () = seal number type tagged let tagged : tagged structure typ = structure "tagged" let tag = field tagged "tag" char let num = field tagged "num" number let () = seal tagged type triple let triple : triple structure typ = structure "triple" let elements = field triple "elements" (array 3 double) let () = seal triple let add_tagged_numbers = foreign "add_tagged_numbers" (tagged @-> tagged @-> returning tagged) let add_triples = foreign "add_triples" (triple @-> triple @-> returning triple) end module Stubs (F: Ctypes.FOREIGN) = struct include Common(F) include Stubs_only(F) end yallop-ocaml-ctypes-3f8211a/tests/test-structs/stubs/types.ml000066400000000000000000000025371445631112600244350ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes module Struct_stubs(S : Ctypes.TYPE) = struct open S (* missing fields *) let s1 : [`s1] structure typ = structure "s1" let x1 = field s1 "x1" int let x4 = field s1 "x4" int let () = seal s1 (* fields reordered *) let s2 : [`s2] structure typ = structure "s2" let y2 = field s2 "y2" int let y1 = field s2 "y1" int let () = seal s2 (* one struct depending on another *) let s3 : [`s3] structure typ = structure "s3" let z1 = field s3 "z1" int let z2 = field s3 "z2" (ptr s3) let () = seal s3 let s4 : [`s4] structure typ = structure "s4" let z3 = field s4 "z3" s3 let z4 = field s4 "z4" (ptr s3) let () = seal s4 (* dependencies involving function pointers *) (* (incomplete types are available in the present) *) let s1_fwd : [`s1] Ctypes.structure Ctypes.typ = Ctypes.structure "s1" let s5 : [`s5] structure typ = structure "s5" let w1 = field s5 "w1" (lift_typ (Foreign.funptr Ctypes.(ptr s1_fwd @-> returning int))) let () = seal s5 (* adding fields through views (typedefs) *) let struct_s6 : [`s6] structure typ = structure "" let s6 = typedef struct_s6 "s6" let v1 = field s6 "v1" int let v2 = field s6 "v2" float let () = seal s6 end yallop-ocaml-ctypes-3f8211a/tests/test-structs/test_structs.ml000066400000000000000000000410531445631112600246730ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@warning "-32-33-34"] open OUnit2 open Ctypes let testlib = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) module Build_foreign_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Common(S) open M (* Call a function of type void (struct simple) where struct simple { int i; double f; struct simple *self; }; *) let test_passing_struct _ = let module M = struct let s = make simple let () = begin setf s i 10; setf s f 14.5; setf s self (from_voidp simple null) end let v = accept_struct s let () = assert_equal 25 v ~printer:string_of_int end in () (* Call a function of type struct simple(void) where struct simple { int i; double f; struct simple *self; }; *) let test_returning_struct _ = let module M = struct let s = return_struct () let () = assert_equal 20 (getf s i) let () = assert_equal 35.0 (getf s f) let t = getf s self let () = assert_equal 10 !@(t |-> i) ~printer:string_of_int let () = assert_equal 12.5 !@(t |-> f) ~printer:string_of_float let () = assert_equal (to_voidp !@(t |-> self)) (to_voidp t) end in () end (* Check that attempts to use incomplete types for struct members are rejected. *) let test_incomplete_struct_members _ = let s = structure "s" in begin assert_raises IncompleteType (fun () -> field s "_" void); assert_raises IncompleteType (fun () -> field s "_" (structure "incomplete")); assert_raises IncompleteType (fun () -> field s "_" (union "incomplete")); end (* Test that fields can be added to views over structs. *) let test_adding_fields_through_views _ = let module M = struct let struct_s = structure "struct_s" let s = typedef struct_s "s" let i = field s "i" int let j = field s "j" float let () = seal s end in () (* Test that OCaml types cannot be used as struct or union fields. *) let test_ocaml_types_rejected_as_fields _ = let module M = struct let s = structure "s" let () = assert_raises IncompleteType (fun () -> field s "o" ocaml_string) let u = union "u" let () = assert_raises IncompleteType (fun () -> let _ = field u "o" ocaml_string in (* The error is currently only caught on sealing the union *) seal u) end in () (* Test reading and writing pointers to struct members. *) let test_pointers_to_struct_members _ = let module M = struct type s let styp : s structure typ = structure "s" let (-:) ty label = field styp label ty let i = int -: "i" let j = int -: "j" let k = ptr int -: "k" let () = seal styp let s = make styp let () = begin let sp = addr s in sp |-> i <-@ 10; sp |-> j <-@ 20; (sp |-> k) <-@ (sp |-> i); assert_equal ~msg:"sp->i = 10" ~printer:string_of_int 10 (!@(sp |-> i)); assert_equal ~msg:"sp->j = 20" ~printer:string_of_int 20 (!@(sp |-> j)); assert_equal ~msg:"*sp->k = 10" ~printer:string_of_int 10 (!@(!@(sp |-> k))); (sp |-> k) <-@ (sp |-> j); assert_equal ~msg:"*sp->k = 20" ~printer:string_of_int 20 (!@(!@(sp |-> k))); sp |-> i <-@ 15; sp |-> j <-@ 25; assert_equal ~msg:"*sp->k = 25" ~printer:string_of_int 25 (!@(!@(sp |-> k))); (sp |-> k) <-@ (sp |-> i); assert_equal ~msg:"*sp->k = 15" ~printer:string_of_int 15 (!@(!@(sp |-> k))); end end in () (* Test structs with union members. *) let test_structs_with_union_members _ = let module M = struct type u and s let complex64_eq = let open Complex in let eps = 1e-12 in fun { re = lre; im = lim } { re = rre; im = rim } -> abs_float (lre -. rre) < eps && abs_float (lim -. rim) < eps let utyp : u union typ = union "u" let (-:) ty label = field utyp label ty let uc = char -: "uc" let ui = int -: "ui" let uz = complex64 -: "uz" let () = seal utyp let u = make utyp let () = begin setf u ui 14; assert_equal ~msg:"u.ui = 14" ~printer:string_of_int 14 (getf u ui); setf u uc 'x'; assert_equal ~msg:"u.uc = 'x'" ~printer:(String.make 1) 'x' (getf u uc); setf u uz { Complex.re = 5.55; im = -3.3 }; assert_equal ~msg:"u.uz = 5.55 - 3.3i" ~cmp:complex64_eq ~printer:(fun z -> Printf.sprintf "{re=%f; im=%f}" z.Complex.re z.Complex.im) { Complex.re = 5.55; im = -3.3 } (getf u uz); end let styp : s structure typ = structure "s" let (-:) ty label = field styp label ty let si = int -: "si" let su = utyp -: "su" let sc = char -: "sc" let () = seal styp let s = make styp let () = begin setf s si 22; setf s su u; setf s sc 'z'; assert_equal ~msg:"s.si = 22" ~printer:string_of_int 22 (getf s si); assert_equal ~msg:"s.su.uc = 0.0 - 3.3i" ~cmp:complex64_eq { Complex.re = 5.55; im = -3.3 } (getf (getf s su) uz); assert_equal ~msg:"s.sc = 'z'" ~printer:(String.make 1) 'z' (getf s sc); end end in () (* Test structs with array members. *) let test_structs_with_array_members _ = let module M = struct type u and s let styp : s structure typ = structure "s" let (-:) ty label = field styp label ty let i = int -: "i" let a = array 3 double -: "a" let c = char -: "c" let () = seal styp let s = make styp module Array = CArray let arr = Array.of_list double [3.3; 4.4; 5.5] let () = begin setf s i 22; setf s a arr; setf s c 'z'; assert_equal ~msg:"s.i = 22" ~printer:string_of_int 22 (getf s i); assert_equal ~msg:"s.a[0] = 3.3" ~printer:string_of_float 3.3 (getf s a).(0); assert_equal ~msg:"s.a[0] = 3.3" ~printer:string_of_float 3.3 (getf s a).(0); assert_equal ~msg:"s.a[1] = 4.4" ~printer:string_of_float 4.4 (getf s a).(1); assert_equal ~msg:"s.a[2] = 5.5" ~printer:string_of_float 5.5 (getf s a).(2); assert_raises (Invalid_argument "index out of bounds") (fun () -> (getf s a).(3)); assert_equal ~msg:"s.c = 'z'" ~printer:(String.make 1) 'z' (getf s c); (* References to the array member should alias the original *) let arr' = getf s a in arr'.(0) <- 13.3; arr'.(1) <- 24.4; arr'.(2) <- 35.5; assert_equal ~msg:"s.a[0] = 13.3" ~printer:string_of_float 13.3 (getf s a).(0); assert_equal ~msg:"s.a[1] = 24.4" ~printer:string_of_float 24.4 (getf s a).(1); assert_equal ~msg:"s.a[2] = 35.5" ~printer:string_of_float 35.5 (getf s a).(2); end end in () (* Test that attempting to update a sealed struct is treated as an error. *) let test_updating_sealed_struct _ = let styp = structure "sealed" in let _ = field styp "_" int in let () = seal styp in assert_raises (ModifyingSealedType "sealed") (fun () -> field styp "_" char) (* Test that attempting to seal an empty struct is treated as an error. *) let test_sealing_empty_struct _ = let empty = structure "empty" in assert_raises (Unsupported "struct with no fields") (fun () -> seal empty) (* Check that references to fields aren't garbage collected while they're still needed. *) let test_field_references_not_invalidated _ = let module M = struct type s1 and s2 (* struct s1 { struct s2 { int i; } s2; }; *) let s1 : s1 structure typ = structure "s1" let () = (fun () -> let s2 : s2 structure typ = structure "s2" in let _ = field s2 "i" int in let () = seal s2 in let _ = field s1 "_" s2 in () ) () let () = begin Gc.full_major (); seal s1; assert_equal ~printer:string_of_int (sizeof int) (sizeof s1) end end in () (* Check that references to ffi_type values for structs aren't collected while they're still needed *) let test_struct_ffi_type_lifetime _ = let module M = struct let f = let t = void @-> returning (begin let s = structure "one_int" in let _ = field s "i" int in let () = seal s in s end) in Foreign.foreign ~from:testlib "return_struct_by_value" t let () = Gc.full_major() let x = f () end in () module Build_stub_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct open Functions include Build_foreign_tests(S) module N = Functions.Stubs(S) open N (* Test passing structs with union members. *) let test_passing_structs_with_union_members _ = let mkInt v = let t = make tagged in t @. tag <-@ 'i'; (t @. num |-> i) <-@ v; t and mkDbl v = let t = make tagged in t @. tag <-@ 'd'; (t @. num |-> d) <-@ v; t and readDbl t = assert_equal 'd' !@(t @. tag); !@(t @. num |-> d) in begin assert_equal 10.0 (readDbl (add_tagged_numbers (mkInt 3) (mkInt 7))); assert_equal 10.0 (readDbl (add_tagged_numbers (mkInt 3) (mkDbl 7.0))); assert_equal 10.0 (readDbl (add_tagged_numbers (mkDbl 3.0) (mkInt 7))); assert_equal 10.0 (readDbl (add_tagged_numbers (mkDbl 3.0) (mkDbl 7.0))); end (* Test passing structs with array members. *) let test_passing_structs_with_array_members _ = let mkTriple (x, y, z) = let t = make triple in t @. elements <-@ CArray.of_list double [x; y; z]; t and readTriple t = match CArray.to_list (getf t elements) with | [x; y; z] -> (x, y, z) | _ -> assert false in begin assert_equal (10.0, 20.0, 30.0) (readTriple (add_triples (mkTriple (5.0, 12.0, 17.0)) (mkTriple (5.0, 8.0, 13.0)))) end end module Foreign_tests = Build_foreign_tests(Tests_common.Foreign_binder) module Stub_tests = Build_stub_tests(Generated_bindings) module Build_struct_stub_tests (S : Ctypes.TYPE with type 'a typ = 'a Ctypes.typ and type ('a, 's) field = ('a, 's) Ctypes.field) = struct module M = Types.Struct_stubs(S) let retrieve_size name = let f = Foreign.foreign ~from:testlib name (void @-> returning size_t) in Unsigned.Size_t.to_int (f ()) let sizeof_s1 = retrieve_size "sizeof_s1" let alignmentof_s1 = retrieve_size "alignmentof_s1" let offsetof_x1 = retrieve_size "offsetof_x1" let offsetof_x2 = retrieve_size "offsetof_x2" let offsetof_x3 = retrieve_size "offsetof_x3" let offsetof_x4 = retrieve_size "offsetof_x4" let sizeof_s2 = retrieve_size "sizeof_s2" let alignmentof_s2 = retrieve_size "alignmentof_s2" let offsetof_y1 = retrieve_size "offsetof_y1" let offsetof_y2 = retrieve_size "offsetof_y2" let offsetof_y3 = retrieve_size "offsetof_y3" let offsetof_y4 = retrieve_size "offsetof_y4" let sizeof_s3 = retrieve_size "sizeof_s3" let alignmentof_s3 = retrieve_size "alignmentof_s3" let offsetof_z1 = retrieve_size "offsetof_z1" let offsetof_z2 = retrieve_size "offsetof_z2" let sizeof_s4 = retrieve_size "sizeof_s4" let alignmentof_s4 = retrieve_size "alignmentof_s4" let offsetof_z3 = retrieve_size "offsetof_z3" let offsetof_z4 = retrieve_size "offsetof_z4" let sizeof_s6 = retrieve_size "sizeof_s6" let alignmentof_s6 = retrieve_size "alignmentof_s6" let offsetof_v1 = retrieve_size "offsetof_v1" let offsetof_v2 = retrieve_size "offsetof_v2" (* Test that struct layout retrieved from C correctly accounts for missing fields. *) let test_missing_fields _ = begin assert_equal sizeof_s1 (sizeof M.s1); assert_equal alignmentof_s1 (alignment M.s1); assert_equal offsetof_x1 (offsetof M.x1); assert_equal offsetof_x4 (offsetof M.x4); end (* Test that struct layout retrieved from C correctly accounts for reordered fields. *) let test_reordered_fields _ = begin assert_equal sizeof_s2 (sizeof M.s2); assert_equal alignmentof_s2 (alignment M.s2); assert_equal offsetof_y1 (offsetof M.y1); assert_equal offsetof_y2 (offsetof M.y2); end (* Test that we can retrieve information about multiple structs with dependencies between them. *) let test_struct_dependencies _ = begin assert_equal sizeof_s3 (sizeof M.s3); assert_equal alignmentof_s3 (alignment M.s3); assert_equal offsetof_z1 (offsetof M.z1); assert_equal offsetof_z2 (offsetof M.z2); assert_equal sizeof_s4 (sizeof M.s4); assert_equal alignmentof_s4 (alignment M.s4); assert_equal offsetof_z3 (offsetof M.z3); assert_equal offsetof_z4 (offsetof M.z4); end (* Test that we can retrieve information for structs without tags that are identified through typedefs, e.g. typedef struct { int x; float y; } t; *) let test_tagless_structs _ = begin assert_equal sizeof_s6 (sizeof M.s6); assert_equal alignmentof_s6 (alignment M.s6); assert_equal offsetof_v1 (offsetof M.v1); assert_equal offsetof_v2 (offsetof M.v2); end module Build_call_tests (F : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module F = Functions.Common(F) open F open M let callback p = !@(p |-> x1) + !@(p |-> x4) (* Call a function passing two structs, one of which contains a function pointer which accepts an argument to the other. This is mostly testing that we can support complex dependencies together with retrieved layout. *) let test_struct_dependencies _ = let v5 = make s5 in let v1 = make s1 in begin setf v1 x1 10; setf v1 x4 20; setf v5 w1 callback; assert_equal 30 (call_s5 (addr v1) (addr v5)) ~printer:string_of_int; end end end module Struct_stubs_tests = Build_struct_stub_tests(Generated_struct_bindings) module Combined_foreign_tests = Struct_stubs_tests.Build_call_tests(Tests_common.Foreign_binder) module Combined_stub_tests = Struct_stubs_tests.Build_call_tests(Generated_bindings) let suite = "Struct tests" >::: ["passing struct (foreign)" >:: Foreign_tests.test_passing_struct; "passing struct (stubs)" >:: Stub_tests.test_passing_struct; "returning struct (foreign)" >:: Foreign_tests.test_returning_struct; "returning struct (stubs)" >:: Stub_tests.test_returning_struct; "struct dependencies (foreign)" >:: Combined_foreign_tests.test_struct_dependencies; "struct dependencies (stubs)" >:: Combined_stub_tests.test_struct_dependencies; "incomplete struct members rejected" >:: test_incomplete_struct_members; "fields can be added to views over structs" >:: test_adding_fields_through_views; "ocaml_string cannot be used as a structure field" >:: test_ocaml_types_rejected_as_fields; "pointers to struct members" >:: test_pointers_to_struct_members; "structs with union members" >:: test_structs_with_union_members; "passing structs with union members (stubs)" >:: Stub_tests.test_passing_structs_with_union_members; "passing structs with array members (stubs)" >:: Stub_tests.test_passing_structs_with_array_members; "structs with array members" >:: test_structs_with_array_members; "updating sealed struct" >:: test_updating_sealed_struct; "sealing empty struct" >:: test_sealing_empty_struct; "field references not invalidated" >:: test_field_references_not_invalidated; "test struct ffi_type lifetime" >:: test_struct_ffi_type_lifetime; "test layout of structs with missing fields" >:: Struct_stubs_tests.test_missing_fields; "test layout of structs with reordered fields" >:: Struct_stubs_tests.test_reordered_fields; "test retrieving information about structs with dependencies" >:: Struct_stubs_tests.test_struct_dependencies; "test adding fields to tagless structs" >:: Struct_stubs_tests.test_tagless_structs; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-stubs/000077500000000000000000000000001445631112600212215ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-stubs/dune000066400000000000000000000001271445631112600220770ustar00rootroot00000000000000(test (name test_stubs) (package ctypes-foreign) (libraries ctypes-foreign ounit2)) yallop-ocaml-ctypes-3f8211a/tests/test-stubs/test_stubs.ml000066400000000000000000000012651445631112600237560ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes open Foreign let missing = "_60d2dd04_1b66_4b79_a2ea_8375157da563" let test_missing _ = let miss = foreign missing ~stub:true (int @-> int @-> (returning int)) in begin try ignore (miss 2 3); assert_failure "should raise" with _exn -> () end; try let _miss = foreign missing ~stub:false (int @-> int @-> (returning int)) in assert_failure "should raise" with _exn -> () let suite = "Foreign value stubs" >::: [ "missing symbols" >:: test_missing; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-threads/000077500000000000000000000000001445631112600215135ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-threads/dune000066400000000000000000000004041445631112600223670ustar00rootroot00000000000000(test (name test_threads) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_threads_stubs test_threads_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-threads/stub-generator/000077500000000000000000000000001445631112600244545ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-threads/stub-generator/driver.ml000066400000000000000000000004431445631112600263020ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the threads tests. *) let () = Tests_common.run ~concurrency:Cstubs.unlocked Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-threads/stub-generator/dune000066400000000000000000000007261445631112600253370ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_threads_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_threads_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-threads/stubs/000077500000000000000000000000001445631112600226535ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-threads/stubs/dune000066400000000000000000000001121445631112600235230ustar00rootroot00000000000000(library (name test_threads_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-threads/stubs/functions.ml000066400000000000000000000007701445631112600252210ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the threads tests. *) open Ctypes module Stubs(F: Ctypes.FOREIGN) = struct open F let initialize_waiters = foreign "initialize_waiters" (void @-> returning void) let post1_wait2 = foreign "post1_wait2" (void @-> returning void) let post2_wait1 = foreign "post2_wait1" (void @-> returning void) end yallop-ocaml-ctypes-3f8211a/tests/test-threads/test_threads.ml000066400000000000000000000106371445631112600245450ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) [@@@warning "-33-35"] open Ctypes open OUnit2 open Foreign let () = (* temporary workaround due to flexlink limitations *) if Sys.os_type = "Win32" then ignore (Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW])) let callback_with_pointers = Foreign.foreign "passing_pointers_to_callback" ~release_runtime_lock:true (Foreign.funptr ~runtime_lock:true (ptr int @-> ptr int @-> returning int) @-> returning int) module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) (* Ensure that passing ~release_runtime_lock releases the runtime lock. *) let test_release_runtime_lock _ = begin M.initialize_waiters (); let t1 = Thread.create M.post1_wait2 () in let t2 = Thread.create M.post2_wait1 () in Thread.join t1; Thread.join t2; end end module Foreign_tests = Common_tests(struct type 'a fn = 'a Ctypes.fn type 'a return = 'a let (@->) = Ctypes.(@->) let returning = Ctypes.returning type 'a result = 'a let foreign name fn = Foreign.foreign name fn ~release_runtime_lock:true let foreign_value name fn = Foreign.foreign_value name fn end) module Stub_tests = Common_tests(Generated_bindings) (* Ensure that passing ~runtime_lock to funptr causes a callback to acquire the runtime lock. *) let test_acquire_runtime_lock _ = begin let f x y = let _ = Gc.full_major () in !@x + !@y in let t1 = Thread.create Gc.full_major () in assert (callback_with_pointers f = 7); Thread.join t1 end (* Acquire the runtime lock in a callback while other threads execute OCaml code. *) let test_acquire_runtime_lock_parallel _ = begin let r = ref None in let g size n = for i = 0 to n do r := Some (CArray.make float size ~initial:0.0); Thread.yield (); done in let f x y = let _ = Gc.compact () in !@x + !@y in let threads = ref [] in for i = 0 to 10 do threads := Thread.create (g 100) 10000 :: !threads; done; for i = 0 to 10 do assert (callback_with_pointers f = 7); Thread.yield (); done; List.iter Thread.join !threads; end (* Ensure that threads created by external code are registered with caml_c_thread_register *) let create_threads_that_call_back = Foreign.foreign "foreign_thread_registration_test" (Foreign.funptr ~thread_registration:true ~runtime_lock:true (uint64_t @-> returning void) @-> uint @-> uint @-> returning int) ~release_runtime_lock:true let test_register_thread _ = begin (* number of threads to create *) let n_threads = 25 in (* how often each thread calls back *) let n_callback = 3 in let protect = let m = Mutex.create () in fun f -> Mutex.lock m; let r = try f () with x -> Mutex.unlock m; raise x in Mutex.unlock m; r in let rs = Random.State.make_self_init () in let htl_res = Hashtbl.create (succ n_threads) in let cb d = let cnt,delay = protect @@ fun () -> let c = try Hashtbl.find htl_res d with Not_found -> 0 in Hashtbl.replace htl_res d (succ c); let d = Random.State.float rs 0.1 in c,d in Thread.delay (if cnt <> 0 then delay else delay +. 0.2) in let un_threads = Unsigned.UInt.of_int n_threads in let un_callback = Unsigned.UInt.of_int n_callback in let result = if create_threads_that_call_back cb un_threads un_callback <> 0 then false else if Hashtbl.length htl_res <> succ n_threads then false else Hashtbl.fold ( fun _k v ac -> if v = n_callback then ac else false ) htl_res true in OUnit2.assert_equal true result end let suite = "Thread tests" >::: ["test_release_runtime_lock (foreign)" >:: Foreign_tests.test_release_runtime_lock; "test_release_runtime_lock (stubs)" >:: Stub_tests.test_release_runtime_lock; "test_acquire_runtime_lock (foreign)" >:: test_acquire_runtime_lock; "test_acquire_runtime_lock_parallel (foreign)" >:: test_acquire_runtime_lock_parallel; "test_register_thread (foreign)" >:: test_register_thread; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-type_printing/000077500000000000000000000000001445631112600227545ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-type_printing/dune000066400000000000000000000023351445631112600236350ustar00rootroot00000000000000(rule (targets generated_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) (rule (targets generated_struct_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) (rule (targets ml-stub-generator.exe) (deps generated_struct_stubs.c ../clib/test_functions.h ../config/test-cflags) (action (run %{cc} %{read-lines:../config/test-cflags} -I ../clib -I %{ocaml-config:standard_library} -o %{targets} generated_struct_stubs.c))) (rule (targets generated_struct_bindings.ml) (deps ml-stub-generator.exe) (action (with-stdout-to %{targets} (run %{deps})))) (library (name test_type_printing_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings generated_struct_bindings) (libraries ctypes test_functions lwt.unix)) (test (name test_type_printing) (modules test_type_printing) (package ctypes-foreign) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_type_printing_stubs test_functions test_type_printing_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-type_printing/stub-generator/000077500000000000000000000000001445631112600257155ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-type_printing/stub-generator/driver.ml000066400000000000000000000005121445631112600275400ustar00rootroot00000000000000(* * Copyright (c) 2017 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the type printing tests. *) let () = Tests_common.run Sys.argv ~structs:(module Types.Stubs) (module functor (B:Ctypes.FOREIGN) -> struct end) yallop-ocaml-ctypes-3f8211a/tests/test-type_printing/stub-generator/dune000066400000000000000000000001501445631112600265670ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_type_printing_stubs tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-type_printing/stubs/000077500000000000000000000000001445631112600241145ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-type_printing/stubs/dune000066400000000000000000000001201445631112600247630ustar00rootroot00000000000000(library (name test_type_printing_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-type_printing/stubs/types.ml000066400000000000000000000006001445631112600256060ustar00rootroot00000000000000(* * Copyright (c) 2017 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) module Stubs(S : Ctypes.TYPE) = struct open S let fruit : int64 S.typ = enum "fruit" [] let bears_t : int64 S.typ = enum "bears_t" [] ~typedef:true let letter_t : int64 S.typ = typedef (enum "letter" []) "letter_t" end yallop-ocaml-ctypes-3f8211a/tests/test-type_printing/test_type_printing.ml000066400000000000000000000405451445631112600272500ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes module Struct_stubs = Types.Stubs(Generated_struct_bindings) let strip_whitespace = Str.(global_replace (regexp "[\r\n ]+") "") let equal_ignoring_whitespace l r = strip_whitespace l = strip_whitespace r let assert_printed_as ?name format expected typ = assert_equal ~cmp:equal_ignoring_whitespace ~printer:(fun s -> s) expected (format ?name typ) let assert_typ_printed_as ?name e t = assert_printed_as ?name string_of_typ e t let assert_fn_printed_as ?name e f = assert_printed_as ?name string_of_fn e f (* Test the printing of atomic types: void, arithmetic types and abstract types. *) let test_atomic_printing _ = begin assert_typ_printed_as "void" void; assert_typ_printed_as ~name:"a" "char a" char; assert_typ_printed_as "signed char" schar; assert_typ_printed_as ~name:"b" "short b" short; assert_typ_printed_as "int" int; assert_typ_printed_as ~name:"c" "long c" long; assert_typ_printed_as "long long" llong; assert_typ_printed_as ~name:"d" "intnat d" nativeint; assert_typ_printed_as "int8_t" int8_t; assert_typ_printed_as ~name:"e" "int16_t e" int16_t; assert_typ_printed_as "int32_t" int32_t; assert_typ_printed_as ~name:"f" "int64_t f" int64_t; assert_typ_printed_as "unsigned char" uchar; assert_typ_printed_as "_Bool" bool; assert_typ_printed_as ~name:"g" "uint8_t g" uint8_t; assert_typ_printed_as "uint16_t" uint16_t; assert_typ_printed_as ~name:"h" "uint32_t h" uint32_t; assert_typ_printed_as "uint64_t" uint64_t; assert_typ_printed_as ~name:"i" "size_t i" size_t; assert_typ_printed_as "unsigned short" ushort; assert_typ_printed_as ~name:"j" "unsigned int j" uint; assert_typ_printed_as "unsigned long" ulong; assert_typ_printed_as ~name:"k" "unsigned long long k" ullong; assert_typ_printed_as "float" float; assert_typ_printed_as ~name:"l" "double l" double; let abs_t = abstract ~name:"abs_t" ~size:1 ~alignment:1 in assert_typ_printed_as "abs_t" abs_t; end (* Test the printing of pointers to object and function types. *) let test_pointer_printing _ = begin (* Pointers to atomic types *) assert_typ_printed_as ~name:"a" "void *a" (ptr void); assert_typ_printed_as "unsigned long long **" (ptr (ptr ullong)); assert_typ_printed_as ~name:"b" "char *****b" (ptr (ptr (ptr (ptr (ptr char))))); let abs_t = abstract ~name:"abs_t" ~size:1 ~alignment:1 in assert_typ_printed_as "abs_t *" (ptr abs_t); (* Pointers to incomplete structs and unions *) let s_incomplete = structure "s_incomplete" in let u_incomplete = union "u_incomplete" in assert_typ_printed_as ~name:"c" "struct s_incomplete *c" (ptr s_incomplete); assert_typ_printed_as "union u_incomplete **" (ptr (ptr u_incomplete)); (* Pointers to complete structs and unions *) let s_complete = structure "s_complete" in let _ = field s_complete "i" int in seal s_complete; let u_complete = union "u_complete" in let _ = field u_complete "i" int in seal u_complete; assert_typ_printed_as ~name:"d" "struct s_complete *d" (ptr s_complete); assert_typ_printed_as "union u_complete **" (ptr (ptr u_complete)); (* Pointers to arrays *) assert_typ_printed_as ~name:"e" "int (*e)[4]" (ptr (array 4 int)); assert_typ_printed_as "struct s_complete (*)[3]" (ptr (array 3 s_complete)); assert_typ_printed_as ~name:"f" "union u_complete (*f)[3][4][5]" (ptr (array 3 (array 4 (array 5 u_complete)))); (* Pointers to functions *) assert_typ_printed_as "void (*)(void)" (Foreign.funptr (void @-> returning void)); assert_typ_printed_as ~name:"g" "float (*g)(int, long)" (Foreign.funptr (int @-> long @-> returning float)); assert_typ_printed_as "void (*)(int (*)[4])" (Foreign.funptr (ptr (array 4 int) @-> returning void)); assert_typ_printed_as ~name:"h" "int32_t (*(*h)(void ))(int)" (Foreign.funptr (void @-> returning (Foreign.funptr (int @-> returning int32_t)))); assert_typ_printed_as "unsigned long (*(*)(int, void (*)(float, float)))(long)" (Foreign.funptr (int @-> Foreign.funptr (float @-> float @-> returning void) @-> returning (Foreign.funptr (long @-> returning ulong)))); (* Pointers to pointers to functions *) assert_typ_printed_as ~name:"i" "double (**i)(int)" (ptr (Foreign.funptr (int @-> returning double))); assert_typ_printed_as "double (**)(int)" (ptr (Foreign.funptr (int @-> returning double))); assert_typ_printed_as ~name:"j" "void (*(*(*(**j)(int))(void))[8])(long, long)" (ptr (Foreign.funptr (int @-> returning (Foreign.funptr (void @-> returning (ptr (array 8 (Foreign.funptr (long @-> long @-> returning void))))))))); end (* Test the printing of pointers to object and function types. *) let test_struct_and_union_printing _ = begin (* Incomplete structs and unions *) let s_incomplete = structure "s_incomplete" in let u_incomplete = union "u_incomplete" in assert_typ_printed_as ~name:"a" "struct s_incomplete a" s_incomplete; assert_typ_printed_as "union u_incomplete" u_incomplete; (* Structs and unions containing primitives *) let s_prims = structure "s_prims" in let (-:) ty label = field s_prims label ty in let _ = int -: "i" in let _ = ulong -: "l" in let _ = float -: "z" in seal s_prims; assert_typ_printed_as ~name:"b" "struct s_prims { int i; unsigned long l; float z; } b" s_prims; let u_prims = union "u_prims" in let (-:) ty label = field u_prims label ty in let _ = int32_t -: "i32" in let _ = int64_t -: "i64" in let _ = double -: "d" in seal u_prims; assert_typ_printed_as "union u_prims { int32_t i32; int64_t i64; double d; }" u_prims; (* Structs and unions containing pointers to themselves *) let selfish = structure "selfish" in let (-:) ty label = field selfish label ty in let _ = ptr selfish -: "s" in let _ = ptr int -: "i" in let _ = ptr (ptr selfish) -: "p" in seal selfish; assert_typ_printed_as ~name:"c" "struct selfish { struct selfish *s; int *i; struct selfish **p; } c" selfish; let u_selfish = union "u_selfish" in let (-:) ty label = field u_selfish label ty in let _ = ptr u_selfish -: "self" in let _ = ptr (union "other") -: "other" in seal u_selfish; assert_typ_printed_as "union u_selfish { union u_selfish *self; union other *other; }" u_selfish; (* Structs and unions containing arrays and pointers to functions *) let mixture = structure "mixture" in let (-:) ty label = field mixture label ty in let _ = array 10 (array 12 (ptr mixture)) -: "parr" in let _ = Foreign.funptr (ptr mixture @-> returning void) -: "fn" in let _ = int -: "i" in seal mixture; assert_typ_printed_as ~name:"d" "struct mixture { struct mixture *parr[10][12]; void (*fn)(struct mixture *); int i; } d" mixture; let u_mixture = union "u_mixture" in let (-:) ty label = field u_mixture label ty in let _ = float -: "fl" in let _ = ptr (array 3 (Foreign.funptr (float @-> returning float))) -: "p" in seal u_mixture; assert_typ_printed_as ~name:"e" "union u_mixture { float fl; float (*(*p)[3])(float); } e" u_mixture; (* Structs and unions containing struct and union members *) let inner_s = structure "inner_s" in let _ = field inner_s "_" int in seal inner_s; let inner_u = union "inner_u" in let _ = field inner_u "_" int in seal inner_u; let anon_s = structure "" in let _ = field anon_s "a" int in seal anon_s; let anon_u = union "" in let _ = field anon_u "b" int in seal anon_u; let struct_containing_struct = structure "scs" in let _ = field struct_containing_struct "inner" inner_s in seal struct_containing_struct; let union_containing_struct = union "ucs" in let _ = field union_containing_struct "uinner" inner_s in seal union_containing_struct; let struct_containing_union = structure "scu" in let _ = field struct_containing_union "scuf" inner_u in seal struct_containing_union; let struct_containing_anonymous_struct = structure "scas" in let _ = field struct_containing_anonymous_struct "scasf" anon_s in seal struct_containing_anonymous_struct; let struct_containing_anonymous_union = structure "scau" in let _ = field struct_containing_anonymous_union "scauf" anon_u in seal struct_containing_anonymous_union; let union_containing_union = union "ucu" in let _ = field union_containing_union "ucuf" inner_u in seal union_containing_union; assert_typ_printed_as "struct scs { struct inner_s inner; }" struct_containing_struct; assert_typ_printed_as ~name:"f" "union ucs { struct inner_s uinner; } f" union_containing_struct; assert_typ_printed_as "struct scu { union inner_u scuf; }" struct_containing_union; assert_typ_printed_as ~name:"g" "union ucu { union inner_u ucuf; } g" union_containing_union; assert_typ_printed_as "struct scas { struct { int a; } scasf; }" struct_containing_anonymous_struct; assert_typ_printed_as "struct scau { union { int b; } scauf; }" struct_containing_anonymous_union; end (* Test the printing of array types. *) let test_array_printing _ = begin assert_typ_printed_as ~name:"a" "int a[10]" (array 10 int); assert_typ_printed_as "long [1][2][3]" (array 1 (array 2 (array 3 long))); assert_typ_printed_as ~name:"b" "int (*b[10])(float)" (array 10 (Foreign.funptr (float @-> returning int))); let s = structure "s" in assert_typ_printed_as ~name:"c" "struct s (*(*(*c[1])[2])(int (*)[3]))[4]" (array 1 (ptr (array 2 (Foreign.funptr (ptr (array 3 int) @-> returning (ptr (array 4 s))))))); end (* Test the printing of OCaml string types. *) let test_ocaml_string_printing _ = begin assert_typ_printed_as ~name:"p" "char *p" ocaml_string; assert_typ_printed_as "char *" ocaml_string; end (* Test the printing of bigarray types with signed elements. *) let test_bigarray_signed_printing _ = begin assert_typ_printed_as "int8_t[1][3]" (bigarray genarray [|1; 3|] Bigarray_compat.int8_signed); assert_typ_printed_as "int16_t[3]" (bigarray array1 3 Bigarray_compat.int16_signed); assert_typ_printed_as "int32_t[5][6]" (bigarray array2 (5, 6) Bigarray_compat.int32); assert_typ_printed_as "int64_t[7][8]" (bigarray array2 (7, 8) Bigarray_compat.int64); assert_typ_printed_as "intnat[9][10]" (bigarray array2 (9, 10) Bigarray_compat.int); assert_typ_printed_as "intnat[13][14][15]" (bigarray array3 (13, 14, 15) Bigarray_compat.nativeint); end (* Test the printing of bigarray types with unsigned elements. *) let test_bigarray_unsigned_printing _ = skip_if true "Unsigned bigarray elements currently indistinguishable from signed elements"; begin assert_typ_printed_as "uint8_t[2]" (bigarray array1 2 Bigarray_compat.int8_unsigned); assert_typ_printed_as "uint16_t[4]" (bigarray array1 4 Bigarray_compat.int16_unsigned); end (* Test the printing of bigarray types with floating elements. *) let test_bigarray_float_printing _ = begin assert_typ_printed_as "float[10][100]" (bigarray genarray [|10; 100|] Bigarray_compat.float32); assert_typ_printed_as "double[20][30][40]" (bigarray genarray [|20; 30; 40|] Bigarray_compat.float64); assert_typ_printed_as "float _Complex[16][17][18]" (bigarray array3 (16, 17, 18) Bigarray_compat.complex32); assert_typ_printed_as "double _Complex[19][20][21]" (bigarray array3 (19, 20, 21) Bigarray_compat.complex64); end (* Test the printing of function types. *) let test_function_printing _ = begin assert_fn_printed_as ~name:"a" "void a(void)" (void @-> returning void); assert_fn_printed_as "float(int, char, double)" (int @-> char @-> double @-> returning float); assert_fn_printed_as ~name:"c" "int (*c(void (*)(void)))(int)" (Foreign.funptr (void @-> returning void) @-> returning (Foreign.funptr (int @-> returning int))); let s = structure "s" in let _ = field s "_" int in seal s; assert_fn_printed_as "struct s(struct s)" (s @-> returning s); end (* Test the printing of view types. *) let test_view_printing _ = begin (* By default, views are printed as the underlying type *) assert_typ_printed_as ~name:"a" "char *a" string; let v : unit typ = view ~read:(fun _ -> ()) ~write:(fun () () -> ()) (Foreign.funptr (void @-> returning void)) in assert_typ_printed_as "void (*)(void)" v; (* The format_typ optional argument can be used to provide custom printing for views. *) let w : unit typ = view (Foreign.funptr (int @-> returning float)) ~format_typ:(fun k fmt -> Format.fprintf fmt "unit%t" k) ~read:(fun _ -> ()) ~write:(fun () _ -> 0.0) in assert_typ_printed_as "unit" w; assert_fn_printed_as ~name:"g" "unit g(unit)" (w @-> returning w) end (* Test the printing of enum types *) let test_enum_printing _ = begin assert_typ_printed_as ~name:"f" "enum fruit f" Struct_stubs.fruit; assert_typ_printed_as "enum fruit" Struct_stubs.fruit; assert_typ_printed_as ~name:"b" "bears_t b" Struct_stubs.bears_t; assert_typ_printed_as "bears_t" Struct_stubs.bears_t; assert_typ_printed_as ~name:"l" "letter_t l" Struct_stubs.letter_t; assert_typ_printed_as "letter_t" Struct_stubs.letter_t; end let suite = "Type printing tests" >::: ["printing atomic types" >:: test_atomic_printing; "printing pointers" >:: test_pointer_printing; "printing structs and unions" >:: test_struct_and_union_printing; "printing arrays" >:: test_array_printing; "printing OCaml string types" >:: test_ocaml_string_printing; "printing bigarrays with signed elements" >:: test_bigarray_signed_printing; "printing bigarrays with unsigned elements" >:: test_bigarray_unsigned_printing; "printing bigarrays with floating elements" >:: test_bigarray_float_printing; "printing functions" >:: test_function_printing; "printing views" >:: test_view_printing; "printing enums" >:: test_enum_printing; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-unions/000077500000000000000000000000001445631112600213745ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-unions/dune000066400000000000000000000024721445631112600222570ustar00rootroot00000000000000(rule (targets generated_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:stub-generator/driver.exe} --ml-file %{targets}))) (rule (targets generated_struct_stubs.c) (action (run %{exe:stub-generator/driver.exe} --c-struct-file %{targets}))) (rule (targets ml-stub-generator.exe) (deps generated_struct_stubs.c ../clib/test_functions.h ../config/test-cflags) (action (run %{cc} %{read-lines:../config/test-cflags} -I ../clib -I %{ocaml-config:standard_library} -o %{targets} generated_struct_stubs.c))) (rule (targets generated_struct_bindings.ml) (deps ml-stub-generator.exe) (action (with-stdout-to %{targets} (run %{deps})))) (library (name test_unions_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings generated_struct_bindings) (libraries ctypes test_functions lwt.unix)) (test (name test_unions) (modules test_unions) (deps ../clib/clib%{ext_dll}) (package ctypes-foreign) (action (run %{test} -runner sequential)) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_unions_stubs test_functions test_unions_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-unions/stub-generator/000077500000000000000000000000001445631112600243355ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-unions/stub-generator/driver.ml000066400000000000000000000004571445631112600261700ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the union tests. *) let () = Tests_common.run Sys.argv ~structs:(module Types.Struct_stubs) (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-unions/stub-generator/dune000066400000000000000000000001411445631112600252070ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_unions_stubs tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-unions/stubs/000077500000000000000000000000001445631112600225345ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-unions/stubs/dune000066400000000000000000000001301445631112600234040ustar00rootroot00000000000000(library (name test_unions_stubs) (wrapped false) (libraries ctypes ctypes-foreign)) yallop-ocaml-ctypes-3f8211a/tests/test-unions/stubs/functions.ml000066400000000000000000000020611445631112600250750ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the union tests. *) open Ctypes type padded let padded : padded union typ = union "padded" let (-:) ty label = field padded label ty let i = int64_t -: "i" let a = array (sizeof int64_t + 1) char -: "a" let () = seal padded (* These functions can be bound either dynamically using Foreign or statically using stub generation. *) module Common (F: Ctypes.FOREIGN) = struct let sum_union_components = F.(foreign "sum_union_components" (ptr padded @-> size_t @-> returning int64_t)) end (* These functions can only be bound using stub generation, since Foreign doesn't support passing unions by value. *) module Stubs_only(F : Ctypes.FOREIGN) = struct let add_unions = F.(foreign "add_unions" (padded @-> padded @-> returning padded)) end module Stubs (F: Ctypes.FOREIGN) = struct include Common(F) include Stubs_only(F) end yallop-ocaml-ctypes-3f8211a/tests/test-unions/stubs/types.ml000066400000000000000000000010321445631112600242260ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes module Struct_stubs(S : Ctypes.TYPE) = struct open S (* missing fields *) let u1 : [`u1] union typ = union "u1" let x1 = field u1 "x1" char let () = seal u1 (* adding fields through views (typedefs) *) let union_u2 : [`s7] union typ = union "" let u2 = typedef union_u2 "u2" let t1 = field u2 "t1" int let t2 = field u2 "t2" float let () = seal u2 end yallop-ocaml-ctypes-3f8211a/tests/test-unions/test_unions.ml000066400000000000000000000163441445631112600243100ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes open Unsigned let testlib = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) (* Check that using a union to inspect the representation of a float (double) value gives the same result as Int64.of_bits. union u { double f; int64_t i; }; *) let test_inspecting_float _ = let module M = struct type u let utyp : u union typ = union "u" let (-:) ty label = field utyp label ty let f = double -: "f" let i = int64_t -: "i" let () = seal utyp let pi = 3.14 let e = 2.718 let u = make utyp (* Write through the double; read through the int64_t *) let () = setf u f pi let repr = getf u i let () = assert_equal (Int64.bits_of_float pi) repr (* Write through the int64_t; read through the double *) let () = setf u i (Int64.bits_of_float e) let e' = getf u f let () = assert_equal e e' end in () (* Use a union with the following type to detect endianness union e { int64_t i; unsigned char c[sizeof int64_t]; }; *) let test_endian_detection _ = let module M = struct type e let etyp : e union typ = union "e" let (-:) ty label = field etyp label ty let i = int64_t -: "i" let c = array (sizeof int64_t) uchar -: "c" let () = seal etyp let updated_char_index = if Sys.big_endian then sizeof int64_t - 1 else 0 let e = make etyp let () = setf e i 1L let arr = getf e c module Array = CArray let () = assert_equal ~msg:"the byte that we expected to change was changed" arr.(updated_char_index) UChar.one let () = for i = 1 to sizeof int64_t - 1 do if i <> updated_char_index then assert_equal ~msg:"only the top or the bottom byte was changed" UChar.zero arr.(i) done end in () module Build_foreign_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct open Functions module M = Common(S) open M (* Check that unions are tail-padded sufficiently to satisfy the alignment requirements of all their members. *) let test_union_padding _ = let module M = struct let mkPadded : int64 -> padded union = fun x -> let u = make padded in setf u i x; u let arr = CArray.of_list padded [ mkPadded 1L; mkPadded 2L; mkPadded 3L; mkPadded 4L; mkPadded 5L; ] let sum = sum_union_components (CArray.start arr) (Unsigned.Size_t.of_int (CArray.length arr)) let () = assert_equal ~msg:"padded union members accessed correctly" 15L sum ~printer:Int64.to_string end in () end module Build_stub_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct open Functions include Build_foreign_tests(S) module N = Functions.Stubs(S) open N (* Check that unions can be passed and returned by value. *) let test_passing_unions_by_value _ = let module M = struct let mkPadded : int64 -> padded union = fun x -> let u = make padded in setf u i x; u let u = add_unions (mkPadded 20L) (mkPadded 30L) let () = assert_equal ~msg:"unions passed by value" 50L (getf u i) ~printer:Int64.to_string end in () end module Build_struct_stub_tests (S : Ctypes.TYPE with type 'a typ = 'a Ctypes.typ and type ('a, 's) field = ('a, 's) Ctypes.field) = struct module M = Types.Struct_stubs(S) let retrieve_size name = let f = Foreign.foreign ~from:testlib name (void @-> returning size_t) in Unsigned.Size_t.to_int (f ()) let sizeof_u1 = retrieve_size "sizeof_u1" let alignmentof_u1 = retrieve_size "alignmentof_u1" let sizeof_u2 = retrieve_size "sizeof_u2" let alignmentof_u2 = retrieve_size "alignmentof_u2" (* Test that union layout retrieved from C correctly accounts for missing fields. *) let test_missing_fields _ = begin assert_equal sizeof_u1 (sizeof M.u1); assert_equal alignmentof_u1 (alignment M.u1); end (* Test that we can retrieve information for unions without tags that are identified through typedefs, e.g. typedef union { int x; float y; } u; *) let test_tagless_unions _ = begin assert_equal sizeof_u2 (sizeof M.u2); assert_equal alignmentof_u2 (alignment M.u2); end end module Struct_stubs_tests = Build_struct_stub_tests(Generated_struct_bindings) (* Check that the address of a union is equal to the addresses of each of its members. *) let test_union_address _ = let module M = struct type u let u : u union typ = union "u" let (-:) ty label = field u label ty let i = int64_t -: "i" let c = char -: "c" let s = ptr (structure "incomplete") -: "s" let () = seal u let up = addr (make u) let () = begin assert_equal (to_voidp up) (to_voidp (up |-> i)); assert_equal (to_voidp up) (to_voidp (up |-> c)); assert_equal (to_voidp up) (to_voidp (up |-> s)); end end in () (* Test that attempting to update a sealed union is treated as an error. *) let test_updating_sealed_union _ = let utyp = union "sealed" in let _ = field utyp "_" int in let () = seal utyp in assert_raises (ModifyingSealedType "sealed") (fun () -> field utyp "_" char) (* Test that fields can be added to views over unions. *) let test_adding_fields_through_views _ = let module M = struct let union_u = union "union_u" let u = typedef union_u "u" let _x = field u "x" int let _y = field u "y" float let () = seal u end in () (* Test that attempting to seal an empty union is treated as an error. *) let test_sealing_empty_union _ = let empty = union "empty" in assert_raises (Unsupported "union with no fields") (fun () -> seal empty) module Foreign_tests = Build_foreign_tests(Tests_common.Foreign_binder) module Stub_tests = Build_stub_tests(Generated_bindings) let suite = "Union tests" >::: ["inspecting float representation" >:: test_inspecting_float; "detecting endianness" >:: test_endian_detection; "union padding (foreign)" >:: Foreign_tests.test_union_padding; "union padding (stubs)" >:: Stub_tests.test_union_padding; "passing unions by value (stubs)" >:: Stub_tests.test_passing_unions_by_value; "union address" >:: test_union_address; "updating sealed union" >:: test_updating_sealed_union; "sealing empty union" >:: test_sealing_empty_union; "fields can be added to views over unions" >:: test_adding_fields_through_views; "sealing empty union" >:: test_sealing_empty_union; "test adding fields to tagless unions" >:: Struct_stubs_tests.test_tagless_unions; "test layout of unions with missing fields" >:: Struct_stubs_tests.test_missing_fields; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-value_printing/000077500000000000000000000000001445631112600231075ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-value_printing/dune000066400000000000000000000004311445631112600237630ustar00rootroot00000000000000(test (name test_value_printing) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes ctypes.stubs ctypes-foreign test_value_printing_stubs test_value_printing_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-value_printing/stub-generator/000077500000000000000000000000001445631112600260505ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-value_printing/stub-generator/driver.ml000066400000000000000000000004151445631112600276750ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the value printing tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-value_printing/stub-generator/dune000066400000000000000000000007441445631112600267330ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_value_printing_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_value_printing_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-value_printing/stubs/000077500000000000000000000000001445631112600242475ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-value_printing/stubs/dune000066400000000000000000000001211445631112600251170ustar00rootroot00000000000000(library (name test_value_printing_stubs) (wrapped false) (libraries ctypes)) yallop-ocaml-ctypes-3f8211a/tests/test-value_printing/stubs/functions.ml000066400000000000000000000063051445631112600266150ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the value printing tests. *) open Ctypes module Stubs (F: Ctypes.FOREIGN) = struct open F let retrieve_CHAR_MIN = foreign "retrieve_CHAR_MIN" (void @-> returning char) let retrieve_CHAR_MAX = foreign "retrieve_CHAR_MAX" (void @-> returning char) let retrieve_SCHAR_MIN = foreign "retrieve_SCHAR_MIN" (void @-> returning schar) let retrieve_SCHAR_MAX = foreign "retrieve_SCHAR_MAX" (void @-> returning schar) let retrieve_SHRT_MIN = foreign "retrieve_SHRT_MIN" (void @-> returning short) let retrieve_SHRT_MAX = foreign "retrieve_SHRT_MAX" (void @-> returning short) let retrieve_INT_MIN = foreign "retrieve_INT_MIN" (void @-> returning int) let retrieve_INT_MAX = foreign "retrieve_INT_MAX" (void @-> returning int) let retrieve_LONG_MAX = foreign "retrieve_LONG_MAX" (void @-> returning long) let retrieve_LONG_MIN = foreign "retrieve_LONG_MIN" (void @-> returning long) let retrieve_LLONG_MAX = foreign "retrieve_LLONG_MAX" (void @-> returning llong) let retrieve_LLONG_MIN = foreign "retrieve_LLONG_MIN" (void @-> returning llong) let retrieve_UCHAR_MAX = foreign "retrieve_UCHAR_MAX" (void @-> returning uchar) let retrieve_USHRT_MAX = foreign "retrieve_USHRT_MAX" (void @-> returning ushort) let retrieve_UINT_MAX = foreign "retrieve_UINT_MAX" (void @-> returning uint) let retrieve_ULONG_MAX = foreign "retrieve_ULONG_MAX" (void @-> returning ulong) let retrieve_ULLONG_MAX = foreign "retrieve_ULLONG_MAX" (void @-> returning ullong) let retrieve_INT8_MIN = foreign "retrieve_INT8_MIN" (void @-> returning int8_t) let retrieve_INT8_MAX = foreign "retrieve_INT8_MAX" (void @-> returning int8_t) let retrieve_INT16_MIN = foreign "retrieve_INT16_MIN" (void @-> returning int16_t) let retrieve_INT16_MAX = foreign "retrieve_INT16_MAX" (void @-> returning int16_t) let retrieve_INT32_MIN = foreign "retrieve_INT32_MIN" (void @-> returning int32_t) let retrieve_INT32_MAX = foreign "retrieve_INT32_MAX" (void @-> returning int32_t) let retrieve_INT64_MIN = foreign "retrieve_INT64_MIN" (void @-> returning int64_t) let retrieve_INT64_MAX = foreign "retrieve_INT64_MAX" (void @-> returning int64_t) let retrieve_UINT8_MAX = foreign "retrieve_UINT8_MAX" (void @-> returning uint8_t) let retrieve_UINT16_MAX = foreign "retrieve_UINT16_MAX" (void @-> returning uint16_t) let retrieve_UINT32_MAX = foreign "retrieve_UINT32_MAX" (void @-> returning uint32_t) let retrieve_UINT64_MAX = foreign "retrieve_UINT64_MAX" (void @-> returning uint64_t) let retrieve_SIZE_MAX = foreign "retrieve_SIZE_MAX" (void @-> returning size_t) (* float *) let retrieve_FLT_MIN = foreign "retrieve_FLT_MIN" (void @-> returning float) let retrieve_FLT_MAX = foreign "retrieve_FLT_MAX" (void @-> returning float) let retrieve_DBL_MIN = foreign "retrieve_DBL_MIN" (void @-> returning double) let retrieve_DBL_MAX = foreign "retrieve_DBL_MAX" (void @-> returning double) end yallop-ocaml-ctypes-3f8211a/tests/test-value_printing/test_value_printing.ml000066400000000000000000000315511445631112600275330ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes let _ = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) let strip_whitespace = Str.(global_replace (regexp "[\n ]+") "") let equal_ignoring_whitespace l r = strip_whitespace l = strip_whitespace r module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Test the printing of atomic values: arithmetic types and values of abstract types. *) let test_atomic_printing _ = let open Signed in let open Unsigned in (* char *) let _CHAR_MIN = retrieve_CHAR_MIN () in let _CHAR_MAX = retrieve_CHAR_MAX () in assert_equal (string_of char _CHAR_MIN) (Printf.sprintf "'%c'" _CHAR_MIN); assert_equal (string_of char 'a') "'a'"; assert_equal (string_of char 'A') "'A'"; assert_equal (string_of char '3') "'3'"; assert_equal (string_of char '\n') "'\n'"; assert_equal (string_of char ' ') "' '"; assert_equal (string_of char _CHAR_MAX) (Printf.sprintf "'%c'" _CHAR_MAX); (* signed char *) let _SCHAR_MIN = retrieve_SCHAR_MIN () in let _SCHAR_MAX = retrieve_SCHAR_MAX () in assert_equal (string_of schar _SCHAR_MIN) (string_of_int _SCHAR_MIN); assert_equal (string_of schar 0) (string_of_int 0); assert_equal (string_of schar (-5)) (string_of_int (-5)); assert_equal (string_of schar 5) (string_of_int 5); assert_equal (string_of schar _SCHAR_MAX) (string_of_int _SCHAR_MAX); (* short *) let _SHRT_MIN = retrieve_SHRT_MIN () in let _SHRT_MAX = retrieve_SHRT_MAX () in assert_equal (string_of short _SHRT_MIN) (string_of_int _SHRT_MIN); assert_equal (string_of short 0) (string_of_int 0); assert_equal (string_of short (-5)) (string_of_int (-5)); assert_equal (string_of short 14) (string_of_int 14); assert_equal (string_of short _SHRT_MAX) (string_of_int _SHRT_MAX); (* int *) let _INT_MIN = retrieve_INT_MIN () in let _INT_MAX = retrieve_INT_MAX () in assert_equal (string_of int _INT_MIN) (string_of_int _INT_MIN); assert_equal (string_of int 0) (string_of_int 0); assert_equal (string_of int (-5)) (string_of_int (-5)); assert_equal (string_of int 14) (string_of_int 14); assert_equal (string_of int _INT_MAX) (string_of_int _INT_MAX); (* long *) let _LONG_MAX = retrieve_LONG_MAX () in let _LONG_MIN = retrieve_LONG_MIN () in assert_equal (string_of long _LONG_MIN) Long.(to_string _LONG_MIN); assert_equal (string_of long Long.(of_int 0)) Long.(to_string (of_int 0)); assert_equal (string_of long (Long.of_int (-5))) Long.(to_string (of_int (-5))); assert_equal (string_of long (Long.of_int 14)) Long.(to_string (of_int 14)); assert_equal (string_of long _LONG_MAX) Long.(to_string _LONG_MAX); (* long long *) let _LLONG_MAX = retrieve_LLONG_MAX () in let _LLONG_MIN = retrieve_LLONG_MIN () in assert_equal (string_of llong _LLONG_MIN) LLong.(to_string _LLONG_MIN); assert_equal (string_of llong LLong.(of_int 0)) LLong.(to_string (of_int 0)); assert_equal (string_of llong (LLong.of_int (-5))) LLong.(to_string (of_int (-5))); assert_equal (string_of llong (LLong.of_int 14)) LLong.(to_string (of_int 14)); assert_equal (string_of llong _LLONG_MAX) LLong.(to_string _LLONG_MAX); (* unsigned char *) let _UCHAR_MAX = retrieve_UCHAR_MAX () in UChar.(assert_equal (string_of uchar (of_int 0)) (to_string (of_int 0))); UChar.(assert_equal (string_of uchar (of_int 5)) (to_string (of_int 5))); UChar.(assert_equal (string_of uchar _UCHAR_MAX) (to_string _UCHAR_MAX)); (* bool *) assert_equal (string_of bool true) "true"; assert_equal (string_of bool false) "false"; (* unsigned short *) let _USHRT_MAX = retrieve_USHRT_MAX () in UShort.(assert_equal (string_of ushort (of_int 0)) (to_string (of_int 0))); UShort.(assert_equal (string_of ushort (of_int 5)) (to_string (of_int 5))); UShort.(assert_equal (string_of ushort _USHRT_MAX) (to_string _USHRT_MAX)); (* unsigned int *) let _UINT_MAX = retrieve_UINT_MAX () in UInt.(assert_equal (string_of uint (of_int 0)) (to_string (of_int 0))); UInt.(assert_equal (string_of uint (of_int 5)) (to_string (of_int 5))); UInt.(assert_equal (string_of uint _UINT_MAX) (to_string _UINT_MAX)); (* unsigned long *) let _ULONG_MAX = retrieve_ULONG_MAX () in ULong.(assert_equal (string_of ulong (of_int 0)) (to_string (of_int 0))); ULong.(assert_equal (string_of ulong (of_int 5)) (to_string (of_int 5))); ULong.(assert_equal (string_of ulong _ULONG_MAX) (to_string _ULONG_MAX)); (* unsigned long long *) let _ULLONG_MAX = retrieve_ULLONG_MAX () in ULLong.(assert_equal (string_of ullong (of_int 0)) (to_string (of_int 0))); ULLong.(assert_equal (string_of ullong (of_int 5)) (to_string (of_int 5))); ULLong.(assert_equal (string_of ullong _ULLONG_MAX) (to_string _ULLONG_MAX)); (* int8_t *) let _INT8_MIN = retrieve_INT8_MIN () in let _INT8_MAX = retrieve_INT8_MAX () in assert_equal (string_of int8_t _INT8_MIN) (string_of_int _INT8_MIN); assert_equal (string_of int8_t 0) (string_of_int 0); assert_equal (string_of int8_t (-5)) (string_of_int (-5)); assert_equal (string_of int8_t 14) (string_of_int 14); assert_equal (string_of int8_t _INT8_MAX) (string_of_int _INT8_MAX); (* int16_t *) let _INT16_MIN = retrieve_INT16_MIN () in let _INT16_MAX = retrieve_INT16_MAX () in assert_equal (string_of int16_t _INT16_MIN) (string_of_int _INT16_MIN); assert_equal (string_of int16_t 0) (string_of_int 0); assert_equal (string_of int16_t (-5)) (string_of_int (-5)); assert_equal (string_of int16_t 14) (string_of_int 14); assert_equal (string_of int16_t _INT16_MAX) (string_of_int _INT16_MAX); (* int32_t *) let _INT32_MIN = retrieve_INT32_MIN () in let _INT32_MAX = retrieve_INT32_MAX () in assert_equal (string_of int32_t _INT32_MIN) (Int32.to_string _INT32_MIN); assert_equal (string_of int32_t 0l) (Int32.to_string 0l); assert_equal (string_of int32_t (-5l)) (Int32.to_string (-5l)); assert_equal (string_of int32_t 14l) (Int32.to_string 14l); assert_equal (string_of int32_t _INT32_MAX) (Int32.to_string _INT32_MAX); (* int64_t *) let _INT64_MIN = retrieve_INT64_MIN () in let _INT64_MAX = retrieve_INT64_MAX () in assert_equal (string_of int64_t _INT64_MIN) (Int64.to_string _INT64_MIN); assert_equal (string_of int64_t 0L) (Int64.to_string 0L); assert_equal (string_of int64_t (-5L)) (Int64.to_string (-5L)); assert_equal (string_of int64_t 14L) (Int64.to_string 14L); assert_equal (string_of int64_t _INT64_MAX) (Int64.to_string _INT64_MAX); (* uint8_t *) let _UINT8_MAX = retrieve_UINT8_MAX () in UInt8.(assert_equal (string_of uint8_t (of_int 0)) (to_string (of_int 0))); UInt8.(assert_equal (string_of uint8_t (of_int 5)) (to_string (of_int 5))); UInt8.(assert_equal (string_of uint8_t _UINT8_MAX) (to_string _UINT8_MAX)); (* uint16_t *) let _UINT16_MAX = retrieve_UINT16_MAX () in UInt16.(assert_equal (string_of uint16_t (of_int 0)) (to_string (of_int 0))); UInt16.(assert_equal (string_of uint16_t (of_int 5)) (to_string (of_int 5))); UInt16.(assert_equal (string_of uint16_t _UINT16_MAX) (to_string _UINT16_MAX)); (* uint32_t *) let _UINT32_MAX = retrieve_UINT32_MAX () in UInt32.(assert_equal (string_of uint32_t (of_int 0)) (to_string (of_int 0))); UInt32.(assert_equal (string_of uint32_t (of_int 5)) (to_string (of_int 5))); UInt32.(assert_equal (string_of uint32_t _UINT32_MAX) (to_string _UINT32_MAX)); (* uint64_t *) let _UINT64_MAX = retrieve_UINT64_MAX () in UInt64.(assert_equal (string_of uint64_t (of_int 0)) (to_string (of_int 0))); UInt64.(assert_equal (string_of uint64_t (of_int 5)) (to_string (of_int 5))); UInt64.(assert_equal (string_of uint64_t _UINT64_MAX) (to_string _UINT64_MAX)); (* size_t *) let _SIZE_MAX = retrieve_SIZE_MAX () in Size_t.(assert_equal (string_of size_t (of_int 0)) (to_string (of_int 0))); Size_t.(assert_equal (string_of size_t (of_int 5)) (to_string (of_int 5))); Size_t.(assert_equal (string_of size_t _SIZE_MAX) (to_string _SIZE_MAX)); (* float *) let _FLT_MIN = retrieve_FLT_MIN () in let _FLT_MAX = retrieve_FLT_MAX () in let rex = Str.regexp "e\\([-+]\\)[0]+\\([1-9]+\\)" in let exp_equal a b = (* remove leading zeros from exponential form *) let a = Str.global_replace rex "e\\1\\2" a in let b = Str.global_replace rex "e\\1\\2" b in assert_equal a b in exp_equal (string_of float _FLT_MIN) (string_of_float _FLT_MIN); assert_equal (valid_float_lexem (string_of float 0.0)) (string_of_float 0.0); assert_equal (string_of float nan) (string_of_float nan); assert_equal (string_of float infinity) (string_of_float infinity); exp_equal (string_of float _FLT_MAX) (string_of_float _FLT_MAX); (* double *) let _DBL_MIN = retrieve_DBL_MIN () in let _DBL_MAX = retrieve_DBL_MAX () in assert_equal (string_of double _DBL_MIN) (string_of_float _DBL_MIN); assert_equal (valid_float_lexem (string_of double 0.0)) (string_of_float 0.0); assert_equal (string_of double (-1.03)) (string_of_float (-1.03)); assert_equal (string_of double (34.22)) (string_of_float (34.22)); exp_equal (string_of double (1.39e16)) (string_of_float (1.39e16)); assert_equal (string_of double nan) (string_of_float nan); assert_equal (string_of double infinity) (string_of_float infinity); assert_equal (string_of double _DBL_MAX) (string_of_float _DBL_MAX); () end (* Test the printing of pointers. *) let test_pointer_printing _ = (* There's not much we can test here, since pointer formatting is implementation-dependent. We can at least run the pointer-formatting code, and test that pointers of different types are printed equivalently. *) let arr = CArray.make int 10 in let p = CArray.start arr in assert_equal (string_of (ptr (reference_type p)) p) (string_of (ptr void) (to_voidp p)) (* Test the printing of structs. *) let test_struct_printing _ = let s = structure "s" in let (-:) ty label = field s label ty in let a = array 3 int -: "arr" in let d = double -: "dbl" in let c = char -: "chr" in let () = seal s in let t = structure "t" in let (-:) ty label = field t label ty in let ts = s -: "ts" in let ti = int -: "ti" in let () = seal t in let vt = make t in let vs = make s in begin setf vs a (CArray.of_list int [4; 5; 6]); setf vs d nan; setf vs c 'a'; setf vt ts vs; setf vt ti 14; assert_bool "struct printing" (equal_ignoring_whitespace "{ts = { arr = {4, 5, 6}, dbl = nan, chr = 'a' }, ti = 14}" (string_of t vt)) end (* Test the printing of unions. *) let test_union_printing _ = let s = structure "s" in let (-:) ty label = field s label ty in let i = uint16_t -: "i" in let j = uint16_t -: "j" in let () = seal s in let u = union "u" in let (-:) ty label = field u label ty in let us = s -: "us" in let ua = array 4 uint8_t -: "ua" in let () = seal u in let v = make u in ignore (i, j, us); setf v ua (CArray.make ~initial:(Unsigned.UInt8.of_int 0) uint8_t 4); assert_bool "union printing" (equal_ignoring_whitespace "{ us = {i = 0, j = 0} | ua = {0, 0, 0, 0}}" (string_of u v)) (* Test the printing of array types. *) let test_array_printing _ = let arr = CArray.of_list int [-1; 0; 1] in let arrarr = CArray.of_list (array 3 int) [arr; arr] in assert_bool "array printing" (equal_ignoring_whitespace "{{-1, 0, 1}, {-1, 0, 1}}" (string_of (array 2 (array 3 int)) arrarr)) (* Test the printing of ocaml_string values. *) let test_ocaml_string_printing _ = let s = "abc@%^&*[\"" in begin assert_equal (string_of ocaml_string (ocaml_string_start s)) (Printf.sprintf "%S" s); assert_bool "ocaml_string printing with offsets" (equal_ignoring_whitespace (string_of ocaml_string ((ocaml_string_start s) +@ 3)) (Printf.sprintf "%S [offset:3]" s)); end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Value printing tests" >::: ["printing atomic values (foreign)" >:: Foreign_tests.test_atomic_printing; "printing atomic values (stubs)" >:: Stub_tests.test_atomic_printing; "printing pointers" >:: test_pointer_printing; "printing structs" >:: test_struct_printing; "printing unions" >:: test_union_printing; "printing arrays" >:: test_array_printing; "printing ocaml strings" >:: test_ocaml_string_printing; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-variadic/000077500000000000000000000000001445631112600216435ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-variadic/dune000066400000000000000000000002371445631112600225230ustar00rootroot00000000000000(test (name test_variadic) (package ctypes-foreign) (libraries ounit2 ctypes integers test_variadic_stubs test_variadic_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-variadic/stub-generator/000077500000000000000000000000001445631112600246045ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-variadic/stub-generator/driver.ml000066400000000000000000000004771445631112600264410ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the variadic function tests. *) let cheader = " #include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-variadic/stub-generator/dune000066400000000000000000000007301445631112600254620ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_variadic_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_variadic_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-variadic/stubs/000077500000000000000000000000001445631112600230035ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-variadic/stubs/dune000066400000000000000000000001241445631112600236560ustar00rootroot00000000000000(library (name test_variadic_stubs) (wrapped false) (libraries ctypes integers)) yallop-ocaml-ctypes-3f8211a/tests/test-variadic/stubs/functions.ml000066400000000000000000000014561445631112600253530ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the variadic function tests. *) open Ctypes module Stubs (F: Ctypes.FOREIGN) = struct open F let size_t_as_int : int typ = view size_t ~read:Unsigned.Size_t.to_int ~write:Unsigned.Size_t.of_int let bind_snprintf tail = foreign "snprintf" (ptr char @-> size_t_as_int @-> string @-> tail) let snprintf_int = bind_snprintf (int @-> returning int) let snprintf_char_unsigned = bind_snprintf (char @-> uint @-> returning int) let snprintf_longlong_int = bind_snprintf (llong @-> int @-> returning int) let snprintf_string_ushort = bind_snprintf (string @-> ushort @-> returning int) end yallop-ocaml-ctypes-3f8211a/tests/test-variadic/test_variadic.ml000066400000000000000000000037401445631112600250220ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Tests for binding variadic functions. *) [@@@ocaml.warning "-6"] open OUnit2 open Ctypes [@@@warning "-6"] module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open Signed open Unsigned open M (* Test calling snprintf. *) let test_snprintf _ = let bufsz = 128 in let write snprintf apply = let buf = allocate_n char bufsz in let _ : int = apply (snprintf buf bufsz) in coerce (ptr char) string buf in begin assert_equal "an int: 100." (write snprintf_int (fun k -> k "an int: %d." 100)); assert_equal "a char A and a uint 33." (write snprintf_char_unsigned (fun k -> k "a char %c and a uint %u." 'A' (UInt.of_int 33))); let ref_string = match Sys.word_size with | 32 -> "a long long 2147483647 and an int -4." | 64 -> "a long long 9223372036854775807 and an int -4." | n -> failwith (Printf.sprintf "This test doesn't yet support word size %d" n) in let format_string = match Sys.os_type with | "Win32" -> "a long long %I64d and an int %d." | _ -> "a long long %lld and an int %d." in assert_equal ref_string (write snprintf_longlong_int (fun k -> k format_string (LLong.of_nativeint Nativeint.max_int) (-4))); assert_equal "a string abcde and an unsigned short ffd." (write snprintf_string_ushort (fun k -> k "a string %s and an unsigned short %hx." "abcde" (UShort.of_int 0xffd))); end end module Stub_tests = Common_tests(Generated_bindings) let suite = "Variadic tests" >::: ["snprintf" >:: Stub_tests.test_snprintf; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/test-views/000077500000000000000000000000001445631112600212165ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-views/dune000066400000000000000000000003241445631112600220730ustar00rootroot00000000000000(test (name test_views) (package ctypes-foreign) (deps ../clib/clib%{ext_dll}) (link_flags (:include ../flags/link-flags.sexp)) (libraries ounit2 ctypes test_views_stubs test_views_bindings tests_common)) yallop-ocaml-ctypes-3f8211a/tests/test-views/stub-generator/000077500000000000000000000000001445631112600241575ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-views/stub-generator/driver.ml000066400000000000000000000005071445631112600260060ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the views tests. *) let cheader = " #include #include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) yallop-ocaml-ctypes-3f8211a/tests/test-views/stub-generator/dune000066400000000000000000000007221445631112600250360ustar00rootroot00000000000000(executable (name driver) (modules driver) (libraries ctypes test_views_stubs tests_common)) (rule (targets generated_stubs.c) (action (run %{exe:driver.exe} --c-file %{targets}))) (rule (targets generated_bindings.ml) (action (run %{exe:driver.exe} --ml-file %{targets}))) (library (name test_views_bindings) (wrapped false) (foreign_stubs (language c) (names generated_stubs)) (modules generated_bindings) (libraries ctypes test_functions)) yallop-ocaml-ctypes-3f8211a/tests/test-views/stubs/000077500000000000000000000000001445631112600223565ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/test-views/stubs/dune000066400000000000000000000001271445631112600232340ustar00rootroot00000000000000(library (name test_views_stubs) (wrapped false) (libraries ctypes ctypes-foreign)) yallop-ocaml-ctypes-3f8211a/tests/test-views/stubs/functions.ml000066400000000000000000000016601445631112600247230ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the views tests. *) open Ctypes module Stubs (F: Ctypes.FOREIGN) = struct open F let charish = view ~read:Char.chr ~write:Char.code int let nullable_intptr = Foreign.funptr_opt Ctypes.(int @-> int @-> returning int) let concat_strings = foreign "concat_strings" (ptr string @-> int @-> ptr char @-> returning void) let toupper = foreign "toupper" (charish @-> returning charish) let returning_funptr = foreign "returning_funptr" (int @-> returning nullable_intptr) let accepting_possibly_null_funptr = foreign "accepting_possibly_null_funptr" (nullable_intptr @-> int @-> int @-> returning int) let strcmp = foreign "strcmp" (string @-> string @-> returning int) end yallop-ocaml-ctypes-3f8211a/tests/test-views/test_views.ml000066400000000000000000000132501445631112600237450ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes let _ = Dl.(dlopen ~filename:"../clib/clib.so" ~flags:[RTLD_NOW]) [@@@warning "-3-35"] module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Call a function of type void (char **sv, int sc, char *buffer) using strings for input parameters and a char array for an output parameter. Examine the output buffer using a cast to a string view. *) let test_passing_string_array _ = let l = ["the "; "quick "; "brown "; "fox "; "etc. "; "etc. "; ] in let arr = CArray.of_list string l in let outlen = List.fold_left (fun a s -> String.length s + a) 1 l in let buf = CArray.make char outlen in let () = CArray.(concat_strings (start arr) (length arr) (start buf)) in let buf_addr = allocate (ptr char) (CArray.start buf) in let s = from_voidp string (to_voidp buf_addr) in assert_equal ~msg:"Check output" "the quick brown fox etc. etc. " !@s (* Call a function of type int (int) using a custom view that treats chars as ints. *) let test_passing_chars_as_ints _ = assert_equal ~msg:"toupper('x') = 'X'" 'X' (toupper 'x'); assert_equal ~msg:"toupper('3') = '3'" '3' (toupper '3'); assert_equal ~msg:"toupper('X') = 'X'" 'X' (toupper 'X') (* Use views to create a nullable function pointer. *) let test_nullable_function_pointer_view _ = begin let fromSome = function None -> assert false | Some x -> x in let add = fromSome (returning_funptr 0) and times = fromSome (returning_funptr 1) in assert_equal ~msg:"reading non-null function pointer return value" 9 (add 5 4); assert_equal ~msg:"reading non-null function pointer return value" 20 (times 5 4); assert_equal ~msg:"reading null function pointer return value" None (returning_funptr 2); assert_equal ~msg:"passing null function pointer" (-1) (accepting_possibly_null_funptr None 2 3); assert_equal ~msg:"passing non-null function pointer" 5 (accepting_possibly_null_funptr (Some (+)) 2 3); assert_equal ~msg:"passing non-null function pointer obtained from C" 6 (accepting_possibly_null_funptr (returning_funptr 1) 2 3); end (* Test that intermediate values from views are not prematurely collected. *) let test_intermediate_value_lifetime _ = for i = 0 to 100_000 do assert_equal 0 ~printer:(Printf.sprintf "%d") (strcmp (Bytes.to_string (Bytes.copy (Bytes.of_string "abcdefg"))) (Bytes.to_string (Bytes.copy (Bytes.of_string "abcdefg")))); (* Gc.compact (); *) done end (* Use the nullable pointer view to view nulls as Nones. *) let test_nullable_pointer_view _ = let p = allocate int 10 in let pp = allocate (ptr int) p in let npp = from_voidp (ptr_opt int) (to_voidp pp) in begin assert_equal 10 !@ !@pp; begin match !@npp with | Some x -> assert_equal 10 !@x | None -> assert false end; pp <-@ from_voidp int null; assert_equal null (to_voidp !@pp); assert_equal None !@npp; end (* Use a polar form view of complex numbers. *) let test_polar_form_view _ = let module M = struct open Complex type polar = {norm: float; arg: float} let pi = 4.0 *. atan 1.0 let polar_of_cartesian c = { norm = norm c; arg = arg c} let cartesian_of_polar { norm; arg } = polar norm arg let polar64 = view complex64 ~read:polar_of_cartesian ~write:cartesian_of_polar let eps = 1e-9 let complex64_eq { re = lre; im = lim } { re = rre; im = rim } = abs_float (lre -. rre) < eps && abs_float (lim -. rim) < eps let polar64_eq { norm = lnorm; arg = larg } { norm = rnorm; arg = rarg } = abs_float (lnorm -. rnorm) < eps && abs_float (larg -. rarg) < eps let polp = allocate polar64 { norm = 0.0; arg = 0.0 } let carp = from_voidp complex64 (to_voidp polp) let () = begin assert_equal !@polp { norm = 0.0; arg = 0.0 } ~cmp:polar64_eq; assert_equal !@carp { re = 0.0; im = 0.0 } ~cmp:complex64_eq; carp <-@ { re = 1.0; im = 0.0 }; assert_equal !@polp { norm = 1.0; arg = 0.0 } ~cmp:polar64_eq; carp <-@ { re = 0.0; im = 2.5 }; assert_equal !@polp { norm = 2.5; arg = pi /. 2. } ~cmp:polar64_eq; polp <-@ { norm = 4.1e5; arg = pi *. 1.5 }; assert_equal !@carp { re = 0.0; im = -4.1e5 } ~cmp:complex64_eq; end end in () module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "View tests" >::: ["passing array of strings (foreign)" >:: Foreign_tests.test_passing_string_array; "passing array of strings (stubs)" >:: Stub_tests.test_passing_string_array; "custom views (foreign)" >:: Foreign_tests.test_passing_chars_as_ints; "custom views (stubs)" >:: Stub_tests.test_passing_chars_as_ints; "nullable function pointers (foreign)" >:: Foreign_tests.test_nullable_function_pointer_view; "nullable function pointers (stubs)" >:: Stub_tests.test_nullable_function_pointer_view; "intermediate value lifetime (foreign)" >:: Foreign_tests.test_intermediate_value_lifetime; "intermediate value lifetime (stubs)" >:: Stub_tests.test_intermediate_value_lifetime; "nullable pointers" >:: test_nullable_pointer_view; "polar form view" >:: test_polar_form_view; ] let _ = run_test_tt_main suite yallop-ocaml-ctypes-3f8211a/tests/tests-common/000077500000000000000000000000001445631112600215345ustar00rootroot00000000000000yallop-ocaml-ctypes-3f8211a/tests/tests-common/dune000066400000000000000000000001171445631112600224110ustar00rootroot00000000000000(library (name tests_common) (libraries ctypes ctypes.stubs ctypes-foreign)) yallop-ocaml-ctypes-3f8211a/tests/tests-common/tests_common.ml000066400000000000000000000045241445631112600246050ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Functions for test stub generation. *) let filenames _argv = let usage = "arguments: [--ml-file $filename] [--c-file $filename]" in let ml_filename = ref "" and c_filename = ref "" and c_struct_filename = ref "" in let spec = Arg.([("--ml-file", Set_string ml_filename, "ML filename"); ("--c-file", Set_string c_filename, "C filename"); ("--c-struct-file", Set_string c_struct_filename, "C struct filename");]) in let no_positional_args _ = prerr_endline "No positional arguments" in begin Arg.parse spec no_positional_args usage; (!ml_filename, !c_filename, !c_struct_filename) end module Foreign_binder : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a = struct type 'a fn = 'a Ctypes.fn type 'a return = 'a let (@->) = Ctypes.(@->) let returning = Ctypes.returning type 'a result = 'a let foreign name fn = Foreign.foreign name fn let foreign_value name fn = Foreign.foreign_value name fn end module type STUBS = functor (F : Cstubs.FOREIGN) -> sig end let with_open_formatter filename f = let out = open_out filename in let fmt = Format.formatter_of_out_channel out in let close_channel () = close_out out in try let rv = f fmt in close_channel (); rv with e -> close_channel (); raise e let header = "#include \"test_functions.h\"" let run ?concurrency ?errno ?(cheader="") argv ?structs specs = let ml_filename, c_filename, c_struct_filename = filenames argv in if ml_filename <> "" then with_open_formatter ml_filename (fun fmt -> Cstubs.write_ml ?concurrency ?errno fmt ~prefix:"cstubs_tests" specs); if c_filename <> "" then with_open_formatter c_filename (fun fmt -> Format.fprintf fmt "%s@\n%s@\n" header cheader; Cstubs.write_c ?concurrency ?errno fmt ~prefix:"cstubs_tests" specs); begin match structs, c_struct_filename with | None, _ -> () | Some _, "" -> () | Some specs, c_filename -> with_open_formatter c_filename (fun fmt -> Format.fprintf fmt "%s@\n%s@\n" header cheader; Cstubs_structs.write_c fmt specs) end