pax_global_header00006660000000000000000000000064123021035550014506gustar00rootroot0000000000000052 comment=e730a33fb353d998341d0d32ecfefd94d1279d9c ocaml-ctypes-ocaml-ctypes-0.2.3/000077500000000000000000000000001230210355500165065ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/.depend000066400000000000000000000330611230210355500177510ustar00rootroot00000000000000_build/src/ctypes-foreign-base/closure_properties.cmi : _build/src/ctypes-foreign-base/dl.cmi : _build/src/ctypes/ctypes_raw.cmo _build/src/ctypes-foreign-base/ffi.cmi : _build/src/ctypes/static.cmo _build/src/ctypes-foreign-base/weakRef.cmi : _build/src/ctypes-foreign-threaded/foreign.cmi : _build/src/ctypes-foreign-base/dl.cmi \ _build/src/ctypes/ctypes.cmi _build/src/ctypes-foreign-unthreaded/foreign.cmi : _build/src/ctypes-foreign-base/dl.cmi \ _build/src/ctypes/ctypes.cmi _build/src/ctypes-top/ctypes_printers.cmi : _build/src/ctypes/unsigned.cmi \ _build/src/ctypes/signed.cmi _build/src/ctypes/posixTypes.cmi _build/src/ctypes/ctypes.cmi _build/src/ctypes/coerce.cmi : _build/src/ctypes/static.cmo _build/src/ctypes/ctypes.cmi : _build/src/ctypes/unsigned.cmi _build/src/ctypes/static.cmo \ _build/src/ctypes/signed.cmi _build/src/ctypes/ctypes_bigarray.cmi : _build/src/ctypes/primitives.cmo \ _build/src/ctypes/ctypes_raw.cmo _build/src/ctypes/posixTypes.cmi : _build/src/ctypes/unsigned.cmi _build/src/ctypes/ctypes.cmi _build/src/ctypes/signed.cmi : _build/src/ctypes/unsigned.cmi _build/src/ctypes/structs.cmi : _build/src/ctypes/static.cmo _build/src/ctypes/structs_computed.cmi : _build/src/ctypes/structs.cmi \ _build/src/ctypes/static.cmo _build/src/ctypes/unsigned.cmi : _build/src/configure/make_primitive_details.cmo : _build/src/configure/make_primitive_details.cmx : _build/src/ctypes-foreign-base/closure_properties.cmo : \ _build/src/ctypes-foreign-base/closure_properties.cmi _build/src/ctypes-foreign-base/closure_properties.cmx : \ _build/src/ctypes-foreign-base/closure_properties.cmi _build/src/ctypes-foreign-base/dl.cmo : _build/src/ctypes/ctypes_raw.cmo \ _build/src/ctypes-foreign-base/dl.cmi _build/src/ctypes-foreign-base/dl.cmx : _build/src/ctypes/ctypes_raw.cmx \ _build/src/ctypes-foreign-base/dl.cmi _build/src/ctypes-foreign-base/ffi.cmo : _build/src/ctypes-foreign-base/weakRef.cmi \ _build/src/ctypes/type_printing.cmo _build/src/ctypes/static.cmo _build/src/ctypes/memory.cmo \ _build/src/ctypes-foreign-base/ffi_stubs.cmo _build/src/ctypes/ctypes_raw.cmo \ _build/src/ctypes-foreign-base/ffi.cmi _build/src/ctypes-foreign-base/ffi.cmx : _build/src/ctypes-foreign-base/weakRef.cmx \ _build/src/ctypes/type_printing.cmx _build/src/ctypes/static.cmx _build/src/ctypes/memory.cmx \ _build/src/ctypes-foreign-base/ffi_stubs.cmx _build/src/ctypes/ctypes_raw.cmx \ _build/src/ctypes-foreign-base/ffi.cmi _build/src/ctypes-foreign-base/ffi_stubs.cmo : _build/src/ctypes/primitives.cmo \ _build/src/ctypes/ctypes_raw.cmo _build/src/ctypes-foreign-base/ffi_stubs.cmx : _build/src/ctypes/primitives.cmx \ _build/src/ctypes/ctypes_raw.cmx _build/src/ctypes-foreign-base/foreign_basis.cmo : _build/src/ctypes/type_printing.cmo \ _build/src/ctypes/std_views.cmo _build/src/ctypes/static.cmo _build/src/ctypes/memory.cmo \ _build/src/ctypes-foreign-base/ffi_stubs.cmo _build/src/ctypes-foreign-base/ffi.cmi \ _build/src/ctypes-foreign-base/dl.cmi _build/src/ctypes/ctypes_raw.cmo \ _build/src/ctypes/ctypes.cmi _build/src/ctypes/coerce.cmi _build/src/ctypes-foreign-base/foreign_basis.cmx : _build/src/ctypes/type_printing.cmx \ _build/src/ctypes/std_views.cmx _build/src/ctypes/static.cmx _build/src/ctypes/memory.cmx \ _build/src/ctypes-foreign-base/ffi_stubs.cmx _build/src/ctypes-foreign-base/ffi.cmx \ _build/src/ctypes-foreign-base/dl.cmx _build/src/ctypes/ctypes_raw.cmx \ _build/src/ctypes/ctypes.cmx _build/src/ctypes/coerce.cmx _build/src/ctypes-foreign-base/weakRef.cmo : _build/src/ctypes-foreign-base/weakRef.cmi _build/src/ctypes-foreign-base/weakRef.cmx : _build/src/ctypes-foreign-base/weakRef.cmi _build/src/ctypes-foreign-threaded/foreign.cmo : \ _build/src/ctypes-foreign-base/foreign_basis.cmo \ _build/src/ctypes-foreign-base/closure_properties.cmi \ _build/src/ctypes-foreign-threaded/foreign.cmi _build/src/ctypes-foreign-threaded/foreign.cmx : \ _build/src/ctypes-foreign-base/foreign_basis.cmx \ _build/src/ctypes-foreign-base/closure_properties.cmx \ _build/src/ctypes-foreign-threaded/foreign.cmi _build/src/ctypes-foreign-unthreaded/foreign.cmo : \ _build/src/ctypes-foreign-unthreaded/gc_mutex.cmo \ _build/src/ctypes-foreign-base/foreign_basis.cmo \ _build/src/ctypes-foreign-base/closure_properties.cmi \ _build/src/ctypes-foreign-unthreaded/foreign.cmi _build/src/ctypes-foreign-unthreaded/foreign.cmx : \ _build/src/ctypes-foreign-unthreaded/gc_mutex.cmx \ _build/src/ctypes-foreign-base/foreign_basis.cmx \ _build/src/ctypes-foreign-base/closure_properties.cmx \ _build/src/ctypes-foreign-unthreaded/foreign.cmi _build/src/ctypes-foreign-unthreaded/gc_mutex.cmo : _build/src/ctypes-foreign-unthreaded/gc_mutex.cmx : _build/src/ctypes-top/ctypes_printers.cmo : _build/src/ctypes/unsigned.cmi \ _build/src/ctypes/signed.cmi _build/src/ctypes/posixTypes.cmi _build/src/ctypes/ctypes.cmi \ _build/src/ctypes-top/ctypes_printers.cmi _build/src/ctypes-top/ctypes_printers.cmx : _build/src/ctypes/unsigned.cmx \ _build/src/ctypes/signed.cmx _build/src/ctypes/posixTypes.cmx _build/src/ctypes/ctypes.cmx \ _build/src/ctypes-top/ctypes_printers.cmi _build/src/ctypes-top/install_printers.cmo : _build/src/ctypes-top/install_printers.cmx : _build/src/ctypes/bigarray_stubs.cmo : _build/src/ctypes/ctypes_raw.cmo _build/src/ctypes/bigarray_stubs.cmx : _build/src/ctypes/ctypes_raw.cmx _build/src/ctypes/coerce.cmo : _build/src/ctypes/static.cmo _build/src/ctypes/memory.cmo \ _build/src/ctypes/coerce.cmi _build/src/ctypes/coerce.cmx : _build/src/ctypes/static.cmx _build/src/ctypes/memory.cmx \ _build/src/ctypes/coerce.cmi _build/src/ctypes/common.cmo : _build/src/ctypes/common.cmx : _build/src/ctypes/ctypes.cmo : _build/src/ctypes/value_printing.cmo \ _build/src/ctypes/type_printing.cmo _build/src/ctypes/structs_computed.cmi \ _build/src/ctypes/std_views.cmo _build/src/ctypes/static.cmo _build/src/ctypes/memory.cmo \ _build/src/ctypes/common.cmo _build/src/ctypes/coerce.cmi _build/src/ctypes/ctypes.cmi _build/src/ctypes/ctypes.cmx : _build/src/ctypes/value_printing.cmx \ _build/src/ctypes/type_printing.cmx _build/src/ctypes/structs_computed.cmx \ _build/src/ctypes/std_views.cmx _build/src/ctypes/static.cmx _build/src/ctypes/memory.cmx \ _build/src/ctypes/common.cmx _build/src/ctypes/coerce.cmx _build/src/ctypes/ctypes.cmi _build/src/ctypes/ctypes_bigarray.cmo : _build/src/ctypes/primitives.cmo \ _build/src/ctypes/ctypes_raw.cmo _build/src/ctypes/ctypes_primitives.cmo \ _build/src/ctypes/bigarray_stubs.cmo _build/src/ctypes/ctypes_bigarray.cmi _build/src/ctypes/ctypes_bigarray.cmx : _build/src/ctypes/primitives.cmx \ _build/src/ctypes/ctypes_raw.cmx _build/src/ctypes/ctypes_primitives.cmx \ _build/src/ctypes/bigarray_stubs.cmx _build/src/ctypes/ctypes_bigarray.cmi _build/src/ctypes/ctypes_primitives.cmo : _build/src/ctypes/primitives.cmo _build/src/ctypes/ctypes_primitives.cmx : _build/src/ctypes/primitives.cmx _build/src/ctypes/ctypes_raw.cmo : _build/src/ctypes/signed.cmi \ _build/src/ctypes/ctypes_primitives.cmo _build/src/ctypes/ctypes_raw.cmx : _build/src/ctypes/signed.cmx \ _build/src/ctypes/ctypes_primitives.cmx _build/src/ctypes/memory.cmo : _build/src/ctypes/static.cmo _build/src/ctypes/memory_stubs.cmo \ _build/src/ctypes/ctypes_raw.cmo _build/src/ctypes/ctypes_bigarray.cmi _build/src/ctypes/memory.cmx : _build/src/ctypes/static.cmx _build/src/ctypes/memory_stubs.cmx \ _build/src/ctypes/ctypes_raw.cmx _build/src/ctypes/ctypes_bigarray.cmx _build/src/ctypes/memory_stubs.cmo : _build/src/ctypes/primitives.cmo \ _build/src/ctypes/ctypes_raw.cmo _build/src/ctypes/memory_stubs.cmx : _build/src/ctypes/primitives.cmx \ _build/src/ctypes/ctypes_raw.cmx _build/src/ctypes/posixTypes.cmo : _build/src/ctypes/unsigned.cmi _build/src/ctypes/ctypes.cmi \ _build/src/ctypes/posixTypes.cmi _build/src/ctypes/posixTypes.cmx : _build/src/ctypes/unsigned.cmx _build/src/ctypes/ctypes.cmx \ _build/src/ctypes/posixTypes.cmi _build/src/ctypes/primitives.cmo : _build/src/ctypes/unsigned.cmi _build/src/ctypes/signed.cmi _build/src/ctypes/primitives.cmx : _build/src/ctypes/unsigned.cmx _build/src/ctypes/signed.cmx _build/src/ctypes/signed.cmo : _build/src/ctypes/unsigned.cmi _build/src/ctypes/signed.cmi _build/src/ctypes/signed.cmx : _build/src/ctypes/unsigned.cmx _build/src/ctypes/signed.cmi _build/src/ctypes/static.cmo : _build/src/ctypes/primitives.cmo _build/src/ctypes/ctypes_raw.cmo \ _build/src/ctypes/ctypes_primitives.cmo _build/src/ctypes/ctypes_bigarray.cmi _build/src/ctypes/static.cmx : _build/src/ctypes/primitives.cmx _build/src/ctypes/ctypes_raw.cmx \ _build/src/ctypes/ctypes_primitives.cmx _build/src/ctypes/ctypes_bigarray.cmx _build/src/ctypes/std_view_stubs.cmo : _build/src/ctypes/memory_stubs.cmo \ _build/src/ctypes/ctypes_raw.cmo _build/src/ctypes/std_view_stubs.cmx : _build/src/ctypes/memory_stubs.cmx \ _build/src/ctypes/ctypes_raw.cmx _build/src/ctypes/std_views.cmo : _build/src/ctypes/std_view_stubs.cmo \ _build/src/ctypes/static.cmo _build/src/ctypes/memory_stubs.cmo _build/src/ctypes/memory.cmo \ _build/src/ctypes/coerce.cmi _build/src/ctypes/std_views.cmx : _build/src/ctypes/std_view_stubs.cmx \ _build/src/ctypes/static.cmx _build/src/ctypes/memory_stubs.cmx _build/src/ctypes/memory.cmx \ _build/src/ctypes/coerce.cmx _build/src/ctypes/structs.cmo : _build/src/ctypes/static.cmo _build/src/ctypes/structs.cmi _build/src/ctypes/structs.cmx : _build/src/ctypes/static.cmx _build/src/ctypes/structs.cmi _build/src/ctypes/structs_computed.cmo : _build/src/ctypes/static.cmo \ _build/src/ctypes/structs_computed.cmi _build/src/ctypes/structs_computed.cmx : _build/src/ctypes/static.cmx \ _build/src/ctypes/structs_computed.cmi _build/src/ctypes/type_printing.cmo : _build/src/ctypes/static.cmo \ _build/src/ctypes/ctypes_primitives.cmo _build/src/ctypes/ctypes_bigarray.cmi \ _build/src/ctypes/common.cmo _build/src/ctypes/type_printing.cmx : _build/src/ctypes/static.cmx \ _build/src/ctypes/ctypes_primitives.cmx _build/src/ctypes/ctypes_bigarray.cmx \ _build/src/ctypes/common.cmx _build/src/ctypes/unsigned.cmo : _build/src/ctypes/unsigned.cmi _build/src/ctypes/unsigned.cmx : _build/src/ctypes/unsigned.cmi _build/src/ctypes/value_printing.cmo : _build/src/ctypes/value_printing_stubs.cmo \ _build/src/ctypes/static.cmo _build/src/ctypes/memory.cmo \ _build/src/ctypes/ctypes_bigarray.cmi _build/src/ctypes/common.cmo _build/src/ctypes/value_printing.cmx : _build/src/ctypes/value_printing_stubs.cmx \ _build/src/ctypes/static.cmx _build/src/ctypes/memory.cmx \ _build/src/ctypes/ctypes_bigarray.cmx _build/src/ctypes/common.cmx _build/src/ctypes/value_printing_stubs.cmo : _build/src/ctypes/primitives.cmo \ _build/src/ctypes/ctypes_raw.cmo _build/src/ctypes/value_printing_stubs.cmx : _build/src/ctypes/primitives.cmx \ _build/src/ctypes/ctypes_raw.cmx _build/src/discover/discover.cmo : _build/src/discover/discover.cmx : _build/examples/date/date.cmi : _build/src/ctypes/posixTypes.cmi _build/src/ctypes/ctypes.cmi _build/examples/fts/fts.cmi : _build/src/ctypes/posixTypes.cmi _build/src/ctypes/ctypes.cmi _build/examples/ncurses/ncurses.cmi : _build/examples/sigset/sigset.cmi : _build/src/ctypes/posixTypes.cmi _build/src/ctypes/ctypes.cmi _build/examples/churny/churny.cmo : _build/src/ctypes-foreign-threaded/foreign.cmi \ _build/src/ctypes-foreign-base/dl.cmi _build/src/ctypes/ctypes.cmi _build/examples/churny/churny.cmx : _build/src/ctypes-foreign-threaded/foreign.cmx \ _build/src/ctypes-foreign-base/dl.cmx _build/src/ctypes/ctypes.cmx _build/examples/date/date.cmo : _build/src/ctypes/posixTypes.cmi \ _build/src/ctypes-foreign-threaded/foreign.cmi _build/src/ctypes/ctypes.cmi \ _build/examples/date/date.cmi _build/examples/date/date.cmx : _build/src/ctypes/posixTypes.cmx \ _build/src/ctypes-foreign-threaded/foreign.cmx _build/src/ctypes/ctypes.cmx \ _build/examples/date/date.cmi _build/examples/fts/fts.cmo : _build/src/ctypes/unsigned.cmi _build/src/ctypes/posixTypes.cmi \ _build/src/ctypes-foreign-threaded/foreign.cmi _build/src/ctypes/ctypes.cmi \ _build/src/ctypes/coerce.cmi _build/examples/fts/fts.cmi _build/examples/fts/fts.cmx : _build/src/ctypes/unsigned.cmx _build/src/ctypes/posixTypes.cmx \ _build/src/ctypes-foreign-threaded/foreign.cmx _build/src/ctypes/ctypes.cmx \ _build/src/ctypes/coerce.cmx _build/examples/fts/fts.cmi _build/examples/fts/fts_cmd.cmo : _build/examples/fts/fts.cmi _build/src/ctypes/ctypes.cmi _build/examples/fts/fts_cmd.cmx : _build/examples/fts/fts.cmx _build/src/ctypes/ctypes.cmx _build/examples/ncurses/ncurses.cmo : _build/src/ctypes-foreign-threaded/foreign.cmi \ _build/src/ctypes/ctypes.cmi _build/examples/ncurses/ncurses.cmi _build/examples/ncurses/ncurses.cmx : _build/src/ctypes-foreign-threaded/foreign.cmx \ _build/src/ctypes/ctypes.cmx _build/examples/ncurses/ncurses.cmi _build/examples/ncurses/ncurses_cmd.cmo : _build/examples/ncurses/ncurses.cmi _build/examples/ncurses/ncurses_cmd.cmx : _build/examples/ncurses/ncurses.cmx _build/examples/sigset/sigset.cmo : _build/src/ctypes/posixTypes.cmi \ _build/src/ctypes-foreign-threaded/foreign.cmi _build/src/ctypes/ctypes.cmi \ _build/examples/sigset/sigset.cmi _build/examples/sigset/sigset.cmx : _build/src/ctypes/posixTypes.cmx \ _build/src/ctypes-foreign-threaded/foreign.cmx _build/src/ctypes/ctypes.cmx \ _build/examples/sigset/sigset.cmi _build/examples/struct-subtyping/struct_subtyping.cmo : _build/src/ctypes/ctypes.cmi _build/examples/struct-subtyping/struct_subtyping.cmx : _build/src/ctypes/ctypes.cmx ocaml-ctypes-ocaml-ctypes-0.2.3/.gitignore000066400000000000000000000001361230210355500204760ustar00rootroot00000000000000_build setup.data src/ctypes/ctypes_primitives.ml src/ctypes_config.h src/ctypes_config.ml *~ ocaml-ctypes-ocaml-ctypes-0.2.3/CHANGES000066400000000000000000000027511230210355500175060ustar00rootroot00000000000000== ctypes 0.2.3 == 39cacd: Fix GC-related bug that shows up on OS X. == ctypes 0.2.2 == 608714: Don't install the cmx files for ctypes-foreign. == ctypes 0.2 == c8d54a: Basic coercion support 2552d3: Build fix for Debian Squeeze d1131d: Bigarray support 816b56: Replace returning_checking_errno with an option to Foreign.foreign 1a8ead: Check homebrew prefix during configuration 554939: Foreign.foreign, give the choice of not failing if symbol is absent. 038420: Tweak passability tests to distinguish libffi's restrictions from C's. df10e1: Move funptr and funptr_opt to the Foreign module. 71a4c7: Struct type equality is now structural, not physical 510b7a: Compulsory field names (deprecate *:* and +:+) 349422: Fix bug on 32-bit platforms 7d0037: More efficient string view implementation. 8c5b93: Expose field type function. 2d38bc: UInt32.(of|to)_int32 and UInt64.(of|to)_int64 functions. ea135b: Eliminate build-time oasis dependency d6fc68: Finalisers for ctypes-allocated memory. ea6ef2: Expose the camlint type in the public interface. 7a7106: Add the 'camlint' basic type. 9caf55: Treat sealing empty structs or unions as an error. 84ea43: Support for C99's complex number types. e2a42e: Add string_opt view 8ae5a3: Give the user control over the lifetime of closures passed to C. db1ee3: Findlib target for installing top-level pretty printers. 378a02: Pretty-printing for C values. ee178a: Pretty-printing for C types. 4ce9b5: Abstract types now have names == ctypes 0.1 == initial release ocaml-ctypes-ocaml-ctypes-0.2.3/LICENSE000066400000000000000000000020401230210355500175070ustar00rootroot00000000000000Copyright (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.ocaml-ctypes-ocaml-ctypes-0.2.3/META000066400000000000000000000031101230210355500171520ustar00rootroot00000000000000version = "0.2.3" description = "Combinators for binding to C libraries without writing any C." requires = "unix bigarray" archive(byte) = "ctypes.cma" archive(byte, plugin) = "ctypes.cma" archive(native) = "ctypes.cmxa" archive(native, plugin) = "ctypes.cmxs" exists_if = "ctypes.cma" package "top" ( version = "0.2.3" description = "Toplevel printers for C types" requires = "ctypes" archive(byte) = "ctypes-top.cma" archive(byte, plugin) = "ctypes-top.cma" archive(native) = "ctypes-top.cmxa" archive(native, plugin) = "ctypes-top.cmxs" exists_if = "ctypes-top.cma" ) package "foreign-base" ( version = "0.2.3" description = "Dynamic linking of C functions" requires = "ctypes" archive(byte) = "ctypes-foreign-base.cma" archive(byte, plugin) = "ctypes-foreign-base.cma" archive(native) = "ctypes-foreign-base.cmxa" archive(native, plugin) = "ctypes-foreign-base.cmxs" exists_if = "ctypes-foreign-base.cma" ) package "foreign" ( version = "0.2.3" description = "Dynamic linking of C functions" requires = "ctypes ctypes.foreign-base" requires(mt) = "threads ctypes ctypes.foreign-base" archive(byte, mt) = "ctypes-foreign-threaded.cma" archive(byte, plugin, mt) = "ctypes-foreign-threaded.cma" archive(native, mt) = "ctypes-foreign-threaded.cmxa" archive(native, plugin, mt) = "ctypes-foreign-threaded.cmxs" archive(byte) = "ctypes-foreign-unthreaded.cma" archive(byte, plugin) = "ctypes-foreign-unthreaded.cma" archive(native) = "ctypes-foreign-unthreaded.cmxa" archive(native, plugin) = "ctypes-foreign-unthreaded.cmxs" exists_if = "ctypes-foreign-threaded.cma" ) ocaml-ctypes-ocaml-ctypes-0.2.3/Makefile000066400000000000000000000100451230210355500201460ustar00rootroot00000000000000.SECONDEXPANSION: OCAML=ocaml OCAMLDEP=ocamldep OCAMLFIND=ocamlfind OCAMLMKLIB=ocamlmklib VPATH=src examples BUILDDIR=_build PROJECTS=configure configured ctypes ctypes-foreign-base ctypes-foreign-threaded ctypes-foreign-unthreaded ctypes-top GENERATED=src/ctypes_config.h src/ctypes_config.ml setup.data src/ctypes/ctypes_primitives.ml CFLAGS=-fPIC -Wall -O3 $(OCAML_FFI_INCOPTS) OCAML_FFI_INCOPTS=$(libffi_opt) # public targets all: setup.data build build: $(PROJECTS) clean: rm -fr _build distclean: clean rm -f $(GENERATED) # ctypes subproject ctypes.public = unsigned signed structs ctypes posixTypes ctypes.dir = src/ctypes ctypes.extra_mls = ctypes_primitives.ml ctypes.deps = bigarray ctypes.install = yes ctypes.install_native_objects = yes ctypes: PROJECT=ctypes ctypes: $(ctypes.dir)/$(ctypes.extra_mls) $$(LIB_TARGETS) # ctypes-foreign-base subproject ctypes-foreign-base.public = dl ctypes-foreign-base.install = yes ctypes-foreign-base.install_native_objects = yes ctypes-foreign-base.threads = no ctypes-foreign-base.dir = src/ctypes-foreign-base ctypes-foreign-base.subproject_deps = ctypes ctypes-foreign-base.link_flags = $(libffi_lib) ctypes-foreign-base.cmo_opts = $(OCAML_FFI_INCOPTS:%=-ccopt %) ctypes-foreign-base.cmx_opts = $(OCAML_FFI_INCOPTS:%=-ccopt %) ctypes-foreign-base: PROJECT=ctypes-foreign-base ctypes-foreign-base: $$(LIB_TARGETS) # ctypes-foreign-threaded subproject ctypes-foreign-threaded.public = foreign ctypes-foreign-threaded.install = yes ctypes-foreign-threaded.threads = yes ctypes-foreign-threaded.dir = src/ctypes-foreign-threaded ctypes-foreign-threaded.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-threaded.link_flags = $(libffi_lib) ctypes-foreign-threaded.cmo_opts = $(OCAML_FFI_INCOPTS:%=-ccopt %) ctypes-foreign-threaded.cmx_opts = $(OCAML_FFI_INCOPTS:%=-ccopt %) ctypes-foreign-threaded.install_native_objects = no ctypes-foreign-threaded: PROJECT=ctypes-foreign-threaded ctypes-foreign-threaded: $$(LIB_TARGETS) # ctypes-foreign-unthreaded subproject ctypes-foreign-unthreaded.public = foreign ctypes-foreign-unthreaded.install = yes ctypes-foreign-unthreaded.threads = no ctypes-foreign-unthreaded.dir = src/ctypes-foreign-unthreaded ctypes-foreign-unthreaded.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded.link_flags = $(libffi_lib) ctypes-foreign-unthreaded.cmo_opts = $(OCAML_FFI_INCOPTS:%=-ccopt %) ctypes-foreign-unthreaded.cmx_opts = $(OCAML_FFI_INCOPTS:%=-ccopt %) ctypes-foreign-threaded.install_native_objects = no ctypes-foreign-unthreaded: PROJECT=ctypes-foreign-unthreaded ctypes-foreign-unthreaded: $$(LIB_TARGETS) # ctypes-top subproject ctypes-top.public = ctypes_printers ctypes-top.dir = src/ctypes-top ctypes-top.install = yes ctypes-top.deps = compiler-libs ctypes-top.subproject_deps = ctypes ctypes-top.install_native_objects = yes ctypes-top: PROJECT=ctypes-top ctypes-top: $$(LIB_TARGETS) # configure subproject configure.dir = src/configure configure: PROJECT=configure configure: $$(NATIVE_TARGET) # configuration configured: src/ctypes/ctypes_primitives.ml src/ctypes/ctypes_primitives.ml: $(BUILDDIR)/configure.native $< > $@ setup.data: src/discover/discover.ml ocaml $^ -ocamlc "$(OCAMLFIND) ocamlc" # dependencies depend: configure $(OCAMLDEP) $(foreach project,$(PROJECTS),-I $($(project).dir)) \ src/*/*.mli src/*/*.ml examples/*/*.mli examples/*/*.ml \ | sed "s!src/!_build/src/!g; s!examples/!_build/examples/!g" > .depend #installation META-install: $(OCAMLFIND) install ctypes META install-%: PROJECT=$* install-%: $(if $(filter yes,$($(PROJECT).install)),\ $(OCAMLFIND) install -add ctypes $^ \ $(LIB_TARGETS) $(LIB_TARGET_EXTRAS) \ $(INSTALL_MLIS) $(INSTALL_CMIS) \ $(if $(filter yes,$($(PROJECT).install_native_objects)),$(NATIVE_OBJECTS))) install: META-install $(PROJECTS:%=install-%) uninstall: $(OCAMLFIND) remove ctypes .PHONY: depend distclean clean build configure all install $(PROJECTS) include .depend Makefile.rules Makefile.examples Makefile.tests -include setup.data ocaml-ctypes-ocaml-ctypes-0.2.3/Makefile.examples000066400000000000000000000013261230210355500217650ustar00rootroot00000000000000# -*- Makefile -*- # fts subproject fts.install = no fts.dir = examples/fts fts.deps = bigarray fts.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded fts: PROJECT=fts fts: $$(NATIVE_TARGET) # date subproject date.install = no date.dir = examples/date date.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded date.deps = bigarray date: PROJECT=date date: $$(NATIVE_TARGET) # ncurses subproject ncurses.install = no ncurses.dir = examples/ncurses ncurses.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded ncurses.deps = bigarray ncurses.link_flags = -Wl,-no-as-needed -lncurses ncurses: PROJECT=ncurses ncurses: $$(NATIVE_TARGET) examples: build ncurses fts date ocaml-ctypes-ocaml-ctypes-0.2.3/Makefile.rules000066400000000000000000000057671230210355500213160ustar00rootroot00000000000000# -*- Makefile -*- .SECONDARY: C_SOURCE = $(wildcard $($(PROJECT).dir)/*.c) ML_SOURCE = $(shell $(OCAMLDEP) -sort $(sort $(wildcard $($(PROJECT).dir)/*.ml) \ $(patsubst %,$($(PROJECT).dir)/%,$($(PROJECT).extra_mls)))) NATIVE_OBJECTS = $(ML_SOURCE:$($(PROJECT).dir)/%.ml=$(BUILDDIR)/$($(PROJECT).dir)/%.cmx) BYTE_OBJECTS = $(ML_SOURCE:$($(PROJECT).dir)/%.ml=$(BUILDDIR)/$($(PROJECT).dir)/%.cmo) C_OBJECTS = $(C_SOURCE:$($(PROJECT).dir)/%.c=$(BUILDDIR)/$($(PROJECT).dir)/%.o) STUB_LIB = $(if $(C_OBJECTS),$(BUILDDIR)/dll$(PROJECT)_stubs.so) CMO_OPTS = $($(PROJECT).cmo_opts) CMX_OPTS = $($(PROJECT).cmx_opts) CMA_OPTS = $(if $(C_OBJECTS),-cclib -l$(PROJECT)_stubs -dllib -l$(PROJECT)_stubs) SUBPROJECT_DEPS = $($(PROJECT).subproject_deps) LOCAL_CMXAS = $(SUBPROJECT_DEPS:%=$(BUILDDIR)/%.cmxa) CMXA_OPTS = $(if $(C_OBJECTS),-cclib -l$(PROJECT)_stubs) OCAMLINCLUDES = -I $(BUILDDIR)/$($(PROJECT).dir) \ $($(PROJECT).subproject_deps:%=-I $(BUILDDIR)/src/%) NATIVE_LIB=$(BUILDDIR)/$(PROJECT).cmxa NATIVE_TARGET=$(BUILDDIR)/$(PROJECT).native LIB_TARGETS = $(BUILDDIR)/$(PROJECT).cma \ $(STUB_LIB) \ $(BUILDDIR)/$(PROJECT).cmxa \ $(BUILDDIR)/$(PROJECT).cmxs LIB_TARGET_EXTRAS = $(if $(STUB_LIB),$(BUILDDIR)/lib$(PROJECT)_stubs.a) \ $(BUILDDIR)/$(PROJECT).a INSTALL_CMIS = $($(PROJECT).public:%=$(BUILDDIR)/$($(PROJECT).dir)/%.cmi) INSTALL_MLIS = $($(PROJECT).public:%=$($(PROJECT).dir)/%.mli) THREAD_FLAG = $(if $(filter yes,$($(PROJECT).threads)),-thread) LINK_FLAGS = $($(PROJECT).link_flags) OCAML_LINK_FLAGS=$(LINK_FLAGS:%=-cclib %) OCAMLFIND_PACKAGE_FLAGS=$(patsubst %,-package %,$($(PROJECT).deps)) \ $(patsubst %,-package threads,$(THREAD_FLAG)) $(BUILDDIR)/%.cmxa: $$(NATIVE_OBJECTS) $(OCAMLFIND) opt -a -linkall $(THREAD_FLAG) $(OCAMLFIND_PACKAGE_FLAGS) $(CMXA_OPTS) $(OCAML_LINK_FLAGS) -o $@ $(NATIVE_OBJECTS) $(BUILDDIR)/dll%_stubs.so: $$(C_OBJECTS) $(OCAMLMKLIB) -o $(BUILDDIR)/$*_stubs $^ $(LINK_FLAGS) $(BUILDDIR)/%.cmxs : $$(NATIVE_OBJECTS) $(OCAMLFIND) opt -shared -linkall $(THREAD_FLAG) $(OCAMLFIND_PACKAGE_FLAGS) $(OCAML_LINK_FLAGS) -o $@ $(NATIVE_OBJECTS) $(BUILDDIR)/%.cma: $$(BYTE_OBJECTS) $(OCAMLFIND) ocamlc -a $(THREAD_FLAG) $(CMA_OPTS) $(OCAMLFIND_PACKAGE_FLAGS) $(OCAML_LINK_FLAGS) -o $@ $(BYTE_OBJECTS) $(BUILDDIR)/%.cmo : %.ml @mkdir -p $(@D) $(OCAMLFIND) ocamlc $(OCAMLFIND_PACKAGE_FLAGS) $(THREAD_FLAG) $(CMO_OPTS) -c -o $@ $(OCAMLINCLUDES) $< $(BUILDDIR)/%.cmx : %.ml @mkdir -p $(@D) $(OCAMLFIND) opt -c -o $@ $(THREAD_FLAG) $(OCAMLFIND_PACKAGE_FLAGS) $(CMX_OPTS) $(OCAMLINCLUDES) $(filter %.ml,$<) $(BUILDDIR)/%.o : %.c @mkdir -p $(@D) cd $(@D) && $(OCAMLFIND) ocamlc -c $(CFLAGS:%=-ccopt %) -o $(@F) ../../../$< $(BUILDDIR)/%.cmi : %.mli @mkdir -p $(@D) $(OCAMLFIND) ocamlc -c -o $@ $(OCAMLINCLUDES) $< $(BUILDDIR)/%.native : $$(NATIVE_OBJECTS) $$(C_OBJECTS) $(OCAMLFIND) opt -I $(BUILDDIR) -linkpkg $(THREAD_FLAG) $(OCAMLFIND_PACKAGE_FLAGS) $(LOCAL_CMXAS) $(OCAML_LINK_FLAGS) -o $@ $^ ocaml-ctypes-ocaml-ctypes-0.2.3/Makefile.tests000066400000000000000000000162311230210355500213120ustar00rootroot00000000000000# -*- Makefile -*- VPATH += tests test-raw.dir = tests/test-raw test-raw.threads = yes test-raw.deps = bigarray oUnit test-raw.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-raw: PROJECT=test-raw test-raw: $$(NATIVE_TARGET) test-pointers.dir = tests/test-pointers test-pointers.threads = yes test-pointers.deps = bigarray oUnit test-pointers.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-pointers: PROJECT=test-pointers test-pointers: $$(NATIVE_TARGET) test-higher_order.dir = tests/test-higher_order test-higher_order.threads = yes test-higher_order.deps = bigarray oUnit test-higher_order.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-higher_order: PROJECT=test-higher_order test-higher_order: $$(NATIVE_TARGET) test-structs.dir = tests/test-structs test-structs.threads = yes test-structs.deps = bigarray oUnit test-structs.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-structs: PROJECT=test-structs test-structs: $$(NATIVE_TARGET) test-finalisers.dir = tests/test-finalisers test-finalisers.threads = yes test-finalisers.deps = bigarray oUnit test-finalisers.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-finalisers: PROJECT=test-finalisers test-finalisers: $$(NATIVE_TARGET) test-cstdlib.dir = tests/test-cstdlib test-cstdlib.threads = yes test-cstdlib.deps = bigarray oUnit test-cstdlib.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-cstdlib: PROJECT=test-cstdlib test-cstdlib: $$(NATIVE_TARGET) test-sizeof.dir = tests/test-sizeof test-sizeof.threads = yes test-sizeof.deps = bigarray oUnit test-sizeof.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-sizeof: PROJECT=test-sizeof test-sizeof: $$(NATIVE_TARGET) test-unions.dir = tests/test-unions test-unions.threads = yes test-unions.deps = bigarray oUnit test-unions.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-unions: PROJECT=test-unions test-unions: $$(NATIVE_TARGET) test-custom_ops.dir = tests/test-custom_ops test-custom_ops.threads = yes test-custom_ops.deps = bigarray oUnit test-custom_ops.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-custom_ops: PROJECT=test-custom_ops test-custom_ops: $$(NATIVE_TARGET) test-arrays.dir = tests/test-arrays test-arrays.threads = yes test-arrays.deps = bigarray oUnit test-arrays.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-arrays: PROJECT=test-arrays test-arrays: $$(NATIVE_TARGET) test-errno.dir = tests/test-errno test-errno.threads = yes test-errno.deps = bigarray oUnit test-errno.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-errno: PROJECT=test-errno test-errno: $$(NATIVE_TARGET) test-passable.dir = tests/test-passable test-passable.threads = yes test-passable.deps = bigarray oUnit test-passable.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-passable: PROJECT=test-passable test-passable: $$(NATIVE_TARGET) test-alignment.dir = tests/test-alignment test-alignment.threads = yes test-alignment.deps = bigarray oUnit test-alignment.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-alignment: PROJECT=test-alignment test-alignment: $$(NATIVE_TARGET) test-views.dir = tests/test-views test-views.threads = yes test-views.deps = bigarray oUnit test-views.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-views: PROJECT=test-views test-views: $$(NATIVE_TARGET) test-global_values.dir = tests/test-global_values test-global_values.threads = yes test-global_values.deps = bigarray oUnit test-global_values.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-global_values: PROJECT=test-global_values test-global_values: $$(NATIVE_TARGET) test-oo_style.dir = tests/test-oo_style test-oo_style.threads = yes test-oo_style.deps = bigarray oUnit test-oo_style.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-oo_style: PROJECT=test-oo_style test-oo_style: $$(NATIVE_TARGET) test-type_printing.dir = tests/test-type_printing test-type_printing.threads = yes test-type_printing.deps = str bigarray oUnit test-type_printing.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-type_printing: PROJECT=test-type_printing test-type_printing: $$(NATIVE_TARGET) test-value_printing.dir = tests/test-value_printing test-value_printing.threads = yes test-value_printing.deps = str bigarray oUnit test-value_printing.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-value_printing: PROJECT=test-value_printing test-value_printing: $$(NATIVE_TARGET) test-complex.dir = tests/test-complex test-complex.threads = yes test-complex.deps = bigarray oUnit test-complex.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-complex: PROJECT=test-complex test-complex: $$(NATIVE_TARGET) test-callback_lifetime.dir = tests/test-callback_lifetime test-callback_lifetime.threads = yes test-callback_lifetime.deps = bigarray oUnit test-callback_lifetime.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-callback_lifetime: PROJECT=test-callback_lifetime test-callback_lifetime: $$(NATIVE_TARGET) test-stubs.dir = tests/test-stubs test-stubs.threads = yes test-stubs.deps = bigarray oUnit test-stubs.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-stubs: PROJECT=test-stubs test-stubs: $$(NATIVE_TARGET) test-bigarrays.dir = tests/test-bigarrays test-bigarrays.threads = yes test-bigarrays.deps = bigarray oUnit test-bigarrays.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-bigarrays: PROJECT=test-bigarrays test-bigarrays: $$(NATIVE_TARGET) test-coercions.dir = tests/test-coercions test-coercions.threads = yes test-coercions.deps = bigarray oUnit test-coercions.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded test-coercions: PROJECT=test-coercions test-coercions: $$(NATIVE_TARGET) TESTS = \ test-raw \ test-pointers \ test-higher_order \ test-structs \ test-finalisers \ test-cstdlib \ test-sizeof \ test-unions \ test-custom_ops \ test-arrays \ test-errno \ test-passable \ test-alignment \ test-views \ test-global_values \ test-oo_style \ test-type_printing \ test-value_printing \ test-complex \ test-callback_lifetime \ test-stubs \ test-bigarrays \ test-coercions testlib: $(BUILDDIR)/clib/test_functions.so $(BUILDDIR)/clib/test_functions.so: $(BUILDDIR)/clib/test_functions.o $(CC) -shared $(LDFLAGS) -o $@ $^ $(BUILDDIR)/clib/test_functions.o: tests/clib/test_functions.c @mkdir -p $(@D) $(CC) -c $(CFLAGS) -o $@ $^ .PHONY: $(TESTS) test: testlib $(TESTS) $(TESTS:%=run-%) run-%: $* @echo running $* @cd $(BUILDDIR) && ./$*.native -verbose @echo ocaml-ctypes-ocaml-ctypes-0.2.3/README.md000066400000000000000000000042361230210355500177720ustar00rootroot00000000000000ctypes 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! For example, 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-4.00/manual033.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 * [Tutorial](https://github.com/ocamllabs/ocaml-ctypes/wiki/ctypes-tutorial) * [API documentation](http://ocamllabs.github.io/ocaml-ctypes) * [Mailing list](http://lists.ocaml.org/listinfo/ctypes) ocaml-ctypes-ocaml-ctypes-0.2.3/examples/000077500000000000000000000000001230210355500203245ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/examples/date/000077500000000000000000000000001230210355500212415ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/examples/date/date.ml000066400000000000000000000023521230210355500225120ustar00rootroot00000000000000(* * 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 ocaml-ctypes-ocaml-ctypes-0.2.3/examples/date/date.mli000066400000000000000000000012311230210355500226560ustar00rootroot00000000000000(* * 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 ocaml-ctypes-ocaml-ctypes-0.2.3/examples/fts/000077500000000000000000000000001230210355500211205ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/examples/fts/fts.ml000066400000000000000000000151651230210355500222560ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) 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 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 -> 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 } -> Array.(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 = Array.make typ (1 + nitems) in List.iteri (Array.set arr) list; (castp (ptr void) (Array.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 (Array.start paths) options compar; compar } ocaml-ctypes-ocaml-ctypes-0.2.3/examples/fts/fts.mli000066400000000000000000000324741230210355500224310ustar00rootroot00000000000000(* * 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 -> 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 ocaml-ctypes-ocaml-ctypes-0.2.3/examples/fts/fts_cmd.ml000066400000000000000000000017241230210355500230750ustar00rootroot00000000000000(* * 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 ents ?compar path_argv = let fts : FTS.t = fts_open ~path_argv ?compar ~options:[] in Stream.from (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 Stream.iter 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 | _ -> ()) (ents ~compar:sort_by_name paths) let () = match List.tl (Array.to_list Sys.argv) with | [] -> prerr_endline usage | l -> main l ocaml-ctypes-ocaml-ctypes-0.2.3/examples/ncurses/000077500000000000000000000000001230210355500220065ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/examples/ncurses/ncurses.ml000066400000000000000000000017731230210355500240320ustar00rootroot00000000000000(* * 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)) ocaml-ctypes-ocaml-ctypes-0.2.3/examples/ncurses/ncurses.mli000066400000000000000000000050371230210355500242000ustar00rootroot00000000000000(* * 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 ocaml-ctypes-ocaml-ctypes-0.2.3/examples/ncurses/ncurses_cmd.ml000066400000000000000000000006711230210355500246510ustar00rootroot00000000000000(* * 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() ocaml-ctypes-ocaml-ctypes-0.2.3/examples/sigset/000077500000000000000000000000001230210355500216225ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/examples/sigset/sigset.ml000066400000000000000000000041771230210355500234630ustar00rootroot00000000000000(* * 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 ocaml-ctypes-ocaml-ctypes-0.2.3/examples/sigset/sigset.mli000066400000000000000000000005431230210355500236250ustar00rootroot00000000000000(* * 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 ocaml-ctypes-ocaml-ctypes-0.2.3/examples/struct-subtyping/000077500000000000000000000000001230210355500236725ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/examples/struct-subtyping/struct_subtyping.ml000066400000000000000000000105571230210355500276640ustar00rootroot00000000000000(* * 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 Struct open OUnit module Hierarchy : sig type point2d type point3d = private point2d type coloured_point2d = private point2d val point2d : point2d structure typ val point3d : point3d structure typ val coloured_point2d : coloured_point2d structure typ val make_point2d : _x:int -> _y:int -> point2d structure val make_point3d : _x:int -> _y:int -> _z:int -> point3d structure val make_coloured_point2d : _x:int -> _y:int -> _colour:char -> coloured_point2d structure val x : (int, point2d) field val y : (int, point2d) field val z : (int, point3d) field val colour : (char, coloured_point2d) field end = struct open Type type point2d let point2d = tag "point2d" let x = point2d *:* int let y = point2d *:* int let () = seal point2d let make_point2d ~_x ~_y = let p2 = Struct.make point2d in let () = setf p2 x _x in let () = setf p2 y _y in p2 type point3d = private point2d let point3d : point3d structure typ = tag "point3d" let base = point3d *:* point2d let z = point3d *:* int let () = seal point3d let make_point3d ~_x ~_y ~_z = let p3 : point3d structure = Struct.make point3d in let base = (p3 :> point2d structure) in let () = setf base x _x in let () = setf base y _y in let () = setf p3 z _z in p3 type coloured_point2d = private point2d let coloured_point2d : coloured_point2d structure typ = tag "coloured_point2d" let base = coloured_point2d *:* point2d let colour = coloured_point2d *:* char let () = seal coloured_point2d let make_coloured_point2d ~_x ~_y ~_colour = let cp : coloured_point2d structure = Struct.make coloured_point2d in let base = (cp :> point2d structure) in let () = setf base x _x in let () = setf base y _y in let () = setf cp colour _colour in cp end let main = let open Hierarchy in let p2 = make_point2d ~_x:10 ~_y:20 in let p3 = make_point3d ~_x:100 ~_y:200 ~_z:300 in let cp = make_coloured_point2d ~_x:1000 ~_y:2000 ~_colour:'r' in (* structure subtyping *) assert_equal (getf p2 x) 10 ~printer:string_of_int; assert_equal (getf p2 y) 20 ~printer:string_of_int; assert_equal (getf (p3 :> point2d structure) x) 100 ~printer:string_of_int; assert_equal (getf (p3 :> point2d structure) y) 200 ~printer:string_of_int; assert_equal (getf p3 z) 300 ~printer:string_of_int; assert_equal (getf (cp :> point2d structure) x) 1000 ~printer:string_of_int; assert_equal (getf (cp :> point2d structure) y) 2000 ~printer:string_of_int; assert_equal (getf cp colour) 'r'; setf p2 x 11; setf p2 y 21; setf (p3 :> point2d structure) x 101; setf (p3 :> point2d structure) y 201; setf p3 z 301; setf (cp :> point2d structure) x 1001; setf (cp :> point2d structure) y 2001; setf cp colour 'b'; assert_equal (getf p2 x) 11 ~printer:string_of_int; assert_equal (getf p2 y) 21 ~printer:string_of_int; assert_equal (getf (p3 :> point2d structure) x) 101 ~printer:string_of_int; assert_equal (getf (p3 :> point2d structure) y) 201 ~printer:string_of_int; assert_equal (getf p3 z) 301 ~printer:string_of_int; assert_equal (getf (cp :> point2d structure) x) 1001 ~printer:string_of_int; assert_equal (getf (cp :> point2d structure) y) 2001 ~printer:string_of_int; assert_equal (getf cp colour) 'b'; (* field subtyping *) setf p2 x 12; setf p2 y 22; setf p3 (x :> (int, point3d) field) 102; setf p3 (y :> (int, point3d) field) 202; setf p3 z 302; setf cp (x :> (int, coloured_point2d) field) 1002; setf cp (y :> (int, coloured_point2d) field) 2002; setf cp colour 'y'; assert_equal (getf p2 x) 12 ~printer:string_of_int; assert_equal (getf p2 y) 22 ~printer:string_of_int; assert_equal (getf p3 (x :> (int, point3d) field)) 102 ~printer:string_of_int; assert_equal (getf p3 (y :> (int, point3d) field)) 202 ~printer:string_of_int; assert_equal (getf p3 z) 302 ~printer:string_of_int; assert_equal (getf cp (x :> (int, coloured_point2d) field)) 1002 ~printer:string_of_int; assert_equal (getf cp (y :> (int, coloured_point2d) field)) 2002 ~printer:string_of_int; assert_equal (getf cp colour) 'y'; print_endline "ok" ocaml-ctypes-ocaml-ctypes-0.2.3/src/000077500000000000000000000000001230210355500172755ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/src/configure/000077500000000000000000000000001230210355500212565ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/src/configure/make_primitive_details.ml000066400000000000000000000001401230210355500263150ustar00rootroot00000000000000external make_primitives : unit -> unit = "ctypes_make_primitives" let () = make_primitives () ocaml-ctypes-ocaml-ctypes-0.2.3/src/configure/make_primitive_details_stubs.c000066400000000000000000000044141230210355500273570ustar00rootroot00000000000000/* * 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 #define ALIGNMENT(T) (offsetof(struct { char c; T t; }, t)) #define FULL_ENTRY(CTOR, T, SIZE, ALIGNMENT) { #CTOR, #T, SIZE, ALIGNMENT } #define ENTRY(CTOR, T) FULL_ENTRY(CTOR, T, sizeof(T), ALIGNMENT(T)) static struct details { const char *constructor; const char *name; int size, alignment; } details[] = { ENTRY(Char, char), ENTRY(Schar, signed char), ENTRY(Uchar, unsigned char), ENTRY(Short, short), ENTRY(Int, int), ENTRY(Long, long), ENTRY(Llong, long long), ENTRY(Ushort, unsigned short), ENTRY(Uint, unsigned int), ENTRY(Ulong, unsigned long), ENTRY(Ullong, unsigned long long), ENTRY(Size_t, size_t), ENTRY(Int8_t, int8_t), ENTRY(Int16_t, int16_t), ENTRY(Int32_t, int32_t), ENTRY(Int64_t, int64_t), ENTRY(Uint8_t, uint8_t), ENTRY(Uint16_t, uint16_t), ENTRY(Uint32_t, uint32_t), ENTRY(Uint64_t, uint64_t), FULL_ENTRY(Camlint, camlint, sizeof(intnat), ALIGNMENT(intnat)), ENTRY(Nativeint, intnat), ENTRY(Float, float), ENTRY(Double, double), ENTRY(Complex32, float complex), ENTRY(Complex64, double complex), }; void generate_function(char *name, char *type, void (*cse)(struct details*)) { int i; printf("let %s : type a. a prim -> %s = function\n", name, type); for (i = 0; i < sizeof details / sizeof *details; i++) { printf(" | %s -> ", details[i].constructor); cse(&details[i]); printf("\n"); } } void print_size(struct details *d) { printf("%d", d->size); } void print_alignment(struct details *d) { printf("%d", d->alignment); } void print_name(struct details *d) { printf("\"%s\"", d->name); } value ctypes_make_primitives(value _unit) { printf("open Primitives\n"); generate_function("sizeof", "int", print_size); generate_function("alignment", "int", print_alignment); generate_function("name", "string", print_name); printf("let pointer_size = %d\n", (int)sizeof(void *)); printf("let pointer_alignment = %d\n", (int)ALIGNMENT(void *)); fflush(stdout); return Val_unit; } ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-base/000077500000000000000000000000001230210355500231435ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-base/closure_properties.ml000066400000000000000000000047361230210355500274370ustar00rootroot00000000000000(* * 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 record closure boxed_closure : int = let key = fresh () in try (* For closures we add an entry to function_by_id and a finaliser that removes the entry. *) Gc.finalise (finalise key) closure; begin Mutex.lock tables_lock; Hashtbl.add function_by_id key boxed_closure; Mutex.unlock tables_lock; end; key with Invalid_argument "Gc.finalise" -> (* For non-closures we add entries to function_by_id and id_by_function. *) begin 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; let f = try Hashtbl.find function_by_id id with Not_found -> Mutex.unlock tables_lock; raise Not_found in begin Mutex.unlock tables_lock; f end end end ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-base/closure_properties.mli000066400000000000000000000013401230210355500275740ustar00rootroot00000000000000(* * 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 ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-base/dl.ml000066400000000000000000000027711230210355500241030ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) type library type flag = RTLD_LAZY | RTLD_NOW | RTLD_GLOBAL | 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 -> int64 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 () = match _dlerror () with | None -> failwith "dl_error: expected error, but no error reported" | Some error -> raise (DL_error (error)) let crush_flags f : 'a list -> int = List.fold_left (fun i o -> i lor (f o)) 0 let dlopen ?filename ~flags = match _dlopen ?filename ~flags:(crush_flags resolve_flag flags) with | Some library -> library | None -> _report_dl_error () let dlclose ~handle = match _dlclose ~handle with | 0 -> () | _ -> _report_dl_error () let dlsym ?handle ~symbol = match _dlsym ?handle ~symbol with | Some symbol -> Ctypes_raw.PtrType.of_int64 symbol | None -> _report_dl_error () ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-base/dl.mli000066400000000000000000000015471230210355500242540ustar00rootroot00000000000000(* * 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} *) type flag = RTLD_LAZY | RTLD_NOW | RTLD_GLOBAL | RTLD_NODELETE | RTLD_NOLOAD | RTLD_DEEPBIND val dlopen : ?filename:string -> flags:flag list -> library (** Open a dynamic library. *) val dlclose : handle:library -> unit (** Close a dynamic library. *) val dlsym : ?handle:library -> symbol:string -> Ctypes_raw.voidp (** Look up a symbol in a dynamic library. *) ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-base/dl_stubs.c000066400000000000000000000045421230210355500251330ustar00rootroot00000000000000/* * 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_NODELETE, _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_NODELETE: rv = RTLD_NODELETE; break; case _RTLD_NOLOAD: rv = RTLD_NOLOAD; break; #ifdef RTLD_DEEPBIND case _RTLD_DEEPBIND: rv = RTLD_DEEPBIND; break; #endif /* _RTLD_DEEPBIND */ default: assert(0); } return Val_int(rv); } /* ctypes_dlopen : filename:string -> flags:int -> library option */ value ctypes_dlopen(value filename, value flag) { CAMLparam2(filename, flag); 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((value)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 *)Some_val(handle_option); char *s = String_val(symbol); void *result = dlsym(handle, s); CAMLreturn(result == NULL ? Val_none : Val_some(caml_copy_int64((intptr_t)result))); } /* ctypes_dlclose : handle:library -> int */ value ctypes_dlclose(value handle) { return Val_int(dlclose((void *)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); } ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-base/ffi.ml000066400000000000000000000153031230210355500242430ustar00rootroot00000000000000(* * 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) = struct open Static (* Register the closure lookup function with C. *) let () = Ffi_stubs.set_closure_callback Closure_properties.retrieve type _ ccallspec = Call : bool * (Ctypes_raw.voidp -> 'a) -> 'a ccallspec | WriteArg : ('a -> Ctypes_raw.voidp -> unit) * 'b ccallspec -> ('a -> 'b) ccallspec type arg_type = ArgType : 'a 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. *) let keep_alive w ~while_live:v = Gc.finalise (fun _ -> w; ()) v 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 (Ffi_stubs.void_ffitype ()) | Primitive p as prim -> let ffitype = Ffi_stubs.primitive_ffitype p in if ffitype = Ctypes_raw.null then report_unpassable (Type_printing.string_of_typ prim) else ArgType ffitype | Pointer _ -> ArgType (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 = 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 Ffi_stubs.struct_type_set_argument bufspec i t) fields; Ffi_stubs.complete_struct_type bufspec; ArgType (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. string option -> a ccallspec -> (Ctypes_raw.voidp -> unit) list -> Ffi_stubs.callspec -> Ctypes_raw.voidp -> a = fun name -> function | Call (check_errno, read_return_value) -> let call = match check_errno, name with | true, Some name -> Ffi_stubs.call_errno name | true, None -> Ffi_stubs.call_errno "" | false, _ -> Ffi_stubs.call in fun writers callspec addr -> call addr callspec (fun buf -> List.iter (fun w -> w buf) writers) read_return_value | 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. Ffi_stubs.callspec -> a typ -> int = fun callspec -> function | Void -> 0 | ty -> let ArgType ffitype = arg_type ty in Ffi_stubs.add_argument callspec ffitype let prep_callspec callspec ty = let ArgType ctype = arg_type ty in Ffi_stubs.prep_callspec callspec ctype let rec box_function : type a. a fn -> Ffi_stubs.callspec -> a WeakRef.t -> Ffi_stubs.boxedfn = fun fn callspec -> match fn with | Returns ty -> let () = prep_callspec callspec ty in let write_rv = Memory.write ty in fun f -> Ffi_stubs.Done (write_rv ~offset:0 (WeakRef.get f), callspec) | Function (p, f) -> let _ = add_argument callspec p in let box = box_function f callspec in let read = Memory.build p ~offset:0 in fun f -> Ffi_stubs.Fn (fun buf -> let f' = try WeakRef.get f (read buf) with WeakRef.EmptyWeakReference -> raise Ffi_stubs.CallToExpiredClosure in let v = box (WeakRef.make f') in let () = Gc.finalise (fun _ -> f'; ()) v in 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. check_errno:bool -> a fn -> Ffi_stubs.callspec -> a ccallspec = fun ~check_errno fn callspec -> match fn with | Returns t -> let () = prep_callspec callspec t in Call (check_errno, Memory.build t ~offset:0) | Function (p, f) -> let offset = add_argument callspec p in let rest = build_ccallspec ~check_errno f callspec in WriteArg (Memory.write p ~offset, rest) let build_function ?name ~check_errno fn = let c = Ffi_stubs.allocate_callspec () in let e = build_ccallspec ~check_errno fn c in invoke name e [] c let ptr_of_rawptr raw_ptr = { raw_ptr ; pbyte_offset = 0; reftype = void; pmanaged = None } let function_of_pointer ?name ~check_errno fn = let f = build_function ?name ~check_errno fn in fun {raw_ptr} -> f raw_ptr let pointer_of_function fn = let cs' = Ffi_stubs.allocate_callspec () in let cs = box_function fn cs' in fun f -> let boxed = cs (WeakRef.make f) in let id = Closure_properties.record (Obj.repr f) (Obj.repr boxed) in ptr_of_rawptr (Ffi_stubs.make_function_pointer cs' id) end ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-base/ffi.mli000066400000000000000000000022361230210355500244150ustar00rootroot00000000000000(* * 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 Static (** Dynamic function calls based on libffi *) val function_of_pointer : ?name:string -> check_errno:bool -> ('a -> 'b) fn -> unit ptr -> ('a -> 'b) (** Build an OCaml function from a type specification and a pointer to a C function. *) val pointer_of_function : ('a -> 'b) fn -> ('a -> 'b) -> unit ptr (** 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. *) end ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-base/ffi_call_stubs.c000066400000000000000000000272151230210355500262750ustar00rootroot00000000000000/* * 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 "../ctypes/managed_buffer_stubs.h" #include "../ctypes/type_info_stubs.h" #include "../ctypes/raw_pointer.h" /* TODO: support callbacks that raise exceptions? e.g. using caml_callback_exn etc. */ /* TODO: thread support */ /* An OCaml function that converts resolves identifiers to OCaml functions */ static value retrieve_closure_; /* Resolve identifiers to OCaml functions */ static value retrieve_closure(int key) { CAMLparam0 (); CAMLlocal1(result); result = caml_callback_exn(retrieve_closure_, Val_int(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: raise_with_string(*caml_named_value("FFI_internal_error"), "FFI_BAD_TYPEDEF"); case FFI_BAD_ABI: 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 bufferspec value. */ enum { BUILDING, CALLSPEC } state; /* A null-terminated array of size `nelements' types */ ffi_type **args; /* return value offset */ size_t roffset; /* 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, NULL }; static void finalize_bufferspec(value v) { struct callspec *callspec = Data_custom_val(v); free(callspec->args); free(callspec->cif); } static struct custom_operations callspec_custom_ops = { "ocaml-ctypes:bufferspec", finalize_bufferspec, custom_compare_default, custom_hash_default, custom_serialize_default, custom_deserialize_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 : unit -> callspec */ value ctypes_allocate_callspec(value unit) { value block = caml_alloc_custom(&callspec_custom_ops, sizeof(struct callspec), 0, 1); memcpy(Data_custom_val(block), &callspec_prototype, sizeof(struct callspec)); 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_int(offset)); } /* Pass the return type and conclude the specification preparation */ /* prep_callspec : callspec -> 'a ffitype -> unit */ value ctypes_prep_callspec(value callspec_, value rtype) { CAMLparam2(callspec_, rtype); struct callspec *callspec = Data_custom_val(callspec_); ffi_type *rffitype = CTYPES_TO_PTR(rtype); /* 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->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, FFI_DEFAULT_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 : raw_pointer -> callspec -> (raw_pointer -> unit) -> (raw_pointer -> 'a) -> 'a */ value ctypes_call(value function, value callspec_, value argwriter, value rvreader) { CAMLparam4(function, callspec_, argwriter, rvreader); CAMLlocal2(callback_arg_buf, callback_rv_buf); struct callspec *callspec = Data_custom_val(callspec_); int roffset = callspec->roffset; 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_slot = callbuffer + roffset; populate_arg_array(callspec, (struct callbuffer *)callbuffer, (void **)(callbuffer + arg_array_offset)); callback_arg_buf = CTYPES_FROM_PTR(callbuffer); caml_callback(argwriter, callback_arg_buf); void (*cfunction)(void) = (void (*)(void)) CTYPES_TO_PTR(function); ffi_call(((struct callspec *)Data_custom_val(callspec_))->cif, cfunction, return_slot, (void **)(callbuffer + arg_array_offset)); callback_rv_buf = CTYPES_FROM_PTR(return_slot); CAMLreturn(caml_callback(rvreader, callback_rv_buf)); } /* call_errno : string -> raw_pointer -> callspec -> (raw_pointer -> unit) -> (raw_pointer -> 'a) -> 'a */ value ctypes_call_errno(value fnname, value function, value callspec_, value argwriter, value rvreader) { CAMLparam5(fnname, function, callspec_, argwriter, rvreader); errno = 0; CAMLlocal1(rv); rv = ctypes_call(function, callspec_, argwriter, rvreader); if (errno != 0) { char *buffer = alloca(caml_string_length(fnname) + 1); strcpy(buffer, String_val(fnname)); unix_error(errno, buffer, Nothing); } CAMLreturn(rv); } typedef struct closure closure; struct closure { ffi_closure closure; int fnkey; }; enum boxedfn_tags { Done, Fn }; static void callback_handler(ffi_cif *cif, void *ret, void **args, void *user_data) { CAMLparam0 (); CAMLlocal2(boxedfn, argptr); boxedfn = retrieve_closure(*(int *)user_data); int i, arity = cif->nargs; 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); } /* now store the return value */ assert (Tag_val(boxedfn) == Done); argptr = CTYPES_FROM_PTR(ret); caml_callback(Field(boxedfn, 0), argptr); CAMLreturn0; } /* 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; /* TODO: we need to call ffi_closure_free at some point. This function should return a managed object to which we can attach a finaliser for the closure. */ closure *closure = ffi_closure_alloc(sizeof *closure, (void *)&code_address); if (closure == NULL) { caml_raise_out_of_memory(); } else { closure->fnkey = Int_val(fnid); ffi_status status = ffi_prep_closure_loc ((ffi_closure *)closure, callspec->cif, callback_handler, &closure->fnkey, (void *)code_address); ctypes_check_ffi_status(status); codeptr = CTYPES_FROM_PTR((void *)code_address); CAMLreturn (codeptr); } } ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-base/ffi_stubs.ml000066400000000000000000000054441230210355500254700ustar00rootroot00000000000000(* * 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_raw (* The type of structure types *) type 'a ffitype = voidp type struct_ffitype external primitive_ffitype : 'a Primitives.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 : unit -> 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 -> _ 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 : voidp -> callspec -> (voidp -> unit) -> (voidp -> 'a) -> 'a = "ctypes_call" (* As ctypes_call, but check errno and raise Unix_error if the call failed. *) external call_errno : string -> voidp -> callspec -> (voidp -> unit) -> (voidp -> 'a) -> 'a = "ctypes_call_errno" (* nary callbacks *) type boxedfn = | Done of (voidp -> unit) * callspec | Fn of (voidp -> boxedfn) (* Construct a pointer to an OCaml function represented by an identifier *) external make_function_pointer : callspec -> int -> voidp = "ctypes_make_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 ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-base/ffi_type_stubs.c000066400000000000000000000104501230210355500263340ustar00rootroot00000000000000/* * 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 "../ctypes/raw_pointer.h" #include "../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 /* The order here must correspond to the constructor order in primitives.ml */ static ffi_type *primitive_ffi_types[] = { &ctypes_ffi_type_char, /* Char */ &ffi_type_schar, /* Schar */ &ffi_type_uchar, /* Uchar */ &ffi_type_sshort, /* Short */ &ffi_type_sint, /* Int */ &ffi_type_slong, /* Long */ &ctypes_ffi_type_sllong, /* Llong */ &ffi_type_ushort, /* Ushort */ &ffi_type_ulong, /* Uint */ &ffi_type_ulong, /* Ulong */ &ctypes_ffi_type_ullong, /* Ullong */ &ctypes_ffi_type_size_t, /* Size */ &ffi_type_sint8, /* Int8 */ &ffi_type_sint16, /* Int16 */ &ffi_type_sint32, /* Int32 */ &ffi_type_sint64, /* Int64 */ &ffi_type_uint8, /* Uint8 */ &ffi_type_uint16, /* Uint16 */ &ffi_type_uint32, /* Uint32 */ &ffi_type_uint64, /* Uint64 */ &ctypes_ffi_type_camlint, /* Camlint */ &ctypes_ffi_type_camlint, /* Nativeint */ &ffi_type_float, /* Float */ &ffi_type_double, /* Double */ NULL, /* Complex32 */ NULL, /* Complex64 */ }; /* primitive_ffitype : 'a prim -> 'a ffitype */ value ctypes_primitive_ffitype(value prim) { return CTYPES_FROM_PTR(primitive_ffi_types[Int_val(prim)]); } /* 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(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; } ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-base/foreign_basis.ml000066400000000000000000000025031230210355500263070ustar00rootroot00000000000000(* * 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 : Ffi.CLOSURE_PROPERTIES) = struct open Dl open Ctypes module Ffi = Ffi.Make(Closure_properties) exception CallToExpiredClosure = Ffi_stubs.CallToExpiredClosure let format_function_pointer fn k fmt = Type_printing.format_fn' fn (fun fmt -> Format.fprintf fmt "(*%t)" k) fmt let funptr ?name ?(check_errno=false) fn = let open Ffi in let read = function_of_pointer ~check_errno ?name fn and write = pointer_of_function fn and format_typ = format_function_pointer fn in Static.(view ~format_typ ~read ~write (ptr void)) let castp typ p = Memory.(from_voidp typ (to_voidp p)) let funptr_opt fn = Std_views.nullable_view (funptr fn) let ptr_of_raw_ptr p = Ctypes.ptr_of_raw_address (Ctypes_raw.PtrType.to_int64 p) let foreign_value ?from symbol t = from_voidp t (ptr_of_raw_ptr (dlsym ?handle:from ~symbol)) let foreign ?from ?(stub=false) ?(check_errno=false) symbol typ = try let coerce = Coerce.coerce (ptr void) (funptr ~name:symbol ~check_errno typ) in coerce (ptr_of_raw_ptr (dlsym ?handle:from ~symbol)) with | exn -> if stub then fun _ -> raise exn else raise exn end ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-base/weakRef.ml000066400000000000000000000006651230210355500250700ustar00rootroot00000000000000(* * 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 ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-base/weakRef.mli000066400000000000000000000012021230210355500252250ustar00rootroot00000000000000(* * 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. *) ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-threaded/000077500000000000000000000000001230210355500240115ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-threaded/foreign.ml000066400000000000000000000003201230210355500257670ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) include Foreign_basis.Make(Closure_properties.Make(Mutex)) ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-threaded/foreign.mli000066400000000000000000000043041230210355500261460ustar00rootroot00000000000000(* * 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 : ?from:Dl.library -> ?stub:bool -> ?check_errno:bool -> string -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) (** [foreign name typ] exposes the C function of type [typ] named by [name] as an OCaml value. The argument [?from], if supplied, is a library handle returned by {!Dl.dlopen}. The argument [?stub], if [true] (defaults to [false]), indicates that the function should not raise an exception if [name] is not found but return an OCaml value that raises an exception when called. The value [?check_errno], which defaults to [false], indicates whether {!Unix.Unix_error} should be raised if the C function modifies [errno]. @raise Dl.DL_error if [name] is not found in [?from] and [?stub] is [false]. *) val foreign_value : ?from:Dl.library -> string -> 'a Ctypes.typ -> 'a Ctypes.ptr (** [foreign_value name typ] exposes the C value of type [typ] named by [name] as an OCaml value. The argument [?from], if supplied, is a library handle returned by {!Dl.dlopen}. *) val funptr : ?name:string -> ?check_errno:bool -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) Ctypes.typ (** Construct a function pointer type from a function type. The ctypes library, like C itself, distinguishes functions and function pointers. Functions are not first class: it is not possible to use them as arguments or return values of calls, or store them in addressable memory. Function pointers are first class, and so have none of these restrictions. The value [?check_errno], which defaults to [false], indicates whether {!Unix.Unix_error} should be raised if the C function modifies [errno]. *) val funptr_opt : ('a -> 'b) Ctypes.fn -> ('a -> 'b) option Ctypes.typ (** Construct a function pointer type from a function type. 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. *) ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-unthreaded/000077500000000000000000000000001230210355500243545ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-unthreaded/foreign.ml000066400000000000000000000003231230210355500263350ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) include Foreign_basis.Make(Closure_properties.Make(Gc_mutex)) ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-unthreaded/foreign.mli000066400000000000000000000043041230210355500265110ustar00rootroot00000000000000(* * 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 : ?from:Dl.library -> ?stub:bool -> ?check_errno:bool -> string -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) (** [foreign name typ] exposes the C function of type [typ] named by [name] as an OCaml value. The argument [?from], if supplied, is a library handle returned by {!Dl.dlopen}. The argument [?stub], if [true] (defaults to [false]), indicates that the function should not raise an exception if [name] is not found but return an OCaml value that raises an exception when called. The value [?check_errno], which defaults to [false], indicates whether {!Unix.Unix_error} should be raised if the C function modifies [errno]. @raise Dl.DL_error if [name] is not found in [?from] and [?stub] is [false]. *) val foreign_value : ?from:Dl.library -> string -> 'a Ctypes.typ -> 'a Ctypes.ptr (** [foreign_value name typ] exposes the C value of type [typ] named by [name] as an OCaml value. The argument [?from], if supplied, is a library handle returned by {!Dl.dlopen}. *) val funptr : ?name:string -> ?check_errno:bool -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) Ctypes.typ (** Construct a function pointer type from a function type. The ctypes library, like C itself, distinguishes functions and function pointers. Functions are not first class: it is not possible to use them as arguments or return values of calls, or store them in addressable memory. Function pointers are first class, and so have none of these restrictions. The value [?check_errno], which defaults to [false], indicates whether {!Unix.Unix_error} should be raised if the C function modifies [errno]. *) val funptr_opt : ('a -> 'b) Ctypes.fn -> ('a -> 'b) option Ctypes.typ (** Construct a function pointer type from a function type. 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. *) ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-foreign-unthreaded/gc_mutex.ml000066400000000000000000000016231230210355500265230ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* For internal use only, and really only for use with Closure_properties_base. A mutex for synchronizing between the GC (i.e. finalisers) and the single mutator thread. Provides very few guarantees. Since the program is single-threaded, there is no waiting; locking either succeeds or fails immediately. *) exception MutexError of string type t = { mutable locked: bool } let create () = { locked = false } (* the only allocation below is exception raising *) let lock m = if m.locked then raise (MutexError "Locking locked mutex") else m.locked <- true let try_lock m = if m.locked then false else (m.locked <- true; true) let unlock m = if not m.locked then raise (MutexError "Unlocking unlocked mutex") else m.locked <- false ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-top/000077500000000000000000000000001230210355500214045ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-top/ctypes_printers.ml000066400000000000000000000057031230210355500252000ustar00rootroot00000000000000(* * 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_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_size_t fmt v = Format.fprintf fmt "" (Unsigned.Size_t.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 Array.(array (length v) (reference_type (start v))) fmt v) let format_blkcnt_t fmt v = Ctypes.format PosixTypes.blkcnt_t fmt v let format_blksize_t fmt v = Ctypes.format PosixTypes.blksize_t 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_fsblkcnt_t fmt v = Ctypes.format PosixTypes.fsblkcnt_t fmt v let format_fsfilcnt_t fmt v = Ctypes.format PosixTypes.fsfilcnt_t fmt v let format_gid_t fmt v = Ctypes.format PosixTypes.gid_t fmt v let format_id_t fmt v = Ctypes.format PosixTypes.id_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_suseconds_t fmt v = Ctypes.format PosixTypes.suseconds_t fmt v let format_time_t fmt v = Ctypes.format PosixTypes.time_t fmt v let format_uid_t fmt v = Ctypes.format PosixTypes.uid_t fmt v let format_useconds_t fmt v = Ctypes.format PosixTypes.useconds_t fmt v ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-top/ctypes_printers.mli000066400000000000000000000043711230210355500253510ustar00rootroot00000000000000(* * 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_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.Array.t -> unit val format_blkcnt_t : formatter -> PosixTypes.blkcnt_t -> unit val format_blksize_t : formatter -> PosixTypes.blksize_t -> unit val format_clock_t : formatter -> PosixTypes.clock_t -> unit val format_dev_t : formatter -> PosixTypes.dev_t -> unit val format_fsblkcnt_t : formatter -> PosixTypes.fsblkcnt_t -> unit val format_fsfilcnt_t : formatter -> PosixTypes.fsfilcnt_t -> unit val format_gid_t : formatter -> PosixTypes.gid_t -> unit val format_id_t : formatter -> PosixTypes.id_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_suseconds_t : formatter -> PosixTypes.suseconds_t -> unit val format_time_t : formatter -> PosixTypes.time_t -> unit val format_uid_t : formatter -> PosixTypes.uid_t -> unit val format_useconds_t : formatter -> PosixTypes.useconds_t -> unit ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes-top/install_printers.ml000066400000000000000000000046451230210355500253430ustar00rootroot00000000000000(* Adapted from Anil Madhavapeddy's ocaml-uri package. *) let printers = [ "Ctypes_printers.format_typ"; "Ctypes_printers.format_fn"; "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_blkcnt_t"; "Ctypes_printers.format_blksize_t"; "Ctypes_printers.format_clock_t"; "Ctypes_printers.format_dev_t"; "Ctypes_printers.format_fsblkcnt_t"; "Ctypes_printers.format_fsfilcnt_t"; "Ctypes_printers.format_gid_t"; "Ctypes_printers.format_id_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_suseconds_t"; "Ctypes_printers.format_time_t"; "Ctypes_printers.format_uid_t"; "Ctypes_printers.format_useconds_t";] 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@." ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/000077500000000000000000000000001230210355500206045ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/bigarray_stubs.ml000066400000000000000000000033751230210355500241660ustar00rootroot00000000000000(* * 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 external kind : ('a, 'b) Bigarray.kind -> 'a kind (* Bigarray.kind is simply an int whose values are consecutively numbered starting from zero, so we can directly transform its values to a variant with appropriately-ordered constructors. Unfortunately, Bigarray.char and Bigarray.int8_unsigned are currently indistinguishable, so the 'kind' function will never return Kind_char. Mantis bug 6064 has a patch that gives char and int8_unsigned distinct representations. *) = "%identity" external address : 'b -> Ctypes_raw.voidp = "ctypes_bigarray_address" external view : 'a kind -> dims:int array -> Ctypes_raw.voidp -> offset:int -> ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t = "ctypes_bigarray_view" external view1 : 'a kind -> dims:int array -> Ctypes_raw.voidp -> offset:int -> ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t = "ctypes_bigarray_view" external view2 : 'a kind -> dims:int array -> Ctypes_raw.voidp -> offset:int -> ('a, 'b, Bigarray.c_layout) Bigarray.Array2.t = "ctypes_bigarray_view" external view3 : 'a kind -> dims:int array -> Ctypes_raw.voidp -> offset:int -> ('a, 'b, Bigarray.c_layout) Bigarray.Array3.t = "ctypes_bigarray_view" ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/coerce.ml000066400000000000000000000011271230210355500223770ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Coercions *) open Static exception Uncoercible let rec coerce : type a b. a typ -> b typ -> a -> b = fun atyp btyp -> match atyp, btyp with | _, Void -> fun _ -> () | View av, b -> let coerce = coerce av.ty b in fun v -> coerce (av.write v) | a, View bv -> let coerce = coerce a bv.ty in fun v -> bv.read (coerce v) | Pointer _, Pointer b -> fun v -> Memory.(from_voidp b (to_voidp v)) | _ -> raise Uncoercible ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/coerce.mli000066400000000000000000000003441230210355500225500ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) exception Uncoercible val coerce : 'a Static.typ -> 'b Static.typ -> 'a -> 'b ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/common.ml000066400000000000000000000005261230210355500224310ustar00rootroot00000000000000(* * 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 format v = let buf = Buffer.create 100 in let fmt = Format.formatter_of_buffer buf in begin format fmt v; Format.pp_print_flush fmt (); Buffer.contents buf end ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/ctypes.ml000066400000000000000000000005621230210355500224500ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) include Static include Structs_computed include Type_printing include Memory include Std_views include Value_printing include Coerce let ( *:* ) s t = field s "" t let ( +:+ ) s t = field s "" t ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/ctypes.mli000066400000000000000000000550131230210355500226220ustar00rootroot00000000000000(* * 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. *) open Signed open Unsigned (** {2:types Values representing C types} *) type 'a typ = 'a Static.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. *) 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 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 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]. *) (** {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]. *) (** {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. *) (** {4:pointer_types Pointer types} *) type 'a ptr (** The type of pointer values. A value of type [t ptr] can be used to read and write values of type [t] at particular addresses. *) val ptr : 'a typ -> 'a ptr typ (** Construct a pointer type from an existing type (called the {i reference type}). *) val ptr_opt : 'a typ -> 'a 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. *) 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]. *) (** {3 Array types} *) (** {4 C array types} *) (**/**) type 'a std_array = 'a array (**/**) type 'a array (** The type of C array values. A value of type [t array] can be used to read and write array objects in C-managed storage. *) val array : int -> 'a typ -> 'a array typ (** Construct a sized array type from a length and an existing type (called the {i element type}). *) (** {4 Bigarray types} *) type _ bigarray_class (** The type of Bigarray classes. There are four instances, one for each of the Bigarray submodules. *) val genarray : < element: 'a; ba_repr: 'b; bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t; carray: 'a array; dims: int std_array > bigarray_class (** The class of {!Bigarray.Genarray.t} values *) val array1 : < element: 'a; ba_repr: 'b; bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t; carray: 'a array; dims: int > bigarray_class (** The class of {!Bigarray.Array1.t} values *) val array2 : < element: 'a; ba_repr: 'b; bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Array2.t; carray: 'a array array; dims: int * int > bigarray_class (** The class of {!Bigarray.Array2.t} values *) val array3 : < element: 'a; ba_repr: 'b; bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Array3.t; carray: 'a array array array; dims: int * int * int > bigarray_class (** The class of {!Bigarray.Array3.t} values *) val bigarray : < element: 'a; ba_repr: 'b; dims: 'dims; bigarray: 'bigarray; carray: _ > bigarray_class -> 'dims -> ('a, 'b) Bigarray.kind -> 'bigarray typ (** Construct a sized bigarray type representation from a bigarray class, the dimensions, and the {!Bigarray.kind}. *) (** {3 Function types} *) type 'a fn = 'a 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 Struct and union types} *) type ('a, 'kind) structured = ('a, 'kind) 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 (** 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]. *) val structure : string -> 's structure typ (** Construct a new structure type. The type value returned is incomplete and can be updated using {!(*:*)} 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 union typ (** Construct a new union type. This behaves analogously to {!structure}; fields are added with {!(+:+)}. *) val field : 't typ -> string -> 'a typ -> ('a, (('s, [<`Struct | `Union]) 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 ( *:* ) : 't typ -> 'a typ -> ('a, (('s, [`Struct]) structured as 't)) field (** @deprecated Add an anonymous field to a structure. Use {!field} instead. *) val ( +:+ ) : 't typ -> 'a typ -> ('a, (('s, [`Union]) structured as 't)) field (** @deprecated Add an anonymous field to a union. Use {!field} instead. *) val seal : (_, [< `Struct | `Union]) 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) -> 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. *) (** {3 Abstract types} *) type 'a 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.) *) val abstract : name:string -> size:int -> alignment:int -> 'a abstract typ (** Create an abstract type specification from the size and alignment requirements for the type. *) (** {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 ptr -> int -> 'a ptr (** If [p] is a pointer to an array element then [p +@ n] computes the address of the [n]th next element. *) val (-@) : 'a ptr -> int -> 'a ptr (** If [p] is a pointer to an array element then [p -@ n] computes the address of the nth previous element. *) val ptr_diff : 'a ptr -> 'a ptr -> 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. *) 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. *) 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 reference_type : 'a ptr -> 'a typ (** Retrieve the reference type of a pointer. *) val ptr_of_raw_address : int64 -> unit ptr (** Convert the numeric representation of an address to a pointer *) (** {3 Array values} *) (** {4 C array values} *) module Array : sig type 'a t = 'a array 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 {!(!@)}. You can also write [a.(n)] instead of [Array.get a n]. Raise [Invalid_argument "index out of bounds"] if [n] is outside of the range [0] to [(Array.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]. You can also write [a.(n) <- v] instead of [Array.set a n v]. Raise [Invalid_argument "index out of bounds"] if [n] is outside of the range [0] to [(Array.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 [(Array.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 [(Array.length a - 1)] is not performed. *) 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 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 element_type : 'a array -> 'a typ (** Retrieve the element type of an array. *) end (** Operations on C arrays. *) (** {4 Bigarray values} *) val bigarray_start : < element: 'a; 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; ba_repr: 'f; bigarray: 'b; carray: _; dims: 'i > bigarray_class -> 'i -> ('a, 'f) Bigarray.kind -> 'a ptr -> 'b (** Convert a C pointer to a bigarray value. *) val array_of_bigarray : < element: _; ba_repr: _; bigarray: 'b; carray: 'c; dims: _ > bigarray_class -> 'b -> 'c (** Convert a C array to a Bigarray value. *) val bigarray_of_array : < element: 'a; ba_repr: 'f; bigarray: 'b; carray: 'c array; dims: 'i > bigarray_class -> ('a, 'f) Bigarray.kind -> 'c array -> 'b (** Convert a Bigarray value to a C array. *) (** {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 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 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]. 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 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. *) exception Uncoercible (** An attempt was made to coerce between uncoercible types. *) ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/ctypes_bigarray.ml000066400000000000000000000061621230210355500243320ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Bigarray_stubs let prim_of_kind : type a. a kind -> a Primitives.prim = let open Primitives 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 string_of_kind : type a. a kind -> string = function Kind_float32 -> "float32" | Kind_float64 -> "float64" | Kind_int8_signed -> "int8_signed" | Kind_int8_unsigned -> "int8_unsigned" | Kind_int16_signed -> "int16_signed" | Kind_int16_unsigned -> "int16_unsigned" | Kind_int32 -> "int32" | Kind_int64 -> "int64" | Kind_int -> "int" | 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, _, Bigarray.c_layout) Bigarray.Genarray.t) dims | Dims1 : int -> ('a, ('a, _, Bigarray.c_layout) Bigarray.Array1.t) dims | Dims2 : int * int -> ('a, ('a, _, Bigarray.c_layout) Bigarray.Array2.t) dims | Dims3 : int * int * int -> ('a, ('a, _, Bigarray.c_layout) Bigarray.Array3.t) dims type ('a, 'b) t = ('a, 'b) dims * 'a kind let elements : type a b. (b, a) 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 sizeof (d, k) = elements d * bigarray_kind_sizeof k let alignment (d, k) = bigarray_kind_alignment k let bigarray ds k = (DimsGen ds, kind k) let bigarray1 d k = (Dims1 d, kind k) let bigarray2 d1 d2 k = (Dims2 (d1, d2), kind k) let bigarray3 d1 d2 d3 k = (Dims3 (d1, d2, d3), kind k) let format_kind fmt k = Format.pp_print_string fmt (string_of_kind k) let format_dims : type a b. _ -> (b, a) dims -> unit = fun fmt t -> match t with | DimsGen ds -> Array.iter (Format.fprintf fmt "[%d]") ds | Dims1 d1 -> Format.fprintf fmt "[%d]" d1 | Dims2 (d1, d2) -> Format.fprintf fmt "[%d][%d]" d1 d2 | Dims3 (d1, d2, d3) -> Format.fprintf fmt "[%d][%d][%d]" d1 d2 d3 let format fmt (t, ck) = begin format_kind fmt ck; format_dims fmt t end let prim_of_kind k = prim_of_kind (kind k) let address _ b = Bigarray_stubs.address b let view : type a b. (a, b) t -> ?ref:Obj.t -> Ctypes_raw.voidp -> offset:int -> b = let open Bigarray_stubs in fun (dims, kind) ?ref ptr ~offset -> let ba : b = match dims with | DimsGen ds -> view kind ds ptr offset | Dims1 d -> view1 kind [| d |] ptr offset | Dims2 (d1, d2) -> view2 kind [| d1; d2 |] ptr offset | Dims3 (d1, d2, d3) -> view3 kind [| d1; d2; d3 |] ptr offset in match ref with | None -> ba | Some src -> Gc.finalise (fun _ -> ignore src; ()) ba; ba ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/ctypes_bigarray.mli000066400000000000000000000036151230210355500245030ustar00rootroot00000000000000(* * 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) t (** The type of bigarray values of particular sizes. A value of type [(a, b) t] can be used to read and write values of type [b] at particular addresses. *) (** {3 Type constructors *) val bigarray : int array -> ('a, 'b) Bigarray.kind -> ('a, ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t) t (** Create a {!t} value for the {!Bigarray.Genarray.t} type. *) val bigarray1 : int -> ('a, 'b) Bigarray.kind -> ('a, ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t) t (** Create a {!t} value for the {!Bigarray.Array1.t} type. *) val bigarray2 : int -> int -> ('a, 'b) Bigarray.kind -> ('a, ('a, 'b, Bigarray.c_layout) Bigarray.Array2.t) t (** Create a {!t} value for the {!Bigarray.Array2.t} type. *) val bigarray3 : int -> int -> int -> ('a, 'b) Bigarray.kind -> ('a, ('a, 'b, Bigarray.c_layout) Bigarray.Array3.t) t (** Create a {!t} value for the {!Bigarray.Array3.t} type. *) val prim_of_kind : ('a, _) Bigarray.kind -> 'a Primitives.prim (** Create a {!Ctypes_raw.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 format : Format.formatter -> (_, _) t -> unit (** Pretty-print a bigarray type. *) (** {2 Values *) val address : (_, 'a) t -> 'a -> Ctypes_raw.voidp (** Return the address of a bigarray value. *) val view : (_, 'a) t -> ?ref:Obj.t -> Ctypes_raw.voidp -> offset:int -> 'a (** Create a bigarray view onto existing memory. The optional [ref] argument is an OCaml object that controls the lifetime of the memory; if [ref] is present, [view] will ensure that it is not collected before the bigarray returned by [view]. *) ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/ctypes_bigarray_stubs.c000066400000000000000000000016601230210355500253620ustar00rootroot00000000000000/* * 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 "raw_pointer.h" /* 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 -> ptr -> offset:int -> ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t */ value ctypes_bigarray_view(value kind_, value dims_, value ptr_, value offset_) { int kind = Int_val(kind_); int ndims = Wosize_val(dims_); int offset = Int_val(offset_); intnat dims[CAML_BA_MAX_NUM_DIMS]; int i; for (i = 0; i < ndims; i++) { dims[i] = Int_val(Field(dims_, i)); } int flags = kind | CAML_BA_C_LAYOUT | CAML_BA_EXTERNAL; void *data = offset + (char *)CTYPES_TO_PTR(ptr_); return caml_ba_alloc(flags, ndims, data, dims); } ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/ctypes_raw.ml000066400000000000000000000007141230210355500233200ustar00rootroot00000000000000(* * 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 . *) module PtrType = (val match Ctypes_primitives.pointer_size with 4 -> (module Signed.Int32 : Signed.S) | 8 -> (module Signed.Int64 : Signed.S) | _ -> failwith "No suitable type available to represent pointers.") type voidp = PtrType.t let null = PtrType.zero ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/managed_buffer_stubs.c000066400000000000000000000027101230210355500251150ustar00rootroot00000000000000/* * 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 "raw_pointer.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 long hash_address(value l) { /* address hashing */ return (long)*(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 }; /* allocate : int -> managed_buffer */ value ctypes_allocate(value size_) { CAMLparam1(size_); int size = Int_val(size_); CAMLlocal1(block); block = caml_alloc_custom(&managed_buffer_custom_ops, sizeof(void*), 0, 1); void *p = caml_stat_alloc(size); 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)); } ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/managed_buffer_stubs.h000066400000000000000000000007321230210355500251240ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef MANAGED_BUFFER_STUBS_H #define MANAGED_BUFFER_STUBS_H #include /* allocate : int -> managed_buffer */ extern value ctypes_allocate(value size); /* block_address : managed_buffer -> immediate_pointer */ extern value ctypes_block_address(value managed_buffer); #endif /* MANAGED_BUFFER_STUBS_H */ ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/memory.ml000066400000000000000000000243011230210355500224460ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Static module Stubs = Memory_stubs module Raw = Ctypes_raw (* Describes how to read a value, e.g. from a return buffer *) let rec build : type a. a typ -> offset:int -> Raw.voidp -> a = function | Void -> fun ~offset _ -> () | Primitive p -> Stubs.read p | Struct { spec = Incomplete _ } -> raise IncompleteType | Struct { spec = Complete { size } } as reftype -> (fun ~offset buf -> let m = Stubs.allocate size in let raw_ptr = Stubs.block_address m in let () = Stubs.memcpy ~size ~dst:raw_ptr ~dst_offset:0 ~src:buf ~src_offset:offset in { structured = { pmanaged = Some (Obj.repr m); reftype; raw_ptr; pbyte_offset = 0 } }) | Pointer reftype -> (fun ~offset buf -> { raw_ptr = Stubs.Pointer.read ~offset buf; pbyte_offset = 0; reftype; pmanaged = None }) | View { read; ty } -> let buildty = build ty in (fun ~offset buf -> read (buildty ~offset buf)) (* 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. a typ -> offset:int -> a -> Raw.voidp -> unit = let write_aggregate size = (fun ~offset { structured = { raw_ptr; pbyte_offset = src_offset } } dst -> Stubs.memcpy ~size ~dst ~dst_offset:offset ~src:raw_ptr ~src_offset) in function | Void -> (fun ~offset _ _ -> ()) | Primitive p -> Stubs.write p | Pointer _ -> (fun ~offset { raw_ptr; pbyte_offset } dst -> Stubs.Pointer.write ~offset (Raw.PtrType.(add raw_ptr (of_int pbyte_offset))) 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 ~offset { astart = { raw_ptr; pbyte_offset = src_offset } } dst -> Stubs.memcpy ~size ~dst ~dst_offset:offset ~src:raw_ptr ~src_offset) | Bigarray b as t -> let size = sizeof t in (fun ~offset ba dst -> let src = Ctypes_bigarray.address b ba in Stubs.memcpy ~size ~dst ~dst_offset:offset ~src ~src_offset:0) | View { write = w; ty } -> let writety = write ty in (fun ~offset v -> writety ~offset (w v)) let null : unit ptr = { raw_ptr = Raw.null; reftype = Void; pbyte_offset = 0; pmanaged = None } let rec (!@) : type a. a ptr -> a = fun ({ raw_ptr; reftype; pbyte_offset = offset; pmanaged = ref } as ptr) -> match reftype with | Void -> raise IncompleteType | Union { uspec = None } -> raise IncompleteType | Struct { spec = Incomplete _ } -> raise IncompleteType | View { read; ty = reftype } -> read (!@ { ptr with reftype }) (* If it's a reference type then we take a reference *) | Union _ -> { structured = ptr } | Struct _ -> { structured = ptr } | Array (elemtype, alength) -> { astart = { ptr with reftype = elemtype }; alength } | Bigarray b -> Ctypes_bigarray.view b ?ref ~offset raw_ptr | Abstract _ -> { structured = ptr } (* If it's a value type then we cons a new value. *) | _ -> build reftype ~offset raw_ptr let ptr_diff { raw_ptr = lp; pbyte_offset = loff; reftype } { raw_ptr = rp; pbyte_offset = roff } = (* We assume the pointers are properly aligned, or at least that the difference is a multiple of sizeof reftype. *) let open Raw.PtrType in let l = add lp (of_int loff) and r = add rp (of_int roff) in to_int (sub r l) / sizeof reftype let (+@) : type a. a ptr -> int -> a ptr = fun ({ pbyte_offset; reftype } as p) x -> { p with pbyte_offset = pbyte_offset + (x * sizeof reftype) } let (-@) : type a. a ptr -> int -> a ptr = fun p x -> p +@ (-x) let (<-@) : type a. a ptr -> a -> unit = fun { reftype; raw_ptr; pbyte_offset = offset } -> fun v -> write reftype ~offset v raw_ptr let from_voidp : type a. a typ -> unit ptr -> a ptr = fun reftype p -> { p with reftype } let to_voidp : type a. a ptr -> unit ptr = fun p -> { p with reftype = Void } let allocate_n : type a. ?finalise:(a ptr -> unit) -> a typ -> count:int -> a ptr = fun ?finalise reftype ~count -> let package p = { reftype; pbyte_offset = 0; raw_ptr = Stubs.block_address p; pmanaged = Some (Obj.repr 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 reftype) 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 {raw_ptr = lp; pbyte_offset = loff} {raw_ptr = rp; pbyte_offset = roff} = Raw.PtrType.(compare (add lp (of_int loff)) (add rp (of_int roff))) let reference_type { reftype } = reftype let ptr_of_raw_address addr = { reftype = Void; raw_ptr = Raw.PtrType.of_int64 addr; pmanaged = None; pbyte_offset = 0 } module Std_array = Array module Array = struct type 'a t = 'a array let check_bound { alength } i = if 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 } as arr) v = for i = 0 to alength - 1 do unsafe_set arr i v 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 element_type { astart } = reference_type astart 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 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 (|->) p { ftype = reftype; foffset } = { p with reftype; pbyte_offset = p.pbyte_offset + 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 let _bigarray_start kind typ ba = let raw_address = Ctypes_bigarray.address typ ba in let reftype = Primitive (Ctypes_bigarray.prim_of_kind kind) in { reftype = reftype ; raw_ptr = raw_address ; pmanaged = Some (Obj.repr ba) ; pbyte_offset = 0 } let bigarray_start : type a b c d f. < element: a; ba_repr: f; bigarray: b; carray: c; dims: d > bigarray_class -> b -> a ptr = fun spec ba -> match spec with | Genarray -> let kind = Genarray.kind ba in let dims = Genarray.dims ba in _bigarray_start kind (Ctypes_bigarray.bigarray dims kind) ba | Array1 -> let kind = Array1.kind ba in let d = Array1.dim ba in _bigarray_start kind (Ctypes_bigarray.bigarray1 d kind) ba | Array2 -> let kind = Array2.kind ba in let d1 = Array2.dim1 ba and d2 = Array2.dim2 ba in _bigarray_start kind (Ctypes_bigarray.bigarray2 d1 d2 kind) ba | Array3 -> let kind = Array3.kind ba in let d1 = Array3.dim1 ba and d2 = Array3.dim2 ba and d3 = Array3.dim3 ba in _bigarray_start kind (Ctypes_bigarray.bigarray3 d1 d2 d3 kind) ba let castp reftype p = { p with reftype } let array_of_bigarray : type a b c d e. < element: a; ba_repr: e; bigarray: b; carray: c; dims: d > bigarray_class -> b -> c = fun spec ba -> let { reftype } as element_ptr = bigarray_start spec ba in match spec with | Genarray -> let ds = Genarray.dims ba in Array.from_ptr element_ptr (Std_array.fold_left ( * ) 1 ds) | Array1 -> let d = Array1.dim ba in Array.from_ptr element_ptr d | Array2 -> let d1 = Array2.dim1 ba and d2 = Array2.dim2 ba in Array.from_ptr (castp (array d2 reftype) element_ptr) d1 | Array3 -> let d1 = Array3.dim1 ba and d2 = Array3.dim2 ba and d3 = Array3.dim3 ba in Array.from_ptr (castp (array d2 (array d3 reftype)) element_ptr) d1 let bigarray_elements : type a b c d f. < element: a; ba_repr: f; bigarray: b; carray: c; dims: d > bigarray_class -> d -> int = fun spec dims -> match spec, dims with | Genarray, ds -> Std_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 array_dims : type a b c d f. < element: a; ba_repr: f; bigarray: b; carray: c array; dims: d > bigarray_class -> c array -> d = fun spec a -> match spec with | Genarray -> [| a.alength |] | Array1 -> a.alength | Array2 -> let {reftype = Array (_, n)} = a.astart in (a.alength, n) | Array3 -> let {reftype = Array (Array (_, m), n)} = a.astart in (a.alength, n, m) let bigarray_of_array spec kind a = let dims = array_dims spec a in !@ (castp (bigarray spec dims kind) (Array.start a)) let genarray = Genarray let array1 = Array1 let array2 = Array2 let array3 = Array3 ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/memory_stubs.ml000066400000000000000000000024401230210355500236660ustar00rootroot00000000000000(* * 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. *) (* A reference, managed by the garbage collector, to a region of memory in the C heap. *) type managed_buffer (* Allocate a region of stable memory managed by a custom block. *) external allocate : int -> managed_buffer = "ctypes_allocate" (* Obtain the address of the managed block. *) external block_address : managed_buffer -> Ctypes_raw.voidp = "ctypes_block_address" (* Read a C value from a block of memory *) external read : 'a Primitives.prim -> offset:int -> Ctypes_raw.voidp -> 'a = "ctypes_read" (* Write a C value to a block of memory *) external write : 'a Primitives.prim -> offset:int -> 'a -> Ctypes_raw.voidp -> unit = "ctypes_write" module Pointer = struct external read : offset:int -> Ctypes_raw.voidp -> Ctypes_raw.voidp = "ctypes_read_pointer" external write : offset:int -> Ctypes_raw.voidp -> Ctypes_raw.voidp -> unit = "ctypes_write_pointer" end (* Copy [size] bytes from [src + src_offset] to [dst + dst_offset]. *) external memcpy : dst:Ctypes_raw.voidp -> dst_offset:int -> src:Ctypes_raw.voidp -> src_offset:int -> size:int -> unit = "ctypes_memcpy" ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/posixTypes.ml000066400000000000000000000220671230210355500233340ustar00rootroot00000000000000(* * 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) type arithmetic = Int8 | Int16 | Int32 | Int64 | Uint8 | Uint16 | Uint32 | Uint64 | Float | Double let mkArithmetic = let open Ctypes in function Int8 -> mkAbstract int8_t | Int16 -> mkAbstract int16_t | Int32 -> mkAbstract int32_t | Int64 -> mkAbstract int64_t | Uint8 -> mkAbstract uint8_t | Uint16 -> mkAbstract uint16_t | Uint32 -> mkAbstract uint32_t | Uint64 -> mkAbstract uint64_t | Float -> mkAbstract float | Double -> mkAbstract double (* Arithmetic types *) external typeof_blkcnt_t : unit -> arithmetic = "ctypes_typeof_blkcnt_t" external typeof_blksize_t : unit -> arithmetic = "ctypes_typeof_blksize_t" external typeof_clock_t : unit -> arithmetic = "ctypes_typeof_clock_t" external typeof_dev_t : unit -> arithmetic = "ctypes_typeof_dev_t" external typeof_fsblkcnt_t : unit -> arithmetic = "ctypes_typeof_fsblkcnt_t" external typeof_fsfilcnt_t : unit -> arithmetic = "ctypes_typeof_fsfilcnt_t" external typeof_gid_t : unit -> arithmetic = "ctypes_typeof_gid_t" external typeof_id_t : unit -> arithmetic = "ctypes_typeof_id_t" external typeof_ino_t : unit -> arithmetic = "ctypes_typeof_ino_t" external typeof_mode_t : unit -> arithmetic = "ctypes_typeof_mode_t" external typeof_nlink_t : unit -> arithmetic = "ctypes_typeof_nlink_t" external typeof_off_t : unit -> arithmetic = "ctypes_typeof_off_t" external typeof_pid_t : unit -> arithmetic = "ctypes_typeof_pid_t" external typeof_ssize_t : unit -> arithmetic = "ctypes_typeof_ssize_t" external typeof_suseconds_t : unit -> arithmetic = "ctypes_typeof_suseconds_t" external typeof_time_t : unit -> arithmetic = "ctypes_typeof_time_t" external typeof_uid_t : unit -> arithmetic = "ctypes_typeof_uid_t" external typeof_useconds_t : unit -> arithmetic = "ctypes_typeof_useconds_t" module Blkcnt = (val mkArithmetic (typeof_blkcnt_t ()) : Abstract) module Blksize = (val mkArithmetic (typeof_blksize_t ()) : Abstract) module Clock = (val mkArithmetic (typeof_clock_t ()) : Abstract) module Dev = (val mkArithmetic (typeof_dev_t ()) : Abstract) module Fsblkcnt = (val mkArithmetic (typeof_fsblkcnt_t ()) : Abstract) module Fsfilcnt = (val mkArithmetic (typeof_fsfilcnt_t ()) : Abstract) module Gid = (val mkArithmetic (typeof_gid_t ()) : Abstract) module Id = (val mkArithmetic (typeof_id_t ()) : Abstract) module Ino = (val mkArithmetic (typeof_ino_t ()) : Abstract) module Mode = (val mkArithmetic (typeof_mode_t ()) : Abstract) module Nlink = (val mkArithmetic (typeof_nlink_t ()) : Abstract) module Off = (val mkArithmetic (typeof_off_t ()) : Abstract) module Pid = (val mkArithmetic (typeof_pid_t ()) : Abstract) module Size = struct type t = Unsigned.size_t let t = Ctypes.size_t end module Ssize = (val mkArithmetic (typeof_ssize_t ()) : Abstract) module Suseconds = (val mkArithmetic (typeof_suseconds_t ()) : Abstract) module Time = (val mkArithmetic (typeof_time_t ()) : Abstract) module Uid = (val mkArithmetic (typeof_uid_t ()) : Abstract) module Useconds = (val mkArithmetic (typeof_useconds_t ()) : Abstract) type blkcnt_t = Blkcnt.t type blksize_t = Blksize.t type clock_t = Clock.t type dev_t = Dev.t type fsblkcnt_t = Fsblkcnt.t type fsfilcnt_t = Fsfilcnt.t type gid_t = Gid.t type id_t = Id.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 suseconds_t = Suseconds.t type time_t = Time.t type uid_t = Uid.t type useconds_t = Useconds.t let blkcnt_t = Blkcnt.t let blksize_t = Blksize.t let clock_t = Clock.t let dev_t = Dev.t let fsblkcnt_t = Fsblkcnt.t let fsfilcnt_t = Fsfilcnt.t let gid_t = Gid.t let id_t = Id.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 suseconds_t = Suseconds.t let time_t = Time.t let uid_t = Uid.t let useconds_t = Useconds.t (* Non-arithmetic types *) external sizeof_key_t : unit -> int = "ctypes_sizeof_key_t" external sizeof_pthread_t : unit -> int = "ctypes_sizeof_pthread_t" external sizeof_pthread_attr_t : unit -> int = "ctypes_sizeof_pthread_attr_t" external sizeof_pthread_cond_t : unit -> int = "ctypes_sizeof_pthread_cond_t" external sizeof_pthread_condattr_t : unit -> int = "ctypes_sizeof_pthread_condattr_t" external sizeof_pthread_key_t : unit -> int = "ctypes_sizeof_pthread_key_t" external sizeof_pthread_mutex_t : unit -> int = "ctypes_sizeof_pthread_mutex_t" external sizeof_pthread_mutexattr_t : unit -> int = "ctypes_sizeof_pthread_mutexattr_t" external sizeof_pthread_once_t : unit -> int = "ctypes_sizeof_pthread_once_t" external sizeof_pthread_rwlock_t : unit -> int = "ctypes_sizeof_pthread_rwlock_t" external sizeof_pthread_rwlockattr_t : unit -> int = "ctypes_sizeof_pthread_rwlockattr_t" external sizeof_sigset_t : unit -> int = "ctypes_sizeof_sigset_t" external alignmentof_key_t : unit -> int = "ctypes_alignmentof_key_t" external alignmentof_pthread_t : unit -> int = "ctypes_alignmentof_pthread_t" external alignmentof_pthread_attr_t : unit -> int = "ctypes_alignmentof_pthread_attr_t" external alignmentof_pthread_cond_t : unit -> int = "ctypes_alignmentof_pthread_cond_t" external alignmentof_pthread_condattr_t : unit -> int = "ctypes_alignmentof_pthread_condattr_t" external alignmentof_pthread_key_t : unit -> int = "ctypes_alignmentof_pthread_key_t" external alignmentof_pthread_mutex_t : unit -> int = "ctypes_alignmentof_pthread_mutex_t" external alignmentof_pthread_mutexattr_t : unit -> int = "ctypes_alignmentof_pthread_mutexattr_t" external alignmentof_pthread_once_t : unit -> int = "ctypes_alignmentof_pthread_once_t" external alignmentof_pthread_rwlock_t : unit -> int = "ctypes_alignmentof_pthread_rwlock_t" external alignmentof_pthread_rwlockattr_t : unit -> int = "ctypes_alignmentof_pthread_rwlockattr_t" external alignmentof_sigset_t : unit -> int = "ctypes_alignmentof_sigset_t" module Key = (val mkAbstractSized ~name:"key_t" ~size:(sizeof_key_t ()) ~alignment:(alignmentof_key_t ()) : Abstract) module Pthread = (val mkAbstractSized ~name:"pthread_t" ~size:(sizeof_pthread_t ()) ~alignment:(alignmentof_pthread_t ()) : Abstract) module Pthread_attr = (val mkAbstractSized ~name:"pthread_attr_t" ~size:(sizeof_pthread_attr_t ()) ~alignment:(alignmentof_pthread_attr_t ()) : Abstract) module Pthread_cond = (val mkAbstractSized ~name:"pthread_cond_t" ~size:(sizeof_pthread_cond_t ()) ~alignment:(alignmentof_pthread_cond_t ()) : Abstract) module Pthread_condattr = (val mkAbstractSized ~name:"pthread_condattr_t" ~size:(sizeof_pthread_condattr_t ()) ~alignment:(alignmentof_pthread_condattr_t ()) : Abstract) module Pthread_key = (val mkAbstractSized ~name:"pthread_key_t" ~size:(sizeof_pthread_key_t ()) ~alignment:(alignmentof_pthread_key_t ()) : Abstract) module Pthread_mutex = (val mkAbstractSized ~name:"pthread_mutex_t" ~size:(sizeof_pthread_mutex_t ()) ~alignment:(alignmentof_pthread_mutex_t ()) : Abstract) module Pthread_mutexattr = (val mkAbstractSized ~name:"pthread_mutexattr_t" ~size:(sizeof_pthread_mutexattr_t ()) ~alignment:(alignmentof_pthread_mutexattr_t ()) : Abstract) module Pthread_once = (val mkAbstractSized ~name:"pthread_once_t" ~size:(sizeof_pthread_once_t ()) ~alignment:(alignmentof_pthread_once_t ()) : Abstract) module Pthread_rwlock = (val mkAbstractSized ~name:"pthread_rwlock_t" ~size:(sizeof_pthread_rwlock_t ()) ~alignment:(alignmentof_pthread_rwlock_t ()) : Abstract) module Pthread_rwlockattr = (val mkAbstractSized ~name:"pthread_rwlockattr_t" ~size:(sizeof_pthread_rwlockattr_t ()) ~alignment:(alignmentof_pthread_rwlockattr_t ()) : Abstract) module Sigset = (val mkAbstractSized ~name:"sigset_t" ~size:(sizeof_sigset_t ()) ~alignment:(alignmentof_sigset_t ()) : Abstract) type key_t = Key.t type pthread_t = Pthread.t type pthread_attr_t = Pthread_attr.t type pthread_cond_t = Pthread_cond.t type pthread_condattr_t = Pthread_condattr.t type pthread_key_t = Pthread_key.t type pthread_mutex_t = Pthread_mutex.t type pthread_mutexattr_t = Pthread_mutexattr.t type pthread_once_t = Pthread_once.t type pthread_rwlock_t = Pthread_rwlock.t type pthread_rwlockattr_t = Pthread_rwlockattr.t type sigset_t = Sigset.t let key_t = Key.t let pthread_t = Pthread.t let pthread_attr_t = Pthread_attr.t let pthread_cond_t = Pthread_cond.t let pthread_condattr_t = Pthread_condattr.t let pthread_key_t = Pthread_key.t let pthread_mutex_t = Pthread_mutex.t let pthread_mutexattr_t = Pthread_mutexattr.t let pthread_once_t = Pthread_once.t let pthread_rwlock_t = Pthread_rwlock.t let pthread_rwlockattr_t = Pthread_rwlockattr.t let sigset_t = Sigset.t ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/posixTypes.mli000066400000000000000000000040441230210355500235000ustar00rootroot00000000000000(* * 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} *) type blkcnt_t type blksize_t type clock_t type dev_t type fsblkcnt_t type fsfilcnt_t type gid_t type id_t type ino_t type mode_t type nlink_t type off_t type pid_t type size_t = Unsigned.size_t type ssize_t type suseconds_t type time_t type uid_t type useconds_t (** {3 Values representing POSIX arithmetic types} *) val blkcnt_t : blkcnt_t typ val blksize_t : blksize_t typ val clock_t : clock_t typ val dev_t : dev_t typ val fsblkcnt_t : fsblkcnt_t typ val fsfilcnt_t : fsfilcnt_t typ val gid_t : gid_t typ val id_t : id_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 suseconds_t : suseconds_t typ val time_t : time_t typ val uid_t : uid_t typ val useconds_t : useconds_t typ (* non-arithmetic types from *) (** {2 POSIX non-arithmetic types} *) type key_t type pthread_t type pthread_attr_t type pthread_cond_t type pthread_condattr_t type pthread_key_t type pthread_mutex_t type pthread_mutexattr_t type pthread_once_t type pthread_rwlock_t type pthread_rwlockattr_t type sigset_t (** {3 Values representing POSIX non-arithmetic types} *) val key_t : key_t typ val pthread_t : pthread_t typ val pthread_attr_t : pthread_attr_t typ val pthread_cond_t : pthread_cond_t typ val pthread_condattr_t : pthread_condattr_t typ val pthread_key_t : pthread_key_t typ val pthread_mutex_t : pthread_mutex_t typ val pthread_mutexattr_t : pthread_mutexattr_t typ val pthread_once_t : pthread_once_t typ val pthread_rwlock_t : pthread_rwlock_t typ val pthread_rwlockattr_t : pthread_rwlockattr_t typ val sigset_t : sigset_t typ ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/posix_types_stubs.c000066400000000000000000000070541230210355500245640ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #define _XOPEN_SOURCE 500 #include #include #include #include #include #include enum arithmetic { Int8, Int16, Int32, Int64, Uint8, Uint16, Uint32, Uint64, Float, Double, }; #define FLOATING_FLAG_BIT 15 #define UNSIGNED_FLAG_BIT 14 #define FLOATING ((size_t)1u << FLOATING_FLAG_BIT) #define UNSIGNED ((size_t)1u << UNSIGNED_FLAG_BIT) #define CHECK_FLOATING(TYPENAME) \ ((unsigned)(((TYPENAME) 0.5) != 0) << FLOATING_FLAG_BIT) #define CHECK_UNSIGNED(TYPENAME) \ ((unsigned)(((TYPENAME) -1) > 0) << UNSIGNED_FLAG_BIT) #define CLASSIFY(TYPENAME) (CHECK_FLOATING(TYPENAME) | CHECK_UNSIGNED(TYPENAME)) #define ARITHMETIC_TYPEINFO(TYPENAME) (CLASSIFY(TYPENAME) | sizeof(TYPENAME)) static enum arithmetic _underlying_type(size_t typeinfo) { switch (typeinfo) { case FLOATING | sizeof(float): return Float; case FLOATING | sizeof(double): return Double; case UNSIGNED | sizeof(uint8_t): return Uint8; case UNSIGNED | sizeof(uint16_t): return Uint16; case UNSIGNED | sizeof(uint32_t): return Uint32; case UNSIGNED | sizeof(uint64_t): return Uint64; case sizeof(int8_t): return Int8; case sizeof(int16_t): return Int16; case sizeof(int32_t): return Int32; case sizeof(int64_t): return Int64; default: assert(0); } } #define EXPOSE_TYPEINFO(TYPENAME) \ value ctypes_typeof_ ## TYPENAME(value unit) \ { \ size_t typeinfo = ARITHMETIC_TYPEINFO(TYPENAME); \ enum arithmetic underlying = _underlying_type(typeinfo); \ return Val_int(underlying); \ } EXPOSE_TYPEINFO(blkcnt_t) EXPOSE_TYPEINFO(blksize_t) EXPOSE_TYPEINFO(clock_t) EXPOSE_TYPEINFO(dev_t) EXPOSE_TYPEINFO(fsblkcnt_t) EXPOSE_TYPEINFO(fsfilcnt_t) EXPOSE_TYPEINFO(gid_t) EXPOSE_TYPEINFO(id_t) EXPOSE_TYPEINFO(ino_t) EXPOSE_TYPEINFO(mode_t) EXPOSE_TYPEINFO(nlink_t) EXPOSE_TYPEINFO(off_t) EXPOSE_TYPEINFO(pid_t) EXPOSE_TYPEINFO(ssize_t) EXPOSE_TYPEINFO(suseconds_t) EXPOSE_TYPEINFO(time_t) EXPOSE_TYPEINFO(uid_t) EXPOSE_TYPEINFO(useconds_t) #define EXPOSE_TYPESIZE(TYPENAME) \ value ctypes_sizeof_ ## TYPENAME(value unit) \ { \ return Val_int(sizeof(TYPENAME)); \ } EXPOSE_TYPESIZE(key_t) EXPOSE_TYPESIZE(pthread_t) EXPOSE_TYPESIZE(pthread_attr_t) EXPOSE_TYPESIZE(pthread_cond_t) EXPOSE_TYPESIZE(pthread_condattr_t) EXPOSE_TYPESIZE(pthread_key_t) EXPOSE_TYPESIZE(pthread_mutex_t) EXPOSE_TYPESIZE(pthread_mutexattr_t) EXPOSE_TYPESIZE(pthread_once_t) EXPOSE_TYPESIZE(pthread_rwlock_t) EXPOSE_TYPESIZE(pthread_rwlockattr_t) EXPOSE_TYPESIZE(sigset_t) #define EXPOSE_ALIGNMENT(TYPENAME) \ value ctypes_alignmentof_ ## TYPENAME(value unit) \ { \ struct s { char c; TYPENAME t; }; \ return Val_int(offsetof(struct s, t)); \ } EXPOSE_ALIGNMENT(key_t) EXPOSE_ALIGNMENT(pthread_t) EXPOSE_ALIGNMENT(pthread_attr_t) EXPOSE_ALIGNMENT(pthread_cond_t) EXPOSE_ALIGNMENT(pthread_condattr_t) EXPOSE_ALIGNMENT(pthread_key_t) EXPOSE_ALIGNMENT(pthread_mutex_t) EXPOSE_ALIGNMENT(pthread_mutexattr_t) EXPOSE_ALIGNMENT(pthread_once_t) EXPOSE_ALIGNMENT(pthread_rwlock_t) EXPOSE_ALIGNMENT(pthread_rwlockattr_t) EXPOSE_ALIGNMENT(sigset_t) ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/primitives.h000066400000000000000000000053341230210355500231550ustar00rootroot00000000000000/* * 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 /* The order here must correspond to the constructor order in primitives.ml */ enum ctypes_primitive { Char, Schar, Uchar, Short, Int, Long, Llong, Ushort, Uint, Ulong, Ullong, Size_t, Int8_t, Int16_t, Int32_t, Int64_t, Uint8_t, Uint16_t, Uint32_t, Uint64_t, Camlint, Nativeint, Float, Double, Complex32, Complex64, }; /* short is at least 16 bits. */ #if USHRT_MAX == UINT16_MAX #define ctypes_ushort_val Uint16_val #define ctypes_copy_ushort ctypes_copy_uint16 #elif USHRT_MAX == UINT32_MAX #define ctypes_ushort_val Uint32_val #define ctypes_copy_ushort ctypes_copy_uint32 #elif USHRT_MAX == UINT64_MAX #define ctypes_ushort_val Uint64_val #define ctypes_copy_ushort ctypes_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 #define ctypes_uint_val Uint16_val #define ctypes_copy_uint ctypes_copy_uint16 #elif UINT_MAX == UINT32_MAX #define ctypes_uint_val Uint32_val #define ctypes_copy_uint ctypes_copy_uint32 #elif UINT_MAX == UINT64_MAX #define ctypes_uint_val Uint64_val #define ctypes_copy_uint ctypes_copy_uint64 #else # error "No suitable OCaml type available for representing unsigned int values" #endif /* long is at least 16 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 ctypes_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 ctypes_copy_uint64 #else # error "No suitable OCaml type available for representing longs" #endif /* long long is at least 16 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 ctypes_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 ctypes_copy_uint16 #elif SIZE_MAX == UINT32_MAX #define ctypes_size_t_val Uint32_val #define ctypes_copy_size_t ctypes_copy_uint32 #elif SIZE_MAX == UINT64_MAX #define ctypes_size_t_val Uint64_val #define ctypes_copy_size_t ctypes_copy_uint64 #else # error "No suitable OCaml type available for representing size_t values" #endif #endif /* CTYPES_PRIMITIVES_H */ ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/primitives.ml000066400000000000000000000012071230210355500233310ustar00rootroot00000000000000open Unsigned open Signed type _ prim = | Char : char prim | Schar : int prim | Uchar : uchar prim | Short : int prim | Int : int prim | Long : long prim | Llong : llong prim | Ushort : ushort 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 | Complex32 : Complex.t prim | Complex64 : Complex.t prim ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/raw_pointer.h000066400000000000000000000014121230210355500233040ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef RAW_POINTER_STUBS_H #define RAW_POINTER_STUBS_H #include #include #include #if SIZEOF_PTR == 4 #define CTYPES_FROM_PTR(P) caml_copy_int32((intptr_t)P) #define CTYPES_TO_PTR(I32) ((void *)Int32_val(I32)) #define CTYPES_PTR_PLUS(I32, I) caml_copy_int32(Int32_val(I32) + I) #elif SIZEOF_PTR == 8 #define CTYPES_FROM_PTR(P) caml_copy_int64((intptr_t)P) #define CTYPES_TO_PTR(I64) ((void *)Int64_val(I64)) #define CTYPES_PTR_PLUS(I64, I) caml_copy_int64(Int64_val(I64) + I) #else #error "No suitable type available to represent pointers." #endif #endif /* RAW_POINTER_STUBS_H */ ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/raw_pointer_stubs.c000066400000000000000000000024171230210355500245250ustar00rootroot00000000000000/* * 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 "managed_buffer_stubs.h" #include "type_info_stubs.h" #include "raw_pointer.h" /* memcpy : dest:raw_pointer -> dest_offset:int -> src:raw_pointer -> src_offset:int -> size:int -> unit */ value ctypes_memcpy(value dst, value dst_offset, value src, value src_offset, value size) { CAMLparam5(dst, dst_offset, src, src_offset, size); memcpy((char *)CTYPES_TO_PTR(dst) + Int_val(dst_offset), (char *)CTYPES_TO_PTR(src) + Int_val(src_offset), Int_val(size)); CAMLreturn(Val_unit); } /* string_of_cstring : raw_ptr -> int -> string */ value ctypes_string_of_cstring(value p, value offset) { return caml_copy_string(CTYPES_TO_PTR(p) + Int_val(offset)); } /* cstring_of_string : string -> managed_buffer */ value ctypes_cstring_of_string(value s) { CAMLparam1(s); CAMLlocal1(buffer); int len = caml_string_length(s); buffer = ctypes_allocate(Val_int(len + 1)); char *dst = CTYPES_TO_PTR(ctypes_block_address(buffer)); char *ss = String_val(s); memcpy(dst, ss, len); dst[len] = '\0'; CAMLreturn(buffer); } ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/signed.ml000066400000000000000000000033061230210355500224110ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) module type S = sig include Unsigned.S val neg : t -> t val abs : t -> t val minus_one : t val min_int : t val shift_right_logical : t -> int -> t val of_int64 : int64 -> t val to_int64 : t -> int64 end module type Basics = sig type t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val div : t -> t -> t val rem : t -> t -> t val max_int : t val logand : t -> t -> t val logor : t -> t -> t val logxor : t -> t -> t val shift_left : t -> int -> t val shift_right : t -> int -> t val shift_right_logical : t -> int -> t end module MakeInfix(S : Basics) = struct open S let (+) = add let (-) = sub let ( * ) = mul let (/) = div let (mod) = rem let (land) = logand let (lor) = logor let (lxor) = logxor let (lsl) = shift_left let (lsr) = shift_right_logical let (asr) = shift_right end module Int32 = struct include Int32 module Infix = MakeInfix(Int32) let of_int64 = Int64.to_int32 let to_int64 = Int64.of_int32 end module Int64 = struct include Int64 module Infix = MakeInfix(Int64) let of_int64 x = x let to_int64 x = x end (* C guarantees that sizeof(t) == sizeof(unsigned t) *) external long_size : unit -> int = "ctypes_ulong_size" external llong_size : unit -> int = "ctypes_ulonglong_size" let pick : size:int -> (module S) = fun ~size -> match size with | 4 -> (module Int32) | 8 -> (module Int64) | _ -> assert false module Long = (val pick ~size:(long_size ())) module LLong = (val pick ~size:(llong_size ())) type long = Long.t type llong = LLong.t ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/signed.mli000066400000000000000000000024021230210355500225560ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** Types and operations for signed integers. *) module type S = sig include Unsigned.S val neg : t -> t (** Unary negation. *) val abs : t -> t (** Return the absolute value of its argument. *) val minus_one : t (** The value -1 *) val min_int : t (** The smallest representable integer. *) val shift_right_logical : t -> int -> t (** {!shift_right_logical} [x] [y] shifts [x] to the right by [y] bits. See {!Int32.shift_right_logical}. *) val of_int64 : int64 -> t (** Convert the given int64 value to a signed integer. *) val to_int64 : t -> int64 (** Convert the given signed integer to an int64 value. *) end (** Signed integer operations *) module Int32 : S with type t = int32 (** Signed 32-bit integer type and operations. *) module Int64 : S with type t = int64 (** Signed 64-bit integer type and operations. *) module Long : S (** The signed long integer type and operations. *) module LLong : S (** The signed long long integer type and operations. *) type long = Long.t (** The signed long integer type. *) type llong = LLong.t (** The signed long long integer type. *) ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/static.ml000066400000000000000000000163731230210355500224370ustar00rootroot00000000000000(* * 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 *) exception IncompleteType exception ModifyingSealedType of string exception Unsupported of string 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 'a std_array = 'a array type _ typ = Void : unit typ | Primitive : 'a Primitives.prim -> 'a typ | Pointer : 'a typ -> 'a ptr 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 array typ | Bigarray : (_, 'a) Ctypes_bigarray.t -> 'a typ and 'a ptr = { reftype : 'a typ; raw_ptr : Ctypes_raw.voidp; pmanaged : Obj.t option; pbyte_offset : int } and 'a array = { astart : 'a ptr; alength : int } and ('a, 'kind) structured = { structured : ('a, 'kind) structured ptr } and 'a union = ('a, [`Union]) structured and 'a structure = ('a, [`Struct]) structured and 'a abstract = ('a, [`Abstract]) structured and ('a, 'b) view = { read : 'b -> 'a; write : 'a -> 'b; format_typ: ((Format.formatter -> unit) -> Format.formatter -> 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 type _ bigarray_class = Genarray : < element: 'a; dims: int std_array; ba_repr: 'b; bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t; carray: 'a array > bigarray_class | Array1 : < element: 'a; dims: int; ba_repr: 'b; bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t; carray: 'a array > bigarray_class | Array2 : < element: 'a; dims: int * int; ba_repr: 'b; bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Array2.t; carray: 'a array array > bigarray_class | Array3 : < element: 'a; dims: int * int * int; ba_repr: 'b; bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Array3.t; carray: 'a array array array > bigarray_class type _ fn = | Returns : 'a typ -> 'a fn | Function : 'a typ * 'b fn -> ('a -> 'b) fn 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 | 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 | 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 | Abstract _ -> false | View { ty } -> passable ty let void = Void let char = Primitive Primitives.Char let schar = Primitive Primitives.Schar let float = Primitive Primitives.Float let double = Primitive Primitives.Double let complex32 = Primitive Primitives.Complex32 let complex64 = Primitive Primitives.Complex64 let short = Primitive Primitives.Short let int = Primitive Primitives.Int let long = Primitive Primitives.Long let llong = Primitive Primitives.Llong let nativeint = Primitive Primitives.Nativeint let int8_t = Primitive Primitives.Int8_t let int16_t = Primitive Primitives.Int16_t let int32_t = Primitive Primitives.Int32_t let int64_t = Primitive Primitives.Int64_t let camlint = Primitive Primitives.Camlint let uchar = Primitive Primitives.Uchar let uint8_t = Primitive Primitives.Uint8_t let uint16_t = Primitive Primitives.Uint16_t let uint32_t = Primitive Primitives.Uint32_t let uint64_t = Primitive Primitives.Uint64_t let size_t = Primitive Primitives.Size_t let ushort = Primitive Primitives.Ushort let uint = Primitive Primitives.Uint let ulong = Primitive Primitives.Ulong let ullong = Primitive Primitives.Ullong let array i t = Array (t, i) 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 ~read ~write ty = View { read; write; format_typ; ty } let bigarray : type a b c d e. < element: a; dims: b; ba_repr: c; bigarray: d; carray: e > bigarray_class -> b -> (a, c) Bigarray.kind -> d typ = fun spec dims kind -> match spec with | Genarray -> Bigarray (Ctypes_bigarray.bigarray dims kind) | Array1 -> Bigarray (Ctypes_bigarray.bigarray1 dims kind) | Array2 -> let d1, d2 = dims in Bigarray (Ctypes_bigarray.bigarray2 d1 d2 kind) | Array3 -> let d1, d2, d3 = dims in Bigarray (Ctypes_bigarray.bigarray3 d1 d2 d3 kind) let returning v = if not (passable v) then raise (Unsupported "Unsupported return type") else Returns v 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 ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/std_view_stubs.ml000066400000000000000000000007171230210355500242070ustar00rootroot00000000000000(* * 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 : Ctypes_raw.voidp -> int -> string = "ctypes_string_of_cstring" (* Convert an OCaml string to a C string *) external cstring_of_string : string -> Memory_stubs.managed_buffer = "ctypes_cstring_of_string" ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/std_views.ml000066400000000000000000000021211230210355500231410ustar00rootroot00000000000000(* * 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 {Static.raw_ptr; pbyte_offset} = Std_view_stubs.string_of_cstring raw_ptr pbyte_offset let char_ptr_of_string s = let buf = Std_view_stubs.cstring_of_string s in { Static.reftype = Static.char; pmanaged = Some (Obj.repr buf); raw_ptr = Memory_stubs.block_address buf; pbyte_offset = 0 } let string = Static.(view (ptr char)) ~read:string_of_char_ptr ~write:char_ptr_of_string let castp typ p = Memory.(from_voidp typ (to_voidp p)) let read_nullable t = let coerce = Coerce.coerce Static.(ptr void) t in fun p -> Memory.(if p = null then None else Some (coerce p)) let write_nullable t = let coerce = Coerce.coerce t Static.(ptr void) in Memory.(function None -> null | Some f -> coerce f) let nullable_view t = let read = read_nullable t and write = write_nullable t in Static.(view ~read ~write (ptr void)) let ptr_opt t = nullable_view (Static.ptr t) let string_opt = nullable_view string ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/structs.ml000066400000000000000000000006031230210355500226440ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open 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]) Static.structured Static.typ -> unit end ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/structs.mli000066400000000000000000000006031230210355500230150ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open 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]) Static.structured Static.typ -> unit end ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/structs_computed.ml000066400000000000000000000037731230210355500245570ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open 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 field (type k) (structured : (_, k) structured typ) 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) let seal (type a) (type s) : (a, s) structured 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 ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/structs_computed.mli000066400000000000000000000005371230210355500247230ustar00rootroot00000000000000(* * 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 Structs.S with type ('a, 's) field := ('a, 's) Static.field ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/type_info_stubs.c000066400000000000000000000174321230210355500241730ustar00rootroot00000000000000/* * 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 "unsigned_stubs.h" #include "raw_pointer.h" #include "primitives.h" static value allocate_complex_value(double r, double i) { value v = caml_alloc(2 * sizeof(double), Double_array_tag); Store_double_field(v, 0, r); Store_double_field(v, 1, i); return v; } /* Read a C value from a block of memory */ /* read : 'a prim -> offset:int -> raw_pointer -> 'a */ value ctypes_read(value prim_, value offset_, value buffer_) { CAMLparam3(prim_, offset_, buffer_); CAMLlocal1(b); int offset = Int_val(offset_); void *buf = (char *)CTYPES_TO_PTR(buffer_) + offset; switch (Int_val(prim_)) { case Char: b = Val_int(*(char *)buf); break; case Schar: b = Val_int(*(signed char *)buf); break; case Uchar: b = ctypes_copy_uint8(*(unsigned char *)buf); break; case Short: b = Val_int(*(short *)buf); break; case Int: b = Val_int(*(int *)buf); break; case Long: b = ctypes_copy_long(*(long *)buf); break; case Llong: b = ctypes_copy_llong(*(long long *)buf); break; case Ushort: b = ctypes_copy_ushort(*(unsigned short *)buf); break; case Uint: b = ctypes_copy_uint(*(unsigned int *)buf); break; case Ulong: b = ctypes_copy_ulong(*(unsigned long *)buf); break; case Ullong: b = ctypes_copy_ullong(*(unsigned long long *)buf); break; case Size_t: b = ctypes_copy_size_t(*(size_t *)buf); break; case Int8_t: b = Val_int(*(int8_t *)buf); break; case Int16_t: b = Val_int(*(int16_t *)buf); break; case Int32_t: b = caml_copy_int32(*(int32_t *)buf); break; case Int64_t: b = caml_copy_int64(*(int64_t *)buf); break; case Uint8_t: b = ctypes_copy_uint8(*(uint8_t *)buf); break; case Uint16_t: b = ctypes_copy_uint16(*(uint16_t *)buf); break; case Uint32_t: b = ctypes_copy_uint32(*(uint32_t *)buf); break; case Uint64_t: b = ctypes_copy_uint64(*(uint64 *)buf); break; case Camlint: b = Val_int(*(intnat *)buf); break; case Nativeint: b = caml_copy_nativeint(*(intnat *)buf); break; case Float: b = caml_copy_double(*(float *)buf); break; case Double: b = caml_copy_double(*(double *)buf); break; case Complex32: { float complex c = *(float complex *)buf; b = allocate_complex_value(crealf(c), cimagf(c)); break; } case Complex64: { double complex c = *(double complex *)buf; b = allocate_complex_value(creal(c), cimag(c)); break; } default: assert(0); } CAMLreturn(b); } /* Read a C value from a block of memory */ /* write : 'a prim -> offset:int -> 'a -> raw_pointer -> unit */ value ctypes_write(value prim_, value offset_, value v, value buffer_) { CAMLparam4(prim_, offset_, v, buffer_); int offset = Int_val(offset_); void *buf = (char *)CTYPES_TO_PTR(buffer_) + offset; switch (Int_val(prim_)) { case Char: *(char *)buf = Int_val(v); break; case Schar: *(signed char *)buf = Int_val(v); break; case Uchar: *(unsigned char *)buf = Uint8_val(v); break; case Short: *(short *)buf = Int_val(v); break; case Int: *(int *)buf = Int_val(v); break; case Long: *(long *)buf = ctypes_long_val(v); break; case Llong: *(long long *)buf = ctypes_llong_val(v); break; case Ushort: *(unsigned short *)buf = ctypes_ushort_val(v); break; case Uint: *(unsigned int *)buf = ctypes_uint_val(v); break; case Ulong: *(unsigned long *)buf = ctypes_ulong_val(v); break; case Ullong: *(unsigned long long *)buf = ctypes_ullong_val(v); break; case Size_t: *(size_t *)buf = ctypes_size_t_val(v); break; case Int8_t: *(int8_t *)buf = Int_val(v); break; case Int16_t: *(int16_t *)buf = Int_val(v); break; case Int32_t: *(int32_t *)buf = Int32_val(v); break; case Int64_t: *(int64_t *)buf = Int64_val(v); break; case Uint8_t: *(uint8_t *)buf = Uint8_val(v); break; case Uint16_t: *(uint16_t *)buf = Uint16_val(v); break; case Uint32_t: *(uint32_t *)buf = Uint32_val(v); break; case Uint64_t: *(uint64 *)buf = Uint64_val(v); break; case Camlint: *(intnat *)buf = Int_val(v); break; case Nativeint: *(intnat *)buf = Nativeint_val(v); break; case Float: *(float *)buf = Double_val(v); break; case Double: *(double *)buf = Double_val(v); break; case Complex32: *(float complex *)buf = Double_field(v, 0) + Double_field(v, 1) * I; break; case Complex64: *(double complex *)buf = Double_field(v, 0) + Double_field(v, 1) * I; 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); char buf[64]; switch (Int_val(prim_)) { case Char: snprintf(buf, sizeof buf, "'%c'", Int_val(v)); break; case Schar: snprintf(buf, sizeof buf, "%d", Int_val(v)); break; case Uchar: snprintf(buf, sizeof buf, "%d", (unsigned char)Uint8_val(v)); break; case Short: snprintf(buf, sizeof buf, "%hd", Int_val(v)); break; case Int: snprintf(buf, sizeof buf, "%d", Int_val(v)); break; case Long: snprintf(buf, sizeof buf, "%ld", (long)ctypes_long_val(v)); break; case Llong: snprintf(buf, sizeof buf, "%lld", (long long)ctypes_llong_val(v)); break; case Ushort: snprintf(buf, sizeof buf, "%hu", (unsigned short)ctypes_ushort_val(v)); break; case Uint: snprintf(buf, sizeof buf, "%u", (unsigned)ctypes_uint_val(v)); break; case Ulong: snprintf(buf, sizeof buf, "%lu", (unsigned long)ctypes_ulong_val(v)); break; case Ullong: snprintf(buf, sizeof buf, "%llu", (unsigned long long)ctypes_ullong_val(v)); break; case Size_t: snprintf(buf, sizeof buf, "%zu", (size_t)ctypes_size_t_val(v)); break; case Int8_t: snprintf(buf, sizeof buf, "%" PRId8, Int_val(v)); break; case Int16_t: snprintf(buf, sizeof buf, "%" PRId16, Int_val(v)); break; case Int32_t: snprintf(buf, sizeof buf, "%" PRId32, Int32_val(v)); break; case Int64_t: snprintf(buf, sizeof buf, "%" PRId64, Int64_val(v)); break; case Uint8_t: snprintf(buf, sizeof buf, "%" PRIu8, Uint8_val(v)); break; case Uint16_t: snprintf(buf, sizeof buf, "%" PRIu16, Uint16_val(v)); break; case Uint32_t: snprintf(buf, sizeof buf, "%" PRIu32, Uint32_val(v)); break; case Uint64_t: snprintf(buf, sizeof buf, "%" PRIu64, Uint64_val(v)); break; case Camlint: snprintf(buf, sizeof buf, "%" ARCH_INTNAT_PRINTF_FORMAT "d", (intnat)Int_val(v)); break; case Nativeint: snprintf(buf, sizeof buf, "%" ARCH_INTNAT_PRINTF_FORMAT "d", (intnat)Nativeint_val(v)); break; case Float: snprintf(buf, sizeof buf, "%.12g", Double_val(v)); break; case Double: snprintf(buf, sizeof buf, "%.12g", Double_val(v)); break; case Complex32: snprintf(buf, sizeof buf, "%.12g+%.12gi", Double_field(v, 0), Double_field(v, 1)); break; case Complex64: snprintf(buf, sizeof buf, "%.12g+%.12gi", Double_field(v, 0), Double_field(v, 1)); break; default: assert(0); } CAMLreturn (caml_copy_string(buf)); } /* read_pointer : offset:int -> raw_pointer -> raw_pointer */ value ctypes_read_pointer(value offset_, value src_) { CAMLparam2(offset_, src_); void *src = (char *)CTYPES_TO_PTR(src_) + Int_val(offset_); CAMLreturn(CTYPES_FROM_PTR(*(void **)src)); } /* write_pointer : offset:int -> raw_pointer -> dst:raw_pointer -> unit */ value ctypes_write_pointer(value offset_, value p_, value dst_) { CAMLparam3(offset_, p_, dst_); void *dst = (char *)CTYPES_TO_PTR(dst_) + Int_val(offset_); *(void **)dst = CTYPES_TO_PTR(p_); CAMLreturn(Val_unit); } /* string_of_pointer : raw_pointer -> string */ value ctypes_string_of_pointer(value p_) { char buf[32]; CAMLparam1(p_); snprintf(buf, sizeof buf, "%p", CTYPES_TO_PTR(p_)); CAMLreturn (caml_copy_string(buf)); } ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/type_info_stubs.h000066400000000000000000000016651230210355500242010ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef TYPE_INFO_STUBS_H #define TYPE_INFO_STUBS_H #include #include #include #include /* allocate_struct_type_info : ffitype*** -> _ ctype */ value ctypes_allocate_struct_type_info(ffi_type ***args); /* allocate_unpassable_struct_type_info : (size, alignment) -> _ ctype */ value ctypes_allocate_unpassable_struct_type_info(int size, int alignment); /* Read a C value from a block of memory */ /* read : 'a prim -> offset:int -> raw_pointer -> 'a */ extern value ctypes_read(value ctype, value offset, value buffer); /* Write a C value to a block of memory */ /* write : 'a prim -> offset:int -> 'a -> raw_pointer -> unit */ extern value ctypes_write(value ctype, value offset, value v, value buffer); #endif /* TYPE_INFO_STUBS_H */ ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/type_printing.ml000066400000000000000000000106001230210355500240260ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open 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] 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 ; 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; 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 | Array (ty, n) -> format_typ ty (fun _ fmt -> fprintf fmt "%t[%d]" (k `array) n) `nonarray fmt | Bigarray ba -> Format.fprintf fmt "%t" Ctypes_bigarray.format ba (k `nonarray) 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 = Common.string_of (format_typ ?name) ty let string_of_fn ?name fn = Common.string_of (format_fn ?name) fn ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/unsigned.ml000066400000000000000000000163451230210355500227630ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Boxed unsigned types *) module type Basics = sig type t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val div : t -> t -> t val rem : t -> t -> t val max_int : t val logand : t -> t -> t val logor : t -> t -> t val logxor : t -> t -> t val shift_left : t -> int -> t val shift_right : t -> int -> t val of_int : int -> t val to_int : t -> int val of_string : string -> t val to_string : t -> string end module type Extras = sig type t val zero : t val one : t val lognot : t -> t val succ : t -> t val pred : t -> t val compare : t -> t -> int end module type Infix = sig type t val (+) : t -> t -> t val (-) : t -> t -> t val ( * ) : t -> t -> t val (/) : t -> t -> t val (mod) : t -> t -> t val (land) : t -> t -> t val (lor) : t -> t -> t val (lxor) : t -> t -> t val (lsl) : t -> int -> t val (lsr) : t -> int -> t end module type S = sig include Basics include Extras with type t := t module Infix : Infix with type t := t end module MakeInfix (B : Basics) = struct open B let (+) = add let (-) = sub let ( * ) = mul let (/) = div let (mod) = rem let (land) = logand let (lor) = logor let (lxor) = logxor let (lsl) = shift_left let (lsr) = shift_right end module Extras(Basics : Basics) : Extras with type t := Basics.t = struct open Basics let zero = of_int 0 let one = of_int 1 let succ n = add n one let pred n = sub n one let lognot n = logxor n max_int let compare (x : t) (y : t) = Pervasives.compare x y end module UInt8 : S = struct module B = struct type t external add : t -> t -> t = "ctypes_uint8_add" external sub : t -> t -> t = "ctypes_uint8_sub" external mul : t -> t -> t = "ctypes_uint8_mul" external div : t -> t -> t = "ctypes_uint8_div" external rem : t -> t -> t = "ctypes_uint8_rem" external logand : t -> t -> t = "ctypes_uint8_logand" external logor : t -> t -> t = "ctypes_uint8_logor" external logxor : t -> t -> t = "ctypes_uint8_logxor" external shift_left : t -> int -> t = "ctypes_uint8_shift_left" external shift_right : t -> int -> t = "ctypes_uint8_shift_right" external of_int : int -> t = "ctypes_uint8_of_int" external to_int : t -> int = "ctypes_uint8_to_int" external of_string : string -> t = "ctypes_uint8_of_string" external to_string : t -> string = "ctypes_uint8_to_string" external _max_int : unit -> t = "ctypes_uint8_max" let max_int = _max_int () end include B include Extras(B) module Infix = MakeInfix(B) end module UInt16 : S = struct module B = struct type t external add : t -> t -> t = "ctypes_uint16_add" external sub : t -> t -> t = "ctypes_uint16_sub" external mul : t -> t -> t = "ctypes_uint16_mul" external div : t -> t -> t = "ctypes_uint16_div" external rem : t -> t -> t = "ctypes_uint16_rem" external logand : t -> t -> t = "ctypes_uint16_logand" external logor : t -> t -> t = "ctypes_uint16_logor" external logxor : t -> t -> t = "ctypes_uint16_logxor" external shift_left : t -> int -> t = "ctypes_uint16_shift_left" external shift_right : t -> int -> t = "ctypes_uint16_shift_right" external of_int : int -> t = "ctypes_uint16_of_int" external to_int : t -> int = "ctypes_uint16_to_int" external of_string : string -> t = "ctypes_uint16_of_string" external to_string : t -> string = "ctypes_uint16_to_string" external _max_int : unit -> t = "ctypes_uint16_max" let max_int = _max_int () end include B include Extras(B) module Infix = MakeInfix(B) end module UInt32 : sig include S external of_int32 : int32 -> t = "ctypes_uint32_of_int32" external to_int32 : t -> int32 = "ctypes_int32_of_uint32" end = struct module B = struct type t external add : t -> t -> t = "ctypes_uint32_add" external sub : t -> t -> t = "ctypes_uint32_sub" external mul : t -> t -> t = "ctypes_uint32_mul" external div : t -> t -> t = "ctypes_uint32_div" external rem : t -> t -> t = "ctypes_uint32_rem" external logand : t -> t -> t = "ctypes_uint32_logand" external logor : t -> t -> t = "ctypes_uint32_logor" external logxor : t -> t -> t = "ctypes_uint32_logxor" external shift_left : t -> int -> t = "ctypes_uint32_shift_left" external shift_right : t -> int -> t = "ctypes_uint32_shift_right" external of_int : int -> t = "ctypes_uint32_of_int" external to_int : t -> int = "ctypes_uint32_to_int" external of_string : string -> t = "ctypes_uint32_of_string" external to_string : t -> string = "ctypes_uint32_to_string" external _max_int : unit -> t = "ctypes_uint32_max" let max_int = _max_int () end include B include Extras(B) module Infix = MakeInfix(B) external of_int32 : int32 -> t = "ctypes_uint32_of_int32" external to_int32 : t -> int32 = "ctypes_int32_of_uint32" end module UInt64 : sig include S external of_int64 : int64 -> t = "ctypes_uint64_of_int64" external to_int64 : t -> int64 = "ctypes_int64_of_uint64" end = struct module B = struct type t external add : t -> t -> t = "ctypes_uint64_add" external sub : t -> t -> t = "ctypes_uint64_sub" external mul : t -> t -> t = "ctypes_uint64_mul" external div : t -> t -> t = "ctypes_uint64_div" external rem : t -> t -> t = "ctypes_uint64_rem" external logand : t -> t -> t = "ctypes_uint64_logand" external logor : t -> t -> t = "ctypes_uint64_logor" external logxor : t -> t -> t = "ctypes_uint64_logxor" external shift_left : t -> int -> t = "ctypes_uint64_shift_left" external shift_right : t -> int -> t = "ctypes_uint64_shift_right" external of_int : int -> t = "ctypes_uint64_of_int" external to_int : t -> int = "ctypes_uint64_to_int" external of_string : string -> t = "ctypes_uint64_of_string" external to_string : t -> string = "ctypes_uint64_to_string" external _max_int : unit -> t = "ctypes_uint64_max" let max_int = _max_int () end include B include Extras(B) module Infix = MakeInfix(B) external of_int64 : int64 -> t = "ctypes_uint64_of_int64" external to_int64 : t -> int64 = "ctypes_int64_of_uint64" end let pick : size:int -> (module S) = fun ~size -> match size with | 1 -> (module UInt8) | 2 -> (module UInt16) | 4 -> (module UInt32) | 8 -> (module UInt64) | _ -> assert false external size_t_size : unit -> int = "ctypes_size_t_size" external ushort_size : unit -> int = "ctypes_ushort_size" external uint_size : unit -> int = "ctypes_uint_size" external ulong_size : unit -> int = "ctypes_ulong_size" external ulonglong_size : unit -> int = "ctypes_ulonglong_size" module Size_t : S = (val pick ~size:(size_t_size ())) module UChar : S = UInt8 module UShort : S = (val pick ~size:(ushort_size ())) module UInt : S = (val pick ~size:(uint_size ())) module ULong : S = (val pick ~size:(ulong_size ())) module ULLong : S = (val pick ~size:(ulonglong_size ())) type uchar = UChar.t type uint8 = UInt8.t type uint16 = UInt16.t type uint32 = UInt32.t type uint64 = UInt64.t type size_t = Size_t.t type ushort = UShort.t type uint = UInt.t type ulong = ULong.t type ullong = ULLong.t ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/unsigned.mli000066400000000000000000000102331230210355500231220ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** Types and operations for unsigned integers. *) module type S = sig type t val add : t -> t -> t (** Addition. *) val sub : t -> t -> t (** Subtraction. *) val mul : t -> t -> t (** Multiplication. *) val div : t -> t -> t (** Division. Raise {!Division_by_zero} if the second argument is zero. *) val rem : t -> t -> t (** Integer remainder. Raise {!Division_by_zero} if the second argument is zero. *) val max_int : t (** The greatest representable integer. *) val logand : t -> t -> t (** Bitwise logical and. *) val logor : t -> t -> t (** Bitwise logical or. *) val logxor : t -> t -> t (** Bitwise logical exclusive or. *) val shift_left : t -> int -> t (** {!shift_left} [x] [y] shifts [x] to the left by [y] bits. *) val shift_right : t -> int -> t (** {!shift_right} [x] [y] shifts [x] to the right by [y] bits. *) val of_int : int -> t (** Convert the given int value to an unsigned integer. *) val to_int : t -> int (** Convert the given unsigned integer value to an int. *) val of_string : string -> t (** Convert the given string to an unsigned integer. Raise {!Failure} ["int_of_string"] if the given string is not a valid representation of an unsigned integer. *) val to_string : t -> string (** Return the string representation of its argument. *) val zero : t (** The integer 0. *) val one : t (** The integer 1. *) val lognot : t -> t (** Bitwise logical negation. *) val succ : t -> t (** Successor. *) val pred : t -> t (** Predecessor. *) val compare : t -> t -> int (** The comparison function for unsigned integers, with the same specification as {!Pervasives.compare}. *) module Infix : sig val (+) : t -> t -> t (** Addition. See {!add}. *) val (-) : t -> t -> t (** Subtraction. See {!sub}.*) val ( * ) : t -> t -> t (** Multiplication. See {!mul}.*) val (/) : t -> t -> t (** Division. See {!div}.*) val (mod) : t -> t -> t (** Integer remainder. See {!rem}. *) val (land) : t -> t -> t (** Bitwise logical and. See {!logand}. *) val (lor) : t -> t -> t (** Bitwise logical or. See {!logor}. *) val (lxor) : t -> t -> t (** Bitwise logical exclusive or. See {!logxor}. *) val (lsl) : t -> int -> t (** [x lsl y] shifts [x] to the left by [y] bits. See {!shift_left}. *) val (lsr) : t -> int -> t (** [x lsr y] shifts [x] to the right by [y] bits. See {!shift_right}. *) end (** Infix names for the unsigned integer operations. *) end (** Unsigned integer operations. *) module UChar : S (** Unsigned char type and operations. *) module UInt8 : S (** Unsigned 8-bit integer type and operations. *) module UInt16 : S (** Unsigned 16-bit integer type and operations. *) module UInt32 : sig include S val of_int32 : int32 -> t val to_int32 : t -> int32 end (** Unsigned 32-bit integer type and operations. *) module UInt64 : sig include S val of_int64 : int64 -> t val to_int64 : t -> int64 end (** Unsigned 64-bit integer type and operations. *) module Size_t : S (** The size_t unsigned integer type and operations. *) module UShort : S (** The unsigned short integer type and operations. *) module UInt : S (** The unsigned int type and operations. *) module ULong : S (** The unsigned long integer type and operations. *) module ULLong : S (** The unsigned long long integer type and operations. *) type uchar = UChar.t (** The unsigned char type. *) type uint8 = UInt8.t (** Unsigned 8-bit integer type. *) type uint16 = UInt16.t (** Unsigned 16-bit integer type. *) type uint32 = UInt32.t (** Unsigned 32-bit integer type. *) type uint64 = UInt64.t (** Unsigned 64-bit integer type. *) type size_t = Size_t.t (** The size_t unsigned integer type. *) type ushort = UShort.t (** The unsigned short unsigned integer type. *) type uint = UInt.t (** The unsigned int type. *) type ulong = ULong.t (** The unsigned long integer type. *) type ullong = ULLong.t (** The unsigned long long integer type. *) ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/unsigned_stubs.c000066400000000000000000000262251230210355500240130ustar00rootroot00000000000000/* * 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 #define Uint_custom_val(TYPE, V) (*((TYPE *) Data_custom_val(V))) #define TYPE(SIZE) uint ## SIZE ## _t #define BYTES(SIZE) (SIZE / CHAR_BIT) #define BUF_SIZE(TYPE) ((sizeof(TYPE) * CHAR_BIT + 2) / 3 + 1) #define UINT_PRIMOP(NAME, SIZE, OP) \ /* OP : t -> t -> t */ \ value ctypes_uint ## SIZE ## _ ## NAME(value a, value b) \ { \ return ctypes_copy_uint ## SIZE(Uint_custom_val(uint ## SIZE ## _t, a) \ OP Uint_custom_val(uint ## SIZE ## _t, b)); \ } #define UINT_DEFS(BITS, BYTES) \ static int uint ## BITS ## _cmp(value v1, value v2) \ { \ TYPE(BITS) u1 = Uint_custom_val(TYPE(BITS), v1); \ TYPE(BITS) u2 = Uint_custom_val(TYPE(BITS), v2); \ return (u1 > u2) - (u1 < u2); \ } \ \ static long uint ## BITS ## _hash(value v) \ { \ return Uint_custom_val(TYPE(BITS), v); \ } \ \ static void uint ## BITS ## _serialize(value v, \ unsigned long *wsize_32, \ unsigned long *wsize_64) \ { \ caml_serialize_int_ ## BYTES(Uint_custom_val(TYPE(BITS), v)); \ *wsize_32 = *wsize_64 = BYTES; \ } \ \ static unsigned long uint ## BITS ## _deserialize(void *dst) \ { \ *(TYPE(BITS) *)dst = caml_deserialize_uint_ ## BYTES(); \ return BYTES; \ } \ \ static struct custom_operations caml_uint ## BITS ## _ops = { \ "ctypes:uint" #BITS, \ custom_finalize_default, \ uint ## BITS ## _cmp, \ uint ## BITS ## _hash, \ uint ## BITS ## _serialize, \ uint ## BITS ## _deserialize, \ custom_compare_ext_default \ }; \ \ value ctypes_copy_uint ## BITS(TYPE(BITS) u) \ { \ value res = caml_alloc_custom(&caml_uint ## BITS ## _ops, BYTES, 0, 1); \ Uint_custom_val(TYPE(BITS), res) = u; \ return res; \ } \ UINT_PRIMOP(add, BITS, +) \ UINT_PRIMOP(sub, BITS, -) \ UINT_PRIMOP(mul, BITS, *) \ UINT_PRIMOP(logand, BITS, &) \ UINT_PRIMOP(logor, BITS, |) \ UINT_PRIMOP(logxor, BITS, ^) \ \ /* div : t -> t -> t */ \ value ctypes_uint ## BITS ## _div(value n_, value d_) \ { \ TYPE(BITS) n = Uint_custom_val(TYPE(BITS), n_); \ TYPE(BITS) d = Uint_custom_val(TYPE(BITS), d_); \ if (d == (TYPE(BITS)) 0) \ caml_raise_zero_divide(); \ return ctypes_copy_uint ## BITS (n / d); \ } \ \ /* rem : t -> t -> t */ \ value ctypes_uint ## BITS ## _rem(value n_, value d_) \ { \ TYPE(BITS) n = Uint_custom_val(TYPE(BITS), n_); \ TYPE(BITS) d = Uint_custom_val(TYPE(BITS), d_); \ if (d == (TYPE(BITS)) 0) \ caml_raise_zero_divide(); \ return ctypes_copy_uint ## BITS (n % d); \ } \ \ /* shift_left : t -> int -> t */ \ value ctypes_uint ## BITS ## _shift_left(value a, value b) \ { \ return ctypes_copy_uint ## BITS(Uint_custom_val(uint ## BITS ## _t, a) \ << Int_val(b)); \ } \ \ /* shift_right : t -> int -> t */ \ value ctypes_uint ## BITS ## _shift_right(value a, value b) \ { \ return ctypes_copy_uint ## BITS(Uint_custom_val(uint ## BITS ## _t, a) \ >> Int_val(b)); \ } \ \ /* of_int : int -> t */ \ value ctypes_uint ## BITS ## _of_int(value a) \ { \ return ctypes_copy_uint ## BITS (Int_val(a)); \ } \ \ /* to_int : t -> int */ \ value ctypes_uint ## BITS ## _to_int(value a) \ { \ return Val_int(Uint_custom_val(TYPE(BITS), a)); \ } \ \ /* of_string : string -> t */ \ value ctypes_uint ## BITS ## _of_string(value a, value b) \ { \ TYPE(BITS) u; \ if (sscanf(String_val(a), "%" SCNu ## BITS , &u) != 1) \ caml_failwith("int_of_string"); \ else \ return ctypes_copy_uint ## BITS (u); \ } \ \ /* to_string : t -> string */ \ value ctypes_uint ## BITS ## _to_string(value a) \ { \ char buf[BUF_SIZE(TYPE(BITS))]; \ if (sprintf(buf, "%" PRIu ## BITS , Uint_custom_val(TYPE(BITS), a)) < 0) \ caml_failwith("string_of_int"); \ else \ return caml_copy_string(buf); \ } \ \ /* max : unit -> t */ \ value ctypes_uint ## BITS ## _max(value a) \ { \ return ctypes_copy_uint ## BITS ((TYPE(BITS))(-1)); \ } \ UINT_DEFS(8, 1) UINT_DEFS(16, 2) UINT_DEFS(32, 4) UINT_DEFS(64, 8) value ctypes_size_t_size (value _) { return Val_int(sizeof (size_t)); } value ctypes_ushort_size (value _) { return Val_int(sizeof (unsigned short)); } value ctypes_uint_size (value _) { return Val_int(sizeof (unsigned int)); } value ctypes_ulong_size (value _) { return Val_int(sizeof (unsigned long)); } value ctypes_ulonglong_size (value _) { return Val_int(sizeof (unsigned long long)); } value ctypes_uint32_of_int32 (value i) { return ctypes_copy_uint32(Int32_val(i)); } value ctypes_int32_of_uint32 (value u) { return caml_copy_int32(Uint_custom_val(uint32_t, u)); } value ctypes_uint64_of_int64 (value i) { return ctypes_copy_uint64(Int64_val(i)); } value ctypes_int64_of_uint64 (value u) { return caml_copy_int64(Uint_custom_val(uint64_t, u)); } ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/unsigned_stubs.h000066400000000000000000000062611230210355500240160ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef CTYPES_UNSIGNED_STUBS_H #define CTYPES_UNSIGNED_STUBS_H #include #include #define UINT_DECLS(BITS) \ extern value ctypes_copy_uint ## BITS(uint ## BITS ## _t u); \ /* uintX_add : t -> t -> t */ \ extern value ctypes_uint ## BITS ## _ ## add(value a, value b); \ /* uintX_sub : t -> t -> t */ \ extern value ctypes_uint ## BITS ## _ ## sub(value a, value b); \ /* uintX_mul : t -> t -> t */ \ extern value ctypes_uint ## BITS ## _ ## mul(value a, value b); \ /* uintX_div : t -> t -> t */ \ extern value ctypes_uint ## BITS ## _ ## div(value a, value b); \ /* uintX_rem : t -> t -> t */ \ extern value ctypes_uint ## BITS ## _ ## rem(value a, value b); \ /* uintX_logand : t -> t -> t */ \ extern value ctypes_uint ## BITS ## _ ## logand(value a, value b); \ /* uintX_logor : t -> t -> t */ \ extern value ctypes_uint ## BITS ## _ ## logor(value a, value b); \ /* uintX_logxor : t -> t -> t */ \ extern value ctypes_uint ## BITS ## _ ## logxor(value a, value b); \ /* uintX_shift_left : t -> t -> t */ \ extern value ctypes_uint ## BITS ## _ ## shift_left(value a, value b); \ /* uintX_shift_right : t -> t -> t */ \ extern value ctypes_uint ## BITS ## _ ## shift_right(value a, value b); \ /* of_int : int -> t */ \ extern value ctypes_uint ## BITS ## _of_int(value a); \ /* to_int : t -> int */ \ extern value ctypes_uint ## BITS ## _to_int(value a); \ /* of_string : string -> t */ \ extern value ctypes_uint ## BITS ## _of_string(value a, value b); \ /* to_string : t -> string */ \ extern value ctypes_uint ## BITS ## _to_string(value a); \ /* max : unit -> t */ \ extern value ctypes_uint ## BITS ## _max(value a); UINT_DECLS(8) UINT_DECLS(16) UINT_DECLS(32) UINT_DECLS(64) /* X_size : unit -> int */ extern value ctypes_size_t_size (value _); extern value ctypes_ushort_size (value _); extern value ctypes_uint_size (value _); extern value ctypes_ulong_size (value _); extern value ctypes_ulonglong_size (value _); #define Uint8_val(V) (*((uint8_t *) Data_custom_val(V))) #define Uint16_val(V) (*((uint16_t *) Data_custom_val(V))) #define Uint32_val(V) (*((uint32_t *) Data_custom_val(V))) #define Uint64_val(V) (*((uint64_t *) Data_custom_val(V))) #endif /* CTYPES_UNMSIGNED_STUBS_H */ ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/value_printing.ml000066400000000000000000000045401230210355500241670ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Static open 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 (Value_printing_stubs.string_of_prim p v) | Pointer _ -> format_ptr fmt v | Struct _ -> format_struct fmt v | Union _ -> format_union fmt v | Array (a, n) -> format_array fmt v | Bigarray ba -> Format.fprintf fmt "" Ctypes_bigarray.format ba | Abstract abs -> Format.pp_print_string fmt "" (* For now, just print the underlying value in a view *) | View {write; ty} -> format ty fmt (write v) and format_struct : type a. Format.formatter -> a structure -> unit = fun fmt ({structured = {reftype = Struct {fields}}} as s) -> let open Format in fprintf fmt "{@;<1 2>@["; format_fields "," fields fmt s; fprintf fmt "@]@;<1 0>}" and format_union : type a. Format.formatter -> a union -> unit = fun fmt ({structured = {reftype = Union {ufields}}} as u) -> let open Format in fprintf fmt "{@;<1 2>@["; format_fields " |" ufields fmt u; fprintf fmt "@]@;<1 0>}" and format_array : type a. Format.formatter -> a array -> unit = fun fmt ({astart = {reftype}; alength} as arr) -> let open Format in fprintf fmt "{@;<1 2>@["; for i = 0 to alength - 1 do format reftype fmt (Array.get arr i); if i <> alength - 1 then fprintf fmt ",@;" done; fprintf fmt "@]@;<1 0>}" 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 {raw_ptr; reftype; pbyte_offset} -> Format.fprintf fmt "%s" (Value_printing_stubs.string_of_pointer (Raw.PtrType.(add raw_ptr (of_int pbyte_offset)))) let string_of typ v = Common.string_of (format typ) v ocaml-ctypes-ocaml-ctypes-0.2.3/src/ctypes/value_printing_stubs.ml000066400000000000000000000006361230210355500254110ustar00rootroot00000000000000(* * 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 Primitives.prim -> 'a -> string = "ctypes_string_of_prim" external string_of_pointer : Ctypes_raw.voidp -> string = "ctypes_string_of_pointer" ocaml-ctypes-ocaml-ctypes-0.2.3/src/discover/000077500000000000000000000000001230210355500211135ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/src/discover/discover.ml000066400000000000000000000321531230210355500232670ustar00rootroot00000000000000(* Lightweight thread library for Objective Caml * http://www.ocsigen.org/lwt * Program discover * Copyright (C) 2012 Anil Madhavapeddy * Copyright (C) 2010 Jérémie Dimino * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as * published by the Free Software Foundation, with linking exceptions; * either version 2.1 of the License, or (at your option) any later * version. See COPYING file for details. * * This program is distributed in the hope that it will be useful, but * WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * 02111-1307, USA. *) (* Discover available features *) open Printf (* +-----------------------------------------------------------------+ | Search path | +-----------------------------------------------------------------+ *) (* List of search paths for header files, mostly for MacOS users. libffi is installed by port systems into non-standard locations by default on MacOS. We use a hardcorded list of path + the ones from C_INCLUDE_PATH and LIBRARY_PATH. *) let ( // ) = Filename.concat let default_search_paths = List.map (fun dir -> (dir ^ "/include", dir ^ "/lib")) [ "/usr"; "/usr/local"; "/opt"; "/opt/local"; "/sw"; "/mingw"; ] let path_sep = if Sys.os_type = "Win32" then ';' else ':' let split_path str = let len = String.length str in let rec aux i = if i >= len then [] else let j = try String.index_from str i path_sep with Not_found -> len in String.sub str i (j - i) :: aux (j + 1) in aux 0 let search_paths = let get var f = try List.map f (split_path (Sys.getenv var)) with Not_found -> [] in List.flatten [ get "C_INCLUDE_PATH" (fun dir -> (dir, dir // ".." // "lib")); get "LIBRARY_PATH" (fun dir -> (dir // ".." // "include", dir)); default_search_paths; ] (* +-----------------------------------------------------------------+ | Test codes | +-----------------------------------------------------------------+ *) let caml_code = " external test : unit -> unit = \"ffi_test\" let () = test () " let libffi_code = " #include #include CAMLprim value ffi_test() { ffi_prep_closure(NULL, NULL, NULL, NULL); return Val_unit; } " (* +-----------------------------------------------------------------+ | Compilation | +-----------------------------------------------------------------+ *) let ocamlc = ref "ocamlc" let ext_obj = ref ".o" let exec_name = ref "a.out" let os_type = ref "Unix" let ccomp_type = ref "cc" let ffi_dir = ref "" let is_homebrew = ref false let homebrew_prefix = ref "/usr/local" let log_file = ref "" let caml_file = ref "" (* Search for a header file in standard directories. *) let search_header header = let rec loop = function | [] -> None | (dir_include, dir_lib) :: dirs -> if Sys.file_exists (dir_include // header) then Some (dir_include, dir_lib) else loop dirs in loop search_paths let compile (opt, lib) stub_file = ksprintf Sys.command "%s -custom %s %s %s %s > %s 2>&1" !ocamlc (String.concat " " (List.map (sprintf "-ccopt %s") opt)) (Filename.quote stub_file) (Filename.quote !caml_file) (String.concat " " (List.map (sprintf "-cclib %s") lib)) (Filename.quote !log_file) = 0 let safe_remove file_name = try Sys.remove file_name with exn -> () let test_code args stub_code = let stub_file, oc = Filename.open_temp_file "ffi_stub" ".c" in let cleanup () = safe_remove stub_file; safe_remove (Filename.chop_extension (Filename.basename stub_file) ^ !ext_obj) in try output_string oc stub_code; flush oc; close_out oc; let result = compile args stub_file in cleanup (); result with exn -> (try close_out oc with _ -> ()); cleanup (); raise exn let config = open_out "src/ctypes_config.h" let config_ml = open_out "src/ctypes_config.ml" let () = fprintf config "\ #ifndef __CTYPES_CONFIG_H #define __CTYPES_CONFIG_H " let not_available = ref [] let test_feature ?(do_check = true) name macro test = if do_check then begin printf "testing for %s:%!" name; if test () then begin if macro <> "" then begin fprintf config "#define %s\n" macro; fprintf config_ml "#let %s = true\n" macro end; printf " %s available\n%!" (String.make (34 - String.length name) '.') end else begin if macro <> "" then begin fprintf config "//#define %s\n" macro; fprintf config_ml "#let %s = false\n" macro end; printf " %s unavailable\n%!" (String.make (34 - String.length name) '.'); not_available := name :: !not_available end end else begin printf "not checking for %s\n%!" name; if macro <> "" then begin fprintf config "//#define %s\n" macro; fprintf config_ml "#let %s = false\n" macro end end (* +-----------------------------------------------------------------+ | pkg-config | +-----------------------------------------------------------------+ *) let split str = let rec skip_spaces i = if i = String.length str then [] else if str.[i] = ' ' then skip_spaces (i + 1) else extract i (i + 1) and extract i j = if j = String.length str then [String.sub str i (j - i)] else if str.[j] = ' ' then String.sub str i (j - i) :: skip_spaces (j + 1) else extract i (j + 1) in skip_spaces 0 let brew_libffi_version flags = if ksprintf Sys.command "brew ls libffi --versions | awk '{print $NF}' > %s 2>&1" !log_file = 0 then begin let ic = open_in !log_file in let line = input_line ic in close_in ic; if line = "" then begin print_endline "You need to 'brew install libffi' to get a suitably up-to-date version"; exit 1 end; line end else raise Exit let pkg_config choose flags = let cmd () = match choose with |`Default -> ksprintf Sys.command "pkg-config %s > %s 2>&1" flags !log_file |`Homebrew ver -> ksprintf Sys.command "env PKG_CONFIG_PATH=%s/Cellar/libffi/%s/lib/pkgconfig %s/bin/pkg-config %s > %s 2>&1" !homebrew_prefix ver !homebrew_prefix flags !log_file in if cmd () = 0 then begin let ic = open_in !log_file in let line = input_line ic in close_in ic; split line end else raise Exit let pkg_config_flags name = let pkg_config = if !is_homebrew then pkg_config (`Homebrew (brew_libffi_version ())) else pkg_config `Default in try (* Get compile flags. *) let opt = ksprintf pkg_config "--cflags %s" name in (* Get linking flags. *) let lib = if !ccomp_type = "msvc" then ksprintf pkg_config "--libs-only-L %s" name @ ksprintf pkg_config "--libs-only-l --msvc-syntax %s" name else ksprintf pkg_config "--libs %s" name in Some (opt, lib) with Exit -> None let lib_flags env_var_prefix fallback = let get var = try Some (split (Sys.getenv var)) with Not_found -> None in match get (env_var_prefix ^ "_CFLAGS"), get (env_var_prefix ^ "_LIBS") with | Some opt, Some lib -> (opt, lib) | x -> let opt, lib = fallback () in match x with | Some opt, Some lib -> assert false | Some opt, None -> (opt, lib) | None, Some lib -> (opt, lib) | None, None -> (opt, lib) (* +-----------------------------------------------------------------+ | Entry point | +-----------------------------------------------------------------+ *) let arg_bool r = Arg.Symbol (["true"; "false"], function | "true" -> r := true | "false" -> r := false | _ -> assert false) let () = let args = [ "-ocamlc", Arg.Set_string ocamlc, " ocamlc"; "-ext-obj", Arg.Set_string ext_obj, " C object files extension"; "-exec-name", Arg.Set_string exec_name, " name of the executable produced by ocamlc"; "-ccomp-type", Arg.Set_string ccomp_type, " C compiler type"; ] in Arg.parse args ignore "check for external C libraries and available features\noptions are:"; (* Put the caml code into a temporary file. *) let file, oc = Filename.open_temp_file "ffi_caml" ".ml" in caml_file := file; output_string oc caml_code; close_out oc; log_file := Filename.temp_file "ffi_output" ".log"; (* Cleanup things on exit. *) at_exit (fun () -> (try close_out config with _ -> ()); (try close_out config_ml with _ -> ()); safe_remove !log_file; safe_remove !exec_name; safe_remove !caml_file; safe_remove (Filename.chop_extension !caml_file ^ ".cmi"); safe_remove (Filename.chop_extension !caml_file ^ ".cmo")); let setup_data = ref [] in (* Test for MacOS X Homebrew. *) test_feature "brew" "" (fun () -> ksprintf Sys.command "brew info libffi > %s 2>&1" !log_file = 0); (* Not having Homebrew is not fatal. *) is_homebrew := !not_available = []; not_available := []; let get_homebrew_prefix () = let cmd () = ksprintf Sys.command "brew --prefix > %s" !log_file in if cmd () = 0 then begin let ic = open_in !log_file in let line = input_line ic in close_in ic; line end else raise Exit in (* Test for pkg-config. If we are on MacOS X, we need the latest pkg-config * from Homebrew *) (match !is_homebrew with |true -> (* Look in `brew for the right pkg-config *) homebrew_prefix := get_homebrew_prefix (); test_feature "pkg-config" "" (fun () -> ksprintf Sys.command "%s/bin/pkg-config --version > %s 2>&1" !homebrew_prefix !log_file = 0); |false -> test_feature "pkg-config" "" (fun () -> ksprintf Sys.command "pkg-config --version > %s 2>&1" !log_file = 0); ); (* Not having pkg-config is not fatal. *) let have_pkg_config = !not_available = [] in not_available := []; let test_libffi () = let opt, lib = lib_flags "LIBFFI" (fun () -> match if have_pkg_config then pkg_config_flags "libffi" else None with | Some (opt, lib) -> (opt, lib) | None -> match search_header "ffi.h" with | Some (dir_i, dir_l) -> (["-I" ^ dir_i], ["-L" ^ dir_l; "-lffi"]) | None -> ([], ["-lffi"])) in setup_data := ("libffi_opt", opt) :: ("libffi_lib", lib) :: !setup_data; test_code (opt, lib) libffi_code in test_feature "libffi" "" test_libffi; if !not_available <> [] then begin if not have_pkg_config then printf "Warning: the 'pkg-config' command is not available."; printf " The following recquired C libraries are missing: %s. Please install them and retry. If they are installed in a non-standard location or need special flags, set the environment variables _CFLAGS and _LIBS accordingly and retry. For example, if libffi is installed in /opt/local, you can type: export LIBFFI_CFLAGS=-I/opt/local/include export LIBFFI_LIBS=-L/opt/local/lib " (String.concat ", " !not_available); exit 1 end; fprintf config "#endif\n"; (* Our setup.data keys. *) let setup_data_keys = [ "libffi_opt"; "libffi_lib"; ] in (* Load setup.data *) let setup_data_lines = match try Some (open_in "setup.data") with Sys_error _ -> None with | Some ic -> let rec aux acc = match try Some (input_line ic) with End_of_file -> None with | None -> close_in ic; acc | Some line -> match try Some(String.index line '=') with Not_found -> None with | Some idx -> let key = String.sub line 0 idx in if List.mem key setup_data_keys then aux acc else aux (line :: acc) | None -> aux (line :: acc) in aux [] | None -> [] in (* Add flags to setup.data *) let setup_data_lines = List.fold_left (fun lines (name, args) -> sprintf "%s=%s" name (String.concat " " args) :: lines) setup_data_lines !setup_data in let oc = open_out "setup.data" in List.iter (fun str -> output_string oc str; output_char oc '\n') (List.rev setup_data_lines); close_out oc; close_out config; close_out config_ml ocaml-ctypes-ocaml-ctypes-0.2.3/tests/000077500000000000000000000000001230210355500176505ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/clib/000077500000000000000000000000001230210355500205615ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/clib/test_functions.c000066400000000000000000000234261230210355500240030ustar00rootroot00000000000000/* * 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 typedef int intfun(int, int); 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 *callback, int x, int y) { return callback(x, y) == x + y; } typedef int acceptor(intfun *, int, int); int higher_order_3(acceptor *callback, intfun *fn, int x, int y) { return callback(fn, x, y); } typedef int vintfun(int); int higher_order_simplest(vintfun *callback) { return callback(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; fprintf(stderr, "[before] x = %d, y = %d, &x = %p, &y = %p, p = %p, &p = %p\n", x, y, &x, &y, p, &p); fprintf(stderr, "calling f(%p, %p)\n", &p, &y); fprintf(stderr, "[after] x = %d, y = %d, p = %p, *p = %d\n", x, y, p, *p); return f(&p, &y) + *p + x + y; } int is_null(void *p) { return p == NULL; } int callback_returns_funptr(vintfun *(*callback)(int), int x) { vintfun *v1 = callback(x); vintfun *v2 = callback(x + 1); return v1(10) + v2(20); } int *pass_pointer_through(int *a, int *b, int i) { return (i >= 0) ? a : b; } struct simple { int i; double f; struct simple *self; }; 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; } union padded { int64_t i; char a[sizeof(int64_t) + 1]; }; 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; } 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'; } union number { int i; double d; }; struct tagged { char tag; union number num; }; 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; } #define GLOBAL_STRING "global string" struct global_struct { size_t len; const char str[sizeof GLOBAL_STRING]; } global_struct = { sizeof GLOBAL_STRING - 1, GLOBAL_STRING }; /* 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, int *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); } typedef int pintfun1(int *, int *); int passing_pointers_to_callback(pintfun1 *f) { int x = 3, y = 4; return f(&x, &y); } typedef int *pintfun2(int, int); 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 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; } static int (*global_stored_callback)(int) = NULL; void store_callback(int (*callback)(int)) { global_stored_callback = callback; } int invoke_stored_callback(int x) { return global_stored_callback(x); } vintfun *return_callback(vintfun *callback) { return callback; } struct one_int { int i; }; 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; } ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-alignment/000077500000000000000000000000001230210355500226035ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-alignment/test_alignment.ml000066400000000000000000000176561230210355500261710ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit open Ctypes (* 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); 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 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 type k = K : ('a, 'b) Bigarray.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 of bigarray types" >:: test_bigarray_alignment; ] let _ = run_test_tt_main suite ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-array/000077500000000000000000000000001230210355500217435ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-array/test_array.ml000066400000000000000000000113421230210355500244530ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit open Ctypes let testlib = Dl.(dlopen ~filename:"clib/test_functions.so" ~flags:[RTLD_NOW]) (* Creating multidimensional arrays, and reading and writing elements. *) let test_multidimensional_arrays () = (* 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 = Pervasives.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 that creating an array initializes all elements appropriately. *) let test_array_initialiation () = 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 an array initializes all elements appropriately. *) let test_pointer_to_array_arithmetic () = (* 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 passing pointer to array of structs. *) let test_passing_pointer_to_array_of_structs () = (* union u { int i; double d; } *) let u = union "u" in let (-:) ty label = field u label ty in let i = int -: "i" in let d = double -: "d" in let () = seal u in (* struct s { char tag; union u data; } *) let s = structure "s" in let (-:) ty label = field s label ty in let tag = char -: "tag" in let data = u -: "data" in let () = seal s in 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 accepts_pointer_to_array_of_structs = Foreign.foreign "accepts_pointer_to_array_of_structs" (ptr (array 5 s) @-> returning double) ~from:testlib in let sum = accepts_pointer_to_array_of_structs (from_voidp (array 5 s) (to_voidp (Array.start (Array.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 let suite = "Array tests" >::: ["multidimensional arrays" >:: test_multidimensional_arrays; "array initialization" >:: test_array_initialiation; "pointer to array arithmetic" >:: test_pointer_to_array_arithmetic; "passing pointer to array of structs" >:: test_passing_pointer_to_array_of_structs; ] let _ = run_test_tt_main suite ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-bigarrays/000077500000000000000000000000001230210355500226105ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-bigarrays/test_bigarrays.ml000066400000000000000000000344361230210355500261760ustar00rootroot00000000000000(* * 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 open OUnit open Ctypes module BA = Bigarray let testlib = Dl.(dlopen ~filename:"clib/test_functions.so" ~flags:[RTLD_NOW]) let array_of_list2 typ list2 = let dim2 = List.length (List.hd list2) in let atyp = array dim2 typ in Array.of_list atyp (List.map (Array.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 Array.of_list atyp (List.map (array_of_list2 typ) list3) let list2_of_array array = List.map Array.to_list (Array.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 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 () = (* 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 (* Test passing bigarrays to c functions. *) let test_passing_bigarrays () = let matrix_mul = Foreign.foreign "matrix_mul" ~from:testlib (int @-> int @-> int @-> ptr double @-> ptr double @-> ptr double @-> returning void) in 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 matrix_transpose = Foreign.foreign "matrix_transpose" ~from:testlib (int @-> int @-> ptr double @-> returning (ptr double)) in 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.]]))) (* 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.(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.major (); Gc.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.major (); Gc.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 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.major (); Gc.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.major (); Gc.major (); assert_equal !state `Collected end 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; "Passing bigarrays to C" >:: test_passing_bigarrays; "Returning bigarrays from C" >:: test_returning_bigarrays; ] let _ = run_test_tt_main suite ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-callback_lifetime/000077500000000000000000000000001230210355500242375ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-callback_lifetime/test_callback_lifetime.ml000066400000000000000000000114551230210355500312500ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit open Ctypes open Foreign let testlib = Dl.(dlopen ~filename:"clib/test_functions.so" ~flags:[RTLD_NOW]) (* Check that we can store a reference to an OCaml function in a C global and invoke it later. *) let test_storing_function_reference () = let callback_type = int @-> returning int in let store_callback = foreign "store_callback" ~from:testlib (funptr callback_type @-> returning void) in let invoke_stored_callback = foreign "invoke_stored_callback" ~from:testlib (int @-> returning int) in (* This shouldn't be collected in the code that follows. *) let double x = x * 2 in begin store_callback double; Gc.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 callback_type = int @-> returning int in let store_callback = foreign "store_callback" ~from:testlib (funptr callback_type @-> returning void) in let invoke_stored_callback = foreign "invoke_stored_callback" ~from:testlib (int @-> returning int) in let closure x y = x * y in begin (* The closure should be collected in the next GC *) store_callback (closure 2); (* The first GC collects the closure itself, which frees the associated object to be collected on the next GC. *) Gc.major (); Gc.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 () = let callback_type = int @-> returning int in let return_callback = foreign "return_callback" ~from:testlib (funptr callback_type @-> returning (funptr callback_type)) in (* 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. *) let ret = Naive.make ~arg:(closure 3) in Gc.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 = Better.make ~arg:(closure 3) in Gc.major (); assert_equal 15 (Better.get ret 5); (* 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 = Better.get (Better.make ~arg:(closure 3)) in Gc.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 3)) in Gc.major (); assert_equal 15 (ret 5) let suite = "Callback lifetime tests" >::: ["storing references to OCaml functions" >:: test_storing_function_reference; "calling expired closures" >:: test_calling_collected_closure_raises_exception; "controlling the lifetime of closures passed to C" >:: test_controlling_closure_lifetime; ] let _ = run_test_tt_main suite ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-coercions/000077500000000000000000000000001230210355500226115ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-coercions/test_coercions.ml000066400000000000000000000075601230210355500261760ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit 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.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.iter2 types types ~f:(fun (T t1) (T t2) -> let _ = 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 () (* 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 int; T float; T short; T complex64; T (bigarray array1 10 Bigarray.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.iter2 types types ~f:(fun (T t1) (T t2) -> assert_raises Uncoercible (fun () -> coerce t1 t2)) end in () 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 unsupported coercions" >:: test_unsupported_coercions; ] let _ = run_test_tt_main suite ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-complex/000077500000000000000000000000001230210355500222745ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-complex/test_complex.ml000066400000000000000000000034241230210355500253370ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit open Ctypes let testlib = Dl.(dlopen ~filename:"clib/test_functions.so" ~flags:[RTLD_NOW]) (* 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 open Foreign in let wrap typ name = let f = foreign name ~from:testlib (ptr typ @-> ptr typ @-> ptr typ @-> returning void) in fun l r -> let rv = allocate_n ~count:1 typ in f (allocate typ l) (allocate typ r) rv; !@rv in let addz64 = wrap complex64 "add_complexd" and mulz64 = wrap complex64 "mul_complexd" and addz32 = wrap complex32 "add_complexf" and mulz32 = wrap complex32 "mul_complexf" 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); end let suite = "Complex number tests" >::: ["basic operations on complex numbers" >:: test_complex_primitive_operations; ] let _ = run_test_tt_main suite ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-cstdlib/000077500000000000000000000000001230210355500222515ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-cstdlib/test_cstdlib.ml000066400000000000000000000221771230210355500252770ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit open Ctypes open Unsigned open Foreign (* 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 () = let cchar = view ~read:Char.chr ~write:Char.code int in let bool = view ~read:((<>)0) ~write:(fun b -> if b then 1 else 0) int in let t = (cchar @-> returning bool) in 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 in 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 () = (* char *strchr(const char *str, int c); *) let strchr = foreign "strchr" (string @-> int @-> returning string) in (* int strcmp(const char *str1, const char *str2); *) let strcmp = foreign "strcmp" (string @-> string @-> returning int) in (* int memcmp(const void *ptr1, const void *ptr2, size_t num) *) let memcmp = foreign "memcmp" (ptr void @-> ptr void @-> size_t @-> returning int) in (* void *memset(void *ptr, int value, size_t num) *) let memset = foreign "memset" (ptr void @-> int @-> size_t @-> returning (ptr void)) in 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 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 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 () (* Call the function void qsort(void *base, size_t nmemb, size_t size, int(*compar)(const void *, const void *)); *) let test_qsort () = let comparator = ptr void @-> ptr void @-> returning int in let qsort = foreign "qsort" (ptr void @-> size_t @-> size_t @-> funptr comparator @-> returning void) in let sortby (type a) (typ : a typ) (f : a -> a -> int) (l : a list) = let open Array in let open Size_t in let open Infix 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 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 let comparator = ptr void @-> ptr void @-> returning int let bsearch = foreign "bsearch" (ptr void @-> ptr void @-> size_t @-> size_t @-> funptr comparator @-> returning (ptr void)) let qsort = foreign "qsort" (ptr void @-> size_t @-> size_t @-> funptr comparator @-> returning void) let strlen = foreign "strlen" (ptr char @-> returning size_t) (* 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 array = fun s -> let len = String.length s in let arr = Array.make char (len + 1) in for i = 0 to len - 1 do arr.(i) <- s.[i]; done; arr.(len) <- '\000'; arr let as_string : char ptr -> string = fun p -> let len = Size_t.to_int (strlen p) in let s = String.create len in for i = 0 to len - 1 do s.[i] <- !@(p +@ i); done; s let mkmi n s = let m = make mi in setf m mr n; setf m name (Array.start s); m let cmpi m1 m2 = let mi1 = from_voidp mi m1 in let mi2 = from_voidp mi m2 in Pervasives.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 = Array.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 (Array.start months)) (Size_t.of_int (Array.length months)) (Size_t.of_int (sizeof mi)) cmpi let search : mi structure -> mi structure array -> mi structure option = fun key array -> let len = Size_t.of_int (Array.length array) in let size = Size_t.of_int (sizeof mi) in let r : unit ptr = bsearch (to_voidp (addr key)) (to_voidp (Array.start array)) len size cmpi in if r = null then None else Some (!@(from_voidp mi r)) let find_month_by_name : char array -> 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) end in () let suite = "C standard library tests" >::: ["test isX functions" >:: test_isX_functions; "test string function" >:: test_string_functions; "test div function" >:: test_div; "test qsort function" >:: test_qsort; "test bsearch function" >:: test_bsearch; ] let _ = run_test_tt_main suite ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-custom_ops/000077500000000000000000000000001230210355500230205ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-custom_ops/test_custom_ops.ml000066400000000000000000000051141230210355500266050ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit 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 ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-errno/000077500000000000000000000000001230210355500217525ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-errno/test_errno.ml000066400000000000000000000025471230210355500245000ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit open Ctypes (* Call fdopendir() with a bogus file descriptor and check that an exception is raised. *) let test_errno_exception_raised () = let fdopendir = Foreign.foreign "fdopendir" ~check_errno:true (int @-> returning (ptr void)) in assert_raises (Unix.Unix_error(Unix.EBADF, "fdopendir", "")) (fun () -> fdopendir (-300)) (* Call chdir() with a valid directory path and check that zero is returned. *) let test_int_return_errno_exception_raised () = let chdir = Foreign.foreign "chdir" ~check_errno:true (string @-> returning int) in assert_raises (Unix.Unix_error(Unix.ENOENT, "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 "chdir" ~check_errno:true (string @-> returning int) in assert_equal 0 (chdir (Sys.getcwd ())) let suite = "errno tests" >::: ["Exception from fdopendir" >:: test_errno_exception_raised; "Exception from chdir" >:: test_int_return_errno_exception_raised; "No exception from chdir" >:: test_errno_no_exception_raised; ] let _ = run_test_tt_main suite ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-finalisers/000077500000000000000000000000001230210355500227645ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-finalisers/test_finalisers.ml000066400000000000000000000037351230210355500265240ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit open Ctypes (* Simple finalisation test for arrays. *) let test_array_finaliser () = 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.major (); assert_equal ~msg:"The finaliser was not run" false !finaliser_completed; assert_equal 1 !@p; end in begin Gc.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.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.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 ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-foreign_values/000077500000000000000000000000001230210355500236355ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-foreign_values/test_foreign_values.ml000066400000000000000000000030651230210355500302420ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit open Ctypes let testlib = Dl.(dlopen ~filename:"clib/test_functions.so" ~flags:[RTLD_NOW]) (* Retrieve a struct exposed as a global value. *) let test_retrieving_struct () = let s = structure "global_struct" in let (-:) ty label = field s label ty in let len = size_t -: "len" in let str = array 1 char -: "str" in let () = seal s in let global_struct = Foreign.foreign_value "global_struct" s ~from:testlib in let p = Array.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 () = let open Foreign in let plus = foreign_value ~from:testlib "plus_callback" (funptr_opt (int @-> int @-> returning int)) in let sum = foreign ~from:testlib "sum_range_with_plus_callback" (int @-> int @-> returning int) in begin assert_equal !@plus None; plus <-@ Some (+); assert_equal (sum 1 10) 55; end let suite = "Foreign value tests" >::: ["retrieving global struct" >:: test_retrieving_struct; "global callback function" >:: test_global_callback; ] let _ = run_test_tt_main suite ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-higher_order/000077500000000000000000000000001230210355500232665ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-higher_order/test_higher_order.ml000066400000000000000000000062721230210355500273270ustar00rootroot00000000000000(* * 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 OUnit open Foreign let testlib = Dl.(dlopen ~filename:"clib/test_functions.so" ~flags:[RTLD_NOW]) (* 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 () = let intfun = (int @-> int @-> returning int) in let higher_order_1 = foreign ~from:testlib "higher_order_1" (funptr intfun @-> int @-> int @-> returning int) in (* 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 intfun = (int @-> int @-> returning int) in let acceptor = (funptr intfun @-> int @-> int @-> returning int) in let higher_order_3 = foreign ~from:testlib "higher_order_3" (funptr acceptor @-> funptr intfun @-> int @-> int @-> returning int) in let acceptor op x y = op x (op x y) in (* let add = foreign ~from:testlib "add" intfun 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 ( *(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 intfun = (int @-> int @-> returning int) in let returning_funptr = foreign ~from:testlib "returning_funptr" (int @-> returning (funptr intfun)) in 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 intfun = (int @-> returning int) in let callback_returns_funptr = foreign ~from:testlib "callback_returns_funptr" (funptr (int @-> returning (funptr intfun)) @-> int @-> returning int) in let callback = function | 0 -> ( + ) 10 | 1 -> ( * ) 13 | _ -> invalid_arg "callback" in assert_equal 280 (callback_returns_funptr callback 0) let suite = "Higher-order tests" >::: ["test_higher_order_basic" >:: test_higher_order_basic; "test_higher_higher_order" >:: test_higher_higher_order; "test_returning_pointer_to_function" >:: test_returning_pointer_to_function; "test_callback_returns_pointer_to_function" >:: test_callback_returns_pointer_to_function; ] let _ = run_test_tt_main suite ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-oo_style/000077500000000000000000000000001230210355500224625ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-oo_style/test_oo_style.ml000066400000000000000000000113301230210355500257060ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit open Ctypes let testlib = Dl.(dlopen ~filename:"clib/test_functions.so" ~flags:[RTLD_NOW]) (* Establish a hierarchy of "classes", create some "objects" and call some "methods". *) let test_oo_hierarchy () = let module M = struct 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 (ptr animal @-> returning string) -: "say" let identify = Foreign.funptr (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 (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 camel_vtable_singleton = make camel_methods let () = begin let vt = camel_vtable_singleton in let base_vt = !@(cast animal_methods (addr vt)) in (* say *) setf base_vt say (fun animal -> "humph"); (* identify *) setf base_vt identify (fun animal -> let n = call_humps (cast camel animal) in Printf.sprintf "%d-hump camel" n); (* humps *) setf vt humps (fun camel -> !@(camel |-> nhumps)) 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 check_name = Foreign.foreign "check_name" ~from:testlib (ptr animal @-> string @-> returning int) 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 (* 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 let new_chorse = Foreign.foreign "new_chorse" ~from:testlib (int @-> returning (ptr animal)) 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 () let suite = "OO-style tests" >::: ["OO style" >:: test_oo_hierarchy; ] let _ = run_test_tt_main suite ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-passable/000077500000000000000000000000001230210355500224175ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-passable/test_passable.ml000066400000000000000000000273701230210355500256130ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit 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 complex values *) let test_complex_value_passability () = (* complex32 can be used as an argument type *) ignore (complex32 @-> 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)); (* complex64 can be used as an argument type *) ignore (complex64 @-> 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)); (* complex32 can be used as a return type *) ignore (void @-> returning complex32); assert_raises ~msg:"Foreign rejects complex32 type as return type" (Unsupported "libffi does not support passing float _Complex") (fun () -> Foreign.funptr (void @-> returning complex32)); (* complex64 can be used as a return type *) ignore (void @-> returning complex64); assert_raises ~msg:"Foreign rejects complex64 type as return type" (Unsupported "libffi does not support passing double _Complex") (fun () -> Foreign.funptr (void @-> returning complex64)) (* 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.int @-> returning void); assert_raises ~msg:"bigarray1 type rejected as argument" (Unsupported "Unsupported argument type") (fun () -> bigarray array1 1 Bigarray.int @-> returning void); assert_raises ~msg:"bigarray2 type rejected as argument" (Unsupported "Unsupported argument type") (fun () -> bigarray array2 (1, 2) Bigarray.int @-> returning void); assert_raises ~msg:"bigarray3 type rejected as argument" (Unsupported "Unsupported argument type") (fun () -> bigarray array3 (1, 2, 3) Bigarray.int @-> returning void); assert_raises ~msg:"bigarray type rejected as return type" (Unsupported "Unsupported return type") (fun () -> void @-> returning (bigarray genarray [|1|] Bigarray.int)); assert_raises ~msg:"bigarray1 type rejected as return type" (Unsupported "Unsupported return type") (fun () -> void @-> returning (bigarray array1 1 Bigarray.int)); assert_raises ~msg:"bigarray2 type rejected as return type" (Unsupported "Unsupported return type") (fun () -> void @-> returning (bigarray array2 (1, 2) Bigarray.int)); assert_raises ~msg:"bigarray3 type rejected as return type" (Unsupported "Unsupported return type") (fun () -> void @-> returning (bigarray array3 (1, 2, 3) Bigarray.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 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; "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; ] let _ = run_test_tt_main suite ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-pointers/000077500000000000000000000000001230210355500224705ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-pointers/test_pointers.ml000066400000000000000000000430351230210355500257310ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit open Ctypes open Foreign let testlib = Dl.(dlopen ~filename:"clib/test_functions.so" ~flags:[RTLD_NOW]) (* Test passing various types of pointers to a function. *) let test_passing_pointers () = let accept_pointers = foreign "accept_pointers" ~from:testlib (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) in 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 accept_pointers_to_pointers = foreign "accept_pointers_to_pointers" ~from:testlib (ptr int @-> ptr (ptr int) @-> ptr (ptr (ptr int)) @-> ptr (ptr (ptr (ptr int))) @-> returning int) in 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" Pervasives.(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 () = let pintfun1 = ptr int @-> ptr int @-> returning int in let passing_pointers_to_callback = foreign ~from:testlib "passing_pointers_to_callback" (funptr pintfun1 @-> returning int) in 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 pintfun2 = int @-> int @-> returning (ptr int) in let p = allocate int 17 in let accepting_pointer_from_callback = foreign ~from:testlib "accepting_pointer_from_callback" (funptr pintfun2 @-> returning int) 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 (* 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_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 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_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 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 (* Test passing a pointer-to-a-function-pointer as an argument. *) let test_passing_pointer_to_function_pointer () = let arg_type = funptr (int @-> int @-> returning int) in let accepting_pointer_to_function_pointer = foreign "accepting_pointer_to_function_pointer" ~from:testlib (ptr arg_type @-> returning int) in assert_equal ~printer:string_of_int 5 (accepting_pointer_to_function_pointer (allocate arg_type ( / ))) (* Test returning a pointer to a function pointer *) let test_callback_returning_pointer_to_function_pointer () = let returning_pointer_to_function_pointer = foreign "returning_pointer_to_function_pointer" ~from:testlib (void @-> returning (ptr (funptr (int @-> int @-> returning int)))) in assert_equal 10 (!@(returning_pointer_to_function_pointer ()) 2 5) (* 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 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 (* Test bindings for malloc, realloc and free. *) let test_allocation () = let open Unsigned in let malloc = foreign "malloc" (size_t @-> returning (ptr void)) in let realloc = foreign "realloc" (ptr void @-> size_t @-> returning (ptr void)) in let free = foreign "free" (ptr void @-> returning void) 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 () = let return_global_address = foreign "return_global_address" ~from:testlib (void @-> returning (ptr int)) in assert_equal (!@(return_global_address ())) 100 (* Test a function that returns a pointer passed as argument. *) let test_passing_pointer_through () = let pass_pointer_through = foreign "pass_pointer_through" ~from:testlib (ptr int @-> ptr int @-> int @-> returning (ptr int)) in 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 (* Tests for various aspects of pointer arithmetic. *) let test_pointer_arithmetic () = 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) let suite = "Pointer tests" >::: ["passing pointers" >:: test_passing_pointers; "passing pointers to pointers" >:: test_passing_pointers_to_pointers; "callback receiving pointers" >:: test_callback_receiving_pointers; "callback returning pointers" >:: test_callback_returning_pointers; "pointer assignment with primitives" >:: test_pointer_assignment_with_primitives; "passing pointer to function pointer" >:: test_passing_pointer_to_function_pointer; "callback returning pointer to function pointer" >:: 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" >:: test_allocation; "passing pointers through functions" >:: test_passing_pointer_through; "returned globals" >:: test_reading_returned_global; "arithmetic" >:: test_pointer_arithmetic; "comparisons" >:: test_pointer_comparison; "differences" >:: test_pointer_differences; ] let _ = run_test_tt_main suite ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-raw/000077500000000000000000000000001230210355500214165ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-raw/test_raw.ml000066400000000000000000000035351230210355500236060ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit open Memory_stubs open Std_view_stubs (* Tests for the low-level module on which the public high-level interface is based. *) (* Call the C function double fabs(double) *) let test_fabs () = Ffi_stubs.( let double_ffitype = primitive_ffitype Primitives.Double in let callspec = allocate_callspec () in let arg_1_offset = add_argument callspec double_ffitype in let () = prep_callspec callspec double_ffitype in let dlfabs = Dl.dlsym "fabs" in let fabs x = call dlfabs callspec (write Primitives.Double ~offset:arg_1_offset x) (read Primitives.Double ~offset:0) 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 () = Ffi_stubs.( let double_ffitype = primitive_ffitype Primitives.Double in let callspec = allocate_callspec () 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 double_ffitype in let dlpow = Dl.dlsym "pow" in let pow x y = call dlpow callspec (fun buffer -> write Primitives.Double ~offset:arg_1_offset x buffer; write Primitives.Double ~offset:arg_2_offset y buffer) (read ~offset:0 Primitives.Double) 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 ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-sizeof/000077500000000000000000000000001230210355500221245ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-sizeof/test_sizeof.ml000066400000000000000000000151101230210355500250120ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit open Ctypes (* 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 char <= sizeof int); assert_bool "sizeof (short) <= sizeof (int)" (sizeof char <= sizeof int); assert_bool "sizeof (int) <= sizeof (long)" (sizeof int <= sizeof long); assert_bool "sizeof (long) <= sizeof (long long)" (sizeof long <= sizeof llong); 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 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 type k = K : ('a, 'b) Bigarray.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 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 ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-structs/000077500000000000000000000000001230210355500223345ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-structs/test_structs.ml000066400000000000000000000217741230210355500254470ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit open Ctypes let testlib = Dl.(dlopen ~filename:"clib/test_functions.so" ~flags:[RTLD_NOW]) (* 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 type simple let simple : simple structure typ = structure "simple" let (-:) ty label = field simple label ty let c = int -: "c" let f = double -: "f" let p = ptr simple -: "p" let () = seal simple let accept_struct = Foreign.foreign "accept_struct" ~from:testlib (simple @-> returning int) let s = make simple let () = begin setf s c 10; setf s f 14.5; setf s p (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 type simple let simple : simple structure typ = structure "simple" let (-:) ty label = field simple label ty let c = int -: "c" let f = double -: "f" let p = ptr simple -: "p" let () = seal simple let return_struct = Foreign.foreign "return_struct" ~from:testlib (void @-> returning simple) let s = return_struct () let () = assert_equal 20 (getf s c) let () = assert_equal 35.0 (getf s f) let t = getf s p let () = assert_equal 10 !@(t |-> c) ~printer:string_of_int let () = assert_equal 12.5 !@(t |-> f) ~printer:string_of_float let () = assert_equal (to_voidp !@(t |-> p)) (to_voidp t) end in () (* 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 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 { 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 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.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 i = field s "i" int in let () = seal s in s end) in Foreign.foreign ~from:testlib "return_struct_by_value" t let () = Gc.major() let x = f () end in () let suite = "Struct tests" >::: ["passing struct" >:: test_passing_struct; "returning struct" >:: test_returning_struct; "incomplete struct members rejected" >:: test_incomplete_struct_members; "pointers to struct members" >:: test_pointers_to_struct_members; "structs with union members" >:: test_structs_with_union_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; ] let _ = run_test_tt_main suite ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-stubs/000077500000000000000000000000001230210355500217655ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-stubs/test_stubs.ml000066400000000000000000000012571230210355500245230ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit 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 _ = 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 ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-type_printing/000077500000000000000000000000001230210355500235205ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-type_printing/test_type_printing.ml000066400000000000000000000344141230210355500300120ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit open Ctypes let strip_whitespace = Str.(global_replace (regexp "[\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 ~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 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 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; 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 bigarray types. *) let test_bigarray_printing () = begin assert_typ_printed_as "" (bigarray genarray [|10; 100|] Bigarray.float32); assert_typ_printed_as "" (bigarray genarray [|20; 30; 40|] Bigarray.float64); assert_typ_printed_as "" (bigarray genarray [|1; 3|] Bigarray.int8_signed); assert_typ_printed_as "" (bigarray array1 2 Bigarray.int8_unsigned); assert_typ_printed_as "" (bigarray array1 3 Bigarray.int16_signed); assert_typ_printed_as "" (bigarray array1 4 Bigarray.int16_unsigned); assert_typ_printed_as "" (bigarray array2 (5, 6) Bigarray.int32); assert_typ_printed_as "" (bigarray array2 (7, 8) Bigarray.int64); assert_typ_printed_as "" (bigarray array2 (9, 10) Bigarray.int); assert_typ_printed_as "" (bigarray array3 (13, 14, 15) Bigarray.nativeint); assert_typ_printed_as "" (bigarray array3 (16, 17, 18) Bigarray.complex32); assert_typ_printed_as "" (bigarray array3 (19, 20, 21) Bigarray.complex64); assert_typ_printed_as ~name:"b" "int (*b[10])( *)" (array 10 (Foreign.funptr (ptr (bigarray genarray [|5|] Bigarray.int) @-> returning int))); 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 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 bigarrays" >:: test_bigarray_printing; "printing functions" >:: test_function_printing; "printing views" >:: test_view_printing; ] let _ = run_test_tt_main suite ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-unions/000077500000000000000000000000001230210355500221405ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-unions/test_unions.ml000066400000000000000000000111031230210355500250400ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit open Ctypes open Unsigned let testlib = Dl.(dlopen ~filename:"clib/test_functions.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 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 () (* Check that unions are tail-padded sufficiently to satisfy the alignment requirements of all their members. *) let test_union_padding () = let module M = struct 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 let sum_union_components = Foreign.foreign "sum_union_components" (ptr padded @-> size_t @-> returning int64_t) ~from:testlib let mkPadded : int64 -> padded union = fun x -> let u = make padded in setf u i x; u let arr = Array.of_list padded [ mkPadded 1L; mkPadded 2L; mkPadded 3L; mkPadded 4L; mkPadded 5L; ] let sum = sum_union_components (Array.start arr) (Unsigned.Size_t.of_int (Array.length arr)) let () = assert_equal ~msg:"padded union members accessed correctly" 15L sum ~printer:Int64.to_string end in () (* 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 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) let suite = "Union tests" >::: ["inspecting float representation" >:: test_inspecting_float; "detecting endianness" >:: test_endian_detection; "union padding" >:: test_union_padding; "union address" >:: test_union_address; "updating sealed union" >:: test_updating_sealed_union; "sealing empty union" >:: test_sealing_empty_union; ] let _ = run_test_tt_main suite ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-value_printing/000077500000000000000000000000001230210355500236535ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-value_printing/test_value_printing.ml000066400000000000000000000376501230210355500303050ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit open Ctypes let testlib = Dl.(dlopen ~filename:"clib/test_functions.so" ~flags:[RTLD_NOW]) let strip_whitespace = Str.(global_replace (regexp "[\n ]+") "") let equal_ignoring_whitespace l r = strip_whitespace l = strip_whitespace r (* 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 retrieve_CHAR_MIN = Foreign.foreign "retrieve_CHAR_MIN" ~from:testlib (void @-> returning char) in let _CHAR_MIN = retrieve_CHAR_MIN () in let retrieve_CHAR_MAX = Foreign.foreign "retrieve_CHAR_MAX" ~from:testlib (void @-> returning char) 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 retrieve_SCHAR_MIN = Foreign.foreign "retrieve_SCHAR_MIN" ~from:testlib (void @-> returning schar) in let _SCHAR_MIN = retrieve_SCHAR_MIN () in let retrieve_SCHAR_MAX = Foreign.foreign "retrieve_SCHAR_MAX" ~from:testlib (void @-> returning schar) 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 retrieve_SHRT_MIN = Foreign.foreign "retrieve_SHRT_MIN" ~from:testlib (void @-> returning short) in let _SHRT_MIN = retrieve_SHRT_MIN () in let retrieve_SHRT_MAX = Foreign.foreign "retrieve_SHRT_MAX" ~from:testlib (void @-> returning short) 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 retrieve_INT_MIN = Foreign.foreign "retrieve_INT_MIN" ~from:testlib (void @-> returning int) in let _INT_MIN = retrieve_INT_MIN () in let retrieve_INT_MAX = Foreign.foreign "retrieve_INT_MAX" ~from:testlib (void @-> returning int) 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 retrieve_LONG_MAX = Foreign.foreign "retrieve_LONG_MAX" ~from:testlib (void @-> returning long) in let _LONG_MAX = retrieve_LONG_MAX () in let retrieve_LONG_MIN = Foreign.foreign "retrieve_LONG_MIN" ~from:testlib (void @-> returning long) 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 retrieve_LLONG_MAX = Foreign.foreign "retrieve_LLONG_MAX" ~from:testlib (void @-> returning llong) in let _LLONG_MAX = retrieve_LLONG_MAX () in let retrieve_LLONG_MIN = Foreign.foreign "retrieve_LLONG_MIN" ~from:testlib (void @-> returning llong) 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 retrieve_UCHAR_MAX = Foreign.foreign "retrieve_UCHAR_MAX" ~from:testlib (void @-> returning uchar) in 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)); (* unsigned short *) let retrieve_USHRT_MAX = Foreign.foreign "retrieve_USHRT_MAX" ~from:testlib (void @-> returning ushort) in 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 retrieve_UINT_MAX = Foreign.foreign "retrieve_UINT_MAX" ~from:testlib (void @-> returning uint) in 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 retrieve_ULONG_MAX = Foreign.foreign "retrieve_ULONG_MAX" ~from:testlib (void @-> returning ulong) in 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 retrieve_ULLONG_MAX = Foreign.foreign "retrieve_ULLONG_MAX" ~from:testlib (void @-> returning ullong) in 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 retrieve_INT8_MIN = Foreign.foreign "retrieve_INT8_MIN" ~from:testlib (void @-> returning int8_t) in let _INT8_MIN = retrieve_INT8_MIN () in let retrieve_INT8_MAX = Foreign.foreign "retrieve_INT8_MAX" ~from:testlib (void @-> returning int8_t) 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 retrieve_INT16_MIN = Foreign.foreign "retrieve_INT16_MIN" ~from:testlib (void @-> returning int16_t) in let _INT16_MIN = retrieve_INT16_MIN () in let retrieve_INT16_MAX = Foreign.foreign "retrieve_INT16_MAX" ~from:testlib (void @-> returning int16_t) 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 retrieve_INT32_MIN = Foreign.foreign "retrieve_INT32_MIN" ~from:testlib (void @-> returning int32_t) in let _INT32_MIN = retrieve_INT32_MIN () in let retrieve_INT32_MAX = Foreign.foreign "retrieve_INT32_MAX" ~from:testlib (void @-> returning int32_t) 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 retrieve_INT64_MIN = Foreign.foreign "retrieve_INT64_MIN" ~from:testlib (void @-> returning int64_t) in let _INT64_MIN = retrieve_INT64_MIN () in let retrieve_INT64_MAX = Foreign.foreign "retrieve_INT64_MAX" ~from:testlib (void @-> returning int64_t) 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 retrieve_UINT8_MAX = Foreign.foreign "retrieve_UINT8_MAX" ~from:testlib (void @-> returning uint8_t) in 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 retrieve_UINT16_MAX = Foreign.foreign "retrieve_UINT16_MAX" ~from:testlib (void @-> returning uint16_t) in 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 retrieve_UINT32_MAX = Foreign.foreign "retrieve_UINT32_MAX" ~from:testlib (void @-> returning uint32_t) in 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 retrieve_UINT64_MAX = Foreign.foreign "retrieve_UINT64_MAX" ~from:testlib (void @-> returning uint64_t) in 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 retrieve_SIZE_MAX = Foreign.foreign "retrieve_SIZE_MAX" ~from:testlib (void @-> returning size_t) in 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)); (* nativeint *) let min_name, max_name = match sizeof (ptr void) with | 4 -> "retrieve_INT32_MIN", "retrieve_INT32_MAX" | 8 -> "retrieve_INT64_MIN", "retrieve_INT64_MAX" | _ -> assert false in let retrieve_nINT_MIN = Foreign.foreign min_name ~from:testlib (void @-> returning nativeint) in let _nINT_MIN = retrieve_nINT_MIN () in let retrieve_nINT_MAX = Foreign.foreign max_name ~from:testlib (void @-> returning nativeint) in let _nINT_MAX = retrieve_nINT_MAX () in assert_equal (string_of nativeint _nINT_MIN) (Nativeint.to_string _nINT_MIN); assert_equal (string_of nativeint 0n) (Nativeint.to_string 0n); assert_equal (string_of nativeint (-5n)) (Nativeint.to_string (-5n)); assert_equal (string_of nativeint 14n) (Nativeint.to_string 14n); assert_equal (string_of nativeint _nINT_MAX) (Nativeint.to_string _nINT_MAX); (* float *) let retrieve_FLT_MIN = Foreign.foreign "retrieve_FLT_MIN" ~from:testlib (void @-> returning float) in let _FLT_MIN = retrieve_FLT_MIN () in let retrieve_FLT_MAX = Foreign.foreign "retrieve_FLT_MAX" ~from:testlib (void @-> returning float) in let _FLT_MAX = retrieve_FLT_MAX () in assert_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); assert_equal (string_of float _FLT_MAX) (string_of_float _FLT_MAX); (* double *) let retrieve_DBL_MIN = Foreign.foreign "retrieve_DBL_MIN" ~from:testlib (void @-> returning double) in let _DBL_MIN = retrieve_DBL_MIN () in let retrieve_DBL_MAX = Foreign.foreign "retrieve_DBL_MAX" ~from:testlib (void @-> returning double) 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)); assert_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); () (* 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 = Array.make int 10 in let p = Array.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 (Array.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 (Array.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 = Array.of_list int [-1; 0; 1] in let arrarr = Array.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)) let suite = "Value printing tests" >::: ["printing atomic values" >:: test_atomic_printing; "printing pointers" >:: test_pointer_printing; "printing structs" >:: test_struct_printing; "printing unions" >:: test_union_printing; "printing arrays" >:: test_array_printing; ] let _ = run_test_tt_main suite ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-views/000077500000000000000000000000001230210355500217625ustar00rootroot00000000000000ocaml-ctypes-ocaml-ctypes-0.2.3/tests/test-views/test_views.ml000066400000000000000000000117401230210355500245130ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit open Ctypes let testlib = Dl.(dlopen ~filename:"clib/test_functions.so" ~flags:[RTLD_NOW]) (* 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 concat = Foreign.foreign "concat_strings" ~from:testlib (ptr string @-> int @-> ptr char @-> returning void) in let l = ["the "; "quick "; "brown "; "fox "; "etc. "; "etc. "; ] in let arr = Array.of_list string l in let outlen = List.fold_left (fun a s -> String.length s + a) 1 l in let buf = Array.make char outlen in let () = Array.(concat (start arr) (length arr) (start buf)) in let buf_addr = allocate (ptr char) (Array.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 () = let charish = view ~read:Char.chr ~write:Char.code int in let toupper = Foreign.foreign "toupper" (charish @-> returning charish) in 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 () = let nullable_intptr = Foreign.funptr_opt (int @-> int @-> returning int) in let returning_funptr = Foreign.foreign "returning_funptr" ~from:testlib (int @-> returning nullable_intptr) and accepting_possibly_null_funptr = Foreign.foreign "accepting_possibly_null_funptr" ~from:testlib (nullable_intptr @-> int @-> int @-> returning int) in 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 Pervasives.(+)) 2 3); assert_equal ~msg:"passing non-null function pointer obtained from C" 6 (accepting_possibly_null_funptr (returning_funptr 1) 2 3); 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 () let suite = "View tests" >::: ["passing array of strings" >:: test_passing_string_array; "custom views" >:: test_passing_chars_as_ints; "nullable function pointers" >:: test_nullable_function_pointer_view; "nullable pointers" >:: test_nullable_pointer_view; "polar form view" >:: test_polar_form_view; ] let _ = run_test_tt_main suite