pax_global_header00006660000000000000000000000064127414313760014522gustar00rootroot0000000000000052 comment=d8152372f2f5131a755a6a2a5349f71456976a0d ocaml-ctypes-0.7.0/000077500000000000000000000000001274143137600141265ustar00rootroot00000000000000ocaml-ctypes-0.7.0/.depend000066400000000000000000000631701274143137600153750ustar00rootroot00000000000000_build/src/cstubs/cstubs_emit_c.cmo : _build/src/ctypes/ctypes_type_printing.cmi \ _build/src/ctypes/ctypes_static.cmi _build/src/ctypes/ctypes.cmi \ _build/src/cstubs/cstubs_c_language.cmo _build/src/cstubs/cstubs_emit_c.cmx : _build/src/ctypes/ctypes_type_printing.cmx \ _build/src/ctypes/ctypes_static.cmx _build/src/ctypes/ctypes.cmx \ _build/src/cstubs/cstubs_c_language.cmx _build/src/cstubs/cstubs.cmi : _build/src/ctypes/ctypes_types.cmi _build/src/ctypes/ctypes.cmi _build/src/cstubs/cstubs_analysis.cmo : _build/src/ctypes/unsigned.cmi \ _build/src/ctypes/signed.cmi _build/src/ctypes/ctypes_static.cmi \ _build/src/ctypes/ctypes_primitive_types.cmi _build/src/ctypes/ctypes_bigarray.cmi \ _build/src/cstubs/cstubs_analysis.cmi _build/src/cstubs/cstubs_analysis.cmx : _build/src/ctypes/unsigned.cmx \ _build/src/ctypes/signed.cmx _build/src/ctypes/ctypes_static.cmx \ _build/src/ctypes/ctypes_primitive_types.cmx _build/src/ctypes/ctypes_bigarray.cmx \ _build/src/cstubs/cstubs_analysis.cmi _build/src/cstubs/cstubs_internals.cmo : _build/src/ctypes/unsigned.cmi \ _build/src/ctypes/ctypes_static.cmi _build/src/ctypes/ctypes_ptr.cmo \ _build/src/ctypes/ctypes_primitive_types.cmi _build/src/ctypes/ctypes_memory_stubs.cmo \ _build/src/ctypes/ctypes.cmi _build/src/cstubs/cstubs_internals.cmi _build/src/cstubs/cstubs_internals.cmx : _build/src/ctypes/unsigned.cmx \ _build/src/ctypes/ctypes_static.cmx _build/src/ctypes/ctypes_ptr.cmx \ _build/src/ctypes/ctypes_primitive_types.cmx _build/src/ctypes/ctypes_memory_stubs.cmx \ _build/src/ctypes/ctypes.cmx _build/src/cstubs/cstubs_internals.cmi _build/src/cstubs/cstubs_structs.cmo : _build/src/ctypes/ctypes_types.cmi \ _build/src/ctypes/ctypes_static.cmi _build/src/ctypes/ctypes_primitives.cmo \ _build/src/ctypes/ctypes_primitive_types.cmi _build/src/ctypes/ctypes_path.cmi \ _build/src/ctypes/ctypes.cmi \ _build/src/cstubs/cstubs_public_name.cmi _build/src/cstubs/cstubs_c_language.cmo \ _build/src/cstubs/cstubs_structs.cmi _build/src/cstubs/cstubs_structs.cmx : _build/src/ctypes/ctypes_types.cmi \ _build/src/ctypes/ctypes_static.cmx _build/src/ctypes/ctypes_primitives.cmx \ _build/src/ctypes/ctypes_primitive_types.cmx _build/src/ctypes/ctypes_path.cmx \ _build/src/ctypes/ctypes.cmx \ _build/src/cstubs/cstubs_public_name.cmx _build/src/cstubs/cstubs_c_language.cmx \ _build/src/cstubs/cstubs_structs.cmi _build/src/cstubs/cstubs_internals.cmi : _build/src/ctypes/unsigned.cmi \ _build/src/ctypes/signed.cmi _build/src/ctypes/ctypes_static.cmi \ _build/src/ctypes/ctypes_ptr.cmo _build/src/ctypes/ctypes_primitive_types.cmi \ _build/src/ctypes/ctypes_memory_stubs.cmo _build/src/ctypes/ctypes_bigarray.cmi \ _build/src/ctypes/ctypes.cmi _build/src/cstubs/cstubs_generate_c.cmo : _build/src/ctypes/ctypes_static.cmi \ _build/src/ctypes/ctypes_primitive_types.cmi _build/src/ctypes/ctypes.cmi \ _build/src/cstubs/cstubs_emit_c.cmo _build/src/cstubs/cstubs_c_language.cmo \ _build/src/cstubs/cstubs_generate_c.cmi _build/src/cstubs/cstubs_generate_c.cmx : _build/src/ctypes/ctypes_static.cmx \ _build/src/ctypes/ctypes_primitive_types.cmx _build/src/ctypes/ctypes.cmx \ _build/src/cstubs/cstubs_emit_c.cmx _build/src/cstubs/cstubs_c_language.cmx \ _build/src/cstubs/cstubs_generate_c.cmi _build/src/cstubs/cstubs_generate_c.cmi : _build/src/ctypes/ctypes.cmi _build/src/cstubs/cstubs_generate_ml.cmi : _build/src/ctypes/ctypes.cmi _build/src/cstubs/cstubs_errors.cmi : _build/src/cstubs/cstubs_c_language.cmo : _build/src/ctypes/ctypes_static.cmi \ _build/src/ctypes/ctypes.cmi _build/src/cstubs/cstubs_errors.cmi _build/src/cstubs/cstubs_c_language.cmx : _build/src/ctypes/ctypes_static.cmx \ _build/src/ctypes/ctypes.cmx _build/src/cstubs/cstubs_errors.cmx _build/src/cstubs/cstubs_inverted.cmi : _build/src/ctypes/ctypes.cmi _build/src/cstubs/cstubs.cmo : _build/src/ctypes/ctypes.cmi _build/src/cstubs/cstubs_structs.cmi \ _build/src/cstubs/cstubs_generate_ml.cmi _build/src/cstubs/cstubs_generate_c.cmi \ _build/src/cstubs/cstubs.cmi _build/src/cstubs/cstubs.cmx : _build/src/ctypes/ctypes.cmx _build/src/cstubs/cstubs_structs.cmx \ _build/src/cstubs/cstubs_generate_ml.cmx _build/src/cstubs/cstubs_generate_c.cmx \ _build/src/cstubs/cstubs.cmi _build/src/cstubs/cstubs_public_name.cmo : _build/src/ctypes/ctypes_static.cmi \ _build/src/ctypes/ctypes_primitive_types.cmi _build/src/ctypes/ctypes_path.cmi \ _build/src/cstubs/cstubs_public_name.cmi _build/src/cstubs/cstubs_public_name.cmx : _build/src/ctypes/ctypes_static.cmx \ _build/src/ctypes/ctypes_primitive_types.cmx _build/src/ctypes/ctypes_path.cmx \ _build/src/cstubs/cstubs_public_name.cmi _build/src/cstubs/cstubs_errors.cmo : _build/src/cstubs/cstubs_errors.cmi _build/src/cstubs/cstubs_errors.cmx : _build/src/cstubs/cstubs_errors.cmi _build/src/cstubs/cstubs_inverted.cmo : _build/src/ctypes/ctypes_type_printing.cmi \ _build/src/ctypes/ctypes.cmi _build/src/cstubs/cstubs_generate_ml.cmi \ _build/src/cstubs/cstubs_generate_c.cmi _build/src/cstubs/cstubs_inverted.cmi _build/src/cstubs/cstubs_inverted.cmx : _build/src/ctypes/ctypes_type_printing.cmx \ _build/src/ctypes/ctypes.cmx _build/src/cstubs/cstubs_generate_ml.cmx \ _build/src/cstubs/cstubs_generate_c.cmx _build/src/cstubs/cstubs_inverted.cmi _build/src/cstubs/cstubs_generate_ml.cmo : _build/src/ctypes/ctypes_static.cmi \ _build/src/ctypes/ctypes_primitive_types.cmi _build/src/ctypes/ctypes_path.cmi \ _build/src/ctypes/ctypes.cmi _build/src/cstubs/cstubs_public_name.cmi \ _build/src/cstubs/cstubs_errors.cmi _build/src/cstubs/cstubs_analysis.cmi \ _build/src/cstubs/cstubs_generate_ml.cmi _build/src/cstubs/cstubs_generate_ml.cmx : _build/src/ctypes/ctypes_static.cmx \ _build/src/ctypes/ctypes_primitive_types.cmx _build/src/ctypes/ctypes_path.cmx \ _build/src/ctypes/ctypes.cmx _build/src/cstubs/cstubs_public_name.cmx \ _build/src/cstubs/cstubs_errors.cmx _build/src/cstubs/cstubs_analysis.cmx \ _build/src/cstubs/cstubs_generate_ml.cmi _build/src/cstubs/cstubs_analysis.cmi : _build/src/ctypes/ctypes_static.cmi _build/src/cstubs/cstubs_structs.cmi : _build/src/ctypes/ctypes_types.cmi _build/src/cstubs/cstubs_public_name.cmi : _build/src/ctypes/ctypes_primitive_types.cmi \ _build/src/ctypes/ctypes_path.cmi _build/src/libffi-abigen/libffi_abigen.cmo : _build/src/libffi-abigen/libffi_abigen.cmx : _build/src/discover/discover.cmo : _build/src/discover/discover.cmx : _build/src/discover/commands.cmo : _build/src/discover/commands.cmi _build/src/discover/commands.cmx : _build/src/discover/commands.cmi _build/src/discover/commands.cmi : _build/src/ctypes/ctypes_value_printing.cmo : \ _build/src/ctypes/ctypes_value_printing_stubs.cmo \ _build/src/ctypes/ctypes_type_printing.cmi _build/src/ctypes/ctypes_static.cmi \ _build/src/ctypes/ctypes_ptr.cmo _build/src/ctypes/ctypes_memory.cmo _build/src/ctypes/ctypes_value_printing.cmx : \ _build/src/ctypes/ctypes_value_printing_stubs.cmx \ _build/src/ctypes/ctypes_type_printing.cmx _build/src/ctypes/ctypes_static.cmx \ _build/src/ctypes/ctypes_ptr.cmx _build/src/ctypes/ctypes_memory.cmx _build/src/ctypes/ctypes_types.cmi : _build/src/ctypes/unsigned.cmi _build/src/ctypes/signed.cmi \ _build/src/ctypes/ctypes_static.cmi _build/src/ctypes/ctypes_std_view_stubs.cmo : _build/src/ctypes/ctypes_static.cmi \ _build/src/ctypes/ctypes_ptr.cmo _build/src/ctypes/ctypes_memory_stubs.cmo _build/src/ctypes/ctypes_std_view_stubs.cmx : _build/src/ctypes/ctypes_static.cmx \ _build/src/ctypes/ctypes_ptr.cmx _build/src/ctypes/ctypes_memory_stubs.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/ctypes_path.cmi : _build/src/ctypes/ctypes_primitive_types.cmi : _build/src/ctypes/unsigned.cmi \ _build/src/ctypes/signed.cmi _build/src/ctypes/ctypes_coerce.cmo : _build/src/ctypes/ctypes_static.cmi \ _build/src/ctypes/ctypes_ptr.cmo _build/src/ctypes/ctypes_primitive_types.cmi _build/src/ctypes/ctypes_coerce.cmx : _build/src/ctypes/ctypes_static.cmx \ _build/src/ctypes/ctypes_ptr.cmx _build/src/ctypes/ctypes_primitive_types.cmx _build/src/ctypes/ctypes_ptr.cmo : _build/src/ctypes/signed.cmi _build/src/ctypes/ctypes_ptr.cmx : _build/src/ctypes/signed.cmx _build/src/ctypes/ctypes_primitives.cmo : _build/src/ctypes/ctypes_primitive_types.cmi _build/src/ctypes/ctypes_primitives.cmx : _build/src/ctypes/ctypes_primitive_types.cmx _build/src/ctypes/posixTypes.cmi : _build/src/ctypes/unsigned.cmi _build/src/ctypes/signed.cmi \ _build/src/ctypes/ctypes.cmi _build/src/ctypes/ctypes_structs.cmo : _build/src/ctypes/ctypes_static.cmi \ _build/src/ctypes/ctypes_structs.cmi _build/src/ctypes/ctypes_structs.cmx : _build/src/ctypes/ctypes_static.cmx \ _build/src/ctypes/ctypes_structs.cmi _build/src/ctypes/ctypes_static.cmi : _build/src/ctypes/unsigned.cmi _build/src/ctypes/signed.cmi \ _build/src/ctypes/ctypes_ptr.cmo _build/src/ctypes/ctypes_primitive_types.cmi \ _build/src/ctypes/ctypes_bigarray.cmi _build/src/ctypes/coerce.cmi : _build/src/ctypes/ctypes_static.cmi _build/src/ctypes/ctypes_primitive_types.cmo : _build/src/ctypes/unsigned.cmi \ _build/src/ctypes/signed.cmi _build/src/ctypes/ctypes_primitive_types.cmi _build/src/ctypes/ctypes_primitive_types.cmx : _build/src/ctypes/unsigned.cmx \ _build/src/ctypes/signed.cmx _build/src/ctypes/ctypes_primitive_types.cmi _build/src/ctypes/ctypes_static.cmo : _build/src/ctypes/ctypes_ptr.cmo \ _build/src/ctypes/ctypes_primitives.cmo _build/src/ctypes/ctypes_primitive_types.cmi \ _build/src/ctypes/ctypes_bigarray.cmi _build/src/ctypes/ctypes_static.cmi _build/src/ctypes/ctypes_static.cmx : _build/src/ctypes/ctypes_ptr.cmx \ _build/src/ctypes/ctypes_primitives.cmx _build/src/ctypes/ctypes_primitive_types.cmx \ _build/src/ctypes/ctypes_bigarray.cmx _build/src/ctypes/ctypes_static.cmi _build/src/ctypes/ctypes.cmi : _build/src/ctypes/ctypes_types.cmi \ _build/src/ctypes/ctypes_static.cmi _build/src/ctypes/ctypes_path.cmo : _build/src/ctypes/ctypes_path.cmi _build/src/ctypes/ctypes_path.cmx : _build/src/ctypes/ctypes_path.cmi _build/src/ctypes/ctypes_type_printing.cmi : _build/src/ctypes/ctypes_static.cmi _build/src/ctypes/unsigned.cmo : _build/src/ctypes/unsigned.cmi _build/src/ctypes/unsigned.cmx : _build/src/ctypes/unsigned.cmi _build/src/ctypes/ctypes_bigarray_stubs.cmo : _build/src/ctypes/ctypes_ptr.cmo _build/src/ctypes/ctypes_bigarray_stubs.cmx : _build/src/ctypes/ctypes_ptr.cmx _build/src/ctypes/ctypes_structs_computed.cmo : _build/src/ctypes/ctypes_static.cmi \ _build/src/ctypes/ctypes_structs_computed.cmi _build/src/ctypes/ctypes_structs_computed.cmx : _build/src/ctypes/ctypes_static.cmx \ _build/src/ctypes/ctypes_structs_computed.cmi _build/src/ctypes/ctypes_bigarray.cmo : _build/src/ctypes/ctypes_ptr.cmo \ _build/src/ctypes/ctypes_primitives.cmo _build/src/ctypes/ctypes_primitive_types.cmi \ _build/src/ctypes/ctypes_path.cmi _build/src/ctypes/ctypes_bigarray_stubs.cmo \ _build/src/ctypes/ctypes_bigarray.cmi _build/src/ctypes/ctypes_bigarray.cmx : _build/src/ctypes/ctypes_ptr.cmx \ _build/src/ctypes/ctypes_primitives.cmx _build/src/ctypes/ctypes_primitive_types.cmx \ _build/src/ctypes/ctypes_path.cmx _build/src/ctypes/ctypes_bigarray_stubs.cmx \ _build/src/ctypes/ctypes_bigarray.cmi _build/src/ctypes/unsigned.cmi : _build/src/ctypes/ctypes_memory_stubs.cmo : _build/src/ctypes/ctypes_ptr.cmo \ _build/src/ctypes/ctypes_primitive_types.cmi _build/src/ctypes/ctypes_memory_stubs.cmx : _build/src/ctypes/ctypes_ptr.cmx \ _build/src/ctypes/ctypes_primitive_types.cmx _build/src/ctypes/signed.cmi : _build/src/ctypes/unsigned.cmi _build/src/ctypes/ctypes_bigarray.cmi : _build/src/ctypes/ctypes_ptr.cmo \ _build/src/ctypes/ctypes_primitive_types.cmi _build/src/ctypes/ctypes_path.cmi _build/src/ctypes/posixTypes.cmo : _build/src/ctypes/unsigned.cmi \ _build/src/ctypes/ctypes_std_views.cmo _build/src/ctypes/ctypes_static.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_std_views.cmx _build/src/ctypes/ctypes_static.cmx \ _build/src/ctypes/ctypes.cmx _build/src/ctypes/posixTypes.cmi _build/src/ctypes/ctypes_memory.cmo : _build/src/ctypes/ctypes_static.cmi \ _build/src/ctypes/ctypes_roots_stubs.cmo _build/src/ctypes/ctypes_ptr.cmo \ _build/src/ctypes/ctypes_memory_stubs.cmo _build/src/ctypes/ctypes_bigarray.cmi _build/src/ctypes/ctypes_memory.cmx : _build/src/ctypes/ctypes_static.cmx \ _build/src/ctypes/ctypes_roots_stubs.cmx _build/src/ctypes/ctypes_ptr.cmx \ _build/src/ctypes/ctypes_memory_stubs.cmx _build/src/ctypes/ctypes_bigarray.cmx _build/src/ctypes/ctypes.cmo : _build/src/ctypes/ctypes_value_printing.cmo \ _build/src/ctypes/ctypes_type_printing.cmi \ _build/src/ctypes/ctypes_structs_computed.cmi _build/src/ctypes/ctypes_std_views.cmo \ _build/src/ctypes/ctypes_static.cmi _build/src/ctypes/ctypes_memory.cmo \ _build/src/ctypes/ctypes_coerce.cmo _build/src/ctypes/ctypes.cmi _build/src/ctypes/ctypes.cmx : _build/src/ctypes/ctypes_value_printing.cmx \ _build/src/ctypes/ctypes_type_printing.cmx \ _build/src/ctypes/ctypes_structs_computed.cmx _build/src/ctypes/ctypes_std_views.cmx \ _build/src/ctypes/ctypes_static.cmx _build/src/ctypes/ctypes_memory.cmx \ _build/src/ctypes/ctypes_coerce.cmx _build/src/ctypes/ctypes.cmi _build/src/ctypes/ctypes_structs_computed.cmi : _build/src/ctypes/ctypes_structs.cmi \ _build/src/ctypes/ctypes_static.cmi _build/src/ctypes/ctypes_type_printing.cmo : _build/src/ctypes/ctypes_static.cmi \ _build/src/ctypes/ctypes_primitives.cmo \ _build/src/ctypes/ctypes_bigarray.cmi _build/src/ctypes/ctypes_type_printing.cmi _build/src/ctypes/ctypes_type_printing.cmx : _build/src/ctypes/ctypes_static.cmx \ _build/src/ctypes/ctypes_primitives.cmx \ _build/src/ctypes/ctypes_bigarray.cmx _build/src/ctypes/ctypes_type_printing.cmi _build/src/ctypes/ctypes_std_views.cmo : _build/src/ctypes/unsigned.cmi \ _build/src/ctypes/signed.cmi _build/src/ctypes/ctypes_std_view_stubs.cmo \ _build/src/ctypes/ctypes_static.cmi _build/src/ctypes/ctypes_ptr.cmo \ _build/src/ctypes/ctypes_memory_stubs.cmo _build/src/ctypes/ctypes_memory.cmo \ _build/src/ctypes/ctypes_coerce.cmo _build/src/ctypes/ctypes_std_views.cmx : _build/src/ctypes/unsigned.cmx \ _build/src/ctypes/signed.cmx _build/src/ctypes/ctypes_std_view_stubs.cmx \ _build/src/ctypes/ctypes_static.cmx _build/src/ctypes/ctypes_ptr.cmx \ _build/src/ctypes/ctypes_memory_stubs.cmx _build/src/ctypes/ctypes_memory.cmx \ _build/src/ctypes/ctypes_coerce.cmx _build/src/ctypes/ctypes_structs.cmi : _build/src/ctypes/ctypes_static.cmi _build/src/ctypes/ctypes_value_printing_stubs.cmo : _build/src/ctypes/ctypes_ptr.cmo \ _build/src/ctypes/ctypes_primitive_types.cmi _build/src/ctypes/ctypes_value_printing_stubs.cmx : _build/src/ctypes/ctypes_ptr.cmx \ _build/src/ctypes/ctypes_primitive_types.cmx _build/src/ctypes-top/install_ctypes_printers.cmo : _build/src/ctypes-top/install_ctypes_printers.cmx : _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-top/ctypes_printers.cmo : _build/src/ctypes/unsigned.cmi \ _build/src/ctypes/signed.cmi _build/src/ctypes/posixTypes.cmi \ _build/src/ctypes/ctypes_static.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_static.cmx _build/src/ctypes/ctypes.cmx \ _build/src/ctypes-top/ctypes_printers.cmi _build/src/ctypes-foreign-threaded/foreign.cmi : \ _build/src/ctypes-foreign-base/libffi_abi.cmi _build/src/ctypes-foreign-base/dl.cmi \ _build/src/ctypes/ctypes.cmi _build/src/ctypes-foreign-threaded/foreign.cmo : \ _build/src/ctypes-foreign-base/ctypes_foreign_basis.cmo \ _build/src/ctypes-foreign-base/ctypes_closure_properties.cmi \ _build/src/ctypes-foreign-threaded/foreign.cmi _build/src/ctypes-foreign-threaded/foreign.cmx : \ _build/src/ctypes-foreign-base/ctypes_foreign_basis.cmx \ _build/src/ctypes-foreign-base/ctypes_closure_properties.cmx \ _build/src/ctypes-foreign-threaded/foreign.cmi _build/src/configure/make_primitive_details.cmo : _build/src/configure/make_primitive_details.cmx : _build/src/ctypes-foreign-base/ctypes_ffi_stubs.cmo : _build/src/ctypes/ctypes_static.cmi \ _build/src/ctypes/ctypes_ptr.cmo _build/src/ctypes/ctypes_primitive_types.cmi _build/src/ctypes-foreign-base/ctypes_ffi_stubs.cmx : _build/src/ctypes/ctypes_static.cmx \ _build/src/ctypes/ctypes_ptr.cmx _build/src/ctypes/ctypes_primitive_types.cmx _build/src/ctypes-foreign-base/dl.cmi : _build/src/ctypes/ctypes_ptr.cmo _build/src/ctypes-foreign-base/ctypes_weak_ref.cmo : \ _build/src/ctypes-foreign-base/ctypes_weak_ref.cmi _build/src/ctypes-foreign-base/ctypes_weak_ref.cmx : \ _build/src/ctypes-foreign-base/ctypes_weak_ref.cmi _build/src/ctypes-foreign-base/libffi_abi.cmo : _build/src/ctypes/ctypes.cmi \ _build/src/ctypes-foreign-base/libffi_abi.cmi _build/src/ctypes-foreign-base/libffi_abi.cmx : _build/src/ctypes/ctypes.cmx \ _build/src/ctypes-foreign-base/libffi_abi.cmi _build/src/ctypes-foreign-base/dl.cmo : _build/src/ctypes/ctypes_ptr.cmo \ _build/src/ctypes-foreign-base/dl.cmi _build/src/ctypes-foreign-base/dl.cmx : _build/src/ctypes/ctypes_ptr.cmx \ _build/src/ctypes-foreign-base/dl.cmi _build/src/ctypes-foreign-base/ctypes_foreign_basis.cmo : \ _build/src/ctypes-foreign-base/libffi_abi.cmi _build/src/ctypes-foreign-base/dl.cmi \ _build/src/ctypes/ctypes_std_views.cmo _build/src/ctypes/ctypes_static.cmi \ _build/src/ctypes/ctypes_ptr.cmo _build/src/ctypes-foreign-base/ctypes_ffi_stubs.cmo \ _build/src/ctypes-foreign-base/ctypes_ffi.cmi _build/src/ctypes/ctypes_coerce.cmo \ _build/src/ctypes/ctypes.cmi _build/src/ctypes-foreign-base/ctypes_foreign_basis.cmx : \ _build/src/ctypes-foreign-base/libffi_abi.cmx _build/src/ctypes-foreign-base/dl.cmx \ _build/src/ctypes/ctypes_std_views.cmx _build/src/ctypes/ctypes_static.cmx \ _build/src/ctypes/ctypes_ptr.cmx _build/src/ctypes-foreign-base/ctypes_ffi_stubs.cmx \ _build/src/ctypes-foreign-base/ctypes_ffi.cmx _build/src/ctypes/ctypes_coerce.cmx \ _build/src/ctypes/ctypes.cmx _build/src/ctypes-foreign-base/libffi_abi.cmi : _build/src/ctypes-foreign-base/ctypes_ffi.cmi : \ _build/src/ctypes-foreign-base/libffi_abi.cmi _build/src/ctypes/ctypes_static.cmi _build/src/ctypes-foreign-base/ctypes_weak_ref.cmi : _build/src/ctypes-foreign-base/ctypes_ffi.cmo : \ _build/src/ctypes-foreign-base/libffi_abi.cmi \ _build/src/ctypes-foreign-base/ctypes_weak_ref.cmi \ _build/src/ctypes/ctypes_type_printing.cmi _build/src/ctypes/ctypes_static.cmi \ _build/src/ctypes/ctypes_ptr.cmo _build/src/ctypes/ctypes_primitives.cmo \ _build/src/ctypes/ctypes_primitive_types.cmi _build/src/ctypes/ctypes_memory.cmo \ _build/src/ctypes-foreign-base/ctypes_ffi_stubs.cmo \ _build/src/ctypes-foreign-base/ctypes_ffi.cmi _build/src/ctypes-foreign-base/ctypes_ffi.cmx : \ _build/src/ctypes-foreign-base/libffi_abi.cmx \ _build/src/ctypes-foreign-base/ctypes_weak_ref.cmx \ _build/src/ctypes/ctypes_type_printing.cmx _build/src/ctypes/ctypes_static.cmx \ _build/src/ctypes/ctypes_ptr.cmx _build/src/ctypes/ctypes_primitives.cmx \ _build/src/ctypes/ctypes_primitive_types.cmx _build/src/ctypes/ctypes_memory.cmx \ _build/src/ctypes-foreign-base/ctypes_ffi_stubs.cmx \ _build/src/ctypes-foreign-base/ctypes_ffi.cmi _build/src/ctypes-foreign-base/ctypes_closure_properties.cmo : \ _build/src/ctypes-foreign-base/ctypes_closure_properties.cmi _build/src/ctypes-foreign-base/ctypes_closure_properties.cmx : \ _build/src/ctypes-foreign-base/ctypes_closure_properties.cmi _build/src/ctypes-foreign-base/ctypes_closure_properties.cmi : _build/src/ctypes-foreign-unthreaded/foreign.cmi : \ _build/src/ctypes-foreign-base/libffi_abi.cmi _build/src/ctypes-foreign-base/dl.cmi \ _build/src/ctypes/ctypes.cmi _build/src/ctypes-foreign-unthreaded/foreign.cmo : \ _build/src/ctypes-foreign-unthreaded/ctypes_gc_mutex.cmo \ _build/src/ctypes-foreign-base/ctypes_foreign_basis.cmo \ _build/src/ctypes-foreign-base/ctypes_closure_properties.cmi \ _build/src/ctypes-foreign-unthreaded/foreign.cmi _build/src/ctypes-foreign-unthreaded/foreign.cmx : \ _build/src/ctypes-foreign-unthreaded/ctypes_gc_mutex.cmx \ _build/src/ctypes-foreign-base/ctypes_foreign_basis.cmx \ _build/src/ctypes-foreign-base/ctypes_closure_properties.cmx \ _build/src/ctypes-foreign-unthreaded/foreign.cmi _build/src/ctypes-foreign-unthreaded/ctypes_gc_mutex.cmo : _build/src/ctypes-foreign-unthreaded/ctypes_gc_mutex.cmx : _build/examples/date/stub-generation/date_cmd.cmo : _build/src/ctypes/posixTypes.cmi \ _build/src/ctypes/ctypes.cmi _build/examples/date/stub-generation/date_cmd.cmx : _build/src/ctypes/posixTypes.cmx \ _build/src/ctypes/ctypes.cmx _build/examples/date/stub-generation/bindings/date_stubs.cmo : \ _build/src/ctypes/posixTypes.cmi _build/src/ctypes/ctypes.cmi _build/examples/date/stub-generation/bindings/date_stubs.cmx : \ _build/src/ctypes/posixTypes.cmx _build/src/ctypes/ctypes.cmx _build/examples/date/stub-generation/stub-generator/date_stub_generator.cmo : \ _build/src/cstubs/cstubs.cmi _build/examples/date/stub-generation/stub-generator/date_stub_generator.cmx : \ _build/src/cstubs/cstubs.cmx _build/examples/date/foreign/date.cmi : _build/src/ctypes/posixTypes.cmi \ _build/src/ctypes/ctypes.cmi _build/examples/date/foreign/date.cmo : _build/src/ctypes/posixTypes.cmi \ _build/src/ctypes-foreign-threaded/foreign.cmi _build/src/ctypes/ctypes.cmi \ _build/examples/date/foreign/date.cmi _build/examples/date/foreign/date.cmx : _build/src/ctypes/posixTypes.cmx \ _build/src/ctypes-foreign-threaded/foreign.cmx _build/src/ctypes/ctypes.cmx \ _build/examples/date/foreign/date.cmi _build/examples/fts/stub-generation/bindings/fts_types.cmo : \ _build/src/ctypes/unsigned.cmi _build/src/ctypes/posixTypes.cmi \ _build/src/ctypes-foreign-threaded/foreign.cmi _build/src/ctypes/ctypes_coerce.cmo \ _build/src/ctypes/ctypes.cmi _build/examples/fts/stub-generation/bindings/fts_types.cmx : \ _build/src/ctypes/unsigned.cmx _build/src/ctypes/posixTypes.cmx \ _build/src/ctypes-foreign-threaded/foreign.cmx _build/src/ctypes/ctypes_coerce.cmx \ _build/src/ctypes/ctypes.cmx _build/examples/fts/stub-generation/bindings/fts_bindings.cmo : \ _build/src/ctypes/ctypes.cmi _build/src/cstubs/cstubs.cmi _build/examples/fts/stub-generation/bindings/fts_bindings.cmx : \ _build/src/ctypes/ctypes.cmx _build/src/cstubs/cstubs.cmx _build/examples/fts/stub-generation/bindings/fts.cmi : _build/src/ctypes/ctypes.cmi _build/examples/fts/stub-generation/fts_if.cmo : _build/src/ctypes/ctypes.cmi _build/examples/fts/stub-generation/fts_if.cmx : _build/src/ctypes/ctypes.cmx _build/examples/fts/stub-generation/fts_cmd.cmo : _build/src/ctypes/ctypes.cmi _build/examples/fts/stub-generation/fts_cmd.cmx : _build/src/ctypes/ctypes.cmx _build/examples/fts/stub-generation/stub-generator/fts_stub_generator.cmo : \ _build/src/cstubs/cstubs.cmi _build/examples/fts/stub-generation/stub-generator/fts_stub_generator.cmx : \ _build/src/cstubs/cstubs.cmx _build/examples/fts/foreign/fts.cmo : _build/src/ctypes/unsigned.cmi \ _build/src/ctypes/posixTypes.cmi _build/src/ctypes-foreign-threaded/foreign.cmi \ _build/src/ctypes/ctypes_coerce.cmo _build/src/ctypes/ctypes.cmi \ _build/examples/fts/foreign/fts.cmi _build/examples/fts/foreign/fts.cmx : _build/src/ctypes/unsigned.cmx \ _build/src/ctypes/posixTypes.cmx _build/src/ctypes-foreign-threaded/foreign.cmx \ _build/src/ctypes/ctypes_coerce.cmx _build/src/ctypes/ctypes.cmx \ _build/examples/fts/foreign/fts.cmi _build/examples/fts/foreign/fts.cmi : _build/src/ctypes/posixTypes.cmi \ _build/src/ctypes/ctypes.cmi _build/examples/fts/foreign/fts_cmd.cmo : _build/src/ctypes/ctypes.cmi _build/examples/fts/foreign/fts_cmd.cmx : _build/src/ctypes/ctypes.cmx _build/examples/ncurses/stub-generation/bindings/ncurses_bindings.cmo : \ _build/src/ctypes/ctypes.cmi _build/src/cstubs/cstubs.cmi _build/examples/ncurses/stub-generation/bindings/ncurses_bindings.cmx : \ _build/src/ctypes/ctypes.cmx _build/src/cstubs/cstubs.cmx _build/examples/ncurses/stub-generation/ncurses_stub_cmd.cmo : _build/examples/ncurses/stub-generation/ncurses_stub_cmd.cmx : _build/examples/ncurses/foreign/ncurses_cmd.cmo : _build/examples/ncurses/foreign/ncurses_cmd.cmx : _build/examples/ncurses/foreign/ncurses.cmo : \ _build/src/ctypes-foreign-threaded/foreign.cmi _build/src/ctypes/ctypes.cmi \ _build/examples/ncurses/foreign/ncurses.cmi _build/examples/ncurses/foreign/ncurses.cmx : \ _build/src/ctypes-foreign-threaded/foreign.cmx _build/src/ctypes/ctypes.cmx \ _build/examples/ncurses/foreign/ncurses.cmi _build/examples/ncurses/foreign/ncurses.cmi : _build/examples/sigset/sigset.cmi : _build/src/ctypes/posixTypes.cmi _build/src/ctypes/ctypes.cmi _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 ocaml-ctypes-0.7.0/.gitignore000066400000000000000000000011201274143137600161100ustar00rootroot00000000000000_build libffi.config asneeded.config discover gen_c_primitives gen_c_primitives.log gen_libffi_abi gen_libffi_abi.log src/ctypes/ctypes_primitives.ml src/ctypes_config.h src/ctypes_config.ml src/ctypes-foreign-base/dl_stubs.c src/ctypes-foreign-base/dl.ml src/discover/commands.cm* src/discover/discover.cm* src/configure/extract_from_c.cm* src/configure/gen_c_primitives.cm* src/configure/gen_libffi_abi.cm* *~ generated_stubs.c generated_bindings.ml generated_struct_bindings.ml ncurses_generated.ml ncurses_stubs.c date_generated.ml date_stubs.c fts_generated.ml fts_stubs.c libffi_abi.ml ocaml-ctypes-0.7.0/.merlin000066400000000000000000000007331274143137600154200ustar00rootroot00000000000000PRJ ctypes S src S src/cstubs S src/libffi-abigen S src/discover S src/ctypes S src/ctypes-top S src/ctypes-foreign-threaded S src/configure S src/ctypes-foreign-base S src/ctypes-foreign S src/ctypes-foreign-unthreaded B _build B _build/src B _build/src/cstubs B _build/src/libffi-abigen B _build/src/ctypes B _build/src/ctypes-top B _build/src/ctypes-foreign-threaded B _build/src/configure B _build/src/ctypes-foreign-base B _build/src/ctypes-foreign-unthreaded PKG bytes ocaml-ctypes-0.7.0/.travis-ci-arm.sh000077500000000000000000000003221274143137600172160ustar00rootroot00000000000000#!/bin/bash cd $(dirname $0) eval $(opam config env) make make test # build and run the tests make examples # build and run the examples _build/date.native _build/date-cmd.native _build/fts-cmd.native examples ocaml-ctypes-0.7.0/.travis-ci.sh000066400000000000000000000035211274143137600164420ustar00rootroot00000000000000case "$OCAML_VERSION" in 4.01.0) ppa=avsm/ocaml41+opam12 ;; 4.02.3) ppa=avsm/ocaml42+opam12 ;; *) ppa=avsm/ocaml42+opam12; use_opam=true ;; esac install_on_linux () { echo "yes" | sudo add-apt-repository ppa:$ppa sudo apt-get update -qq if test $use_opam; then sudo apt-get install -qq opam opam init opam update opam switch -q $OCAML_VERSION else sudo apt-get install -qq ocaml ocaml-native-compilers camlp4-extra opam opam init opam update fi } install_on_osx () { curl -OL "http://xquartz.macosforge.org/downloads/SL/XQuartz-2.7.6.dmg" sudo hdiutil attach XQuartz-2.7.6.dmg sudo installer -verbose -pkg /Volumes/XQuartz-2.7.6/XQuartz.pkg -target / brew update brew reinstall ocaml brew install libffi opam opam init opam switch $OCAML_VERSION eval `opam config env` } export OPAMYES=1 export OPAMVERBOSE=1 echo $TRAVIS_OS_NAME case $TRAVIS_OS_NAME in osx) install_on_osx ;; linux) install_on_linux ;; esac echo OCaml version ocaml -version echo OPAM versions opam --version opam --git-version eval `opam config env` # Optional dependencies for coverage testing if test $COVERAGE -a $TRAVIS_OS_NAME != osx ; then opam install bisect_ppx ocveralls fi # Optional dependencies for Xen build opam install mirage-xen || echo "Mirage not installable, so not testing Xen build." opam pin add -n ctypes $(pwd) opam install --build-test --yes ctypes # Check that the inverted stubs package builds with this release opam pin add -n ctypes-inverted-stubs-example https://github.com/yallop/ocaml-ctypes-inverted-stubs-example.git if test ! $COVERAGE && opam install --show-actions ctypes-inverted-stubs-example; then opam install --build-test --yes ctypes-inverted-stubs-example else echo "Pinning the inverted stubs example failed, probably due to OCaml version incompatibility" fi ocaml-ctypes-0.7.0/.travis.yml000066400000000000000000000014461274143137600162440ustar00rootroot00000000000000language: c sudo: required services: - docker script: - if [ "${ARM}z" = "truez" ]; then docker run -v /usr/bin/qemu-arm-static:/usr/bin/qemu-arm-static -v $(pwd):/travis yallop/ocaml-ctypes-qemu-arm-base /travis/.travis-ci-arm.sh; else bash -ex .travis-ci.sh; fi os: - linux - osx env: - OCAML_VERSION=4.01.0 - OCAML_VERSION=4.02.3 COVERAGE=true - OCAML_VERSION=4.02.3 ARM=true - OCAML_VERSION=4.03.0 matrix: exclude: - os: osx env: OCAML_VERSION=4.02.3 ARM=true - os: osx env: OCAML_VERSION=4.02.3 COVERAGE=true - os: osx env: OCAML_VERSION=4.03.0 before_install: - if [ "${ARM}z" = "truez" ]; then sudo apt-get update && sudo apt-get install --yes qemu-user-static; docker pull yallop/ocaml-ctypes-qemu-arm-base; fi ocaml-ctypes-0.7.0/CHANGES.md000066400000000000000000000301621274143137600155220ustar00rootroot00000000000000## ctypes 0.7.0 ### Features * Add support for bytecode-only architectures https://github.com/ocamllabs/ocaml-ctypes/issues/410 * Add a new `sint` type corresponding to a full-range C integer and update `errno` support to use `sint` https://github.com/ocamllabs/ocaml-ctypes/issues/411 ### Bug fixes * Handle small integer return types correctly on big-endian platforms https://github.com/ocamllabs/ocaml-ctypes/issues/404 https://github.com/ocamllabs/ocaml-ctypes/issues/405 * Fix a bug with callbacks that return small types (less than a word) https://github.com/ocamllabs/ocaml-ctypes/issues/405 Thanks to Stephane Glondu (@glondu) for contributions to this release. ## ctypes 0.6.2 ### Bug fixes * Fix for argument quoting in the Windows build after new cross compilation support https://github.com/ocamllabs/ocaml-ctypes/pull/399 * Improve Lwt jobs support for functions with many or no arguments https://github.com/ocamllabs/ocaml-ctypes/pull/400 Thanks to Andreas Hauptmann (@fdopen) for contributing to this release. ## ctypes 0.6.1 ### Bug fixes * Fix constructor qualification in code generated for inverted stubs: https://github.com/ocamllabs/ocaml-ctypes/pull/397 ## ctypes 0.6.0 ### Features * The `Cstubs.FOREIGN` interface has been extended with `returning` and `@->`, and some new types. See the pull request for details: https://github.com/ocamllabs/ocaml-ctypes/pull/389 NB: code that generates bindings using `Cstubs` may need to be updated to select `return` and `@->` from the bindings functor argument rather than from the `Ctypes` module. Code that needs to be updated will fail to compile with the new interface. The pull request shows how to update your code, if necessary. * The `Cstubs` module can now generate asynchronous bindings to C functions using the Lwt jobs framework. See the pull request for details: https://github.com/ocamllabs/ocaml-ctypes/pull/391 * The `Cstubs` module now supports optionally returning `errno` alongside the return value of bound C functions. See the pull request for details: https://github.com/ocamllabs/ocaml-ctypes/pull/392 * Cross-compilation support is improved: the configuration step no longer runs binaries on the host. See the pull request for details: https://github.com/ocamllabs/ocaml-ctypes/pull/383 * The `Unsigned.S` interface has new `of_int64` and `to_int64` functions. ### Compatibility * The deprecated `*:*` and `+:+` functions have been removed. Use `Ctypes.field` instead. * OCaml 4.00.* is no longer supported. The earliest supported OCaml release is 4.01.0 Thanks to Spiros Eliopoulos (@seliopou), @orbitz, Leonid Rozenberg (@rleonid) and Peter Zotov (@whitequark) for contributions to this release. ## ctypes 0.5.1 ### Bug fixes * Use a C function, not `Pervasives.ignore`, to keep values alive. ## ctypes 0.5.0 Thanks to Andreas Hauptmann (@fdopen), David Sheets (@dsheets), Etienne Millon (@emillon), Goswin von Brederlow (@mrvn), Leonid Rozenberg (@rleonid), @orbitz, Max Mouratov (@cakeplus), and Peter Zotov (@whitequark) for contributions to this release. ### Features * Build and install `*.cmt` and `*.cmti` files. * Expose `time_t` as an unsigned value * Expose larger interfaces for POSIX types known to be integer types. * Add support for 1- and 2-byte unsigned integer typedefs. * Add support for 1-byte and 2-byte integer typedefs. * Add a `Signed.Int` module. * Expose more information in the `Uncoercible` exception. * `allocate_n` now defaults to zeroing its memory. * Add public root management interface. NB: the interface is experimental and subject to change. * Look through views to add fields to structs and unions. * Support signed arithmetic operations for `ssize_t`. * Add support for `ptrdiff_t` as a typedef for a signed integer type. * Support `intptr_t` and `uintptr_t` as typedefs * Support coercions between object and function pointers. * Add public `funptr_of_raw_address` function. * Support `static_funptr` coercions * Add function pointers to the core type language (See the `Ctypes_static.static_funptr` type, on which `Foreign.funptr` and `Foreign.foreign` are now based.) * Better support for functions returning void with inverted stubs. * Add support for releasing runtime lock to Cstubs_inverted. ### Bug fixes * Fix: inconsistent use of `caml_stat_*` functions * Fix: a memory leak in `ctypes_caml_roots_release` ## ctypes 0.4.2 * Fix a bug involving access to local roots while the runtime lock was not held. ## ctypes 0.4.1 Thanks to Etienne Millon (@emillon) for contributing to this release. * Fix placement of docstring titles * Add funptr's optional arguments to funptr_opt * Fix a typo in libffi detection code * Synchronize foreign.mli files (documentation) ## ctypes 0.4 Thanks to A. Hauptmann (@fdopen), David Sheets (@dsheets), Maverick Woo (@maverickwoo), Peter Zotov (@whitequark), David Kaloper (@pqwy), Ramkumar Ramachandra (@artagnon), Thomas Braibant (@braibant), Hugo Heuzard (@hhugo) and Edwin Török (@edwintorok) for contributions to this release. ### Major features * Support for the C99 bool type * Typedef support * Enum support * Support for accessing C globals with foreign_value in generated stubs * Support for retrieving #define and enum constants from C * Windows support There is now support for Windows (32-bit and 64-bit, using MinGW) and automatic building and testing on Windows using [Appveyor][appveyor-builds]. * Support for releasing the runtime lock in C calls The new `release_runtime_lock` argument to `Foreign.foreign` indicates whether the OCaml runtime lock should be released during the call to the bound C function, allowing other threads to run. * Support for acquiring the runtime lock in callbacks There is a new `runtime_lock` argument to `Foreign.funptr`. Setting `runtime_lock` to `true` indicates that the OCaml runtime lock should be acquired during calls from C to OCaml and released during calls through function pointers from OCaml to C. * Support for passing 'bytes' values directly to C See the [relevant section of the FAQ][strings_faq]. * Add support for custom printers in views. * Optionally obtain struct and union layout from C #### Other changes * string_opt wraps char *, not void *. * Remove some poorly-supported POSIX types * Use nativeint to represent pointers * Support zero-argument callbacks * findlib package naming: ctypes.foreign-base ~> ctypes.foreign.base &c. * Make it possible to print a field name * Better exception handling when using RTLD_NOLOAD * RTLD_LOCAL support * Changed the #include path to $(ocamlfind query ctypes) * Renamed some internal modules to avoid name clashes [appveyor-builds]: https://ci.appveyor.com/project/yallop/ocaml-ctypes/branch/master ## ctypes 0.3.4 #### Bug fixes Thanks to Yakov Zaytsev (@ysz) for contributing to this release. * fix printing for nullary function stubs ## ctypes 0.3.3 #### Bug fixes * respect `pbyte_offset` with cstubs ## ctypes 0.3.2 * Add bytes to the META "requires" field ## ctypes 0.3.1 #### New features * Support for 'bytes' #### Bug fixes * Avoid invalidated pointer access ## ctypes 0.3 Thanks to Peter Zotov (@whitequark), David Sheets (@dsheets), Mike McClurg (@mcclurmc) and Anil Madhavapeddy (@avsm) for contributions to this release. #### Major features ##### Support for passing OCaml strings directly to C (Patch by Peter Zotov.) The implications are discussed [in the FAQ][strings_faq]. [strings_faq]: https://github.com/ocamllabs/ocaml-ctypes/wiki/FAQ#strings ##### Support for generating C stubs from names and type declarations. There are various examples available of packages which use stub support: see the [fts example][fts-example] in the distribution (which uses a custom Makefile), [this fork of async_ssl][async_ssl] (which uses OCamlMakefile), and [the cstubs branch of ocaml-lz4][ocaml-lz4] (which uses oasis and ocamlbuild). [fts-example]: https://github.com/ocamllabs/ocaml-ctypes/tree/master/examples/fts/stub-generation [async_ssl]: https://github.com/yallop/async_ssl/tree/stub-generation [ocaml-lz4]: https://github.com/whitequark/ocaml-lz4/tree/cstubs ##### Support for turning OCaml modules into C libraries. See the [ocaml-ctypes-inverted-stubs-example][inverted-stubs-example] repository for a sample project which exposes a part of [Xmlm][xmlm]'s API to C. [inverted-stubs-example]: https://github.com/yallop/ocaml-ctypes-inverted-stubs-example/ [xmlm]: http://erratique.ch/software/xmlm #### Other changes * Add a function [`string_from_ptr`][string_from_ptr] for creating a string from an address and length. * Generate [codes for libffi ABI specifications][libffi_abi]. * Support for passing complex numbers to C using the stub generation backend. * Add [`raw_address_of_ptr`][raw_address_of_ptr], an inverse of [`ptr_of_raw_address`][ptr_of_raw_address]. * Add a function [`typ_of_bigarray_kind`][typ_of_bigarray_kind] for converting `Bigarray.kind` values to `Ctypes.typ` values. * Improved [coercion][coercion] support [typ_of_bigarray_kind]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALtyp_of_bigarray_kind [string_from_ptr]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALstring_from_ptr [raw_address_of_ptr]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALraw_address_of_ptr [ptr_of_raw_address]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALptr_of_raw_address [CArray]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.Array.html [libffi_abi]: http://ocamllabs.github.io/ocaml-ctypes/Libffi_abi.html [coercion]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALcoerce #### Backwards incompatibilities * `Array` has been renamed to [`CArray`][CArray]. ## ctypes 0.2.3 #### Bug fixes * Fix GC-related bug that shows up on OS X. ## ctypes 0.2.2 * Don't install ctypes-foreign cmx files. ## ctypes 0.2.1 * Bump META version ## ctypes 0.2 Thanks to Ivan Gotovchits, Greg Perkins, Daniel Bünzli, Rob Hoes and Anil Madhavapeddy for contributions to this release. #### Major features ##### Bigarray support. See [Bigarray types][bigarray-types] and [Bigarray values][bigarray-values] for details. [bigarray-types]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#4_Bigarraytypes [bigarray-values]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#4_Bigarrayvalues ##### Give the user control over the lifetime of closures passed to C. See [the FAQ][faq-lifetime] for details. [faq-lifetime]: https://github.com/ocamllabs/ocaml-ctypes/wiki/FAQ#function-lifetime ##### Top level printing for C values and types Loading the new findlib package `ctypes.top` in the toplevel will install custom printers for C types and values. #### Other changes * Basic [coercion][coercion] support * Remove `returning_checking_errno`; pass a flag to [`foreign`][foreign] instead. * Add an optional argument to [`Foreign.foreign`][foreign] that ignores absent symbols. (Patch by Daniel Bünzli.) * More precise tests for whether types are 'passable' * Compulsory names for structure and union fields (`*:*` and `+:+` are deprecated, but still supported for now.) * [`UInt32.of_int32`][of_int32], [`UInt32.to_int32`][to_int32], [`UInt64.of_int64`][of_int64], and [`UInt64.to_int64`][to_int64] functions. * Finalisers for ctypes-allocated memory. * Add a [`string_opt`][string_opt] view (Patch by Rob Hoes.) * Add the ['camlint'][camlint] basic type. * Complex number support * Abstract types [now have names][abstract]. [foreign]: http://ocamllabs.github.io/ocaml-ctypes/Foreign.html#VALforeign [of_int32]: http://ocamllabs.github.io/ocaml-ctypes/Unsigned.Uint32.html#VALof_int32 [to_int32]: http://ocamllabs.github.io/ocaml-ctypes/Unsigned.Uint32.html#VALto_int32 [of_int64]: http://ocamllabs.github.io/ocaml-ctypes/Unsigned.Uint64.html#VALof_int64 [to_int64]: http://ocamllabs.github.io/ocaml-ctypes/Unsigned.Uint64.html#VALto_int64 [string_opt]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALstring_opt [camlint]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALcamlint [abstract]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALabstract [coercion]: http://ocamllabs.github.io/ocaml-ctypes/Ctypes.html#VALcoerce ## ctypes 0.1.1 #### Bug fixes * Remove hard-coded alloc size ## ctypes 0.1 initial release ocaml-ctypes-0.7.0/LICENSE000066400000000000000000000020401274143137600151270ustar00rootroot00000000000000Copyright (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-0.7.0/META000066400000000000000000000044401274143137600146010ustar00rootroot00000000000000version = "0.7.0" description = "Combinators for binding to C libraries without writing any C." requires = "unix bigarray str bytes" 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.7.0" 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 "stubs" ( version = "0.7.0" description = "Stub generation from C types" requires = "ctypes" archive(byte) = "cstubs.cma" archive(byte, plugin) = "cstubs.cma" archive(native) = "cstubs.cmxa" archive(native, plugin) = "cstubs.cmxs" xen_linkopts = "-lctypes_stubs_xen" exists_if = "cstubs.cma" ) package "foreign" ( version = "0.7.0" description = "Dynamic linking of C functions" requires(-mt) = "ctypes.foreign.unthreaded" requires(mt) = "ctypes.foreign.threaded" package "base" ( version = "0.7.0" description = "Dynamic linking of C functions (base package)" 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 "threaded" ( version = "0.7.0" description = "Dynamic linking of C functions (for use in threaded programs)" requires = "threads ctypes ctypes.foreign.base" archive(byte) = "ctypes-foreign-threaded.cma" archive(byte, plugin) = "ctypes-foreign-threaded.cma" archive(native) = "ctypes-foreign-threaded.cmxa" archive(native, plugin) = "ctypes-foreign-threaded.cmxs" exists_if = "ctypes-foreign-threaded.cma" ) package "unthreaded" ( version = "0.7.0" description = "Dynamic linking of C functions (for use in unthreaded programs)" requires = "ctypes ctypes.foreign.base" 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-unthreaded.cma" ) ) ocaml-ctypes-0.7.0/Makefile000066400000000000000000000164031274143137600155720ustar00rootroot00000000000000.SECONDEXPANSION: BEST:=$(shell if ocamlopt > /dev/null 2>&1; then echo native; else echo byte; fi) DEBUG=false COVERAGE=false OCAML=ocaml OCAMLFIND=ocamlfind HOSTOCAMLFIND=$(OCAMLFIND) OCAMLDEP=$(OCAMLFIND) ocamldep OCAMLMKLIB=$(OCAMLFIND) ocamlmklib VPATH=src examples BUILDDIR=_build BASE_PROJECTS=configure libffi-abigen configured ctypes ctypes-top FOREIGN_PROJECTS=test-libffi ctypes-foreign-base ctypes-foreign-threaded ctypes-foreign-unthreaded STUB_PROJECTS=cstubs PROJECTS=$(BASE_PROJECTS) $(FOREIGN_PROJECTS) $(STUB_PROJECTS) GENERATED=src/ctypes/ctypes_primitives.ml \ src/ctypes-foreign-base/libffi_abi.ml \ src/ctypes-foreign-base/dl.ml \ src/ctypes-foreign-base/dl_stubs.c \ libffi.config \ asneeded.config OCAML_FFI_INCOPTS=$(libffi_opt) export CFLAGS DEBUG EXTDLL:=$(shell $(OCAMLFIND) ocamlc -config | awk '/^ext_dll:/{print $$2}') OSYSTEM:=$(shell $(OCAMLFIND) ocamlc -config | awk '/^system:/{print $$2}') ifneq (,$(filter mingw%,$(OSYSTEM))) OS_ALT_SUFFIX=.win else OS_ALT_SUFFIX=.unix endif # public targets all: libffi.config $(PROJECTS) ctypes-base: $(BASE_PROJECTS) ctypes-foreign: ctypes-base $(FOREIGN_PROJECTS) ctypes-stubs: ctypes-base $(STUB_PROJECTS) clean: rm -fr _build rm -f $(GENERATED) # ctypes subproject ctypes.public = ctypes_static ctypes_primitive_types unsigned signed ctypes_structs ctypes posixTypes ctypes_types ctypes.dir = src/ctypes ctypes.extra_mls = ctypes_primitives.ml ctypes.deps = str bigarray bytes ctypes.install = yes ctypes.install_native_objects = yes ifeq ($(XEN),enable) ctypes.xen = yes endif ctypes: PROJECT=ctypes ctypes: $(ctypes.dir)/$(ctypes.extra_mls) $$(LIB_TARGETS) # cstubs subproject cstubs.public = cstubs_internals cstubs_structs cstubs cstubs_inverted cstubs.dir = src/cstubs cstubs.subproject_deps = ctypes cstubs.deps = str bytes cstubs.install = yes cstubs: PROJECT=cstubs cstubs: $(cstubs.dir)/$(cstubs.extra_mls) $$(LIB_TARGETS) # ctypes-foreign-base subproject ctypes-foreign-base.public = dl libffi_abi 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.deps = bytes ctypes-foreign-base.subproject_deps = ctypes ctypes-foreign-base.extra_mls = libffi_abi.ml dl.ml ctypes-foreign-base.extra_cs = dl_stubs.c ctypes-foreign-base.link_flags = $(libffi_lib) $(lib_process) 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) $(lib_process) 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) $(lib_process) ctypes-foreign-unthreaded.cmo_opts = $(OCAML_FFI_INCOPTS:%=-ccopt %) ctypes-foreign-unthreaded.cmx_opts = $(OCAML_FFI_INCOPTS:%=-ccopt %) ctypes-foreign-unthreaded.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) # configuration configured: src/ctypes/ctypes_primitives.ml src/ctypes-foreign-base/libffi_abi.ml src/ctypes-foreign-base/dl.ml src/ctypes-foreign-base/dl_stubs.c src/ctypes-foreign-base/dl.ml: src/ctypes-foreign-base/dl.ml$(OS_ALT_SUFFIX) cp $< $@ src/ctypes-foreign-base/dl_stubs.c: src/ctypes-foreign-base/dl_stubs.c$(OS_ALT_SUFFIX) cp $< $@ src/ctypes/ctypes_primitives.ml: src/configure/extract_from_c.ml src/configure/gen_c_primitives.ml $(HOSTOCAMLFIND) ocamlc -o gen_c_primitives -package str,bytes -linkpkg $^ -I src/configure ./gen_c_primitives > $@ 2> gen_c_primitives.log || (rm $@ && cat gen_c_primitives.log || false) src/ctypes-foreign-base/libffi_abi.ml: src/configure/extract_from_c.ml src/configure/gen_libffi_abi.ml $(HOSTOCAMLFIND) ocamlc -o gen_libffi_abi -package str,bytes -linkpkg $^ -I src/configure ./gen_libffi_abi > $@ 2> gen_c_primitives.log || (rm $@ && cat gen_c_primitives.log || false) libffi.config: src/discover/commands.mli src/discover/commands.ml src/discover/discover.ml $(HOSTOCAMLFIND) ocamlc -o discover -package str,bytes -linkpkg $^ -I src/discover ./discover -ocamlc "$(OCAMLFIND) ocamlc" > $@ || (rm $@ && false) asneeded.config: ./src/discover/determine_as_needed_flags.sh >> $@ # dependencies depend: configure $(OCAMLDEP) $(foreach project,$(PROJECTS),-I $($(project).dir)) \ $(shell find src examples -name '*.mli' -o -name '*.ml') \ | sed "s!src/!_build/src/!g; s!examples/!_build/examples/!g" > .depend #installation META-install: $(OCAMLFIND) install ctypes META CHANGES.md install-%: PROJECT=$* install-%: $(if $(filter yes,$($(PROJECT).install)),\ $(OCAMLFIND) install -add ctypes -optional $^ \ $(LIB_TARGETS) $(LIB_TARGET_EXTRAS) \ $(INSTALL_MLIS) $(INSTALL_CMIS) \ $(INSTALL_CMTS) $(INSTALL_CMTIS) \ $(INSTALL_HEADERS) \ $(if $(filter yes,$($(PROJECT).install_native_objects)),$(NATIVE_OBJECTS))) install: META-install $(PROJECTS:%=install-%) uninstall: $(OCAMLFIND) remove ctypes DOCFILES=$(foreach project,$(PROJECTS),\ $(foreach mli,$($(project).public),\ $($(project).dir)/$(mli).mli)) DOCFLAGS=$(foreach project,$(PROJECTS),-I $(BUILDDIR)/$($(project).dir)) # Avoid passing duplicate interfaces to ocamldoc. DOCFILES:=$(filter-out src/ctypes-foreign-threaded/foreign.mli,$(DOCFILES)) doc: ocamldoc -html $(DOCFLAGS) $(DOCFILES) .PHONY: depend clean configure all install doc $(PROJECTS) include .depend Makefile.rules Makefile.examples Makefile.tests -include libffi.config -include asneeded.config ifeq ($(libffi_available),false) test-libffi: @echo "The following required C libraries are missing: libffi." @echo "Please install them and retry. If they are installed in a non-standard location" @echo "or need special flags, set the environment variables _CFLAGS and _LIBS" @echo "accordingly and retry." @echo @echo " For example, if libffi is installed in /opt/local, you can type:" @echo @echo " export LIBFFI_CFLAGS=-I/opt/local/include" @echo " export LIBFFI_LIBS=-L/opt/local/lib" @exit 1 else: test-libffi: endif ocaml-ctypes-0.7.0/Makefile.examples000066400000000000000000000101161274143137600174020ustar00rootroot00000000000000# -*- Makefile -*- # subproject: fts with stub generation fts-stubs.install = no fts-stubs.dir = examples/fts/stub-generation/bindings fts-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-unthreaded fts-stubs: PROJECT=fts-stubs fts-stubs: $$(LIB_TARGETS) fts-stub-generator.install = no fts-stub-generator.dir = examples/fts/stub-generation/stub-generator fts-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-unthreaded fts-stubs fts-stub-generator.deps = bytes str unix bigarray fts-stub-generator: PROJECT=fts-stub-generator fts-stub-generator: $$(NATIVE_TARGET) fts-cmd.install = no fts-cmd.dir = examples/fts/stub-generation fts-cmd.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-unthreaded fts-stubs fts-cmd.deps = bytes str unix bigarray fts-cmd.extra_mls = fts_generated.ml fts-cmd: CFLAGS+=-D_FILE_OFFSET_BITS=32 fts-cmd: PROJECT=fts-cmd fts-cmd: $$(NATIVE_TARGET) fts-cmd-build: examples/fts/stub-generation/fts_generated.ml examples/fts/stub-generation/fts_generated.ml: fts-stub-generator _build/fts-stub-generator.native # subproject: fts using dynamic linking (foreign) fts.install = no fts.dir = examples/fts/foreign fts.deps = bytes unix bigarray str fts.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded fts: PROJECT=fts fts: $$(NATIVE_TARGET) # subproject: date with stub generation date-stubs.install = no date-stubs.dir = examples/date/stub-generation/bindings date-stubs.subproject_deps = ctypes cstubs date-stubs: PROJECT=date-stubs date-stubs: $$(LIB_TARGETS) date-stub-generator.install = no date-stub-generator.dir = examples/date/stub-generation/stub-generator date-stub-generator.subproject_deps = ctypes cstubs date-stubs date-stub-generator.deps = bytes str unix bigarray date-stub-generator: PROJECT=date-stub-generator date-stub-generator: $$(NATIVE_TARGET) date-cmd.install = no date-cmd.dir = examples/date/stub-generation date-cmd.subproject_deps = ctypes cstubs date-stubs date-cmd.deps = bytes str unix bigarray date-cmd.extra_mls = date_generated.ml date-cmd: PROJECT=date-cmd date-cmd: $$(NATIVE_TARGET) date-cmd-build: examples/date/stub-generation/date_generated.ml examples/date/stub-generation/date_generated.ml: _build/date-stub-generator.native # subproject: date using dynamic linking (foreign) date.install = no date.dir = examples/date/foreign date.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded date.deps = bytes unix bigarray str date: PROJECT=date date: $$(NATIVE_TARGET) # subproject: ncurses with stub generation ncurses-stubs.install = no ncurses-stubs.dir = examples/ncurses/stub-generation/bindings ncurses-stubs.subproject_deps = ctypes cstubs ncurses-stubs.deps = bytes str unix bigarray ncurses-stubs: PROJECT=ncurses-stubs ncurses-stubs: $$(NATIVE_TARGET) $$(LIB_TARGETS) ncurses-cmd.install = no ncurses-cmd.dir = examples/ncurses/stub-generation ncurses-cmd.subproject_deps = ctypes cstubs ncurses-stubs ncurses-cmd.deps = bytes str unix bigarray ncurses-cmd.extra_mls = ncurses_generated.ml ncurses-cmd.link_flags = -lncurses ncurses-cmd: PROJECT=ncurses-cmd ncurses-cmd: $$(NATIVE_TARGET) ncurses-cmd-build: examples/ncurses/stub-generation/ncurses_generated.ml examples/ncurses/stub-generation/ncurses_generated.ml: ncurses-stubs _build/ncurses-stubs.native # subproject: ncurses using dynamic linking (foreign) ncurses.install = no ncurses.dir = examples/ncurses/foreign ncurses.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-unthreaded ncurses.deps = bytes unix bigarray str ncurses.link_flags = -lncurses ncurses: PROJECT=ncurses ncurses: $$(NATIVE_TARGET) EXAMPLES = EXAMPLES += ncurses ncurses-stubs ncurses-cmd-build ncurses-cmd EXAMPLES += fts fts-stubs fts-stub-generator fts-cmd-build fts-cmd EXAMPLES += date date-stubs date-stub-generator date-cmd-build date-cmd run-examples: examples # this doesn't run the ncurses example, which takes control of the terminal _build/date.native _build/date-cmd.native _build/fts-cmd.native src .PHONY: build $(EXAMPLES) examples: build $(EXAMPLES) ocaml-ctypes-0.7.0/Makefile.rules000066400000000000000000000126121274143137600167210ustar00rootroot00000000000000# -*- Makefile -*- .SECONDARY: ifneq (,$(filter mingw%,$(OSYSTEM))) lib_process=-lpsapi ifeq ($(DEBUG),false) CFLAGS=-std=c99 -Wall -O3 $(OCAML_FFI_INCOPTS) else CFLAGS=-std=c99 -Wall -g $(OCAML_FFI_INCOPTS) endif else ifeq ($(DEBUG),false) CFLAGS=-fPIC -Wall -O3 $(OCAML_FFI_INCOPTS) else CFLAGS=-fPIC -Wall -g $(OCAML_FFI_INCOPTS) endif endif ifeq ($(DEBUG),false) OCAMLFLAGS=-principal -short-paths else OCAMLFLAGS=-principal -short-paths -g endif ifneq ($(COVERAGE),false) OCAMLFIND_BISECT_FLAGS=-package bisect_ppx endif C_SOURCE = $(sort $(wildcard $($(PROJECT).dir)/*.c) $(patsubst %,$($(PROJECT).dir)/%,$($(PROJECT).extra_cs))) 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) XEN_OBJECTS = $(C_SOURCE:$($(PROJECT).dir)/%.c=$(BUILDDIR)/xen/$($(PROJECT).dir)/%.o) STUB_LIB = $(if $(C_OBJECTS),$(BUILDDIR)/dll$(PROJECT)_stubs$(EXTDLL)) OPAM_PREFIX=$(shell opam config var prefix) XEN_LIB = $(if $($(PROJECT).xen),$(BUILDDIR)/dll$(PROJECT)_stubs_xen$(EXTDLL)) XEN_CFLAGS=$(if $(XEN_LIB), \ $(CFLAGS) -DMINIOS $(shell env PKG_CONFIG_PATH="$(OPAM_PREFIX)/lib/pkgconfig" \ pkg-config --cflags mirage-xen) -fno-builtin) 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) LOCAL_CMAS = $(SUBPROJECT_DEPS:%=$(BUILDDIR)/%.cma) CMXA_OPTS = $(if $(C_OBJECTS),-cclib -l$(PROJECT)_stubs) OCAMLINCLUDES = -I $(BUILDDIR)/$($(PROJECT).dir) \ $(foreach spdep,$($(PROJECT).subproject_deps),\ -I $(BUILDDIR)/$($(spdep).dir)) NATIVE_LIB=$(BUILDDIR)/$(PROJECT).cmxa NATIVE_TARGET=$(BUILDDIR)/$(PROJECT).native BEST_TARGET=$(BUILDDIR)/$(PROJECT).$(BEST) LIB_TARGETS = $(BUILDDIR)/$(PROJECT).cma \ $(STUB_LIB) \ $(XEN_LIB) ifeq ($(BEST),native) LIB_TARGETS += $(BUILDDIR)/$(PROJECT).cmxa endif ifneq ($(wildcard $(shell ocamlc -where)/dynlink.cmxa),) LIB_TARGETS += $(BUILDDIR)/$(PROJECT).cmxs endif LIB_TARGET_EXTRAS = $(if $(STUB_LIB),$(BUILDDIR)/lib$(PROJECT)_stubs.a) \ $(if $(XEN_LIB),$(BUILDDIR)/lib$(PROJECT)_stubs_xen.a) \ $(BUILDDIR)/$(PROJECT).a INSTALL_CMIS = $($(PROJECT).public:%=$(BUILDDIR)/$($(PROJECT).dir)/%.cmi) INSTALL_CMTIS = $($(PROJECT).public:%=$(BUILDDIR)/$($(PROJECT).dir)/%.cmti) INSTALL_CMTS = $($(PROJECT).public:%=$(BUILDDIR)/$($(PROJECT).dir)/%.cmt) INSTALL_MLIS = $($(PROJECT).public:%=$($(PROJECT).dir)/%.mli) INSTALL_HEADERS = $(wildcard $($(PROJECT).dir)/*.h) THREAD_FLAG = $(if $(filter yes,$($(PROJECT).threads)),-thread) LINK_FLAGS = $(as_needed_flags) $($(PROJECT).link_flags) OCAML_LINK_FLAGS=$(LINK_FLAGS:%=-cclib %) OCAMLMKLIB_FLAGS=$($(PROJECT).link_flags) OCAMLFIND_PACKAGE_FLAGS=$(patsubst %,-package %,$($(PROJECT).deps)) \ $(patsubst %,-thread -package threads,$(THREAD_FLAG)) \ $(OCAMLFIND_BISECT_FLAGS) $(BUILDDIR)/%.cmxa: $$(NATIVE_OBJECTS) $(OCAMLFIND) opt -a -linkall $(OCAMLFLAGS) $(THREAD_FLAG) $(OCAMLFIND_PACKAGE_FLAGS) $(CMXA_OPTS) -o $@ $(NATIVE_OBJECTS) $(OCAML_LINK_FLAGS) $(BUILDDIR)/dll%_stubs$(EXTDLL): $$(C_OBJECTS) $(OCAMLMKLIB) -o $(BUILDDIR)/$*_stubs $^ $(OCAMLMKLIB_FLAGS) $(BUILDDIR)/dll%_stubs_xen$(EXTDLL): $$(XEN_OBJECTS) $(OCAMLMKLIB) -o $(BUILDDIR)/$*_stubs_xen $^ $(OCAMLMKLIB_FLAGS) $(BUILDDIR)/%.cmxs : $$(NATIVE_OBJECTS) $(OCAMLFIND) opt -shared -linkall $(OCAMLFLAGS) $(THREAD_FLAG) $(OCAMLFIND_PACKAGE_FLAGS) -o $@ $(NATIVE_OBJECTS) $(C_OBJECTS) $(OCAML_LINK_FLAGS) $(BUILDDIR)/%.cma: $$(BYTE_OBJECTS) $(OCAMLFIND) ocamlc -a $(OCAMLFLAGS) $(THREAD_FLAG) $(CMA_OPTS) $(OCAMLFIND_PACKAGE_FLAGS) -o $@ $(BYTE_OBJECTS) $(OCAML_LINK_FLAGS) $(BUILDDIR)/%.cmo : %.ml @mkdir -p $(@D) $(OCAMLFIND) ocamlc $(OCAMLFIND_PACKAGE_FLAGS) $(OCAMLFLAGS) $(THREAD_FLAG) $(CMO_OPTS) -c -o $@ $(OCAMLINCLUDES) $< $(BUILDDIR)/%.cmx : %.ml @mkdir -p $(@D) $(OCAMLFIND) opt -bin-annot -c -o $@ $(OCAMLFIND_PACKAGE_FLAGS) $(OCAMLFLAGS) $(THREAD_FLAG) $(OCAMLFIND_PACKAGE_FLAGS) $(CMX_OPTS) $(OCAMLINCLUDES) $(filter %.ml,$<) $(BUILDDIR)/%.o : %.c @mkdir -p $(@D) cd $(@D) && $(OCAMLFIND) ocamlc -c $(OCAMLFIND_PACKAGE_FLAGS) $(CFLAGS:%=-ccopt %) -o $(@F) $(OCAMLFLAGS) $(realpath $<) $(BUILDDIR)/xen/%.o : %.c @mkdir -p $(@D) cd $(@D) && $(OCAMLFIND) ocamlc -c $(OCAMLFIND_PACKAGE_FLAGS) $(XEN_CFLAGS:%=-ccopt %) -o $(@F) $(OCAMLFLAGS) $(realpath $<) $(BUILDDIR)/%.cmi : %.mli @mkdir -p $(@D) $(OCAMLFIND) ocamlc -bin-annot -c -o $@ $(OCAMLFIND_PACKAGE_FLAGS) $(OCAMLFLAGS) $(OCAMLINCLUDES) $< $(BUILDDIR)/%.native : $$(NATIVE_OBJECTS) $$(C_OBJECTS) $(OCAMLFIND) opt -I $(BUILDDIR) -linkpkg $(OCAMLFLAGS) $(THREAD_FLAG) $(OCAMLFIND_PACKAGE_FLAGS) $(LOCAL_CMXAS) -o $@ $(NATIVE_OBJECTS) $(C_OBJECTS) $(OCAML_LINK_FLAGS) $(BUILDDIR)/%.byte : $$(BYTE_OBJECTS) $$(C_OBJECTS) $(OCAMLFIND) ocamlc -custom -I $(BUILDDIR) -linkpkg $(OCAMLFLAGS) $(THREAD_FLAG) $(OCAMLFIND_PACKAGE_FLAGS) $(LOCAL_CMAS) -o $@ $(BYTE_OBJECTS) $(C_OBJECTS) $(OCAML_LINK_FLAGS) ocaml-ctypes-0.7.0/Makefile.tests000066400000000000000000001353661274143137600167450ustar00rootroot00000000000000# -*- Makefile -*- VPATH += tests CFLAGS += -I $(CURDIR)/src/ctypes -I $(CURDIR)/tests CC=$(shell ocamlc -config | sed -n '/native_c_compiler/{ s/[^:]*://; p;}') # tests-common subproject tests-common.dir = tests/tests-common tests-common.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common.install = no tests-common.install_native_objects = yes tests-common: PROJECT=tests-common tests-common: $$(LIB_TARGETS) test-raw.dir = tests/test-raw test-raw.threads = yes test-raw.deps = bigarray oUnit str bytes test-raw.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-threaded test-raw: PROJECT=test-raw test-raw: $$(BEST_TARGET) test-pointers-stubs.dir = tests/test-pointers/stubs test-pointers-stubs.threads = yes test-pointers-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-pointers-stubs: PROJECT=test-pointers-stubs test-pointers-stubs: $$(LIB_TARGETS) test-pointers-stub-generator.dir = tests/test-pointers/stub-generator test-pointers-stub-generator.threads = yes test-pointers-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-pointers-stubs tests-common test-pointers-stub-generator.deps = str bigarray bytes test-pointers-stub-generator: PROJECT=test-pointers-stub-generator test-pointers-stub-generator: $$(BEST_TARGET) test-pointers.dir = tests/test-pointers test-pointers.threads = yes test-pointers.deps = str bigarray oUnit bytes test-pointers.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs tests-common test-pointers-stubs test-pointers.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-pointers: PROJECT=test-pointers test-pointers: $$(BEST_TARGET) test-pointers-generated: \ tests/test-pointers/generated_bindings.ml \ tests/test-pointers/generated_stubs.c tests/test-pointers/generated_stubs.c: $(BUILDDIR)/test-pointers-stub-generator.$(BEST) $< --c-file $@ tests/test-pointers/generated_bindings.ml: $(BUILDDIR)/test-pointers-stub-generator.$(BEST) $< --ml-file $@ test-variadic-stubs.dir = tests/test-variadic/stubs test-variadic-stubs.threads = yes test-variadic-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-variadic-stubs: PROJECT=test-variadic-stubs test-variadic-stubs: $$(LIB_TARGETS) test-variadic-stub-generator.dir = tests/test-variadic/stub-generator test-variadic-stub-generator.threads = yes test-variadic-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-variadic-stubs tests-common test-variadic-stub-generator.deps = str bigarray bytes test-variadic-stub-generator: PROJECT=test-variadic-stub-generator test-variadic-stub-generator: $$(BEST_TARGET) test-variadic.dir = tests/test-variadic test-variadic.threads = yes test-variadic.deps = str bigarray oUnit bytes test-variadic.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs tests-common test-variadic-stubs test-variadic.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-variadic: PROJECT=test-variadic test-variadic: $$(BEST_TARGET) test-variadic-generated: \ tests/test-variadic/generated_bindings.ml \ tests/test-variadic/generated_stubs.c tests/test-variadic/generated_stubs.c: $(BUILDDIR)/test-variadic-stub-generator.$(BEST) $< --c-file $@ tests/test-variadic/generated_bindings.ml: $(BUILDDIR)/test-variadic-stub-generator.$(BEST) $< --ml-file $@ test-builtins-stubs.dir = tests/test-builtins/stubs test-builtins-stubs.threads = yes test-builtins-stubs.subproject_deps = ctypes cstubs tests-common test-builtins-stubs: PROJECT=test-builtins-stubs test-builtins-stubs: $$(LIB_TARGETS) test-builtins-stub-generator.dir = tests/test-builtins/stub-generator test-builtins-stub-generator.threads = yes test-builtins-stub-generator.subproject_deps = ctypes cstubs \ test-builtins-stubs ctypes-foreign-base ctypes-foreign-threaded tests-common test-builtins-stub-generator.deps = str bigarray bytes test-builtins-stub-generator: PROJECT=test-builtins-stub-generator test-builtins-stub-generator: $$(BEST_TARGET) test-builtins.dir = tests/test-builtins test-builtins.threads = yes test-builtins.deps = str bigarray oUnit bytes test-builtins.subproject_deps = ctypes cstubs test-builtins-stubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-builtins.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-builtins: PROJECT=test-builtins test-builtins: $$(BEST_TARGET) test-builtins-generated: \ tests/test-builtins/generated_bindings.ml \ tests/test-builtins/generated_stubs.c tests/test-builtins/generated_stubs.c: $(BUILDDIR)/test-builtins-stub-generator.$(BEST) $< --c-file $@ tests/test-builtins/generated_bindings.ml: $(BUILDDIR)/test-builtins-stub-generator.$(BEST) $< --ml-file $@ test-macros-stubs.dir = tests/test-macros/stubs test-macros-stubs.threads = yes test-macros-stubs.subproject_deps = ctypes cstubs tests-common test-macros-stubs: PROJECT=test-macros-stubs test-macros-stubs: $$(LIB_TARGETS) test-macros-stub-generator.dir = tests/test-macros/stub-generator test-macros-stub-generator.threads = yes test-macros-stub-generator.subproject_deps = ctypes cstubs \ test-macros-stubs ctypes-foreign-base ctypes-foreign-threaded tests-common test-macros-stub-generator.deps = str bigarray bytes test-macros-stub-generator: PROJECT=test-macros-stub-generator test-macros-stub-generator: $$(BEST_TARGET) test-macros.dir = tests/test-macros test-macros.threads = yes test-macros.deps = str bigarray oUnit bytes test-macros.subproject_deps = ctypes cstubs test-macros-stubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-macros.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-macros: PROJECT=test-macros test-macros: $$(BEST_TARGET) test-macros-generated: \ tests/test-macros/generated_bindings.ml \ tests/test-macros/generated_stubs.c tests/test-macros/generated_stubs.c: $(BUILDDIR)/test-macros-stub-generator.$(BEST) $< --c-file $@ tests/test-macros/generated_bindings.ml: $(BUILDDIR)/test-macros-stub-generator.$(BEST) $< --ml-file $@ test-higher_order-stubs.dir = tests/test-higher_order/stubs test-higher_order-stubs.threads = yes test-higher_order-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-higher_order-stubs: PROJECT=test-higher_order-stubs test-higher_order-stubs: $$(LIB_TARGETS) test-higher_order-stub-generator.dir = tests/test-higher_order/stub-generator test-higher_order-stub-generator.threads = yes test-higher_order-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-higher_order-stubs tests-common test-higher_order-stub-generator.deps = str bigarray bytes test-higher_order-stub-generator: PROJECT=test-higher_order-stub-generator test-higher_order-stub-generator: $$(BEST_TARGET) test-higher_order.dir = tests/test-higher_order test-higher_order.threads = yes test-higher_order.deps = str bigarray oUnit bytes test-higher_order.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs test-higher_order-stubs tests-common test-higher_order.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-higher_order: PROJECT=test-higher_order test-higher_order: $$(BEST_TARGET) test-higher_order-generated: \ tests/test-higher_order/generated_bindings.ml \ tests/test-higher_order/generated_stubs.c tests/test-higher_order/generated_stubs.c: $(BUILDDIR)/test-higher_order-stub-generator.$(BEST) $< --c-file $@ tests/test-higher_order/generated_bindings.ml: $(BUILDDIR)/test-higher_order-stub-generator.$(BEST) $< --ml-file $@ test-enums-struct-stubs.dir = tests/test-enums/struct-stubs test-enums-struct-stubs.threads = yes test-enums-struct-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-enums-struct-stubs: PROJECT=test-enums-struct-stubs test-enums-struct-stubs: $$(LIB_TARGETS) test-enums-stubs.dir = tests/test-enums/stubs test-enums-stubs.threads = yes test-enums-stubs.extra_mls = generated_struct_bindings.ml test-enums-stubs.subproject_deps = ctypes cstubs \ test-enums-struct-stubs \ test-enums-struct-stubs-generator \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-enums-stubs: PROJECT=test-enums-stubs test-enums-stubs: $$(LIB_TARGETS) test-enums-stub-generator.dir = tests/test-enums/stub-generator test-enums-stub-generator.threads = yes test-enums-stub-generator.subproject_deps = ctypes cstubs \ test-enums-struct-stubs \ ctypes-foreign-base ctypes-foreign-threaded test-enums-stubs tests-common test-enums-stub-generator.deps = str bigarray bytes test-enums-stub-generator: PROJECT=test-enums-stub-generator test-enums-stub-generator: $$(BEST_TARGET) test-enums-struct-stub-generator.dir = tests/test-enums/struct-stub-generator test-enums-struct-stub-generator.threads = yes test-enums-struct-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-enums-struct-stubs tests-common test-enums-struct-stub-generator.deps = str bigarray bytes test-enums-struct-stub-generator: PROJECT=test-enums-struct-stub-generator test-enums-struct-stub-generator: $$(BEST_TARGET) test-enums.dir = tests/test-enums test-enums.threads = yes test-enums.deps = str bigarray oUnit bytes test-enums.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs test-enums-struct-stubs test-enums-stubs tests-common test-enums.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-enums: PROJECT=test-enums test-enums: $$(BEST_TARGET) test-enums-structs-generated: \ tests/test-enums/stubs/generated_struct_bindings.ml \ $(BUILDDIR)/tests/test-enums/generated_struct_stubs.c test-enums-generated: \ tests/test-enums/generated_bindings.ml \ tests/test-enums/generated_stubs.c \ tests/test-enums/generated_stubs.c: $(BUILDDIR)/test-enums-stub-generator.$(BEST) $< --c-file $@ tests/test-enums/generated_bindings.ml: $(BUILDDIR)/test-enums-stub-generator.$(BEST) $< --ml-file $@ tests/test-enums/stubs/generated_struct_bindings.ml: $(BUILDDIR)/test-enums-ml-struct-stub-generator.$(BEST) $< > $@ $(BUILDDIR)/test-enums-ml-struct-stub-generator.$(BEST): $(BUILDDIR)/tests/test-enums/generated_struct_stubs.c $(CC) -I `$(OCAMLFIND) ocamlc -where | sed 's|\r$$||'` $(CFLAGS) $(LDFLAGS) $(WINLDFLAGS) -o $@ $^ $(BUILDDIR)/tests/test-enums/generated_struct_stubs.c: $(BUILDDIR)/test-enums-struct-stub-generator.$(BEST) $< --c-struct-file $@ test-structs-stubs.dir = tests/test-structs/stubs test-structs-stubs.threads = yes test-structs-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-structs-stubs: PROJECT=test-structs-stubs test-structs-stubs: $$(LIB_TARGETS) test-structs-stub-generator.dir = tests/test-structs/stub-generator test-structs-stub-generator.threads = yes test-structs-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-structs-stubs tests-common test-structs-stub-generator.deps = str bigarray bytes test-structs-stub-generator: PROJECT=test-structs-stub-generator test-structs-stub-generator: $$(BEST_TARGET) test-structs.dir = tests/test-structs test-structs.threads = yes test-structs.deps = str bigarray oUnit bytes test-structs.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs test-structs-stubs tests-common test-structs.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-structs: PROJECT=test-structs test-structs: $$(BEST_TARGET) test-structs-generated: \ tests/test-structs/generated_bindings.ml \ tests/test-structs/generated_stubs.c \ tests/test-structs/generated_struct_bindings.ml \ $(BUILDDIR)/tests/test-structs/generated_struct_stubs.c tests/test-structs/generated_stubs.c: $(BUILDDIR)/test-structs-stub-generator.$(BEST) $< --c-file $@ tests/test-structs/generated_bindings.ml: $(BUILDDIR)/test-structs-stub-generator.$(BEST) $< --ml-file $@ tests/test-structs/generated_struct_bindings.ml: $(BUILDDIR)/test-structs-ml-stub-generator.$(BEST) $< > $@ $(BUILDDIR)/test-structs-ml-stub-generator.$(BEST): $(BUILDDIR)/tests/test-structs/generated_struct_stubs.c $(CC) -I `$(OCAMLFIND) ocamlc -where | sed 's|\r$$||'` $(CFLAGS) $(LDFLAGS) $(WINLDFLAGS) -o $@ $^ $(BUILDDIR)/tests/test-structs/generated_struct_stubs.c: $(BUILDDIR)/test-structs-stub-generator.$(BEST) $< --c-struct-file $@ test-constants-stubs.dir = tests/test-constants/stubs test-constants-stubs.threads = yes test-constants-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-constants-stubs: PROJECT=test-constants-stubs test-constants-stubs: $$(LIB_TARGETS) test-constants-stub-generator.dir = tests/test-constants/stub-generator test-constants-stub-generator.threads = yes test-constants-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-constants-stubs tests-common test-constants-stub-generator.deps = str bigarray bytes test-constants-stub-generator: PROJECT=test-constants-stub-generator test-constants-stub-generator: $$(BEST_TARGET) test-constants.dir = tests/test-constants test-constants.threads = yes test-constants.deps = str bigarray oUnit bytes test-constants.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs test-constants-stubs tests-common test-constants.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-constants: PROJECT=test-constants test-constants: $$(BEST_TARGET) test-constants-generated: \ tests/test-constants/generated_bindings.ml \ tests/test-constants/generated_stubs.c \ tests/test-constants/generated_struct_bindings.ml \ $(BUILDDIR)/tests/test-constants/generated_struct_stubs.c tests/test-constants/generated_stubs.c: $(BUILDDIR)/test-constants-stub-generator.$(BEST) $< --c-file $@ tests/test-constants/generated_bindings.ml: $(BUILDDIR)/test-constants-stub-generator.$(BEST) $< --ml-file $@ tests/test-constants/generated_struct_bindings.ml: $(BUILDDIR)/test-constants-ml-stub-generator.$(BEST) $< > $@ $(BUILDDIR)/test-constants-ml-stub-generator.$(BEST): $(BUILDDIR)/tests/test-constants/generated_struct_stubs.c $(CC) -I `$(OCAMLFIND) ocamlc -where | sed 's|\r$$||'` $(CFLAGS) $(LDFLAGS) $(WINLDFLAGS) -o $@ $^ $(BUILDDIR)/tests/test-constants/generated_struct_stubs.c: $(BUILDDIR)/test-constants-stub-generator.$(BEST) $< --c-struct-file $@ test-finalisers.dir = tests/test-finalisers test-finalisers.threads = yes test-finalisers.deps = str bigarray oUnit bytes test-finalisers.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-threaded test-finalisers: PROJECT=test-finalisers test-finalisers: $$(BEST_TARGET) test-cstdlib-stubs.dir = tests/test-cstdlib/stubs test-cstdlib-stubs.threads = yes test-cstdlib-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-cstdlib-stubs: PROJECT=test-cstdlib-stubs test-cstdlib-stubs: $$(LIB_TARGETS) test-cstdlib-stub-generator.dir = tests/test-cstdlib/stub-generator test-cstdlib-stub-generator.threads = yes test-cstdlib-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-cstdlib-stubs tests-common test-cstdlib-stub-generator.deps = str bigarray bytes test-cstdlib-stub-generator: PROJECT=test-cstdlib-stub-generator test-cstdlib-stub-generator: $$(BEST_TARGET) test-cstdlib.dir = tests/test-cstdlib test-cstdlib.threads = yes test-cstdlib.deps = str bigarray oUnit bytes test-cstdlib.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs test-cstdlib-stubs tests-common test-cstdlib.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-cstdlib: PROJECT=test-cstdlib test-cstdlib: $$(BEST_TARGET) test-cstdlib-generated: \ tests/test-cstdlib/generated_bindings.ml \ tests/test-cstdlib/generated_stubs.c tests/test-cstdlib/generated_stubs.c: $(BUILDDIR)/test-cstdlib-stub-generator.$(BEST) $< --c-file $@ tests/test-cstdlib/generated_bindings.ml: $(BUILDDIR)/test-cstdlib-stub-generator.$(BEST) $< --ml-file $@ test-sizeof.dir = tests/test-sizeof test-sizeof.threads = yes test-sizeof.deps = str bigarray oUnit bytes test-sizeof.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-threaded test-sizeof: PROJECT=test-sizeof test-sizeof: $$(BEST_TARGET) test-foreign_values-stubs.dir = tests/test-foreign_values/stubs test-foreign_values-stubs.threads = yes test-foreign_values-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-foreign_values-stubs: PROJECT=test-foreign_values-stubs test-foreign_values-stubs: $$(LIB_TARGETS) test-foreign_values-stub-generator.dir = tests/test-foreign_values/stub-generator test-foreign_values-stub-generator.threads = yes test-foreign_values-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-foreign_values-stubs tests-common test-foreign_values-stub-generator.deps = str bigarray bytes test-foreign_values-stub-generator: PROJECT=test-foreign_values-stub-generator test-foreign_values-stub-generator: $$(BEST_TARGET) test-foreign_values.dir = tests/test-foreign_values test-foreign_values.threads = yes test-foreign_values.deps = str bigarray oUnit bytes test-foreign_values.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs tests-common test-foreign_values-stubs test-foreign_values.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-foreign_values: PROJECT=test-foreign_values test-foreign_values: $$(BEST_TARGET) test-foreign_values-generated: \ tests/test-foreign_values/generated_bindings.ml \ tests/test-foreign_values/generated_stubs.c tests/test-foreign_values/generated_stubs.c: $(BUILDDIR)/test-foreign_values-stub-generator.$(BEST) $< --c-file $@ tests/test-foreign_values/generated_bindings.ml: $(BUILDDIR)/test-foreign_values-stub-generator.$(BEST) $< --ml-file $@ test-unions-stubs.dir = tests/test-unions/stubs test-unions-stubs.threads = yes test-unions-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-unions-stubs: PROJECT=test-unions-stubs test-unions-stubs: $$(LIB_TARGETS) test-unions-stub-generator.dir = tests/test-unions/stub-generator test-unions-stub-generator.threads = yes test-unions-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-unions-stubs tests-common test-unions-stub-generator.deps = str bigarray bytes test-unions-stub-generator: PROJECT=test-unions-stub-generator test-unions-stub-generator: $$(BEST_TARGET) test-unions.dir = tests/test-unions test-unions.threads = yes test-unions.deps = str bigarray oUnit bytes test-unions.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs test-unions-stubs tests-common test-unions.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-unions: PROJECT=test-unions test-unions: $$(BEST_TARGET) test-unions-generated: \ tests/test-unions/generated_bindings.ml \ tests/test-unions/generated_stubs.c \ tests/test-unions/generated_struct_bindings.ml \ $(BUILDDIR)/tests/test-unions/generated_struct_stubs.c tests/test-unions/generated_stubs.c: $(BUILDDIR)/test-unions-stub-generator.$(BEST) $< --c-file $@ tests/test-unions/generated_bindings.ml: $(BUILDDIR)/test-unions-stub-generator.$(BEST) $< --ml-file $@ tests/test-unions/generated_struct_bindings.ml: $(BUILDDIR)/test-unions-ml-stub-generator.$(BEST) $< > $@ $(BUILDDIR)/test-unions-ml-stub-generator.$(BEST): $(BUILDDIR)/tests/test-unions/generated_struct_stubs.c $(CC) -I `$(OCAMLFIND) ocamlc -where | sed 's|\r$$||'` $(CFLAGS) $(LDFLAGS) $(WINLDFLAGS) -o $@ $^ $(BUILDDIR)/tests/test-unions/generated_struct_stubs.c: $(BUILDDIR)/test-unions-stub-generator.$(BEST) $< --c-struct-file $@ test-custom_ops.dir = tests/test-custom_ops test-custom_ops.threads = yes test-custom_ops.deps = str bigarray oUnit bytes test-custom_ops.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-threaded test-custom_ops: PROJECT=test-custom_ops test-custom_ops: $$(BEST_TARGET) test-arrays-stubs.dir = tests/test-arrays/stubs test-arrays-stubs.threads = yes test-arrays-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-arrays-stubs: PROJECT=test-arrays-stubs test-arrays-stubs: $$(LIB_TARGETS) test-arrays-stub-generator.dir = tests/test-arrays/stub-generator test-arrays-stub-generator.threads = yes test-arrays-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-arrays-stubs tests-common test-arrays-stub-generator.deps = str bigarray bytes test-arrays-stub-generator: PROJECT=test-arrays-stub-generator test-arrays-stub-generator: $$(BEST_TARGET) test-arrays.dir = tests/test-arrays test-arrays.threads = yes test-arrays.deps = str bigarray oUnit bytes test-arrays.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs test-arrays-stubs tests-common test-arrays.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-arrays: PROJECT=test-arrays test-arrays: $$(BEST_TARGET) test-arrays-generated: \ tests/test-arrays/generated_bindings.ml \ tests/test-arrays/generated_stubs.c tests/test-arrays/generated_stubs.c: $(BUILDDIR)/test-arrays-stub-generator.$(BEST) $< --c-file $@ tests/test-arrays/generated_bindings.ml: $(BUILDDIR)/test-arrays-stub-generator.$(BEST) $< --ml-file $@ test-foreign-errno.dir = tests/test-foreign-errno test-foreign-errno.threads = yes test-foreign-errno.deps = str bigarray oUnit bytes test-foreign-errno.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-threaded test-foreign-errno: PROJECT=test-foreign-errno test-foreign-errno: $$(BEST_TARGET) test-passable.dir = tests/test-passable test-passable.threads = yes test-passable.deps = str bigarray oUnit bytes test-passable.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-threaded test-passable: PROJECT=test-passable test-passable: $$(BEST_TARGET) test-alignment.dir = tests/test-alignment test-alignment.threads = yes test-alignment.deps = str bigarray oUnit bytes test-alignment.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-threaded test-alignment: PROJECT=test-alignment test-alignment: $$(BEST_TARGET) test-views-stubs.dir = tests/test-views/stubs test-views-stubs.threads = yes test-views-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-views-stubs: PROJECT=test-views-stubs test-views-stubs: $$(LIB_TARGETS) test-views-stub-generator.dir = tests/test-views/stub-generator test-views-stub-generator.threads = yes test-views-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-views-stubs tests-common test-views-stub-generator.deps = str bigarray bytes test-views-stub-generator: PROJECT=test-views-stub-generator test-views-stub-generator: $$(BEST_TARGET) test-views.dir = tests/test-views test-views.threads = yes test-views.deps = str bigarray oUnit bytes test-views.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-threaded cstubs test-views-stubs tests-common test-views.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-views: PROJECT=test-views test-views: $$(BEST_TARGET) test-views-generated: \ tests/test-views/generated_bindings.ml \ tests/test-views/generated_stubs.c tests/test-views/generated_stubs.c: $(BUILDDIR)/test-views-stub-generator.$(BEST) $< --c-file $@ tests/test-views/generated_bindings.ml: $(BUILDDIR)/test-views-stub-generator.$(BEST) $< --ml-file $@ test-oo_style-stubs.dir = tests/test-oo_style/stubs test-oo_style-stubs.threads = yes test-oo_style-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-oo_style-stubs: PROJECT=test-oo_style-stubs test-oo_style-stubs: $$(LIB_TARGETS) test-oo_style-stub-generator.dir = tests/test-oo_style/stub-generator test-oo_style-stub-generator.threads = yes test-oo_style-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-oo_style-stubs tests-common test-oo_style-stub-generator.deps = str bigarray bytes test-oo_style-stub-generator: PROJECT=test-oo_style-stub-generator test-oo_style-stub-generator: $$(BEST_TARGET) test-oo_style.dir = tests/test-oo_style test-oo_style.threads = yes test-oo_style.deps = str bigarray oUnit bytes test-oo_style.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs test-oo_style-stubs tests-common test-oo_style.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-oo_style: PROJECT=test-oo_style test-oo_style: $$(BEST_TARGET) test-oo_style-generated: \ tests/test-oo_style/generated_bindings.ml \ tests/test-oo_style/generated_stubs.c tests/test-oo_style/generated_stubs.c: $(BUILDDIR)/test-oo_style-stub-generator.$(BEST) $< --c-file $@ tests/test-oo_style/generated_bindings.ml: $(BUILDDIR)/test-oo_style-stub-generator.$(BEST) $< --ml-file $@ test-type_printing.dir = tests/test-type_printing test-type_printing.threads = yes test-type_printing.deps = str bigarray oUnit bytes test-type_printing.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-threaded test-type_printing: PROJECT=test-type_printing test-type_printing: $$(BEST_TARGET) test-value_printing-stubs.dir = tests/test-value_printing/stubs test-value_printing-stubs.threads = yes test-value_printing-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-value_printing-stubs: PROJECT=test-value_printing-stubs test-value_printing-stubs: $$(LIB_TARGETS) test-value_printing-stub-generator.dir = tests/test-value_printing/stub-generator test-value_printing-stub-generator.threads = yes test-value_printing-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-value_printing-stubs tests-common test-value_printing-stub-generator.deps = str bigarray bytes test-value_printing-stub-generator: PROJECT=test-value_printing-stub-generator test-value_printing-stub-generator: $$(BEST_TARGET) test-value_printing.dir = tests/test-value_printing test-value_printing.threads = yes test-value_printing.deps = str bigarray oUnit bytes test-value_printing.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs tests-common test-value_printing-stubs test-value_printing.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-value_printing: PROJECT=test-value_printing test-value_printing: $$(BEST_TARGET) test-value_printing-generated: \ tests/test-value_printing/generated_bindings.ml \ tests/test-value_printing/generated_stubs.c tests/test-value_printing/generated_stubs.c: $(BUILDDIR)/test-value_printing-stub-generator.$(BEST) $< --c-file $@ tests/test-value_printing/generated_bindings.ml: $(BUILDDIR)/test-value_printing-stub-generator.$(BEST) $< --ml-file $@ test-complex-stubs.dir = tests/test-complex/stubs test-complex-stubs.threads = yes test-complex-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-complex-stubs: PROJECT=test-complex-stubs test-complex-stubs: $$(LIB_TARGETS) test-complex-stub-generator.dir = tests/test-complex/stub-generator test-complex-stub-generator.threads = yes test-complex-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-complex-stubs tests-common test-complex-stub-generator.deps = str bigarray bytes test-complex-stub-generator: PROJECT=test-complex-stub-generator test-complex-stub-generator: $$(BEST_TARGET) test-complex.dir = tests/test-complex test-complex.threads = yes test-complex.deps = str bigarray oUnit bytes test-complex.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs tests-common test-complex-stubs test-complex.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-complex: PROJECT=test-complex test-complex: $$(BEST_TARGET) test-complex-generated: \ tests/test-complex/generated_bindings.ml \ tests/test-complex/generated_stubs.c tests/test-complex/generated_stubs.c: $(BUILDDIR)/test-complex-stub-generator.$(BEST) $< --c-file $@ tests/test-complex/generated_bindings.ml: $(BUILDDIR)/test-complex-stub-generator.$(BEST) $< --ml-file $@ test-bools-stubs.dir = tests/test-bools/stubs test-bools-stubs.threads = yes test-bools-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-bools-stubs: PROJECT=test-bools-stubs test-bools-stubs: $$(LIB_TARGETS) test-bools-stub-generator.dir = tests/test-bools/stub-generator test-bools-stub-generator.threads = yes test-bools-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-bools-stubs tests-common test-bools-stub-generator.deps = str bigarray bytes test-bools-stub-generator: PROJECT=test-bools-stub-generator test-bools-stub-generator: $$(BEST_TARGET) test-bools.dir = tests/test-bools test-bools.threads = yes test-bools.deps = str bigarray oUnit bytes test-bools.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs tests-common test-bools-stubs test-bools.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-bools: PROJECT=test-bools test-bools: $$(BEST_TARGET) test-bools-generated: \ tests/test-bools/generated_bindings.ml \ tests/test-bools/generated_stubs.c tests/test-bools/generated_stubs.c: $(BUILDDIR)/test-bools-stub-generator.$(BEST) $< --c-file $@ tests/test-bools/generated_bindings.ml: $(BUILDDIR)/test-bools-stub-generator.$(BEST) $< --ml-file $@ test-callback_lifetime-stubs.dir = tests/test-callback_lifetime/stubs test-callback_lifetime-stubs.threads = yes test-callback_lifetime-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-callback_lifetime-stubs: PROJECT=test-callback_lifetime-stubs test-callback_lifetime-stubs: $$(LIB_TARGETS) test-callback_lifetime-stub-generator.dir = tests/test-callback_lifetime/stub-generator test-callback_lifetime-stub-generator.threads = yes test-callback_lifetime-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-callback_lifetime-stubs tests-common test-callback_lifetime-stub-generator.deps = str bigarray bytes test-callback_lifetime-stub-generator: PROJECT=test-callback_lifetime-stub-generator test-callback_lifetime-stub-generator: $$(BEST_TARGET) test-callback_lifetime.dir = tests/test-callback_lifetime test-callback_lifetime.threads = yes test-callback_lifetime.deps = str bigarray oUnit bytes test-callback_lifetime.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs test-callback_lifetime-stubs tests-common test-callback_lifetime.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-callback_lifetime: PROJECT=test-callback_lifetime test-callback_lifetime: $$(BEST_TARGET) test-callback_lifetime-generated: \ tests/test-callback_lifetime/generated_bindings.ml \ tests/test-callback_lifetime/generated_stubs.c tests/test-callback_lifetime/generated_stubs.c: $(BUILDDIR)/test-callback_lifetime-stub-generator.$(BEST) $< --c-file $@ tests/test-callback_lifetime/generated_bindings.ml: $(BUILDDIR)/test-callback_lifetime-stub-generator.$(BEST) $< --ml-file $@ test-stubs.dir = tests/test-stubs test-stubs.threads = yes test-stubs.deps = str bigarray oUnit bytes test-stubs.subproject_deps = ctypes ctypes-foreign-base ctypes-foreign-threaded test-stubs: PROJECT=test-stubs test-stubs: $$(BEST_TARGET) test-bigarrays-stubs.dir = tests/test-bigarrays/stubs test-bigarrays-stubs.threads = yes test-bigarrays-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-bigarrays-stubs: PROJECT=test-bigarrays-stubs test-bigarrays-stubs: $$(LIB_TARGETS) test-bigarrays-stub-generator.dir = tests/test-bigarrays/stub-generator test-bigarrays-stub-generator.threads = yes test-bigarrays-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-bigarrays-stubs tests-common test-bigarrays-stub-generator.deps = str bigarray bytes test-bigarrays-stub-generator: PROJECT=test-bigarrays-stub-generator test-bigarrays-stub-generator: $$(BEST_TARGET) test-bigarrays.dir = tests/test-bigarrays test-bigarrays.threads = yes test-bigarrays.deps = str bigarray oUnit bytes test-bigarrays.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs tests-common test-bigarrays-stubs test-bigarrays.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-bigarrays: PROJECT=test-bigarrays test-bigarrays: $$(BEST_TARGET) test-bigarrays-generated: \ tests/test-bigarrays/generated_bindings.ml \ tests/test-bigarrays/generated_stubs.c tests/test-bigarrays/generated_stubs.c: $(BUILDDIR)/test-bigarrays-stub-generator.$(BEST) $< --c-file $@ tests/test-bigarrays/generated_bindings.ml: $(BUILDDIR)/test-bigarrays-stub-generator.$(BEST) $< --ml-file $@ test-coercions-stubs.dir = tests/test-coercions/stubs test-coercions-stubs.threads = yes test-coercions-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-coercions-stubs: PROJECT=test-coercions-stubs test-coercions-stubs: $$(LIB_TARGETS) test-coercions-stub-generator.dir = tests/test-coercions/stub-generator test-coercions-stub-generator.threads = yes test-coercions-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-coercions-stubs tests-common test-coercions-stub-generator.deps = str bigarray bytes test-coercions-stub-generator: PROJECT=test-coercions-stub-generator test-coercions-stub-generator: $$(BEST_TARGET) test-coercions.dir = tests/test-coercions test-coercions.threads = yes test-coercions.deps = str bigarray oUnit bytes test-coercions.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs tests-common test-coercions-stubs test-coercions.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-coercions: PROJECT=test-coercions test-coercions: $$(BEST_TARGET) test-coercions-generated: \ tests/test-coercions/generated_bindings.ml \ tests/test-coercions/generated_stubs.c tests/test-coercions/generated_stubs.c: $(BUILDDIR)/test-coercions-stub-generator.$(BEST) $< --c-file $@ tests/test-coercions/generated_bindings.ml: $(BUILDDIR)/test-coercions-stub-generator.$(BEST) $< --ml-file $@ test-roots.dir = tests/test-roots test-roots.threads = yes test-roots.deps = str bigarray oUnit bytes test-roots.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs tests-common test-roots.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-roots: PROJECT=test-roots test-roots: $$(BEST_TARGET) test-passing-ocaml-values-stubs.dir = tests/test-passing-ocaml-values/stubs test-passing-ocaml-values-stubs.threads = yes test-passing-ocaml-values-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-passing-ocaml-values-stubs: PROJECT=test-passing-ocaml-values-stubs test-passing-ocaml-values-stubs: $$(LIB_TARGETS) test-passing-ocaml-values-stub-generator.dir = tests/test-passing-ocaml-values/stub-generator test-passing-ocaml-values-stub-generator.threads = yes test-passing-ocaml-values-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-passing-ocaml-values-stubs tests-common test-passing-ocaml-values-stub-generator.deps = str bigarray bytes test-passing-ocaml-values-stub-generator: PROJECT=test-passing-ocaml-values-stub-generator test-passing-ocaml-values-stub-generator: $$(BEST_TARGET) test-passing-ocaml-values.dir = tests/test-passing-ocaml-values test-passing-ocaml-values.threads = yes test-passing-ocaml-values.deps = str bigarray oUnit bytes test-passing-ocaml-values.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs tests-common test-passing-ocaml-values-stubs test-passing-ocaml-values.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-passing-ocaml-values: PROJECT=test-passing-ocaml-values test-passing-ocaml-values: $$(BEST_TARGET) test-passing-ocaml-values-generated: \ tests/test-passing-ocaml-values/generated_bindings.ml \ tests/test-passing-ocaml-values/generated_stubs.c tests/test-passing-ocaml-values/generated_stubs.c: $(BUILDDIR)/test-passing-ocaml-values-stub-generator.$(BEST) $< --c-file $@ tests/test-passing-ocaml-values/generated_bindings.ml: $(BUILDDIR)/test-passing-ocaml-values-stub-generator.$(BEST) $< --ml-file $@ test-lwt-jobs-stubs.dir = tests/test-lwt-jobs/stubs test-lwt-jobs-stubs.threads = yes test-lwt-jobs-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-lwt-jobs-stubs: PROJECT=test-lwt-jobs-stubs test-lwt-jobs-stubs: $$(LIB_TARGETS) test-lwt-jobs-stub-generator.dir = tests/test-lwt-jobs/stub-generator test-lwt-jobs-stub-generator.threads = yes test-lwt-jobs-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-lwt-jobs-stubs tests-common test-lwt-jobs-stub-generator.deps = str bigarray bytes test-lwt-jobs-stub-generator: PROJECT=test-lwt-jobs-stub-generator test-lwt-jobs-stub-generator: $$(BEST_TARGET) test-lwt-jobs.dir = tests/test-lwt-jobs test-lwt-jobs.threads = yes test-lwt-jobs.deps = str bigarray oUnit bytes lwt.unix test-lwt-jobs.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs tests-common test-lwt-jobs-stubs test-lwt-jobs.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-lwt-jobs: PROJECT=test-lwt-jobs test-lwt-jobs: $$(BEST_TARGET) test-lwt-jobs-generated: \ tests/test-lwt-jobs/generated_bindings.ml \ tests/test-lwt-jobs/generated_stubs.c \ tests/test-lwt-jobs/generated_struct_bindings.ml \ $(BUILDDIR)/tests/test-lwt-jobs/generated_struct_stubs.c tests/test-lwt-jobs/generated_stubs.c: $(BUILDDIR)/test-lwt-jobs-stub-generator.$(BEST) $< --c-file $@ tests/test-lwt-jobs/generated_bindings.ml: $(BUILDDIR)/test-lwt-jobs-stub-generator.$(BEST) $< --ml-file $@ tests/test-lwt-jobs/generated_struct_bindings.ml: $(BUILDDIR)/test-lwt-jobs-ml-stub-generator.$(BEST) $< > $@ $(BUILDDIR)/test-lwt-jobs-ml-stub-generator.$(BEST): $(BUILDDIR)/tests/test-lwt-jobs/generated_struct_stubs.c $(CC) -I `$(OCAMLFIND) ocamlc -where | sed 's|\r$$||'` $(CFLAGS) $(LDFLAGS) $(WINLDFLAGS) -o $@ $^ $(BUILDDIR)/tests/test-lwt-jobs/generated_struct_stubs.c: $(BUILDDIR)/test-lwt-jobs-stub-generator.$(BEST) $< --c-struct-file $@ test-returning-errno-lwt-stubs.dir = tests/test-returning-errno-lwt/stubs test-returning-errno-lwt-stubs.threads = yes test-returning-errno-lwt-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-returning-errno-lwt-stubs: PROJECT=test-returning-errno-lwt-stubs test-returning-errno-lwt-stubs: $$(LIB_TARGETS) test-returning-errno-lwt-stub-generator.dir = tests/test-returning-errno-lwt/stub-generator test-returning-errno-lwt-stub-generator.threads = yes test-returning-errno-lwt-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-returning-errno-lwt-stubs tests-common test-returning-errno-lwt-stub-generator.deps = str bigarray bytes test-returning-errno-lwt-stub-generator: PROJECT=test-returning-errno-lwt-stub-generator test-returning-errno-lwt-stub-generator: $$(BEST_TARGET) test-returning-errno-lwt.dir = tests/test-returning-errno-lwt test-returning-errno-lwt.threads = yes test-returning-errno-lwt.deps = str bigarray oUnit bytes lwt.unix test-returning-errno-lwt.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs tests-common test-returning-errno-lwt-stubs test-returning-errno-lwt.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-returning-errno-lwt: PROJECT=test-returning-errno-lwt test-returning-errno-lwt: $$(BEST_TARGET) test-returning-errno-lwt-generated: \ tests/test-returning-errno-lwt/generated_bindings.ml \ tests/test-returning-errno-lwt/generated_struct_bindings.ml \ tests/test-returning-errno-lwt/generated_stubs.c tests/test-returning-errno-lwt/generated_stubs.c: $(BUILDDIR)/test-returning-errno-lwt-stub-generator.$(BEST) $< --c-file $@ tests/test-returning-errno-lwt/generated_bindings.ml: $(BUILDDIR)/test-returning-errno-lwt-stub-generator.$(BEST) $< --ml-file $@ tests/test-returning-errno-lwt/generated_struct_bindings.ml: $(BUILDDIR)/test-returning-errno-lwt-ml-stub-generator.$(BEST) $< > $@ $(BUILDDIR)/test-returning-errno-lwt-ml-stub-generator.$(BEST): $(BUILDDIR)/tests/test-returning-errno-lwt/generated_struct_stubs.c $(CC) -I `$(OCAMLFIND) ocamlc -where | sed 's|\r$$||'` $(CFLAGS) $(LDFLAGS) $(WINLDFLAGS) -o $@ $^ $(BUILDDIR)/tests/test-returning-errno-lwt/generated_struct_stubs.c: $(BUILDDIR)/test-returning-errno-lwt-stub-generator.$(BEST) $< --c-struct-file $@ test-returning-errno-stubs.dir = tests/test-returning-errno/stubs test-returning-errno-stubs.threads = yes test-returning-errno-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-returning-errno-stubs: PROJECT=test-returning-errno-stubs test-returning-errno-stubs: $$(LIB_TARGETS) test-returning-errno-stub-generator.dir = tests/test-returning-errno/stub-generator test-returning-errno-stub-generator.threads = yes test-returning-errno-stub-generator.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded test-returning-errno-stubs tests-common test-returning-errno-stub-generator.deps = str bigarray bytes test-returning-errno-stub-generator: PROJECT=test-returning-errno-stub-generator test-returning-errno-stub-generator: $$(BEST_TARGET) test-returning-errno.dir = tests/test-returning-errno test-returning-errno.threads = yes test-returning-errno.deps = str bigarray oUnit bytes lwt.unix test-returning-errno.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs tests-common test-returning-errno-stubs test-returning-errno.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-returning-errno: PROJECT=test-returning-errno test-returning-errno: $$(BEST_TARGET) test-returning-errno-generated: \ tests/test-returning-errno/generated_bindings.ml \ tests/test-returning-errno/generated_struct_bindings.ml \ tests/test-returning-errno/generated_stubs.c tests/test-returning-errno/generated_stubs.c: $(BUILDDIR)/test-returning-errno-stub-generator.$(BEST) $< --c-file $@ tests/test-returning-errno/generated_bindings.ml: $(BUILDDIR)/test-returning-errno-stub-generator.$(BEST) $< --ml-file $@ tests/test-returning-errno/generated_struct_bindings.ml: $(BUILDDIR)/test-returning-errno-ml-stub-generator.$(BEST) $< > $@ $(BUILDDIR)/test-returning-errno-ml-stub-generator.$(BEST): $(BUILDDIR)/tests/test-returning-errno/generated_struct_stubs.c $(CC) -I `$(OCAMLFIND) ocamlc -where | sed 's|\r$$||'` $(CFLAGS) $(LDFLAGS) $(WINLDFLAGS) -o $@ $^ $(BUILDDIR)/tests/test-returning-errno/generated_struct_stubs.c: $(BUILDDIR)/test-returning-errno-stub-generator.$(BEST) $< --c-struct-file $@ test-threads-stubs.dir = tests/test-threads/stubs test-threads-stubs.threads = yes test-threads-stubs.subproject_deps = ctypes cstubs \ ctypes-foreign-base ctypes-foreign-threaded tests-common test-threads-stubs: PROJECT=test-threads-stubs test-threads-stubs: $$(LIB_TARGETS) test-threads.dir = tests/test-threads test-threads.threads = yes test-threads.deps = str bigarray oUnit bytes test-threads.subproject_deps = ctypes ctypes-foreign-base \ ctypes-foreign-threaded cstubs tests-common test-threads-stubs test-threads.link_flags = -L$(BUILDDIR)/clib -ltest_functions test-threads: PROJECT=test-threads test-threads: $$(BEST_TARGET) TESTS = TESTS += test-raw TESTS += test-pointers-stubs test-pointers-stub-generator test-pointers-generated test-pointers TESTS += test-variadic-stubs test-variadic-stub-generator test-variadic-generated test-variadic TESTS += test-builtins-stubs test-builtins-stub-generator test-builtins-generated test-builtins TESTS += test-macros-stubs test-macros-stub-generator test-macros-generated test-macros TESTS += test-higher_order-stubs test-higher_order-stub-generator test-higher_order-generated test-higher_order TESTS += test-enums-struct-stubs test-enums-struct-stub-generator test-enums-structs-generated test-enums-stubs test-enums-stub-generator test-enums-generated test-enums TESTS += test-structs-stubs test-structs-stub-generator test-structs-generated test-structs TESTS += test-constants-stubs test-constants-stub-generator test-constants-generated test-constants TESTS += test-finalisers TESTS += test-cstdlib-stubs test-cstdlib-stub-generator test-cstdlib-generated test-cstdlib TESTS += test-sizeof TESTS += test-foreign_values-stubs test-foreign_values-stub-generator test-foreign_values-generated test-foreign_values TESTS += test-unions-stubs test-unions-stub-generator test-unions-generated test-unions TESTS += test-custom_ops TESTS += test-arrays-stubs test-arrays-stub-generator test-arrays-generated test-arrays TESTS += test-foreign-errno TESTS += test-passable TESTS += test-alignment TESTS += test-views-stubs test-views-stub-generator test-views-generated test-views TESTS += test-oo_style-stubs test-oo_style-stub-generator test-oo_style-generated test-oo_style TESTS += test-type_printing TESTS += test-value_printing-stubs test-value_printing-stub-generator test-value_printing-generated test-value_printing TESTS += test-complex-stubs test-complex-stub-generator test-complex-generated test-complex TESTS += test-bools-stubs test-bools-stub-generator test-bools-generated test-bools TESTS += test-callback_lifetime-stubs test-callback_lifetime-stub-generator test-callback_lifetime-generated test-callback_lifetime TESTS += test-stubs TESTS += test-bigarrays-stubs test-bigarrays-stub-generator test-bigarrays-generated test-bigarrays TESTS += test-coercions-stubs test-coercions-stub-generator test-coercions-generated test-coercions TESTS += test-roots TESTS += test-passing-ocaml-values-stubs test-passing-ocaml-values-stub-generator test-passing-ocaml-values-generated test-passing-ocaml-values TESTS += test-lwt-jobs-stubs test-lwt-jobs-stub-generator test-lwt-jobs-generated test-lwt-jobs TESTS += test-returning-errno-lwt-stubs test-returning-errno-lwt-stub-generator test-returning-errno-lwt-generated test-returning-errno-lwt TESTS += test-returning-errno-stubs test-returning-errno-stub-generator test-returning-errno-generated test-returning-errno TESTS += test-threads-stubs test-threads ifneq (,$(filter mingw%,$(OSYSTEM))) WINLDFLAGS=-Wl,--out-implib,libtest_functions.dll.a LDFLAGS+=-static-libgcc endif testlib: $(BUILDDIR)/clib/libtest_functions$(EXTDLL) $(BUILDDIR)/clib/libtest_functions$(EXTDLL): $(BUILDDIR)/clib/test_functions.o $(CC) -shared $(LDFLAGS) $(WINLDFLAGS) -o $@ $^ ifneq (,$(filter mingw%,$(OSYSTEM))) cp $@ libtest_functions.dll.a $(BUILDDIR) endif $(BUILDDIR)/clib/test_functions.o: tests/clib/test_functions.c @mkdir -p $(@D) $(CC) -c $(CFLAGS) -I `$(OCAMLFIND) ocamlc -where | sed 's|\r$$||'` -o $@ $^ tests/clib/test_functions.c: tests/clib/test_functions.h .PHONY: test testlib $(TESTS) tests-common test: build testlib tests-common $(TESTS) \ $(filter-out %-stubs,\ $(filter-out %-stub-generator,\ $(filter-out %-generated,\ $(TESTS:%=run-%)))) run-%: $* @echo running $* @cd $(BUILDDIR) && CAML_LD_LIBRARY_PATH=. LD_LIBRARY_PATH=clib DYLD_LIBRARY_PATH=clib ./$*.$(BEST) -runner sequential ocaml-ctypes-0.7.0/README.md000066400000000000000000000076101274143137600154110ustar00rootroot00000000000000ctypes 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! [![Travis build Status](https://travis-ci.org/ocamllabs/ocaml-ctypes.svg?branch=master)](https://travis-ci.org/ocamllabs/ocaml-ctypes) [![AppVeyor build status](https://ci.appveyor.com/api/projects/status/n5geenq8sinlptfv/branch/master?svg=true)](https://ci.appveyor.com/project/yallop/ocaml-ctypes/branch/master) ## Usage Suppose you want to bind to the following C functions: ```C int sigemptyset(sigset_t *set); int sigfillset(sigset_t *set); int sigaddset(sigset_t *set, int signum); int sigdelset(sigset_t *set, int signum); int sigismember(const sigset_t *set, int signum); ``` Using ctypes you can describe the interfaces to these functions as follows: ```OCaml let sigemptyset = foreign "sigemptyset" (ptr sigset_t @-> returning int) let sigfillset = foreign "sigfillset" (ptr sigset_t @-> returning int) let sigaddset = foreign "sigaddset" (ptr sigset_t @-> int @-> returning int) let sigdelset = foreign "sigdelset" (ptr sigset_t @-> int @-> returning int) let sigismember = foreign "sigismember" (ptr sigset_t @-> int @-> returning int) ``` The names bound by this code have the types you might expect: ```OCaml val sigemptyset : sigset_t ptr -> int val sigfillset : sigset_t ptr -> int val sigaddset : sigset_t ptr -> int -> int val sigdelset : sigset_t ptr -> int -> int val sigismember : sigset_t ptr -> int -> int ``` That's all there is to it. Unlike the [usual way](http://caml.inria.fr/pub/docs/manual-ocaml/intfc.html) of writing C extensions, there are no C "stub" functions to write, so there's much less opportunity for error. The documentation and source distribution contain more complex examples, involving structs, unions, arrays, callback functions, and so on, and show how to create and use C values (like instances of `sigset_t ptr`) in OCaml. ## Links * [Chapter 19: Foreign Function Interface][rwo-19] of [Real World OCaml][rwo] describes ctypes * [Modular Foreign Function Bindings][mirage-blogpost] introduces ctypes in the context of the [Mirage][mirage] library operating system * [Tutorial][tutorial] * [API documentation][apidoc] * [Mailing list][mailing-list] * [Type-safe C bindings using ocaml-ctypes and stub generation][sjb-cstubs-post] introduces the [Cstubs][cstubs] interface * [Using Cstubs_structs][orbitz-cstubs_structs] shows how to use the [`Cstubs_structs`][cstubs_structs] module to reliably determine data layout * [Declarative foreign function binding through generic programming][flops-paper] is a research paper that presents the design of ctypes * [FAQ][faq] [rwo-19]: https://realworldocaml.org/v1/en/html/foreign-function-interface.html [rwo]: http://realworldocaml.org/ [mirage-blogpost]: http://openmirage.org/blog/modular-foreign-function-bindings [tutorial]: https://github.com/ocamllabs/ocaml-ctypes/wiki/ctypes-tutorial [apidoc]: http://ocamllabs.github.io/ocaml-ctypes [mailing-list]: http://lists.ocaml.org/listinfo/ctypes [faq]: https://github.com/ocamllabs/ocaml-ctypes/wiki/FAQ [mirage]: http://openmirage.org [sjb-cstubs-post]: http://simonjbeaumont.com/posts/ocaml-ctypes/ [cstubs]: https://github.com/ocamllabs/ocaml-ctypes/blob/master/src/cstubs/cstubs.mli [orbitz-cstubs_structs]: https://github.com/ocamllabs/ocaml-ctypes/blob/master/examples/cstubs_structs/README.md [cstubs_structs]: http://ocamllabs.github.io/ocaml-ctypes/Cstubs_structs.html [flops-paper]: http://www.cl.cam.ac.uk/~jdy22/papers/declarative-foreign-function-binding-through-generic-programming.pdf ocaml-ctypes-0.7.0/appveyor.yml000066400000000000000000000031161274143137600165170ustar00rootroot00000000000000os: unstable platform: - x64 environment: global: CYG_ARCH: x86 CYG_ROOT: C:/cygwin matrix: - WODI_ARCH: 32 MINGW_ARCH: i686 WODI_FILE: https://dl.dropbox.com/sh/t9ozci9rso9gij4/AABS0ZGie-RdZDxyRaDKImWVa/wodi32.tar.xz WODI_PACKAGES_FILE: https://dl.dropbox.com/sh/feldcwshtinmdo8/AAAaEK0cJoB1h6UDh4Vbvpaaa/packages32.tar.xz - WODI_ARCH: 64 MINGW_ARCH: x86_64 WODI_FILE: https://dl.dropbox.com/sh/t9ozci9rso9gij4/AADtoDkuFC9ALiLduQ73VOzla/wodi64.tar.xz WODI_PACKAGES_FILE: https://dl.dropbox.com/sh/feldcwshtinmdo8/AADlqehWQ17xVWCW2GGHIo_za/packages64.tar.xz init: - 'echo System architecture: %PLATFORM%' - appveyor DownloadFile "%WODI_FILE%" -FileName "C:/wodi%WODI_ARCH%.tar.xz" - appveyor DownloadFile "%WODI_PACKAGES_FILE%" -FileName "C:/packages%WODI_ARCH%.tar.xz" install: - if not exist "%CYG_ROOT%" mkdir "%CYG_ROOT%" - appveyor DownloadFile "http://cygwin.com/setup-%CYG_ARCH%.exe" -FileName "%CYG_ROOT%\setup.exe" - '"%CYG_ROOT%\setup.exe" -qnBWNd -R "%CYG_ROOT%" -P cygwin -P wget -P dos2unix -P diffutils -P cpio -P make -P patch -P mingw64-%MINGW_ARCH%-gcc-core -P mingw64-%MINGW_ARCH%-gcc-g++ >NUL' - '%CYG_ROOT%/bin/bash -lc "cygcheck -dc cygwin"' - '%CYG_ROOT%/bin/bash -lc "cd \"$OLDPWD\" && ./appveyor/install.sh %WODI_ARCH% %MINGW_ARCH% wodi%WODI_ARCH%.tar.xz packages%WODI_ARCH%.tar.xz"' build_script: - '%CYG_ROOT%/bin/bash -lc "cd \"$OLDPWD\" && ./appveyor/build.sh %WODI_ARCH%"' artifacts: - path: test.log name: test-logs ocaml-ctypes-0.7.0/appveyor/000077500000000000000000000000001274143137600157735ustar00rootroot00000000000000ocaml-ctypes-0.7.0/appveyor/build.sh000077500000000000000000000052161274143137600174350ustar00rootroot00000000000000#!/usr/bin/env bash set -ex WODI_ARCH=$1 type -p ocamlc ocamlc -version build_libffi=0 libffi_version=3.1 x="$(echo 'let () = print_int Sys.word_size ;;' | ocaml -stdin)" case "$x" in *64*) build=x86_64-pc-cygwin host=x86_64-w64-mingw32 MINGW_TOOL_PREFIX=x86_64-w64-mingw32- ;; *) build=i686-pc-cygwin host=i686-w64-mingw32 MINGW_TOOL_PREFIX=i686-w64-mingw32- ;; esac godi_dir=/opt/wodi${WODI_ARCH} export PATH=$godi_dir/sbin:$godi_dir/bin:$PATH export AR=${MINGW_TOOL_PREFIX}ar.exe export AS=${MINGW_TOOL_PREFIX}as.exe export CC=${MINGW_TOOL_PREFIX}gcc.exe export CPP=${MINGW_TOOL_PREFIX}cpp.exe export CPPFILT=${MINGW_TOOL_PREFIX}c++filt.exe export CXX=${MINGW_TOOL_PREFIX}g++.exe export DLLTOOL=${MINGW_TOOL_PREFIX}dlltool.exe export DLLWRAP=${MINGW_TOOL_PREFIX}dllwrap.exe export GCOV=${MINGW_TOOL_PREFIX}gcov.exe export LD=${MINGW_TOOL_PREFIX}ld.exe export NM=${MINGW_TOOL_PREFIX}nm.exe export OBJCOPY=${MINGW_TOOL_PREFIX}objcopy.exe export OBJDUMP=${MINGW_TOOL_PREFIX}objdump.exe export RANLIB=${MINGW_TOOL_PREFIX}ranlib.exe export RC=${MINGW_TOOL_PREFIX}windres.exe export READELF=${MINGW_TOOL_PREFIX}readelf.exe export SIZE=${MINGW_TOOL_PREFIX}size.exe export STRINGS=${MINGW_TOOL_PREFIX}strings.exe export STRIP=${MINGW_TOOL_PREFIX}strip.exe export WINDMC=${MINGW_TOOL_PREFIX}windmc.exe export WINDRES=${MINGW_TOOL_PREFIX}windres.exe # findlib is already installed if [ $build_libffi -ne 0 ]; then # libffi: we need a static version and only a static version ( rm -rf /usr/local mkdir -p /usr/local/include wget ftp://sourceware.org/pub/libffi/libffi-${libffi_version}.tar.gz rm -rf libffi-${libffi_version} tar xfvz libffi-${libffi_version}.tar.gz cd libffi-${libffi_version} (./configure --build="$build" --host="$host" --prefix /usr/local --disable-shared --enable-static &1 | tee test.log; test ${PIPESTATUS[0]} -eq 0) ; then echo "test case failure" >&2 exit 1 fi ocaml-ctypes-0.7.0/appveyor/findlib-patch-create-process.patch000066400000000000000000000016011274143137600244330ustar00rootroot00000000000000diff --git a/findlib-1.5.3/src/findlib/frontend.ml b/findlib-1.5.3/src/findlib/frontend.ml index 1fdb117..bf09ce9 100644 --- a/findlib-1.5.3/src/findlib/frontend.ml +++ b/findlib-1.5.3/src/findlib/frontend.ml @@ -384,13 +384,8 @@ let run_command ?filter verbose cmd args = let () = prerr_endline ("Findlib_config.system : " ^ Findlib_config.system) in let () = prerr_endline ("fixed_cmd : " ^ fixed_cmd) in - let pid = - Unix.create_process - fixed_cmd - (Array.of_list (cmd :: args)) - Unix.stdin - cmd_output - Unix.stderr + let status = + Unix.system (Printf.sprintf "%s %s" fixed_cmd (String.concat " " args)) in begin match filter with @@ -414,7 +409,6 @@ let run_command ?filter verbose cmd args = | None -> () end; - let (_,status) = Unix.waitpid [] pid in Sys.set_signal Sys.sigint old_sigint; begin match status with ocaml-ctypes-0.7.0/appveyor/install.sh000066400000000000000000000012011274143137600177670ustar00rootroot00000000000000#!/usr/bin/env bash set -ex WODI_ARCH=$1 MINGW_ARCH=$2 WODI_FILE=$3 WODI_PACKAGES_FILE=$4 echo "WODI_ARCH: ${WODI_ARCH}" echo "MINGW_ARCH: ${MINGW_ARCH}" echo "WODI_FILE: ${WODI_FILE}" echo "WODI_PACKAGES_FILE: ${WODI_PACKAGES_FILE}" cp C:/${WODI_FILE} /tmp cp C:/${WODI_PACKAGES_FILE} /tmp pushd /tmp rm -rf wodi${WODI_ARCH} tar -xf wodi${WODI_ARCH}.tar.xz tar -xf packages${WODI_ARCH}.tar.xz wodi${WODI_ARCH}/install.sh godi_dir=/opt/wodi${WODI_ARCH} mkdir -p $godi_dir/var/cache/godi mv packages${WODI_ARCH}/* $godi_dir/var/cache/godi export PATH=$godi_dir/sbin:$godi_dir/bin:$PATH godi_add godi-ounit base-libffi godi-lwt popd ocaml-ctypes-0.7.0/ctypes-foreign.opam000066400000000000000000000010271274143137600177420ustar00rootroot00000000000000opam-version: "1.2" version: "dev" maintainer: "yallop@gmail.com" author: "yallop@gmail.com" homepage: "https://github.com/ocamllabs/ocaml-ctypes" dev-repo: "http://github.com/ocamllabs/ocaml-ctypes.git" bug-reports: "http://github.com/ocamllabs/ocaml-ctypes/issues" depexts: [ [ ["debian"] [ "libffi-dev"] ] [ ["ubuntu"] [ "libffi-dev" ] ] [ ["osx" "homebrew"] ["libffi"] ] [ ["centos"] ["libffi-devel"] ] ] tags: ["org:ocamllabs" "org:mirage"] post-messages: [ "This package requires libffi on your system" {failure} ] ocaml-ctypes-0.7.0/ctypes.opam000066400000000000000000000022401274143137600163110ustar00rootroot00000000000000opam-version: "1.2" version: "dev" maintainer: "yallop@gmail.com" author: "yallop@gmail.com" homepage: "https://github.com/ocamllabs/ocaml-ctypes" dev-repo: "http://github.com/ocamllabs/ocaml-ctypes.git" bug-reports: "http://github.com/ocamllabs/ocaml-ctypes/issues" license: "MIT" build: [ [make "XEN=%{mirage-xen:enable}%" "COVERAGE=true" {bisect_ppx:installed} "libffi.config" "ctypes-base" "ctypes-stubs"] [make "XEN=%{mirage-xen:enable}%" "ctypes-foreign"] {ctypes-foreign:installed} ] install: [ [make "install" "XEN=%{mirage-xen:enable}%"] ] remove: [ ["ocamlfind" "remove" "ctypes"] ] depends: [ "base-bytes" "ocamlfind" {build} "conf-pkg-config" {build} "lwt" {test} "ctypes-foreign" {test} "ounit" {test} ] depopts: [ "ctypes-foreign" "mirage-xen" "bisect_ppx" {test} "ocveralls" {test} ] build-test: [ [make "COVERAGE=true" {bisect_ppx:installed} "test"] [make "COVERAGE=true" {bisect_ppx:installed} "run-examples"] ["sh" "-c" "ocveralls" "--send bisect*.out" "_build/bisect*.out" ">" "coveralls.json"] {bisect_ppx:installed} ] tags: ["org:ocamllabs" "org:mirage"] available: [ ocaml-version >= "4.01.0" ] ocaml-ctypes-0.7.0/examples/000077500000000000000000000000001274143137600157445ustar00rootroot00000000000000ocaml-ctypes-0.7.0/examples/cstubs_structs/000077500000000000000000000000001274143137600210365ustar00rootroot00000000000000ocaml-ctypes-0.7.0/examples/cstubs_structs/Makefile000066400000000000000000000031751274143137600225040ustar00rootroot00000000000000all: main # Step 1 bindings.cmx: bindings.ml ocamlfind ocamlopt -w '@f@p@u@s@40' -package ctypes,ctypes.foreign,ctypes.stubs -c bindings.ml # Step 2 bindings_c_gen.cmx: bindings_c_gen.ml bindings.cmx ocamlfind ocamlopt -w '@f@p@u@s@40' -package ctypes,ctypes.foreign,ctypes.stubs -c bindings_c_gen.ml bindings.cmx # Step 3 compiling bindings_c_gen: bindings_c_gen.cmx bindings.cmx ocamlfind ocamlopt -w '@f@p@u@s@40' -package ctypes,ctypes.foreign,ctypes.stubs -linkpkg -o bindings_c_gen bindings.cmx bindings_c_gen.cmx # Step 3 executing bindings_stubs_gen.c: bindings_c_gen ./bindings_c_gen # Step 4 compiling bindings_stubs_gen.o: bindings_stubs_gen.c ocamlfind ocamlc -w '@f@p@u@s@40' -package ctypes,ctypes.foreign -c bindings_stubs_gen.c # Step 4 compiling bindings_stubs_gen: bindings_stubs_gen.o cc -o bindings_stubs_gen bindings_stubs_gen.o # Step 5 bindings_stubs.ml: bindings_stubs_gen ./bindings_stubs_gen > bindings_stubs.ml # Step 6 bindings_stubs.cmx: bindings_stubs.ml ocamlfind ocamlopt -w '@f@p@u@s@40' -package ctypes,ctypes.foreign,ctypes.stubs -c bindings_stubs.ml # Use in the main program main.cmx: bindings_stubs.cmx main.ml ocamlfind ocamlopt -w '@f@p@u@s@40' -package ctypes,ctypes.foreign,ctypes.stubs -c main.ml bindings_stubs.cmx main: main.cmx ocamlfind ocamlopt -w '@f@p@u@s@40' -package ctypes,ctypes.foreign,ctypes.stubs -linkpkg -o main bindings.cmx bindings_stubs.cmx main.cmx clean: -rm *.cmx *.cmi *.c *.o bindings_c_gen bindings_stubs_gen bindings_stubs.ml main with_ocamlbuild: ocamlbuild -use-ocamlfind -package ctypes,ctypes.foreign,ctypes.stubs main.native ocamlbuild_clean: ocamlbuild -clean ocaml-ctypes-0.7.0/examples/cstubs_structs/README.md000066400000000000000000000067371274143137600223320ustar00rootroot00000000000000# Using Cstubs_structs Ctypes is generally used to specify how to call C code using a DSL that is executed at runtime. This works great for functions but has some limitations when it comes to data types and macros. For example, one can define a C struct using the Ctypes DSL, however the complete data type needs to be defined so that Ctypes can calculate the proper size of the struct and the correct offsets of members. However, with some structs one may only want to access part of the struct, or it might be large, or can change across OS and OS versions, or may be constructed using compile-time tools such as macros. In those cases, `Cstubs_structs` provides a powerful tool to use C itself to generate the ML definition of the struct that Ctypes can then use at runtime. This definition will always be correct. Because C is being used to generate the definition, it also gives access to other constructs that only exist at compile time, such as macros. Using Cstubs_structs is a bit of a Rube Goldberg machine, however, no step is superfluous. The series of steps that will be needed are: 1. Write a stubs module that is a functor which defines the bindings. 2. Write a module that uses the bindings module and outputs a C file. 3. Compile the program from step 2 and execute it. 4. Compile the C program generated in step 3. 5. Run the C program from step 4, generating an ML module. 6. Compile the module generated in step 5. The generated module can then be applied to the functor created in step 1. # Example The example program included in this tutorial shows how to partially define a struct and access a macro. The struct is `struct tm`, which is used in the time API in C. And the macro is `SHRT_MAX`, which defines the maximum value a value of type `short` can hold. ## The Makefile This tutorial contains a `Makefile` which builds the tutorial. This is done using a Makefile to make the steps clear and executable anywhere. ## Bindings The file `bindings.ml` defines the functor for the stubs. The struct is defined in the module `Tm` and defines that the value `t` is the structure `tm`. The two fields defined are `tm_hour` and `tm_year`. The actual `struct tm` has several fields in its struct. The strings are important in this case because they will be what the generated C program references. The module `Limits` defines the value `shrt_max` which corresponds to a constant value of type `int`. Again, the string is important because that is the name of the macro which will be referenced. ## C Generator The file `bindings_c_gen.ml` defines the ML program which will generate a C source file when executed. The important line is the one that calls `Cstubs_structs.write_c`. This takes the functor which will be applied as a parameter. This functor is applied to a module that generates the C program and outputs it. ## Using it The file `main.ml` defines a usage of the generated ML file. It applies to the `Bindings.Stubs` functor the module, `Bindings_stubs`, that was generated after running the generated C program. Accessing the struct and constant is the same as if it were generated at runtime. # A lot of steps, but not much code The process of using `Cstubs_structs` is has several steps to it, however the amount of code needed to do the whole thing is fairly small. Most of the magic is in the build process. When binding data types, it might be a good idea to use `Cstubs_structs` as the default tool, it is safer and less fragile then defining a struct completely in Ocaml. ocaml-ctypes-0.7.0/examples/cstubs_structs/bindings.ml000066400000000000000000000005561274143137600231730ustar00rootroot00000000000000module Stubs = functor (S : Cstubs_structs.TYPE) -> struct module Tm = struct type tm type t = tm Ctypes.structure let t : t S.typ = S.structure "tm" let tm_hour = S.(field t "tm_hour" int) let tm_year = S.(field t "tm_year" int) let () = S.seal t end module Limits = struct let shrt_max = S.(constant "SHRT_MAX" short) end end ocaml-ctypes-0.7.0/examples/cstubs_structs/bindings_c_gen.ml000066400000000000000000000005651274143137600243260ustar00rootroot00000000000000let c_headers = "#include \n#include " let main () = let stubs_out = open_out "bindings_stubs_gen.c" in let stubs_fmt = Format.formatter_of_out_channel stubs_out in Format.fprintf stubs_fmt "%s@\n" c_headers; Cstubs_structs.write_c stubs_fmt (module Bindings.Stubs); Format.pp_print_flush stubs_fmt (); close_out stubs_out let () = main () ocaml-ctypes-0.7.0/examples/cstubs_structs/main.ml000066400000000000000000000011601274143137600223120ustar00rootroot00000000000000module Stubs = Bindings.Stubs(Bindings_stubs) let time = Foreign.foreign "time" Ctypes.(ptr PosixTypes.time_t @-> returning PosixTypes.time_t) let gmtime = Foreign.foreign "gmtime" Ctypes.(ptr PosixTypes.time_t @-> returning (ptr Stubs.Tm.t)) let main () = let tme = Ctypes.allocate PosixTypes.time_t (time Ctypes.(from_voidp PosixTypes.time_t null)) in let tm = gmtime tme in Printf.printf "tm_hour = %d\n" Ctypes.(getf (!@ tm) Stubs.Tm.tm_hour); Printf.printf "tm_year = %d\n" Ctypes.(getf (!@ tm) Stubs.Tm.tm_year); Printf.printf "SHRT_MAX = %d\n" Stubs.Limits.shrt_max let () = main () ocaml-ctypes-0.7.0/examples/cstubs_structs/myocamlbuild.ml000066400000000000000000000025221274143137600240520ustar00rootroot00000000000000(* This example relies on Ocamlbuild version 0.9.0 (specifically on PR#6794). Otherwise compiling bindings_stubs_gen.c, Step 4, will fail because the package information isn't passed to "ocamlfind ocamlc". *) open Ocamlbuild_plugin let () = let additional_rules = function | Before_hygiene -> () | After_hygiene -> () | Before_options -> () | After_options -> () | Before_rules -> () | After_rules -> (* Generate stubs. Steps 1, 2, & 3 of Makefile (1 & 2 via built-in rules). ML -> C *) rule "cstubs: x_c_gen.native -> x_stubs_gen.c" ~dep:"%_c_gen.native" ~prod:"%_stubs_gen.c" (fun env _build -> Cmd (A (env "./%_c_gen.native"))); (* Step 4. OCamlbuild (nor ocamlc/ocamlopt) has a built in rule for linking executables from C. Call out to 'cc'. *) rule "stub_gen 1: x_stubs_gen.o -> x_stubs_gen" ~dep:"%_stubs_gen.o" ~prod:"%_stubs_gen" (fun env _build -> Cmd (S [ A "cc"; A "-o"; A (env "%_stubs_gen"); A (env "%_stubs_gen.o") ])); (* Step 5. Generate ml stubs. C -> ML *) rule "stubs_gen 2: x_stubs_gen -> x_stubs.ml" ~dep:"%_stubs_gen" ~prod:"%_stubs.ml" (fun env _build -> Cmd (S[A (env "./%_stubs_gen"); Sh">"; A (env "%_stubs.ml")])); in dispatch additional_rules ocaml-ctypes-0.7.0/examples/date/000077500000000000000000000000001274143137600166615ustar00rootroot00000000000000ocaml-ctypes-0.7.0/examples/date/foreign/000077500000000000000000000000001274143137600203125ustar00rootroot00000000000000ocaml-ctypes-0.7.0/examples/date/foreign/date.ml000066400000000000000000000023521274143137600215630ustar00rootroot00000000000000(* * 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-0.7.0/examples/date/foreign/date.mli000066400000000000000000000012311274143137600217270ustar00rootroot00000000000000(* * 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-0.7.0/examples/date/stub-generation/000077500000000000000000000000001274143137600217675ustar00rootroot00000000000000ocaml-ctypes-0.7.0/examples/date/stub-generation/bindings/000077500000000000000000000000001274143137600235645ustar00rootroot00000000000000ocaml-ctypes-0.7.0/examples/date/stub-generation/bindings/date_stubs.ml000066400000000000000000000017551274143137600262630ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open PosixTypes type tm let tm = structure "tm" let (-:) ty label = field tm label ty let tm_sec = int -: "tm_sec" (* seconds *) let tm_min = int -: "tm_min" (* minutes *) let tm_hour = int -: "tm_hour" (* hours *) let tm_mday = int -: "tm_mday" (* day of the month *) let tm_mon = int -: "tm_mon" (* month *) let tm_year = int -: "tm_year" (* year *) let tm_wday = int -: "tm_wday" (* day of the week *) let tm_yday = int -: "tm_yday" (* day in the year *) let tm_isdst = int -: "tm_isdst" (* daylight saving time *) let () = seal (tm : tm structure typ) module Bindings (F : Cstubs.FOREIGN) = struct open F let time = foreign "time" (ptr time_t @-> returning time_t) let asctime = foreign "asctime" (ptr tm @-> returning string) let localtime = foreign "localtime" (ptr time_t @-> returning (ptr tm)) end ocaml-ctypes-0.7.0/examples/date/stub-generation/date_cmd.ml000066400000000000000000000010161274143137600240570ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open PosixTypes open Date_stubs module D = Bindings(Date_generated) open D let () = begin let timep = allocate_n ~count:1 time_t in let time = time timep in assert (time = !@timep); let tm = localtime timep in Printf.printf "tm.tm_mon = %d\n" (getf !@tm tm_mon); Printf.printf "tm.tm_year = %d\n" (getf !@tm tm_year); print_endline (asctime tm) end ocaml-ctypes-0.7.0/examples/date/stub-generation/stub-generator/000077500000000000000000000000001274143137600247305ustar00rootroot00000000000000ocaml-ctypes-0.7.0/examples/date/stub-generation/stub-generator/date_stub_generator.ml000066400000000000000000000014031274143137600313000ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) let c_headers = "#include " let main () = let ml_out = open_out "examples/date/stub-generation/date_generated.ml" and c_out = open_out "examples/date/stub-generation/date_stubs.c" in let ml_fmt = Format.formatter_of_out_channel ml_out and c_fmt = Format.formatter_of_out_channel c_out in Format.fprintf c_fmt "%s@\n" c_headers; Cstubs.write_c c_fmt ~prefix:"date_stub_" (module Date_stubs.Bindings); Cstubs.write_ml ml_fmt ~prefix:"date_stub_" (module Date_stubs.Bindings); Format.pp_print_flush ml_fmt (); Format.pp_print_flush c_fmt (); close_out ml_out; close_out c_out let () = main () ocaml-ctypes-0.7.0/examples/fts/000077500000000000000000000000001274143137600165405ustar00rootroot00000000000000ocaml-ctypes-0.7.0/examples/fts/foreign/000077500000000000000000000000001274143137600201715ustar00rootroot00000000000000ocaml-ctypes-0.7.0/examples/fts/foreign/fts.ml000066400000000000000000000152011274143137600213160ustar00rootroot00000000000000(* * 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 -> Ctypes_coerce.coerce (ptr char) string (t |-> fts_name) let level : t -> int = fun t -> getf !@t fts_level let errno : t -> int = fun t -> getf !@t fts_errno let number : t -> int = fun t -> getf !@t fts_number let set_number : t -> int -> unit = fun t -> setf !@t fts_number let pointer : t -> unit ptr = fun t -> getf !@t fts_pointer let set_pointer : t -> unit ptr -> unit = fun t -> setf !@t fts_pointer let parent : t -> t = fun t -> getf !@t fts_parent let link : t -> t = fun t -> getf !@t fts_link let cycle : t -> t = fun t -> getf !@t fts_cycle end module FTS = struct open PosixTypes open FTSENT type fts let fts : fts structure typ = structure "fts" let ( -: ) ty label = field fts label ty let fts_cur = ptr ftsent -: "fts_cur" let fts_child = ptr ftsent -: "fts_child" let fts_array = ptr (ptr ftsent) -: "fts_array" let fts_dev = dev_t -: "fts_dev" let fts_path = string -: "fts_path" let fts_rfd = int -: "fts_rfd" let fts_pathlen = int -: "fts_pathlen" let fts_nitems = int -: "fts_nitems" let fts_compar = Foreign.funptr (ptr FTSENT.t @-> ptr FTSENT.t @-> returning int) -: "fts_compar" (* fts_options would work well as a view *) let fts_options = int -: "fts_options" let () = seal fts type t = { ptr : fts structure ptr; (* The compar field ties the lifetime of the comparison function to the lifetime of the fts object to prevent untimely collection. *) compar: (FTSENT.t ptr -> FTSENT.t ptr -> int) option } let cur : t -> FTSENT.t = fun { ptr } -> getf !@ptr fts_cur let child : t -> FTSENT.t = fun { ptr } -> getf !@ptr fts_child let array : t -> FTSENT.t list = fun { ptr } -> CArray.(to_list (from_ptr (getf !@ptr fts_array) (getf !@ptr fts_nitems))) let dev : t -> dev_t = fun { ptr } -> getf !@ptr fts_dev let path : t -> string = fun { ptr } -> getf !@ptr fts_path let rfd : t -> int = fun { ptr } -> getf !@ptr fts_rfd end open FTSENT open FTS (* FTS *fts_open(char * const *path_argv, int options, int ( *compar)(const FTSENT **, const FTSENT ** )); *) let compar_type = ptr FTSENT.t @-> ptr FTSENT.t @-> returning int let _fts_open = Foreign.foreign "fts_open" (ptr string @-> int @-> Foreign.funptr_opt compar_type @-> returning (ptr fts)) (* FTSENT *fts_read(FTS *ftsp); *) let _fts_read = Foreign.foreign "fts_read" ~check_errno:true (ptr fts @-> returning (ptr ftsent)) (* FTSENT *fts_children(FTS *ftsp, int options); *) let _fts_children = Foreign.foreign "fts_children" (ptr fts @-> int @-> returning (ptr ftsent)) (* int fts_set(FTS *ftsp, FTSENT *f, int options); *) let _fts_set = Foreign.foreign "fts_set" ~check_errno:true (ptr fts @-> ptr (ftsent) @-> int @-> returning int) (* int fts_close(FTS *ftsp); *) let _fts_close = Foreign.foreign "fts_close" ~check_errno:true (ptr fts @-> returning int) let crush_options f : 'a list -> int = List.fold_left (fun i o -> i lor (f o)) 0 let fts_read fts = let p = _fts_read fts.ptr in if to_voidp p = null then None else Some p let fts_close ftsp = ignore (_fts_close ftsp.ptr) let fts_set ~ftsp ~f ~options = ignore (_fts_set ftsp.ptr f (crush_options fts_set_option_value options)) let fts_children ~ftsp ~name_only = _fts_children ftsp.ptr (fts_children_option_of_bool name_only) let null_terminated_array_of_ptr_list typ list = let nitems = List.length list in let arr = CArray.make typ (1 + nitems) in List.iteri (CArray.set arr) list; (castp (ptr void) (CArray.start arr +@ nitems)) <-@ null; arr let fts_open ~path_argv ?compar ~options = let paths = null_terminated_array_of_ptr_list string path_argv in let options = crush_options fts_open_option_value options in { ptr = _fts_open (CArray.start paths) options compar; compar } ocaml-ctypes-0.7.0/examples/fts/foreign/fts.mli000066400000000000000000000324741274143137600215020ustar00rootroot00000000000000(* * 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-0.7.0/examples/fts/foreign/fts_cmd.ml000066400000000000000000000017241274143137600221460ustar00rootroot00000000000000(* * 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-0.7.0/examples/fts/stub-generation/000077500000000000000000000000001274143137600216465ustar00rootroot00000000000000ocaml-ctypes-0.7.0/examples/fts/stub-generation/bindings/000077500000000000000000000000001274143137600234435ustar00rootroot00000000000000ocaml-ctypes-0.7.0/examples/fts/stub-generation/bindings/fts.mli000066400000000000000000000123741274143137600247510ustar00rootroot00000000000000(* * Copyright (c) Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open Fts_types (* The fts functions are provided for traversing file hierarchies. A simple overview is that the fts_open() function returns a "handle" on a file hierarchy, which is then supplied to the other fts functions. The function fts_read() returns a pointer to a structure describing one of the files in the file hierarchy. The function fts_children() returns a pointer to a linked list of structures, each of which describes one of the files contained in a directory in the hierarchy. In general, directories are visited two distinguishable times; in preorder (before any of their descendants are visited) and in postorder (after all of their descendants have been visited). Files are visited once. It is possible to walk the hierarchy "logically" (ignoring symbolic links) or physically (visiting symbolic links), order the walk of the hierarchy or prune and/or revisit portions of the hierarchy. *) module Bindings (F : sig val foreign : string -> 'a fn -> unit end) : sig (* The fts_open() function takes a list of strings naming one or more paths which make up a logical file hierarchy to be traversed. There are a number of options, at least one of which (either FTS_LOGICAL or FTS_PHYSICAL) must be specified. The argument compar() specifies a user-defined function which may be used to order the traversal of the hierarchy. It takes two pointers to pointers to FTSENT structures as arguments and should return a negative value, zero, or a positive value to indicate if the file referenced by its first argument comes before, in any order with respect to, or after, the file referenced by its second argument. The fts_accpath, fts_path and fts_pathlen fields of the FTSENT structures may never be used in this comparison. If the fts_info field is set to FTS_NS or FTS_NSOK, the fts_statp field may not either. If the compar() argument is NULL, the directory traversal order is in the order listed in path_argv for the root paths, and in the order listed in the directory for everything else. *) val fts_open : path_argv:string list -> ?compar:(FTSENT.t ptr -> FTSENT.t ptr -> int) -> options:fts_open_option list -> FTS.t (* The fts_children() function returns a pointer to an FTSENT structure describing the first entry in a NULL-terminated linked list of the files in the directory represented by the FTSENT structure most recently returned by fts_read(). The list is linked through the fts_link field of the FTSENT struc‐ ture, and is ordered by the user-specified comparison function, if any. Repeated calls to fts_children() will recreate this linked list. As a special case, if fts_read() has not yet been called for a hierarchy, fts_children() will return a pointer to the files in the logical directory specified to fts_open(), that is, the arguments specified to fts_open(). Otherwise, if the FTSENT structure most recently returned by fts_read() is not a directory being visited in preorder, or the directory does not contain any files, fts_children() returns NULL and sets errno to zero. If an error occurs, fts_children() returns NULL and sets errno appropriately. The FTSENT structures returned by fts_children() may be overwritten after a call to fts_children(), fts_close() or fts_read() on the same file hierarchy stream. The name_only option indicates that only the names of the files are needed. The contents of all the fields in the returned linked list of structures are undefined with the exception of the fts_name and fts_namelen fields. *) val fts_children : ftsp:FTS.t -> name_only:bool -> FTSENT.t (* The fts_read() function returns a pointer to an FTSENT structure describing a file in the hierarchy. Directories (that are readable and do not cause cycles) are visited at least twice, once in preorder and once in postorder. All other files are visited at least once. (Hard links between directories that do not cause cycles or symbolic links to symbolic links may cause files to be visited more than once, or directories more than twice.) The FTSENT structures returned by fts_read() may be overwritten after a call to fts_close() on the same file hierarchy stream, or, after a call to fts_read() on the same file hierarchy stream unless they represent a file of type directory, in which case they will not be overwritten until after a call to fts_read() after the FTSENT structure has been returned by the function fts_read() in postorder. *) val fts_read : FTS.t -> FTSENT.t option (* The function fts_set() allows the user application to determine further processing for the file f of the stream ftsp. *) val fts_set : ftsp:FTS.t -> f:FTSENT.t -> options:fts_set_option list -> unit (* The fts_close() function closes a file hierarchy stream ftsp and restores the current directory to the directory from which fts_open() was called to open ftsp. *) val fts_close : FTS.t -> unit end ocaml-ctypes-0.7.0/examples/fts/stub-generation/bindings/fts_bindings.ml000066400000000000000000000020571274143137600264520ustar00rootroot00000000000000(* * Copyright (c) Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open Fts_types open FTSENT open FTS module Bindings (F : Cstubs.FOREIGN) = struct open F (* FTS *fts_open(char * const *path_argv, int options, int ( *compar)(const FTSENT **, const FTSENT ** )); *) let _fts_open = foreign "fts_open" (ptr string @-> int @-> compar_typ_opt @-> returning (ptr fts)) (* FTSENT *fts_read(FTS *ftsp); *) let _fts_read = foreign "fts_read" (* ~check_errno:true *) (ptr fts @-> returning (ptr ftsent)) (* FTSENT *fts_children(FTS *ftsp, int options); *) let _fts_children = foreign "fts_children" (ptr fts @-> int @-> returning (ptr ftsent)) (* int fts_set(FTS *ftsp, FTSENT *f, int options); *) let _fts_set = foreign "fts_set" (* ~check_errno:true *) (ptr fts @-> ptr (ftsent) @-> int @-> returning int) (* int fts_close(FTS *ftsp); *) let _fts_close = foreign "fts_close" (* ~check_errno:true *) (ptr fts @-> returning int) end ocaml-ctypes-0.7.0/examples/fts/stub-generation/bindings/fts_types.ml000066400000000000000000000126461274143137600260260ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes type fts_info = FTS_D | FTS_DC | FTS_DEFAULT | FTS_DNR | FTS_DOT | FTS_DP | FTS_ERR | FTS_F | FTS_NS | FTS_NSOK | FTS_SL | FTS_SLNONE let fts_info_of_int = function | 1 -> FTS_D | 2 -> FTS_DC | 3 -> FTS_DEFAULT | 4 -> FTS_DNR | 5 -> FTS_DOT | 6 -> FTS_DP | 7 -> FTS_ERR | 8 -> FTS_F (* | 9 -> FTS_INIT *) | 10 -> FTS_NS | 11 -> FTS_NSOK | 12 -> FTS_SL | 13 -> FTS_SLNONE | _ -> invalid_arg "fts_info" type fts_open_option = FTS_COMFOLLOW | FTS_LOGICAL | FTS_NOCHDIR | FTS_NOSTAT | FTS_PHYSICAL | FTS_SEEDOT | FTS_XDEV let fts_children_option_of_bool = function | false -> 0 | true -> 0x0100 let fts_open_option_value = function | FTS_COMFOLLOW -> 0x0001 | FTS_LOGICAL -> 0x0002 | FTS_NOCHDIR -> 0x0004 | FTS_NOSTAT -> 0x0008 | FTS_PHYSICAL -> 0x0010 | FTS_SEEDOT -> 0x0020 | FTS_XDEV -> 0x0040 type fts_set_option = FTS_AGAIN | FTS_FOLLOW | FTS_SKIP let fts_set_option_value = function | FTS_AGAIN -> 1 | FTS_FOLLOW -> 2 | FTS_SKIP -> 4 let id x = x module FTSENT = struct open PosixTypes open Unsigned type ftsent let struct_ftsent : ftsent structure typ = structure "FTSENT" let ( -: ) ty label = field struct_ftsent label ty let fts_cycle = ptr struct_ftsent -: "fts_cycle" let fts_parent = ptr struct_ftsent -: "fts_parent" let fts_link = ptr struct_ftsent -: "fts_link" let fts_number = int -: "fts_number" let fts_pointer = ptr void -: "fts_pointer" let fts_accpath = string -: "fts_accpath" let fts_path = string -: "fts_path" let fts_errno = int -: "fts_errno" let fts_symfd = int -: "fts_symfd" let fts_pathlen = ushort -: "fts_pathlen" let fts_namelen = ushort -: "fts_namelen" let fts_ino = ino_t -: "fts_ino" let fts_dev = dev_t -: "fts_dev" let fts_nlink = nlink_t -: "fts_nlink" let fts_level = short -: "fts_level" let fts_info = ushort -: "fts_info" let fts_flags = ushort -: "fts_flags" let fts_instr = ushort -: "fts_instr" let fts_statp = ptr void -: "fts_statp" (* really a struct stat * *) let fts_name = char -: "fts_name" let () = seal struct_ftsent let ftsent = view struct_ftsent ~read:id ~write:id ~format_typ:(fun k fmt -> Format.pp_print_string fmt "FTSENT"; k fmt) type t = ftsent structure ptr let t = ptr ftsent let info : t -> fts_info = fun t -> fts_info_of_int (UShort.to_int (getf !@t fts_info)) let accpath : t -> string = fun t -> getf !@t fts_accpath let path : t -> string = fun t -> getf !@t fts_path let name : t -> string = fun t -> Ctypes_coerce.coerce (ptr char) string (t |-> fts_name) let level : t -> int = fun t -> getf !@t fts_level let errno : t -> int = fun t -> getf !@t fts_errno let number : t -> int = fun t -> getf !@t fts_number let set_number : t -> int -> unit = fun t -> setf !@t fts_number let pointer : t -> unit ptr = fun t -> getf !@t fts_pointer let set_pointer : t -> unit ptr -> unit = fun t -> setf !@t fts_pointer let parent : t -> t = fun t -> getf !@t fts_parent let link : t -> t = fun t -> getf !@t fts_link let cycle : t -> t = fun t -> getf !@t fts_cycle end module FTS = struct open PosixTypes open FTSENT type compar_typ = t ptr -> t ptr -> int let compar_typ : compar_typ typ = Foreign.funptr (ptr FTSENT.t @-> ptr FTSENT.t @-> returning int) type compar_typ_opt = compar_typ option let compar_typ_opt : compar_typ_opt typ = Foreign.funptr_opt (ptr FTSENT.t @-> ptr FTSENT.t @-> returning int) type fts let struct_fts : fts structure typ = structure "FTS" let ( -: ) ty label = field struct_fts label ty let fts_cur = ptr ftsent -: "fts_cur" let fts_child = ptr ftsent -: "fts_child" let fts_array = ptr (ptr ftsent) -: "fts_array" let fts_dev = dev_t -: "fts_dev" let fts_path = string -: "fts_path" let fts_rfd = int -: "fts_rfd" let fts_pathlen = int -: "fts_pathlen" let fts_nitems = int -: "fts_nitems" let fts_compar = compar_typ -: "fts_compar" (* fts_options would work well as a view *) let fts_options = int -: "fts_options" let () = seal struct_fts let fts = view struct_fts ~read:id ~write:id ~format_typ:(fun k fmt -> Format.pp_print_string fmt "FTS"; k fmt) type t = { ptr : fts structure ptr; (* The compar field ties the lifetime of the comparison function to the lifetime of the fts object to prevent untimely collection. *) compar: compar_typ option } let cur : t -> FTSENT.t = fun { ptr } -> getf !@ptr fts_cur let child : t -> FTSENT.t = fun { ptr } -> getf !@ptr fts_child let array : t -> FTSENT.t list = fun { ptr } -> CArray.(to_list (from_ptr (getf !@ptr fts_array) (getf !@ptr fts_nitems))) let dev : t -> dev_t = fun { ptr } -> getf !@ptr fts_dev let path : t -> string = fun { ptr } -> getf !@ptr fts_path let rfd : t -> int = fun { ptr } -> getf !@ptr fts_rfd end ocaml-ctypes-0.7.0/examples/fts/stub-generation/fts_cmd.ml000066400000000000000000000017461274143137600236270ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Fts_types open Fts_if let usage = "fts_cmd path [ path .. ]" let sort_by_name lp rp = let open Ctypes in let open FTSENT in String.compare (name !@lp) (name !@rp) let 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-0.7.0/examples/fts/stub-generation/fts_if.ml000066400000000000000000000022541274143137600234550ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open Fts_types open FTS open FTSENT module N = Fts_bindings.Bindings(Fts_generated) open N let crush_options f : 'a list -> int = List.fold_left (fun i o -> i lor (f o)) 0 let fts_read fts = let p = _fts_read fts.ptr in if to_voidp p = null then None else Some p let fts_close ftsp = ignore (_fts_close ftsp.ptr) let fts_set ~ftsp ~f ~options = ignore (_fts_set ftsp.ptr f (crush_options fts_set_option_value options)) let fts_children ~ftsp ~name_only = _fts_children ftsp.ptr (fts_children_option_of_bool name_only) let null_terminated_array_of_ptr_list typ list = let nitems = List.length list in let arr = CArray.make typ (1 + nitems) in List.iteri (CArray.set arr) list; (coerce (ptr string) (ptr (ptr void)) (CArray.start arr +@ nitems)) <-@ null; arr let fts_open ~path_argv ?compar ~options = let paths = null_terminated_array_of_ptr_list string path_argv in let options = crush_options fts_open_option_value options in { ptr = _fts_open (CArray.start paths) options compar; compar } ocaml-ctypes-0.7.0/examples/fts/stub-generation/stub-generator/000077500000000000000000000000001274143137600246075ustar00rootroot00000000000000ocaml-ctypes-0.7.0/examples/fts/stub-generation/stub-generator/fts_stub_generator.ml000066400000000000000000000014531274143137600310430ustar00rootroot00000000000000(* * Copyright (c) Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) let c_headers = " #include #include #include " let main () = let ml_out = open_out "examples/fts/stub-generation/fts_generated.ml" and c_out = open_out "examples/fts/stub-generation/fts_stubs.c" in let ml_fmt = Format.formatter_of_out_channel ml_out and c_fmt = Format.formatter_of_out_channel c_out in Format.fprintf c_fmt "%s@\n" c_headers; Cstubs.write_c c_fmt ~prefix:"fts_stub_" (module Fts_bindings.Bindings); Cstubs.write_ml ml_fmt ~prefix:"fts_stub_" (module Fts_bindings.Bindings); Format.pp_print_flush ml_fmt (); Format.pp_print_flush c_fmt (); close_out ml_out; close_out c_out let () = main () ocaml-ctypes-0.7.0/examples/ncurses/000077500000000000000000000000001274143137600174265ustar00rootroot00000000000000ocaml-ctypes-0.7.0/examples/ncurses/foreign/000077500000000000000000000000001274143137600210575ustar00rootroot00000000000000ocaml-ctypes-0.7.0/examples/ncurses/foreign/ncurses.ml000066400000000000000000000017731274143137600231030ustar00rootroot00000000000000(* * 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-0.7.0/examples/ncurses/foreign/ncurses.mli000066400000000000000000000050371274143137600232510ustar00rootroot00000000000000(* * 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-0.7.0/examples/ncurses/foreign/ncurses_cmd.ml000066400000000000000000000006711274143137600237220ustar00rootroot00000000000000(* * 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-0.7.0/examples/ncurses/stub-generation/000077500000000000000000000000001274143137600225345ustar00rootroot00000000000000ocaml-ctypes-0.7.0/examples/ncurses/stub-generation/bindings/000077500000000000000000000000001274143137600243315ustar00rootroot00000000000000ocaml-ctypes-0.7.0/examples/ncurses/stub-generation/bindings/ncurses_bindings.ml000066400000000000000000000033121274143137600302210ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes type window = unit ptr let window : window typ = ptr void module Bindings (F : Cstubs.FOREIGN) = struct open F let initscr = foreign "initscr" (void @-> (returning window)) let endwin = foreign "endwin" (void @-> (returning void)) let refresh = foreign "refresh" (void @-> (returning void)) let wrefresh = foreign "wrefresh" (window @-> (returning void)) let newwin = foreign "newwin" (int @-> int @-> int @-> int @-> (returning window)) let addch = foreign "addch" (char @-> (returning void)) let mvwaddch = foreign "mvwaddch" (window @-> int @-> int @-> char @-> (returning void)) let addstr = foreign "addstr" (string @-> (returning void)) let mvwaddstr = foreign "mvwaddstr" (window @-> int @-> int @-> string @-> (returning void)) let box = foreign "box" (window @-> int @-> int @-> (returning void)) let cbreak = foreign "cbreak" (void @-> (returning void)) end let c_headers = "#include " let main () = let ml_out = open_out "examples/ncurses/stub-generation/ncurses_generated.ml" in let c_out = open_out "examples/ncurses/stub-generation/ncurses_stubs.c" in let c_fmt = Format.formatter_of_out_channel c_out in let ml_fmt = Format.formatter_of_out_channel ml_out in Format.fprintf c_fmt "%s@\n" c_headers; Cstubs.write_c c_fmt ~prefix:"ncurses_stub_" (module Bindings); Cstubs.write_ml ml_fmt ~prefix:"ncurses_stub_" (module Bindings); Format.pp_print_flush ml_fmt (); Format.pp_print_flush c_fmt (); close_out ml_out; close_out c_out let () = main () ocaml-ctypes-0.7.0/examples/ncurses/stub-generation/ncurses_stub_cmd.ml000066400000000000000000000007531274143137600264350ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) module N = Ncurses_bindings.Bindings(Ncurses_generated) open N let () = let main_window = initscr () in cbreak (); let small_window = newwin 10 10 5 5 in mvwaddstr main_window 1 2 "Hello"; mvwaddstr small_window 2 2 "World"; box small_window 0 0; refresh (); Unix.sleep 1; wrefresh small_window; Unix.sleep 5; endwin() ocaml-ctypes-0.7.0/examples/sigset/000077500000000000000000000000001274143137600172425ustar00rootroot00000000000000ocaml-ctypes-0.7.0/examples/sigset/sigset.ml000066400000000000000000000041771274143137600211030ustar00rootroot00000000000000(* * 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-0.7.0/examples/sigset/sigset.mli000066400000000000000000000005431274143137600212450ustar00rootroot00000000000000(* * 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-0.7.0/src/000077500000000000000000000000001274143137600147155ustar00rootroot00000000000000ocaml-ctypes-0.7.0/src/configure/000077500000000000000000000000001274143137600166765ustar00rootroot00000000000000ocaml-ctypes-0.7.0/src/configure/extract_from_c.ml000066400000000000000000000057171274143137600222410ustar00rootroot00000000000000(* * Copyright (c) 2016 whitequark. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) let getenv ~default name = try Sys.getenv name with Not_found -> default let nsplit sep str = Str.(split (regexp_string sep)) str let read_output program = let input_filename = Filename.temp_file "ctypes_libffi_config" ".c" in let channel = open_out input_filename in output_string channel program; close_out channel; let output_filename = (Filename.chop_suffix input_filename ".c") ^ ".o" in let cwd = Sys.getcwd () in let cmd = Printf.sprintf "%s ocamlc -verbose %s %s -c 1>&2" (getenv ~default:"ocamlfind" "OCAMLFIND") ((getenv ~default:"" "CFLAGS") |> (nsplit " ") |> (List.map (fun s -> "-ccopt " ^ Filename.quote s)) |> (String.concat " ")) (Filename.quote input_filename) in prerr_endline cmd; Sys.chdir (Filename.dirname input_filename); ignore (Sys.command cmd); Sys.chdir cwd; Sys.remove input_filename; if not (Sys.file_exists output_filename) then raise Not_found; let channel = open_in_bin output_filename in let length = in_channel_length channel in let result = Bytes.create length in really_input channel result 0 length; close_in channel; Sys.remove output_filename; result let find_from haystack pos needle = Str.(search_forward (regexp_string needle) haystack pos) let prefix = Bytes.of_string "BEGIN-" let suffix = Bytes.of_string "-END" let extract bytes = let begin_pos = find_from bytes 0 prefix + Bytes.length prefix in let end_pos = find_from bytes 0 suffix in Bytes.to_string (Bytes.sub bytes begin_pos (end_pos - begin_pos)) let headers = "\ #include #include #include #include #include " let integer ?(extra_headers="") expression = let code = Printf.sprintf "%s %s #define alignof(T) (offsetof(struct { char c; T t; }, t)) #define D0(x) ('0'+(x/1 )%%10) #define D1(x) ('0'+(x/10 )%%10), D0(x) #define D2(x) ('0'+(x/100 )%%10), D1(x) #define D3(x) ('0'+(x/1000 )%%10), D2(x) #define D4(x) ('0'+(x/10000 )%%10), D3(x) #define D5(x) ('0'+(x/100000 )%%10), D4(x) #define D6(x) ('0'+(x/1000000 )%%10), D5(x) #define D7(x) ('0'+(x/10000000 )%%10), D6(x) #define D8(x) ('0'+(x/100000000 )%%10), D7(x) #define D9(x) ('0'+(x/1000000000)%%10), D8(x) const char s[] = { 'B', 'E', 'G', 'I', 'N', '-', D9((%s)), '-', 'E', 'N', 'D' }; " headers extra_headers expression in int_of_string (extract (read_output code)) let string ?(extra_headers="") expression = let code = Printf.sprintf "%s %s #define STRINGIFY1(x) #x #define STRINGIFY(x) STRINGIFY1(x) #if __USE_MINGW_ANSI_STDIO && defined(__MINGW64__) #define REAL_ARCH_INTNAT_PRINTF_FORMAT \"ll\" #else #define REAL_ARCH_INTNAT_PRINTF_FORMAT ARCH_INTNAT_PRINTF_FORMAT #endif const char *s = \"BEGIN-\" %s \"-END\"; " headers extra_headers expression in extract (read_output code) ocaml-ctypes-0.7.0/src/configure/gen_c_primitives.ml000066400000000000000000000074041274143137600225630ustar00rootroot00000000000000let header ="\ (* * Copyright (c) 2016 whitequark * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes_primitive_types " type c_format = | No_format | Known_format of string | Defined_format of string type c_primitive = { constructor : string; typ : string; format : c_format; size : string; alignment : string; } let c_primitive constructor typ format = { constructor; typ; format; size = "sizeof("^typ^")"; alignment = "alignof("^typ^")"; } let c_primitives = [ c_primitive "Char" "char" (Known_format "d"); c_primitive "Schar" "signed char" (Known_format "d"); c_primitive "Uchar" "unsigned char" (Known_format "d"); c_primitive "Bool" "bool" (Known_format "d"); c_primitive "Short" "short" (Known_format "hd"); c_primitive "Int" "int" (Known_format "d"); c_primitive "Long" "long" (Known_format "ld"); c_primitive "Llong" "long long" (Known_format "lld"); c_primitive "Ushort" "unsigned short" (Known_format "hu"); c_primitive "Sint" "int" (Known_format "d"); c_primitive "Uint" "unsigned int" (Known_format "u"); c_primitive "Ulong" "unsigned long" (Known_format "lu"); c_primitive "Ullong" "unsigned long long" (Known_format "llu"); c_primitive "Size_t" "size_t" (Known_format "zu"); c_primitive "Int8_t" "int8_t" (Defined_format "PRId8"); c_primitive "Int16_t" "int16_t" (Defined_format "PRId16"); c_primitive "Int32_t" "int32_t" (Defined_format "PRId32"); c_primitive "Int64_t" "int64_t" (Defined_format "PRId64"); c_primitive "Uint8_t" "uint8_t" (Defined_format "PRIu8"); c_primitive "Uint16_t" "uint16_t" (Defined_format "PRIu16"); c_primitive "Uint32_t" "uint32_t" (Defined_format "PRIu32"); c_primitive "Uint64_t" "uint64_t" (Defined_format "PRIu64"); c_primitive "Float" "float" (Known_format ".12g"); c_primitive "Double" "double" (Known_format ".12g"); c_primitive "Complex32" "float complex" (No_format); c_primitive "Complex64" "double complex" (No_format); c_primitive "Nativeint" "intnat" (Defined_format "REAL_ARCH_INTNAT_PRINTF_FORMAT \"d\""); { constructor = "Camlint"; typ = "camlint"; format = Defined_format "REAL_ARCH_INTNAT_PRINTF_FORMAT \"d\""; size = "sizeof(intnat)"; alignment = "alignof(intnat)" }; ] let printf = Printf.printf let generate name typ f = printf "let %s : type a. a prim -> %s = function\n" name typ; List.iter (fun c_primitive -> printf " | %s -> " c_primitive.constructor; begin try f c_primitive with Not_found -> failwith (name^": "^c_primitive.constructor) end; printf "\n") c_primitives let () = begin print_string header; generate "sizeof" "int" (fun { size } -> printf "%d" (Extract_from_c.integer size)); generate "alignment" "int" (fun { alignment } -> printf "%d" (Extract_from_c.integer alignment)); generate "name" "string" (fun { typ } -> printf "%S" (Extract_from_c.string ("STRINGIFY("^typ^")"))); generate "format_string" "string option" (fun { format } -> match format with | Known_format str -> printf "Some %S" ("%"^str) | Defined_format str -> printf "Some %S" ("%"^Extract_from_c.string str) | No_format -> printf "None"); printf "let pointer_size = %d\n" (Extract_from_c.integer "sizeof(void*)"); printf "let pointer_alignment = %d\n" (Extract_from_c.integer "alignof(void*)"); end ocaml-ctypes-0.7.0/src/configure/gen_libffi_abi.ml000066400000000000000000000036261274143137600221360ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) let header ="\ (* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Support for various ABIs *) type abi = Code of int | Unsupported of string let abi_code = function Code c -> c | Unsupported sym -> raise (Ctypes.Unsupported sym) " let symbols = [ ("aix" , "FFI_AIX"); ("darwin" , "FFI_DARWIN"); ("eabi" , "FFI_EABI"); ("fastcall" , "FFI_FASTCALL"); ("gcc_sysv" , "FFI_GCC_SYSV"); ("linux" , "FFI_LINUX"); ("linux64" , "FFI_LINUX64"); ("linux_soft_float" , "FFI_LINUX_SOFT_FLOAT"); ("ms_cdecl" , "FFI_MS_CDECL"); ("n32" , "FFI_N32"); ("n32_soft_float" , "FFI_N32_SOFT_FLOAT"); ("n64" , "FFI_N64"); ("n64_soft_float" , "FFI_N64_SOFT_FLOAT"); ("o32" , "FFI_O32"); ("o32_soft_float" , "FFI_O32_SOFT_FLOAT"); ("osf" , "FFI_OSF"); ("pa32" , "FFI_PA32"); ("stdcall" , "FFI_STDCALL"); ("sysv" , "FFI_SYSV"); ("thiscall" , "FFI_THISCALL"); ("unix" , "FFI_UNIX"); ("unix64" , "FFI_UNIX64"); ("v8" , "FFI_V8"); ("v8plus" , "FFI_V8PLUS"); ("v9" , "FFI_V9"); ("vfp" , "FFI_VFP"); ("default_abi" , "FFI_DEFAULT_ABI"); ] let extra_headers = "#include " let write_line name symbol = try Printf.printf "let %s = Code %d\n" name (Extract_from_c.integer ~extra_headers symbol) with Not_found -> Printf.printf "let %s = Unsupported \"%s\"\n" name symbol let () = begin print_string header; List.iter (fun (name, symbol) -> write_line name symbol) symbols end ocaml-ctypes-0.7.0/src/cstubs/000077500000000000000000000000001274143137600162205ustar00rootroot00000000000000ocaml-ctypes-0.7.0/src/cstubs/cstubs.ml000066400000000000000000000144701274143137600200630ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Cstubs public interface. *) module type FOREIGN = sig type 'a fn type 'a return val (@->) : 'a Ctypes.typ -> 'b fn -> ('a -> 'b) fn val returning : 'a Ctypes.typ -> 'a return fn type 'a result val foreign : string -> ('a -> 'b) fn -> ('a -> 'b) result val foreign_value : string -> 'a Ctypes.typ -> 'a Ctypes.ptr result end module type FOREIGN' = FOREIGN with type 'a result = unit module type BINDINGS = functor (F : FOREIGN') -> sig end type concurrency_policy = [ `Sequential | `Lwt_jobs ] type errno_policy = [ `Ignore_errno | `Return_errno ] let gen_c ~concurrency ~errno prefix fmt : (module FOREIGN') = (module struct let counter = ref 0 let var prefix name = incr counter; Printf.sprintf "%s_%d_%s" prefix !counter name type 'a fn = 'a Ctypes.fn type 'a return = 'a type 'a result = unit let foreign cname fn = Cstubs_generate_c.fn ~concurrency ~errno ~cname ~stub_name:(var prefix cname) fmt fn let foreign_value cname typ = Cstubs_generate_c.value ~cname ~stub_name:(var prefix cname) fmt typ let returning = Ctypes.returning let (@->) = Ctypes.(@->) end) type bind = Bind : string * string * ('a -> 'b) Ctypes.fn -> bind type val_bind = Val_bind : string * string * 'a Ctypes.typ -> val_bind let write_return : concurrency:concurrency_policy -> errno:errno_policy -> Format.formatter -> unit = fun ~concurrency ~errno fmt -> match concurrency, errno with `Sequential, `Ignore_errno -> Format.fprintf fmt "type 'a return = 'a@\n" | `Sequential, `Return_errno -> Format.fprintf fmt "type 'a return = 'a * Signed.sint@\n" | `Lwt_jobs, `Ignore_errno -> begin Format.fprintf fmt "type 'a return = { lwt: 'a Lwt.t }@\n"; Format.fprintf fmt "let box_lwt lwt = {lwt}@\n"; end | `Lwt_jobs, `Return_errno -> begin Format.fprintf fmt "type 'a return = { lwt: ('a * Signed.sint) Lwt.t }@\n"; Format.fprintf fmt "let box_lwt lwt = {lwt}@\n"; end let write_fn ~concurrency ~errno fmt = begin Format.fprintf fmt "type 'a fn =@\n"; Format.fprintf fmt " | Returns : 'a CI.typ -> 'a return fn@\n"; Format.fprintf fmt " | Function : 'a CI.typ * 'b fn -> ('a -> 'b) fn@\n" end let write_map_result ~concurrency ~errno fmt = match concurrency, errno with `Sequential, `Ignore_errno -> Format.fprintf fmt "let map_result f x = f x@\n" | `Sequential, `Return_errno -> Format.fprintf fmt "let map_result f (x, y) = (f x, y)@\n" | `Lwt_jobs, `Ignore_errno -> Format.fprintf fmt "let map_result f x = Lwt.map f x@\n" | `Lwt_jobs, `Return_errno -> Format.fprintf fmt "let map_result f v = Lwt.map (fun (x, y) -> (f x, y)) v@\n" let write_foreign ~concurrency ~errno fmt bindings val_bindings = Format.fprintf fmt "type 'a result = 'a@\n"; write_return ~concurrency ~errno fmt; write_fn ~concurrency ~errno fmt; write_map_result ~concurrency ~errno fmt; Format.fprintf fmt "let returning t = Returns t@\n"; Format.fprintf fmt "let (@@->) f p = Function (f, p)@\n"; Format.fprintf fmt "let foreign : type a b. string -> (a -> b) fn -> (a -> b) =@\n"; Format.fprintf fmt " fun name t -> match t, name with@\n@["; ListLabels.iter bindings ~f:(fun (Bind (stub_name, external_name, fn)) -> Cstubs_generate_ml.case ~concurrency ~errno ~stub_name ~external_name fmt fn); Format.fprintf fmt "@[@[|@ _,@ s@ ->@]@ "; Format.fprintf fmt " @[Printf.ksprintf@ failwith@ \"No match for %%s\" s@]@]@]@.@\n"; Format.fprintf fmt "@\n"; Format.fprintf fmt "let foreign_value : type a b. string -> a Ctypes.typ -> a Ctypes.ptr =@\n"; Format.fprintf fmt " fun name t -> match t, name with@\n@["; ListLabels.iter val_bindings ~f:(fun (Val_bind (stub_name, external_name, typ)) -> Cstubs_generate_ml.val_case ~stub_name ~external_name fmt typ); Format.fprintf fmt "@[@[|@ _,@ s@ ->@]@ "; Format.fprintf fmt " @[Printf.ksprintf@ failwith@ \"No match for %%s\" s@]@]@]@.@\n" let gen_ml ~concurrency ~errno prefix fmt : (module FOREIGN') * (unit -> unit) = let bindings = ref [] and val_bindings = ref [] and counter = ref 0 in let var prefix name = incr counter; Printf.sprintf "%s_%d_%s" prefix !counter name in (module struct type 'a fn = 'a Ctypes.fn type 'a return = 'a let (@->) = Ctypes.(@->) let returning = Ctypes.returning type 'a result = unit let foreign cname fn = let name = var prefix cname in bindings := Bind (cname, name, fn) :: !bindings; Cstubs_generate_ml.extern ~concurrency ~errno ~stub_name:name ~external_name:name fmt fn let foreign_value cname typ = let name = var prefix cname in Cstubs_generate_ml.extern ~concurrency:`Sequential ~errno:`Ignore_errno ~stub_name:name ~external_name:name fmt Ctypes.(void @-> returning (ptr void)); val_bindings := Val_bind (cname, name, typ) :: !val_bindings let returning = Ctypes.returning let (@->) = Ctypes.(@->) end), fun () -> write_foreign ~concurrency ~errno fmt !bindings !val_bindings let sequential = `Sequential let lwt_jobs = `Lwt_jobs let ignore_errno = `Ignore_errno let return_errno = `Return_errno let concurrency_headers = function `Sequential -> [] | `Lwt_jobs -> ["\"lwt_unix.h\""; ""] let errno_headers = function `Ignore_errno -> [] | `Return_errno -> [""] let headers : concurrency_policy -> errno_policy -> string list = fun concurrency errno -> ["\"ctypes_cstubs_internals.h\""] @ errno_headers errno @ concurrency_headers concurrency let write_c ?(concurrency=`Sequential) ?(errno=`Ignore_errno) fmt ~prefix (module B : BINDINGS) = List.iter (Format.fprintf fmt "#include %s@\n") (headers concurrency errno); let module M = B((val gen_c ~concurrency ~errno prefix fmt)) in () let write_ml ?(concurrency=`Sequential) ?(errno=`Ignore_errno) fmt ~prefix (module B : BINDINGS) = let foreign, finally = gen_ml ~concurrency ~errno prefix fmt in let () = Format.fprintf fmt "module CI = Cstubs_internals@\n@\n" in let module M = B((val foreign)) in finally () module Types = Cstubs_structs ocaml-ctypes-0.7.0/src/cstubs/cstubs.mli000066400000000000000000000137111274143137600202310ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** Operations for generating C bindings stubs. *) module Types : sig module type TYPE = sig include Ctypes_types.TYPE type 'a const val constant : string -> 'a typ -> 'a const (** [constant name typ] retrieves the value of the compile-time constant [name] of type [typ]. It can be used to retrieve enum constants, #defined values and other integer constant expressions. The type [typ] must be either an integer type such as [bool], [char], [int], [uint8], etc., or a view (or perhaps multiple views) where the underlying type is an integer type. When the value of the constant cannot be represented in the type there will typically be a diagnostic from either the C compiler or the OCaml compiler. For example, gcc will say warning: overflow in implicit constant conversion *) val enum : string -> ?unexpected:(int64 -> 'a) -> ('a * int64 const) list -> 'a typ (** [enum name ?unexpected alist] builds a type representation for the enum named [name]. The size and alignment are retrieved so that the resulting type can be used everywhere an integer type can be used: as an array element or struct member, as an argument or return value, etc. The value [alist] is an association list of OCaml values and values retrieved by the [constant] function. For example, to expose the enum enum letters \{ A, B, C = 10, D \}; you might first retrieve the values of the enumeration constants: let a = constant "A" int64_t and b = constant "B" int64_t and c = constant "C" int64_t and d = constant "D" int64_t and then build the enumeration type let letters = enum "letters" [ `A, a; `B, b; `C, c; `D, d; ] ~unexpected:(fun i -> `E i) The [unexpected] function specifies the value to return in the case that some unexpected value is encountered -- for example, if a function with the return type 'enum letters' actually returns the value [-1]. *) end module type BINDINGS = functor (F : TYPE) -> sig end val write_c : Format.formatter -> (module BINDINGS) -> unit end module type FOREIGN = sig type 'a fn type 'a return val (@->) : 'a Ctypes.typ -> 'b fn -> ('a -> 'b) fn val returning : 'a Ctypes.typ -> 'a return fn type 'a result val foreign : string -> ('a -> 'b) fn -> ('a -> 'b) result val foreign_value : string -> 'a Ctypes.typ -> 'a Ctypes.ptr result end module type BINDINGS = functor (F : FOREIGN with type 'a result = unit) -> sig end type errno_policy (** Values of the [errno_policy] type specify the errno support provided by the generated code. See {!ignore_errno} for the available option. *) val ignore_errno : errno_policy (** Generate code with no special support for errno. This is the default. *) val return_errno : errno_policy (** Generate code that returns errno in addition to the return value of each function. Passing [return_errno] as the [errno] argument to {!Cstubs.write_c} and {!Cstubs.write_ml} changes the return type of bound functions from a single value to a pair of values. For example, the binding specification [let realpath = foreign "reaplath" (string @-> string @-> returning string)] generates a value of the following type by default: [val realpath : string -> string -> stirng] but when using [return_errno] the generated type is as follows: [val realpath : string -> string -> stirng * int] and when using both [return_errno] and [lwt_jobs] the generated type is as follows: [val realpath : string -> string -> (stirng * int) Lwt.t] *) type concurrency_policy (** Values of the [concurrency_policy] type specify the concurrency support provided by the generated code. See {!sequential} and {!lwt_jobs} for the available options. *) val sequential : concurrency_policy (** Generate code with no special support for concurrency. This is the default. *) val lwt_jobs : concurrency_policy (** Generate code which implements C function calls as Lwt jobs: http://ocsigen.org/lwt/2.5.1/api/Lwt_unix#TYPEjob Passing [lwt_jobs] as the [concurrency] argument to {!Cstubs.write_c} and {!Cstubs.write_ml} changes the return type of bound functions to include the {!Lwt.t} constructor. For example, the binding specification [let unlink = foreign "unlink" (string @-> returning int)] generates a value of the following type by default: [val unlink : string -> int] but when using [lwt_jobs] the generated type is as follows: [val unlink : string -> int Lwt.t] *) val write_c : ?concurrency:concurrency_policy -> ?errno:errno_policy -> Format.formatter -> prefix:string -> (module BINDINGS) -> unit (** [write_c fmt ~prefix bindings] generates C stubs for the functions bound with [foreign] in [bindings]. The stubs are intended to be used in conjunction with the ML code generated by {!write_ml}. The optional argument [concurrency] specifies the concurrency support provided by the generated code. The default is [sequential]. The generated code uses definitions exposed in the header file [ctypes_cstubs_internals.h]. *) val write_ml : ?concurrency:concurrency_policy -> ?errno:errno_policy -> Format.formatter -> prefix:string -> (module BINDINGS) -> unit (** [write_ml fmt ~prefix bindings] generates ML bindings for the functions bound with [foreign] in [bindings]. The generated code conforms to the {!FOREIGN} interface. The optional argument [concurrency] specifies the concurrency support provided by the generated code. The default is [sequential]. The generated code uses definitions exposed in the module [Cstubs_internals]. *) ocaml-ctypes-0.7.0/src/cstubs/cstubs_analysis.ml000066400000000000000000000073241274143137600217660ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Analysis for stub generation *) open Ctypes_static let is_float_primitive : type a. a typ -> bool = let open Ctypes_primitive_types in function | Primitive Float -> true | Primitive Double -> true | _ -> false let rec float : type a. a fn -> bool = function | Returns t -> is_float_primitive t | Function (f, t) -> is_float_primitive f && float t (* A value of type 'a noalloc says that reading a value of type 'a will not cause an OCaml allocation in C code. *) type _ noalloc = Noalloc_unit : unit noalloc | Noalloc_int : int noalloc | Noalloc_char : char noalloc | Noalloc_bool : bool noalloc | Noalloc_view : ('a, 'b) view * 'b noalloc -> 'a noalloc (* A value of type 'a alloc says that reading a value of type 'a may cause an OCaml allocation in C code. *) type _ alloc = | Alloc_sint : Signed.sint alloc | Alloc_long : Signed.long alloc | Alloc_llong : Signed.llong alloc | Alloc_uint : Unsigned.uint alloc | Alloc_uchar : Unsigned.uchar alloc | Alloc_ushort : Unsigned.ushort alloc | Alloc_ulong : Unsigned.ulong alloc | Alloc_ullong : Unsigned.ullong alloc | Alloc_size_t : Unsigned.size_t alloc | Alloc_int32_t : int32 alloc | Alloc_int64_t : int64 alloc | Alloc_uint8_t : Unsigned.uint8 alloc | Alloc_uint16_t : Unsigned.uint16 alloc | Alloc_uint32_t : Unsigned.uint32 alloc | Alloc_uint64_t : Unsigned.uint64 alloc | Alloc_nativeint : nativeint alloc | Alloc_float : float alloc | Alloc_complex : Complex.t alloc | Alloc_pointer : (_, _) pointer alloc | Alloc_funptr : _ static_funptr alloc | Alloc_structured : (_, _) structured alloc | Alloc_array : _ carray alloc | Alloc_bigarray : (_, 'a) Ctypes_bigarray.t -> 'a alloc | Alloc_view : ('a, 'b) view * 'b alloc -> 'a alloc type 'a allocation = [ `Noalloc of 'a noalloc | `Alloc of 'a alloc ] let primitive_allocation : type a. a Ctypes_primitive_types.prim -> a allocation = let open Ctypes_primitive_types in function | Char -> `Noalloc Noalloc_char | Bool -> `Noalloc Noalloc_bool | Schar -> `Noalloc Noalloc_int | Short -> `Noalloc Noalloc_int | Int -> `Noalloc Noalloc_int | Int8_t -> `Noalloc Noalloc_int | Int16_t -> `Noalloc Noalloc_int | Camlint -> `Noalloc Noalloc_int | Long -> `Alloc Alloc_long | Llong -> `Alloc Alloc_llong | Ushort -> `Alloc Alloc_ushort | Uchar -> `Alloc Alloc_uchar | Sint -> `Alloc Alloc_sint | Uint -> `Alloc Alloc_uint | Ulong -> `Alloc Alloc_ulong | Ullong -> `Alloc Alloc_ullong | Size_t -> `Alloc Alloc_size_t | Int32_t -> `Alloc Alloc_int32_t | Int64_t -> `Alloc Alloc_int64_t | Uint8_t -> `Alloc Alloc_uint8_t | Uint16_t -> `Alloc Alloc_uint16_t | Uint32_t -> `Alloc Alloc_uint32_t | Uint64_t -> `Alloc Alloc_uint64_t | Nativeint -> `Alloc Alloc_nativeint | Float -> `Alloc Alloc_float | Double -> `Alloc Alloc_float | Complex32 -> `Alloc Alloc_complex | Complex64 -> `Alloc Alloc_complex let rec allocation : type a. a typ -> a allocation = function | Void -> `Noalloc Noalloc_unit | Primitive p -> primitive_allocation p | Pointer _ -> `Alloc Alloc_pointer | Funptr _ -> `Alloc Alloc_funptr | Struct _ -> `Alloc Alloc_structured | Union _ -> `Alloc Alloc_structured | Abstract _ -> `Alloc Alloc_structured | View v -> begin match allocation v.ty with | `Alloc a -> `Alloc (Alloc_view (v, a)) | `Noalloc na -> `Noalloc (Noalloc_view (v, na)) end | Array _ -> `Alloc Alloc_array | Bigarray ba -> `Alloc (Alloc_bigarray ba) | OCaml _ -> `Alloc Alloc_pointer let rec may_allocate : type a. a fn -> bool = function | Returns t -> begin match allocation t with | `Noalloc _ -> false | `Alloc _ -> true end | Function (_, t) -> may_allocate t ocaml-ctypes-0.7.0/src/cstubs/cstubs_analysis.mli000066400000000000000000000004201274143137600221250ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Analysis for stub generation *) val float : 'a Ctypes_static.fn -> bool val may_allocate : 'a Ctypes_static.fn -> bool ocaml-ctypes-0.7.0/src/cstubs/cstubs_c_language.ml000066400000000000000000000211201274143137600222160ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* C code representation. *) open Ctypes_static let fresh_var = let var_counter = ref 0 in fun ?(prefix="x") () -> incr var_counter; Printf.sprintf "%s%d" prefix !var_counter type ty = Ty : _ typ -> ty type tfn = Fn : _ fn -> tfn type fieldname = string type cfunction = { fname: string; allocates: bool; reads_ocaml_heap: bool; fn: tfn; } type cglobal = { name: string; typ: ty; references_ocaml_heap: bool; } type clocal = [ `Local of string * ty ] type cvar = [ clocal | `Global of cglobal ] type storage_class = [`Static | `Extern] type cconst = [ `Int of Signed.sint ] type cexp = [ cconst | clocal | `Cast of ty * cexp | `Addr of cvar ] type clvalue = [ cvar | `Index of clvalue * cexp | `Field of clvalue * fieldname | `PointerField of clvalue * fieldname ] type camlop = [ `CAMLparam0 | `CAMLlocalN of cexp * cexp | `CAMLdrop ] type ceff = [ cexp | camlop | `Global of cglobal | `App of cfunction * cexp list | `Index of ceff * cexp | `Deref of cexp | `DerefField of cexp * fieldname ] type cbind = clocal * ceff type ccomp = [ ceff | `LetConst of clocal * cconst * ccomp | `LetAssign of clvalue * ceff * ccomp | `CAMLreturnT of ty * cexp | `Return of ty * cexp | `Let of cbind * ccomp ] type cfundec = [ `Fundec of string * (string * ty) list * ty ] type cfundef = [ `Function of cfundec * ccomp * storage_class ] let rec return_type : type a. a fn -> ty = function | Function (_, f) -> return_type f | Returns t -> Ty t let args : type a. a fn -> (string * ty) list = fun fn -> let rec loop : type a. a Ctypes.fn -> (string * ty) list = function | Ctypes_static.Function (ty, fn) -> (fresh_var (), Ty ty) :: loop fn | Ctypes_static.Returns _ -> [] in loop fn module Type_C = struct let cexp : cexp -> ty = function | `Int _ -> Ty sint | `Local (_, ty) -> ty | `Cast (Ty ty, _) -> Ty ty | `Addr (`Global { typ = Ty ty }) -> Ty (Pointer ty) | `Addr (`Local (_, Ty ty)) -> Ty (Pointer ty) let camlop : camlop -> ty = function | `CAMLparam0 | `CAMLlocalN _ | `CAMLdrop -> Ty Void let rec ceff : ceff -> ty = function | #cexp as e -> cexp e | #camlop as o -> camlop o | `Global { typ } -> typ | `App ({ fn = Fn f }, _) -> return_type f | `Index (e, _) -> reference_ceff e | `Deref e -> reference_ceff (e :> ceff) | `DerefField (e, f) -> field_ceff (e :> ceff) f and reference_ceff : ceff -> ty = fun e -> begin match ceff e with | Ty (Pointer ty) -> Ty ty | Ty (Array (ty, _)) -> Ty ty | Ty t -> Cstubs_errors.internal_error "dereferencing expression of non-pointer type %s" (Ctypes.string_of_typ t) end and field_ceff : ceff -> fieldname -> ty = fun e f -> begin match ceff e with Ty (Pointer (Struct { fields } as s)) -> lookup_field f s fields | Ty t -> Cstubs_errors.internal_error "accessing a field %s in an expression of type %s, which is not a pointer-to-struct type" f (Ctypes.string_of_typ t) end and lookup_field : type s a. string -> a typ -> s boxed_field list -> ty = fun f ty fields -> match fields with [] -> Cstubs_errors.internal_error "field %s not found in struct %s" f (Ctypes.string_of_typ ty) | BoxedField { ftype; fname } :: _ when fname = f -> Ty ftype | _ :: fields -> lookup_field f ty fields let rec ccomp : ccomp -> ty = function | #cexp as e -> cexp e | #ceff as e -> ceff e | `Let (_, c) | `LetConst (_, _, c) -> ccomp c | `LetAssign (_, _, c) -> ccomp c | `CAMLreturnT (ty, _) -> ty | `Return (ty, _) -> ty end let value : [`value] abstract typ = abstract ~name:"value" ~size:0 ~alignment:0 let reader fname fn = { fname; allocates = false; reads_ocaml_heap = true; fn = Fn fn } let conser fname fn = { fname; allocates = true; reads_ocaml_heap = false; fn = Fn fn } let immediater fname fn = { fname; allocates = false; reads_ocaml_heap = false; fn = Fn fn } module Unchecked_function_types = struct (* We're using an abstract type ([value]) as an argument and return type, so we'll use the [Function] and [Return] constructors directly. The smart constructors [@->] and [returning] would reject the abstract type. *) let (@->) f t = Function (f, t) let returning t = Returns t end let prim_prj : type a. a Ctypes_primitive_types.prim -> _ = let open Unchecked_function_types in let open Ctypes_primitive_types in function | Char -> reader "Int_val" (value @-> returning int) | Schar -> reader "Int_val" (value @-> returning int) | Uchar -> reader "Uint8_val" (value @-> returning uint8_t) | Bool -> reader "Bool_val" (value @-> returning bool) | Short -> reader "Int_val" (value @-> returning int) | Int -> reader "Int_val" (value @-> returning int) | Long -> reader "ctypes_long_val" (value @-> returning long) | Llong -> reader "ctypes_llong_val" (value @-> returning llong) | Ushort -> reader "ctypes_ushort_val" (value @-> returning ushort) | Sint -> reader "ctypes_sint_val" (value @-> returning sint) | Uint -> reader "ctypes_uint_val" (value @-> returning uint) | Ulong -> reader "ctypes_ulong_val" (value @-> returning ulong) | Ullong -> reader "ctypes_ullong_val" (value @-> returning ullong) | Size_t -> reader "ctypes_size_t_val" (value @-> returning size_t) | Int8_t -> reader "Int_val" (value @-> returning int) | Int16_t -> reader "Int_val" (value @-> returning int) | Int32_t -> reader "Int32_val" (value @-> returning int32_t) | Int64_t -> reader "Int64_val" (value @-> returning int64_t) | Uint8_t -> reader "Uint8_val" (value @-> returning uint8_t) | Uint16_t -> reader "Uint16_val" (value @-> returning uint16_t) | Uint32_t -> reader "Uint32_val" (value @-> returning uint32_t) | Uint64_t -> reader "Uint64_val" (value @-> returning uint64_t) | Camlint -> reader "Int_val" (value @-> returning int) | Nativeint -> reader "Nativeint_val" (value @-> returning nativeint) | Float -> reader "Double_val" (value @-> returning double) | Double -> reader "Double_val" (value @-> returning double) | Complex32 -> reader "ctypes_float_complex_val" (value @-> returning complex32) | Complex64 -> reader "ctypes_double_complex_val" (value @-> returning complex64) let prim_inj : type a. a Ctypes_primitive_types.prim -> _ = let open Unchecked_function_types in let open Ctypes_primitive_types in function | Char -> immediater "Ctypes_val_char" (int @-> returning value) | Schar -> immediater "Val_int" (int @-> returning value) | Uchar -> conser "ctypes_copy_uint8" (uint8_t @-> returning value) | Bool -> immediater "Val_bool" (bool @-> returning value) | Short -> immediater "Val_int" (int @-> returning value) | Int -> immediater "Val_int" (int @-> returning value) | Long -> conser "ctypes_copy_long" (long @-> returning value) | Llong -> conser "ctypes_copy_llong" (llong @-> returning value) | Ushort -> conser "ctypes_copy_ushort" (ushort @-> returning value) | Sint -> conser "ctypes_copy_sint" (sint @-> returning value) | Uint -> conser "ctypes_copy_uint" (uint @-> returning value) | Ulong -> conser "ctypes_copy_ulong" (ulong @-> returning value) | Ullong -> conser "ctypes_copy_ullong" (ullong @-> returning value) | Size_t -> conser "ctypes_copy_size_t" (size_t @-> returning value) | Int8_t -> immediater "Val_int" (int @-> returning value) | Int16_t -> immediater "Val_int" (int @-> returning value) | Int32_t -> conser "caml_copy_int32" (int32_t @-> returning value) | Int64_t -> conser "caml_copy_int64" (int64_t @-> returning value) | Uint8_t -> conser "ctypes_copy_uint8" (uint8_t @-> returning value) | Uint16_t -> conser "ctypes_copy_uint16" (uint16_t @-> returning value) | Uint32_t -> conser "ctypes_copy_uint32" (uint32_t @-> returning value) | Uint64_t -> conser "ctypes_copy_uint64" (uint64_t @-> returning value) | Camlint -> immediater "Val_int" (int @-> returning value) | Nativeint -> conser "caml_copy_nativeint" (nativeint @-> returning value) | Float -> conser "caml_copy_double" (double @-> returning value) | Double -> conser "caml_copy_double" (double @-> returning value) | Complex32 -> conser "ctypes_copy_float_complex" (complex32 @-> returning value) | Complex64 -> conser "ctypes_copy_double_complex" (complex64 @-> returning value) ocaml-ctypes-0.7.0/src/cstubs/cstubs_emit_c.ml000066400000000000000000000117711274143137600214040ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* C pretty printing. *) open Ctypes_static open Cstubs_c_language open Format let format_seq lbr fmt_item sep rbr fmt items = let open Format in fprintf fmt "%s@[@[" lbr; ListLabels.iteri items ~f:(fun i item -> if i <> 0 then fprintf fmt "@]%s@ @[" sep; fmt_item fmt item); fprintf fmt "@]%s@]" rbr let format_ty fmt (Ty ty) = Ctypes.format_typ fmt ty let cvar_name = function | `Local (name, _) | `Global { name } -> name let cvar fmt v = fprintf fmt "%s" (cvar_name v) let cconst fmt (`Int i) = fprintf fmt "%s" (Signed.SInt.to_string i) (* Determine whether the C expression [(ty)e] is equivalent to [e] *) let cast_unnecessary : ty -> cexp -> bool = let rec harmless l r = match l, r with | Ty (Pointer Void), Ty (Pointer _) -> true | Ty (View { ty }), t -> harmless (Ty ty) t | t, Ty (View { ty }) -> harmless t (Ty ty) | (Ty (Primitive _) as l), (Ty (Primitive _) as r) -> l = r | _ -> false in fun ty e -> harmless ty (Type_C.cexp e) let rec cexp fmt : cexp -> unit = function | #cconst as c -> cconst fmt c | `Local _ as x -> cvar fmt x | `Cast (ty, e) when cast_unnecessary ty e -> cexp fmt e | `Cast (ty, e) -> fprintf fmt "@[@[(%a)@]%a@]" format_ty ty cexp e | `Addr (`Global { name }) | `Addr (`Local (name, _)) -> fprintf fmt "@[&@[%s@]@]" name let rec clvalue fmt : clvalue -> unit = function | #cvar as x -> cvar fmt x | `Index (lv, i) -> fprintf fmt "@[@[%a@]@[[%a]@]@]" clvalue lv cexp i | `Field (lv, f) -> fprintf fmt "@[@[%a@]@[.%s@]@]" clvalue lv f | `PointerField (lv, f) -> fprintf fmt "@[@[%a@]@[->%s@]@]" clvalue lv f let camlop fmt : camlop -> unit = function | `CAMLparam0 -> Format.fprintf fmt "CAMLparam0()" | `CAMLlocalN (e, c) -> Format.fprintf fmt "CAMLlocalN(@[%a@],@ @[%a@])" cexp e cexp c | `CAMLdrop -> Format.fprintf fmt "caml_local_roots = caml__frame;" (* Format.fprintf fmt "CAMLdrop()" *) (* 4.03+ only *) let rec ceff fmt : ceff -> unit = function | #cexp as e -> cexp fmt e | #camlop as o -> camlop fmt o | `Global _ as x -> cvar fmt x | `App ({fname}, es) -> fprintf fmt "@[%s(@[" fname; let last_exp = List.length es - 1 in List.iteri (fun i e -> fprintf fmt "@[%a@]%(%)" cexp e (if i <> last_exp then ",@ " else "" : (_,_,_) format)) es; fprintf fmt ")@]@]"; | `Index (e, i) -> fprintf fmt "@[@[%a@]@[[%a]@]@]" ceff e cexp i | `Deref e -> fprintf fmt "@[*@[%a@]@]" cexp e | `DerefField (e, f) -> fprintf fmt "@[@[%a@]->%s@]" cexp e f let rec ccomp fmt : ccomp -> unit = function | #cexp as e when Type_C.cexp e = Ty Void -> fprintf fmt "@[return@];" | #cexp as e -> fprintf fmt "@[<2>return@;@[%a@]@];" cexp e | #ceff as e -> fprintf fmt "@[<2>return@;@[%a@]@];" ceff e | `Return (Ty Void, _) -> fprintf fmt "@[return@];" | `Return (Ty ty, e) -> fprintf fmt "@[<2>return@;@[%a@]@];" cexp e | `CAMLreturnT (Ty Void, _) -> fprintf fmt "@[CAMLreturn0@];" | `CAMLreturnT (Ty ty, e) -> fprintf fmt "@[<2>CAMLreturnT(@[%a@],@;@[%a@])@];" (fun t -> Ctypes.format_typ t) ty cexp e | `Let (xe, `Cast (ty, (#cexp as e'))) when cast_unnecessary ty e' -> ccomp fmt (`Let (xe, e')) | `Let ((`Local (x, _), e), `Local (y, _)) when x = y -> ccomp fmt (e :> ccomp) | `Let ((`Local (name, Ty Void), e), s) -> fprintf fmt "@[%a;@]@ %a" ceff e ccomp s | `Let ((`Local (name, Ty (Struct { tag })), e), s) -> fprintf fmt "@[struct@;%s@;%s@;=@;@[%a;@]@]@ %a" tag name ceff e ccomp s | `Let ((`Local (name, Ty (Union { utag })), e), s) -> fprintf fmt "@[union@;%s@;%s@;=@;@[%a;@]@]@ %a" utag name ceff e ccomp s | `Let ((`Local (name, Ty ty), e), s) -> fprintf fmt "@[@[%a@]@;=@;@[%a;@]@]@ %a" (Ctypes.format_typ ~name) ty ceff e ccomp s | `LetConst (`Local (x, _), `Int c, s) -> fprintf fmt "@[enum@ {@[@ %s@ =@ %s@ };@]@]@ %a" x (Signed.SInt.to_string c) ccomp s | `LetAssign (lv, e, c) -> fprintf fmt "@[@[%a@]@;=@;@[%a@];@]@ %a" clvalue lv ceff e ccomp c let format_parameter_list parameters k fmt = let format_arg fmt (name, Ty t) = Ctypes_type_printing.format_typ ~name fmt t in match parameters with | [] -> Format.fprintf fmt "%t(void)" k | [(_, Ty Void)] -> Format.fprintf fmt "@[%t@[(void)@]@]" k | _ -> Format.fprintf fmt "@[%t@[%a@]@]" k (format_seq "(" format_arg "," ")") parameters let cfundec : Format.formatter -> cfundec -> unit = fun fmt (`Fundec (name, args, Ty return)) -> Ctypes_type_printing.format_typ' return (fun context fmt -> format_parameter_list args (Ctypes_type_printing.format_name ~name) fmt) `nonarray fmt let storage_class fmt = function `Static -> fprintf fmt "static@\n" | `Extern -> () let cfundef fmt (`Function (dec, body, sc) : cfundef) = storage_class fmt sc; fprintf fmt "%a@\n{@[@\n%a@]@\n}@\n" cfundec dec ccomp body ocaml-ctypes-0.7.0/src/cstubs/cstubs_errors.ml000066400000000000000000000004701274143137600214520ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Exception definitions *) exception Cstubs_internal_error of string let internal_error fmt = Format.ksprintf (fun s -> raise (Cstubs_internal_error s)) fmt ocaml-ctypes-0.7.0/src/cstubs/cstubs_errors.mli000066400000000000000000000004271274143137600216250ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Exception definitions *) exception Cstubs_internal_error of string val internal_error : ('a, unit, string, 'b) format4 -> 'a ocaml-ctypes-0.7.0/src/cstubs/cstubs_generate_c.ml000066400000000000000000000434601274143137600222400ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* C stub generation *) open Ctypes_static open Cstubs_c_language open Unchecked_function_types let max_byte_args = 5 type errno_policy = [ `Ignore_errno | `Return_errno ] module Generate_C = struct let report_unpassable what = let msg = Printf.sprintf "cstubs does not support passing %s" what in raise (Unsupported msg) let local name ty = `Local (name, Ty ty) let rec (>>=) : type a. ccomp * a typ -> (cexp -> ccomp) -> ccomp = fun (e, ty) k -> let x = fresh_var () in match e with (* let x = v in e ~> e[x:=v] *) | #cexp as v -> k v | #ceff as e -> `Let ((local x ty, e), k (local x ty)) | `LetConst (y, i, c) -> (* let x = (let const y = i in c) in e ~> let const y = i in (let x = c in e) *) let Ty t = Type_C.ccomp c in `LetConst (y, i, (c, t) >>= k) | `CAMLreturnT (Ty ty, v) -> (k v, ty) >>= fun e -> `CAMLreturnT (Type_C.cexp e, e) | `Return (Ty ty, v) -> (k v, ty) >>= fun e -> `Return (Type_C.cexp e, e) | `Let (ye, c) -> (* let x = (let y = e1 in e2) in e3 ~> let y = e1 in (let x = e2 in e3) *) let Ty t = Type_C.ccomp c in `Let (ye, (c, t) >>= k) | `LetAssign (lv, v, c) -> (* let x = (y := e1; e2) in e3 ~> y := e1; let x = e2 in e3 *) let Ty t = Type_C.ccomp c in `LetAssign (lv, v, (c, t) >>= k) let (>>) c1 c2 = (c1, Void) >>= fun _ -> c2 let of_fatptr : cexp -> ceff = fun x -> `App (reader "CTYPES_ADDR_OF_FATPTR" (value @-> returning (ptr void)), [x]) let pair_with_errno : cexp -> ceff = fun x -> `App (conser "ctypes_pair_with_errno" (value @-> returning value), [x]) let string_to_ptr : cexp -> ccomp = fun x -> `App (reader "CTYPES_PTR_OF_OCAML_STRING" (value @-> returning (ptr void)), [x]) let float_array_to_ptr : cexp -> ccomp = fun x -> `App (reader "CTYPES_PTR_OF_FLOAT_ARRAY" (value @-> returning (ptr void)), [x]) let from_ptr : cexp -> ceff = fun x -> `App (conser "CTYPES_FROM_PTR" (ptr void @-> returning value), [x]) let acquire_runtime_system : ccomp = `App (conser "caml_acquire_runtime_system" (ptr void @-> returning void), []) let release_runtime_system : ccomp = `App (conser "caml_release_runtime_system" (ptr void @-> returning void), []) let val_unit : ceff = `Global { name = "Val_unit"; references_ocaml_heap = true; typ = Ty value } let errno = `Global { name = "errno"; references_ocaml_heap = false; typ = Ty sint } let functions : ceff = `Global { name = "functions"; references_ocaml_heap = true; typ = Ty (ptr value) } let caml_callbackN : cfunction = { fname = "caml_callbackN"; allocates = true; reads_ocaml_heap = true; fn = Fn (value @-> int @-> ptr value @-> returning value) } let copy_bytes : cfunction = { fname = "ctypes_copy_bytes"; allocates = true; reads_ocaml_heap = true; fn = Fn (ptr void @-> size_t @-> returning value) } let cast : from:ty -> into:ty -> ccomp -> ccomp = fun ~from:(Ty from) ~into e -> (e, from) >>= fun x -> `Cast (into, x) let rec prj : type a b. a typ -> orig: b typ -> cexp -> ccomp option = fun ty ~orig x -> match ty with | Void -> None | Primitive p -> let { fn = Fn fn } as prj = prim_prj p in let rt = return_type fn in Some (cast ~from:rt ~into:(Ty (Primitive p)) (`App (prj, [x]))) | Pointer _ -> Some (of_fatptr x :> ccomp) | Funptr _ -> Some (of_fatptr x :> ccomp) | Struct s -> Some (((of_fatptr x :> ccomp), ptr void) >>= fun y -> `Deref (`Cast (Ty (ptr orig), y))) | Union u -> Some (((of_fatptr x :> ccomp), ptr void) >>= fun y -> `Deref (`Cast (Ty (ptr orig), y))) | Abstract _ -> report_unpassable "values of abstract type" | View { ty } -> prj ty ~orig x | Array _ -> report_unpassable "arrays" | Bigarray _ -> report_unpassable "bigarrays" | OCaml String -> Some (string_to_ptr x) | OCaml Bytes -> Some (string_to_ptr x) | OCaml FloatArray -> Some (float_array_to_ptr x) let prj ty x = prj ty ~orig:ty x let rec inj : type a. a typ -> clocal -> ceff = fun ty x -> match ty with | Void -> val_unit | Primitive p -> `App (prim_inj p, [`Cast (Ty (Primitive p), (x :> cexp))]) | Pointer _ -> from_ptr (x:> cexp) | Funptr _ -> from_ptr (x:> cexp) | Struct s -> `App (copy_bytes, [`Addr (x :> cvar); `Int (Signed.SInt.of_int (sizeof ty))]) | Union u -> `App (copy_bytes, [`Addr (x :> cvar); `Int (Signed.SInt.of_int (sizeof ty))]) | Abstract _ -> report_unpassable "values of abstract type" | View { ty } -> inj ty x | Array _ -> report_unpassable "arrays" | Bigarray _ -> report_unpassable "bigarrays" | OCaml _ -> report_unpassable "ocaml references as return values" type _ fn = | Returns : 'a typ -> 'a fn | Function : string * 'a typ * 'b fn -> ('a -> 'b) fn let rec name_params : type a. a Ctypes_static.fn -> a fn = function | Ctypes_static.Returns t -> Returns t | Ctypes_static.Function (f, t) -> Function (fresh_var (), f, name_params t) let rec value_params : type a. a fn -> (string * ty) list = function | Returns t -> [] | Function (x, _, t) -> (x, Ty value) :: value_params t let fundec : type a. string -> a Ctypes.fn -> cfundec = fun name fn -> `Fundec (name, args fn, return_type fn) let fn : type a. errno:errno_policy -> cname:string -> stub_name:string -> a Ctypes_static.fn -> cfundef = fun ~errno:errno_ ~cname ~stub_name f -> let fvar = { fname = cname; allocates = false; reads_ocaml_heap = false; fn = Fn f; } in let rec body : type a. _ -> a fn -> _ = fun vars -> function | Returns t -> let x = fresh_var () in let e = `App (fvar, (List.rev vars :> cexp list)) in begin match errno_ with `Ignore_errno -> `Let ((local x t, e), (inj t (local x t) :> ccomp)) | `Return_errno -> (`LetAssign (errno, `Int Signed.SInt.zero, `Let ((local x t, e), ((inj t (local x t) :> ccomp), value) >>= fun v -> (pair_with_errno v :> ccomp))) : ccomp) end | Function (x, f, t) -> begin match prj f (local x value) with None -> body vars t | Some projected -> (projected, f) >>= fun x' -> body (x' :: vars) t end in let f' = name_params f in `Function (`Fundec (stub_name, value_params f', Ty value), body [] f', `Extern) let byte_fn : type a. string -> a Ctypes_static.fn -> int -> cfundef = fun fname fn nargs -> let argv = ("argv", Ty (ptr value)) in let argc = ("argc", Ty int) in let f = { fname ; allocates = true; reads_ocaml_heap = true; fn = Fn fn } in let rec build_call ?(args=[]) = function | 0 -> `App (f, args) | n -> (`Index (`Local argv, `Int (Signed.SInt.of_int (n - 1))), value) >>= fun x -> build_call ~args:(x :: args) (n - 1) in let bytename = Printf.sprintf "%s_byte%d" fname nargs in `Function (`Fundec (bytename, [argv; argc], Ty value), build_call nargs, `Extern) let inverse_fn ~stub_name ~runtime_lock f = let `Fundec (_, args, Ty rtyp) as dec = fundec stub_name f in let idx = local (Printf.sprintf "fn_%s" stub_name) int in let project typ e = match prj typ e with None -> (e :> ccomp) | Some e -> e in let wrap_if cond (lft:ccomp) (rgt:ccomp) = if cond then lft >> rgt else rgt in let call = (* f := functions[fn_name]; x := caml_callbackN(f, nargs, locals); y := T_val(x); CAMLdrop(); y *) (`Index (functions, idx), value) >>= fun f -> (`App (caml_callbackN, [f; local "nargs" int; local "locals" (ptr value)]), value) >>= fun x -> (project rtyp x, rtyp) >>= fun y -> (`CAMLdrop, void) >>= fun _ -> wrap_if runtime_lock release_runtime_system (`Return (Ty rtyp, y)) in let body = (* locals[0] = Val_T0(x0); locals[1] = Val_T1(x1); ... locals[n] = Val_Tn(xn); call; *) snd (ListLabels.fold_right args ~init:(List.length args - 1, call) ~f:(fun (x, Ty t) (i, c) -> i - 1, `LetAssign (`Index (local "locals" (ptr value), `Int (Signed.SInt.of_int i)), (inj t (local x t)), c))) in (* T f(T0 x0, T1 x1, ..., Tn xn) { enum { nargs = n }; CAMLparam0(); CAMLlocalN(locals, nargs); body } *) `Function (dec, `LetConst (local "nargs" int, `Int (Signed.SInt.of_int (List.length args)), wrap_if runtime_lock acquire_runtime_system ( `CAMLparam0 >> `CAMLlocalN (local "locals" (array (List.length args) value), local "nargs" int) >> body)), `Extern) let value : type a. cname:string -> stub_name:string -> a Ctypes_static.typ -> cfundef = fun ~cname ~stub_name typ -> let (e, ty) = (`Addr (`Global { name = cname; typ = Ty typ; references_ocaml_heap = false }), (ptr typ)) in let x = fresh_var () in `Function (`Fundec (stub_name, ["_", Ty value], Ty value), `Let ((local x ty, e), (inj (ptr typ) (local x ty) :> ccomp)), `Extern) end let fn ~errno ~cname ~stub_name fmt fn = let `Function (`Fundec (f, xs, _), _, _) as dec = Generate_C.fn ~errno ~stub_name ~cname fn in let nargs = List.length xs in if nargs > max_byte_args then begin Cstubs_emit_c.cfundef fmt dec; Cstubs_emit_c.cfundef fmt (Generate_C.byte_fn f fn nargs) end else Cstubs_emit_c.cfundef fmt dec let value ~cname ~stub_name fmt typ = let dec = Generate_C.value ~cname ~stub_name typ in Cstubs_emit_c.cfundef fmt dec let inverse_fn ~stub_name ~runtime_lock fmt fn : unit = Cstubs_emit_c.cfundef fmt (Generate_C.inverse_fn ~stub_name ~runtime_lock fn) let inverse_fn_decl ~stub_name fmt fn = Format.fprintf fmt "@[%a@];@\n" Cstubs_emit_c.cfundec (Generate_C.fundec stub_name fn) module Lwt = struct let fprintf, sprintf = Format.fprintf, Printf.sprintf let unsupported t = let fail msg = raise (Unsupported msg) in Printf.ksprintf fail "cstubs.lwt does not support the type %s" (Ctypes.string_of_typ t) let rec prj : type a b. a typ -> orig: b typ -> cexp -> ceff = fun ty ~orig x -> match ty with | Primitive p -> `App (prim_prj p, [x]) | Pointer _ -> Generate_C.of_fatptr x | Funptr _ -> Generate_C.of_fatptr x | View { ty } -> prj ty ~orig x | t -> unsupported t let prj ty x = prj ty ~orig:ty x let lwt_unix_job = abstract ~name:"struct lwt_unix_job" ~size:1 ~alignment:1 let structure_type stub_name = structure (sprintf "job_%s" stub_name) let structure ~errno ~stub_name fmt fn args result = let open Ctypes in let s = structure_type stub_name in let (_ : (_,_) field) = field s "job" lwt_unix_job in let (_ : (_,_) field) = field s "result" result in let () = match errno with `Ignore_errno -> () | `Return_errno -> ignore (field s "error_status" sint) in let () = ListLabels.iter args ~f:(fun (BoxedType t, name) -> ignore (field s name t : (_,_) field)) in let () = seal s in fprintf fmt "@[%a@];@\n" (fun t -> format_typ t) s let worker ~errno ~cname ~stub_name fmt f result args = let fn' = { fname = cname; allocates = false; reads_ocaml_heap = false; fn = Fn f } and j = "j", Ty (ptr (structure_type stub_name)) in let rec body args : _ -> ccomp = function [] -> let r c = Generate_C.cast ~from:(Ty result) ~into:(Ty Void) (`LetAssign (`PointerField (`Local j, "result"), `App (fn', List.rev args), c)) in begin match errno with `Ignore_errno -> r (`Return (Ty Void, (`Int Signed.SInt.zero))) | `Return_errno -> let open Generate_C in r (`LetAssign (`PointerField (`Local j, "error_status"), errno, `Return (Ty Void, (`Int Signed.SInt.zero)))) end | (BoxedType ty, x) :: xs -> Generate_C.((`DerefField (`Local j, x), ty) >>= fun y -> body (y :: args) xs) in Cstubs_emit_c.cfundef fmt (`Function (`Fundec (sprintf "worker_%s" stub_name, [j], Ty void), body [] args, `Static)) let result ~errno ~stub_name fmt fn result = begin fprintf fmt "@[static@ value@ result_%s@;@[(struct@ job_%s@ *j)@]@]@;@[<2>{@\n" stub_name stub_name; fprintf fmt "@[CAMLparam0@ ();@]@\n"; fprintf fmt "@[CAMLlocal1@ (rv);@]@\n"; let () = match errno with `Ignore_errno -> fprintf fmt "@[rv@ =@ ("; | `Return_errno -> fprintf fmt "@[rv@ =@ caml_alloc_tuple(2);@]@\n"; fprintf fmt "@[Store_field(rv,@ 1,@ ctypes_copy_sint(j->error_status));@]@\n"; fprintf fmt "@[Store_field(rv,@ 0,@ "; in fprintf fmt "%a);@]@\n" (fun fmt ty -> Cstubs_emit_c.ceff fmt (Generate_C.inj ty (`Local ("j->result", Cstubs_c_language.(Ty ty))))) result; fprintf fmt "@[lwt_unix_free_job(&j->job)@];@\n"; fprintf fmt "@[CAMLreturn@ (rv)@];@]@\n"; fprintf fmt "}@\n"; end let rec camlxParam fmt args = match args with [] -> () | x1 :: [] -> fprintf fmt "@[CAMLxparam1 (%s)@];@\n" x1 | x1 :: x2 :: [] -> fprintf fmt "@[CAMLxparam2 (%s, %s)@];@\n" x1 x2 | x1 :: x2 :: x3 :: [] -> fprintf fmt "@[CAMLxparam3 (%s, %s, %s)@];@\n" x1 x2 x3 | x1 :: x2 :: x3 :: x4 :: [] -> fprintf fmt "@[CAMLxparam4 (%s, %s, %s, %s)@];@\n" x1 x2 x3 x4 | x1 :: x2 :: x3 :: x4 :: x5 :: rest -> fprintf fmt "@[CAMLxparam5 (%s, %s, %s, %s, %s)@];@\n" x1 x2 x3 x4 x5; camlxParam fmt rest let camlParam fmt args = match args with [] -> fprintf fmt "@[CAMLparam0 ()@];@\n" | x1 :: [] -> fprintf fmt "@[CAMLparam1 (%s)@];@\n" x1 | x1 :: x2 :: [] -> fprintf fmt "@[CAMLparam2 (%s, %s)@];@\n" x1 x2 | x1 :: x2 :: x3 :: [] -> fprintf fmt "@[CAMLparam3 (%s, %s, %s)@];@\n" x1 x2 x3 | x1 :: x2 :: x3 :: x4 :: [] -> fprintf fmt "@[CAMLparam4 (%s, %s, %s, %s)@];@\n" x1 x2 x3 x4 | x1 :: x2 :: x3 :: x4 :: x5 :: rest -> fprintf fmt "@[CAMLparam5 (%s, %s, %s, %s, %s)@];@\n" x1 x2 x3 x4 x5; camlxParam fmt rest let stub ~errno ~stub_name fmt fn args = begin fprintf fmt "@[value@ %s@;@[(%s)@]@]@;@[<2>{@\n" stub_name (String.concat ", " (List.map (fun (_, x) -> "value "^ x) args)); camlParam fmt (List.map snd args); fprintf fmt "@[LWT_UNIX_INIT_JOB(job,@ %s,@ 0)@];@\n" stub_name; let () = match errno with `Ignore_errno -> () | `Return_errno -> fprintf fmt "@[job->error_status@ =@ 0@];@\n" in ListLabels.iter args ~f:(fun (BoxedType t, x) -> fprintf fmt "@[job->%s@ =@ %a@];@\n" x (fun fmt (t, x) -> Cstubs_emit_c.ceff fmt (prj t (`Local (x, Cstubs_c_language.(Ty value))))) (t, x)); fprintf fmt "@[CAMLreturn(lwt_unix_alloc_job(&(job->job)))@];@]@\n"; fprintf fmt "}@\n"; end let byte_stub ~errno ~stub_name fmt fn args = begin let nargs = List.length args in fprintf fmt "@[value@ %s_byte%d@;@[(value *argv, int argc)@]@]@;@[<2>{@\n" stub_name nargs; fprintf fmt "@[<2>return@ @[%s(@[" stub_name; ListLabels.iteri args ~f:(fun i _ -> if i = nargs - 1 then fprintf fmt "argv[%d]" i else fprintf fmt "argv[%d],@ " i); fprintf fmt ")@]@]@];@]@\n"; fprintf fmt "}@\n"; end let fn_args_and_result fn = let counter = ref 0 in let var prefix = incr counter; Printf.sprintf "%s_%d" prefix !counter in let rec aux : type a. a fn -> _ -> _ = fun fn args -> match fn with Function (Void, f) -> aux f args | Function (t, f) -> aux f ((BoxedType t, var "arg") :: args) | Returns t -> List.rev args, BoxedType t in aux fn [] let fn ~errno ~cname ~stub_name fmt fn = let args, BoxedType r = fn_args_and_result fn in begin structure ~errno ~stub_name fmt fn args r; worker ~errno ~cname ~stub_name fmt fn r args; result ~errno ~stub_name fmt fn r; stub ~errno ~stub_name fmt fn args; if List.length args > max_byte_args then byte_stub ~errno ~stub_name fmt fn args; fprintf fmt "@\n"; end end let fn ~concurrency ~errno = match concurrency with `Sequential -> fn ~errno | `Lwt_jobs -> Lwt.fn ~errno ocaml-ctypes-0.7.0/src/cstubs/cstubs_generate_c.mli000066400000000000000000000012431274143137600224020ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* C stub generation *) val fn : concurrency:[ `Sequential | `Lwt_jobs ] -> errno:[ `Ignore_errno | `Return_errno ] -> cname:string -> stub_name:string -> Format.formatter -> 'a Ctypes.fn -> unit val value : cname:string -> stub_name:string -> Format.formatter -> 'a Ctypes.typ -> unit val inverse_fn : stub_name:string -> runtime_lock:bool -> Format.formatter -> 'a Ctypes.fn -> unit val inverse_fn_decl : stub_name:string -> Format.formatter -> 'a Ctypes.fn -> unit ocaml-ctypes-0.7.0/src/cstubs/cstubs_generate_ml.ml000066400000000000000000000571371274143137600224340ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* ML stub generation *) open Ctypes_static open Ctypes_path open Cstubs_errors type concurrency_policy = [ `Sequential | `Lwt_jobs ] type errno_policy = [ `Ignore_errno | `Return_errno ] type lident = string type ml_type = [ `Ident of path | `Appl of path * ml_type list | `Pair of ml_type * ml_type | `Fn of ml_type * ml_type ] type ml_external_type = [ `Prim of ml_type list * ml_type ] type ml_pat = [ `Var of string | `Record of (path * ml_pat) list | `As of ml_pat * string | `Underscore | `Con of path * ml_pat list ] type ml_exp = [ `Ident of path | `Project of ml_exp * path | `MakePtr of ml_exp * ml_exp | `MakeFunPtr of ml_exp * ml_exp | `MakeStructured of ml_exp * ml_exp | `Appl of ml_exp * ml_exp | `Tuple of ml_exp list | `Seq of ml_exp * ml_exp | `Let of lident * ml_exp * ml_exp | `Unit | `Fun of lident list * ml_exp ] type attributes = { float: bool; noalloc: bool } type extern = { ident : string; typ: ml_external_type; primname: string; primname_byte: string option; attributes: attributes; } module Emit_ML : sig type appl_parens = ApplParens | NoApplParens val ml_exp : appl_parens -> Format.formatter -> ml_exp -> unit val ml_pat : appl_parens -> Format.formatter -> ml_pat -> unit val ml_external_type : Format.formatter -> ml_external_type -> unit val extern : Format.formatter -> extern -> unit end = struct let fprintf = Format.fprintf (* We (only) need to parenthesize function types in certain contexts * on the lhs of a function type: - -> t * as the argument to a single-argument type constructor: - t *) type arrow_parens = ArrowParens | NoArrowParens (* We (only) need to parenthesize application expressions in certain contexts * in a projection expression: -.l * in a dereference expression: !@ - * as an argument in an application: e - *) type appl_parens = ApplParens | NoApplParens let ident = format_path let rec ml_type arrow_parens fmt t = match arrow_parens, t with | _, `Ident i -> ident fmt i | _, `Appl (t, []) -> ident fmt t | _, `Appl (t, [t']) -> fprintf fmt "@[%a@ %a@]" (ml_type ArrowParens) t' ident t | _, `Appl (t, ts) -> let nargs = List.length ts in fprintf fmt "("; List.iteri (fun i arg -> if i = nargs - 1 then (ml_type NoArrowParens) fmt arg else fprintf fmt "%a,@ " (ml_type NoArrowParens) arg ) ts; fprintf fmt ")@ %a" ident t; | ArrowParens, `Fn (t, t') -> fprintf fmt "@[(%a@ ->@ %a)@]" (ml_type ArrowParens) t (ml_type NoArrowParens) t' | NoArrowParens, `Fn (t, t') -> fprintf fmt "@[%a@ ->@]@ %a" (ml_type ArrowParens) t (ml_type NoArrowParens) t' | _, `Pair (t, t') -> fprintf fmt "@[(%a@ *@ %a)@]" (ml_type NoArrowParens) t (ml_type NoArrowParens) t' let ml_external_type fmt (`Prim (args, ret) : ml_external_type) = List.iter (fprintf fmt "@[%a@ ->@]@ " (ml_type ArrowParens)) args; ml_type ArrowParens fmt ret let primname_opt fmt = function | None -> () | Some primname -> fprintf fmt "%S@ " primname let attrs fmt { float; noalloc } = begin (* TODO: float support not yet implemented *) (* if float then pp_print_string fmt "\"float\""; *) (* TODO: fix this. The may_allocate function determines whether any of the functions in the generated C cause OCaml heap allocations. However, it doesn't currently account for callbacks: if we pass a handle to an OCaml function into C, calling the function can trigger an allocation. We need some way in the interface of the library for the client to indicate whether it is safe to assume that a C function cannot call back into OCaml. *) (* if noalloc then pp_print_string fmt "\"noalloc\"" *) end let args fmt xs = List.iter (fprintf fmt "%s@ ") xs let rec ml_exp appl_parens fmt (e : ml_exp) = match appl_parens, e with | _, `Unit -> fprintf fmt "()" | _, `Ident x -> ident fmt x | _, `Project (e, l) -> fprintf fmt "%a.%a" (ml_exp ApplParens) e ident l | ApplParens, `Appl (f, p) -> fprintf fmt "@[(%a@;<1 2>%a)@]" (ml_exp NoApplParens) f (ml_exp ApplParens) p | NoApplParens, `Appl (f, p) -> fprintf fmt "@[%a@ %a@]" (ml_exp NoApplParens) f (ml_exp ApplParens) p | ApplParens, `MakePtr (t, e) -> fprintf fmt "(@[CI.make_ptr@ %a@ %a)@]" (ml_exp ApplParens) t (ml_exp ApplParens) e | NoApplParens, `MakePtr (t, e) -> fprintf fmt "@[CI.make_ptr@ %a@ %a@]" (ml_exp ApplParens) t (ml_exp ApplParens) e | ApplParens, `MakeFunPtr (t, e) -> fprintf fmt "(@[CI.make_fun_ptr@ %a@ %a)@]" (ml_exp ApplParens) t (ml_exp ApplParens) e | NoApplParens, `MakeFunPtr (t, e) -> fprintf fmt "@[CI.make_fun_ptr@ %a@ %a@]" (ml_exp ApplParens) t (ml_exp ApplParens) e | ApplParens, `MakeStructured (t, e) -> fprintf fmt "(@[CI.make_structured@ %a@ %a)@]" (ml_exp ApplParens) t (ml_exp ApplParens) e | NoApplParens, `MakeStructured (t, e) -> fprintf fmt "@[CI.make_structured@ %a@ %a@]" (ml_exp ApplParens) t (ml_exp ApplParens) e | _, `Fun (xs, e) -> fprintf fmt "(@[<1>fun@ %a->@ %a)@]" args xs (ml_exp NoApplParens) e | _, `Tuple es -> fprintf fmt "(@[%a)@]" tuple_elements es | _, `Seq (e1, e2) -> fprintf fmt "(@[%a;@ %a)@]" (ml_exp NoApplParens) e1 (ml_exp NoApplParens) e2 | ApplParens, `Let (x, e1, e2) -> fprintf fmt "(@[let@ %s@ = %a@ in@ %a)@]" x (ml_exp NoApplParens) e1 (ml_exp NoApplParens) e2 | NoApplParens, `Let (x, e1, e2) -> fprintf fmt "@[let@ %s@ = %a@ in@ %a@]" x (ml_exp NoApplParens) e1 (ml_exp NoApplParens) e2 and tuple_elements fmt : ml_exp list -> unit = fun xs -> let last = List.length xs - 1 in List.iteri (fun i -> if i <> last then fprintf fmt "%a,@ " (ml_exp NoApplParens) else fprintf fmt "%a" (ml_exp NoApplParens)) xs let rec ml_pat appl_parens fmt pat = match appl_parens, pat with | _, `Var x -> fprintf fmt "%s" x | _, `Record fs -> fprintf fmt "{@[%a}@]" pat_fields fs | _, `As (p, x) -> fprintf fmt "@[(%a@ as@ %s)@]" (ml_pat NoApplParens) p x | _, `Underscore -> fprintf fmt "_" | _, `Con (c, []) -> fprintf fmt "%a" format_path c | NoApplParens, `Con (c, [p]) -> fprintf fmt "@[<2>%a@ @[%a@]@]" format_path c (ml_pat ApplParens) p | ApplParens, `Con (c, [p]) -> fprintf fmt "(@[<2>%a@ @[%a@])@]" format_path c (ml_pat ApplParens) p | ApplParens, `Con (c, ps) -> fprintf fmt "(@[<2>%a@ (@[%a)@])@]" format_path c pat_args ps | NoApplParens, `Con (c, ps) -> fprintf fmt "@[<2>%a@ (@[%a)@]@]" format_path c pat_args ps and pat_fields fmt : (path * ml_pat) list -> unit = List.iter (fun (l, p) -> fprintf fmt "@[%a@ =@ %a;@]@ " format_path l (ml_pat NoApplParens) p) and pat_args fmt : ml_pat list -> unit = fun xs -> let last = List.length xs - 1 in List.iteri (fun i -> if i <> last then fprintf fmt "%a,@ " (ml_pat NoApplParens) else fprintf fmt "%a" (ml_pat NoApplParens)) xs let extern fmt { ident; typ; primname; primname_byte; attributes } = fprintf fmt "@[@[external@ %s@]@ @[:@ @[%a@]@]@ " ident ml_external_type typ; fprintf fmt "@[=@ @[@[%a@]@[%S@]@ %a@]@]@]@." primname_opt primname_byte primname attrs attributes end let arity : ml_external_type -> int = fun (`Prim (args, _)) -> List.length args let max_byte_args = 5 let byte_stub_name : string -> ml_external_type -> string option = fun name t -> let arity = arity t in if arity > max_byte_args then Some (Printf.sprintf "%s_byte%d" name arity) else None let attributes : type a. a fn -> attributes = let open Cstubs_analysis in fun fn -> { float = float fn; noalloc = not (may_allocate fn) } let managed_buffer = `Ident (path_of_string "CI.managed_buffer") let voidp = `Ident (path_of_string "CI.voidp") let fatptr = `Appl (path_of_string "CI.fatptr", [`Ident (path_of_string "_")]) let fatfunptr = `Appl (path_of_string "CI.fatfunptr", [`Ident (path_of_string "_")]) (* These functions determine the type that should appear in the extern signature *) let rec ml_typ_of_return_typ : type a. a typ -> ml_type = function | Void -> `Ident (path_of_string "unit") | Primitive p -> `Ident (Cstubs_public_name.ident_of_ml_prim (Ctypes_primitive_types.ml_prim p)) | Struct _ -> managed_buffer | Union _ -> managed_buffer | Abstract _ -> managed_buffer | Pointer _ -> voidp | Funptr _ -> voidp | View { ty } -> ml_typ_of_return_typ ty | Array _ as a -> internal_error "Unexpected array type in the return type: %s" (Ctypes.string_of_typ a) | Bigarray _ as a -> internal_error "Unexpected bigarray type in the return type: %s" (Ctypes.string_of_typ a) | OCaml String -> Ctypes_static.unsupported "cstubs does not support OCaml strings as return values" | OCaml Bytes -> Ctypes_static.unsupported "cstubs does not support OCaml bytes values as return values" | OCaml FloatArray -> Ctypes_static.unsupported "cstubs does not support OCaml float arrays as return values" let rec ml_typ_of_arg_typ : type a. a typ -> ml_type = function | Void -> `Ident (path_of_string "unit") | Primitive p -> `Ident (Cstubs_public_name.ident_of_ml_prim (Ctypes_primitive_types.ml_prim p)) | Pointer _ -> fatptr | Funptr _ -> fatfunptr | Struct _ -> fatptr | Union _ -> fatptr | Abstract _ -> fatptr | View { ty } -> ml_typ_of_arg_typ ty | Array _ as a -> internal_error "Unexpected array in an argument type: %s" (Ctypes.string_of_typ a) | Bigarray _ as a -> internal_error "Unexpected bigarray in an argument type: %s" (Ctypes.string_of_typ a) | OCaml String -> `Appl (path_of_string "CI.ocaml", [`Ident (path_of_string "string")]) | OCaml Bytes -> `Appl (path_of_string "CI.ocaml", [`Ident (path_of_string "Bytes.t")]) | OCaml FloatArray -> `Appl (path_of_string "CI.ocaml", [`Appl (path_of_string "array", [`Ident (path_of_string "float")])]) type polarity = In | Out let flip = function | In -> Out | Out -> In let ml_typ_of_typ = function In -> ml_typ_of_arg_typ | Out -> ml_typ_of_return_typ let lwt_job_type = Ctypes_path.path_of_string "Lwt_unix.job" let int_type = `Ident (Ctypes_path.path_of_string "Signed.sint") let rec ml_external_type_of_fn : type a. concurrency:concurrency_policy -> errno:errno_policy -> a fn -> polarity -> ml_external_type = fun ~concurrency ~errno fn polarity -> match fn, concurrency, errno with | Returns t, `Sequential, `Ignore_errno -> `Prim ([], ml_typ_of_typ polarity t) | Returns t, `Sequential, `Return_errno -> `Prim ([], `Pair (ml_typ_of_typ polarity t, int_type)) | Returns t, `Lwt_jobs, `Ignore_errno -> `Prim ([], `Appl (lwt_job_type, [ml_typ_of_typ polarity t])) | Returns t, `Lwt_jobs, `Return_errno -> `Prim ([], `Appl (lwt_job_type, [`Pair (ml_typ_of_typ polarity t, int_type)])) | Function (f, t), _, _ -> let `Prim (l, t) = ml_external_type_of_fn ~concurrency ~errno t polarity in `Prim (ml_typ_of_typ (flip polarity) f :: l, t) let var_counter = ref 0 let fresh_var () = incr var_counter; Printf.sprintf "x%d" !var_counter let extern ~concurrency ~errno ~stub_name ~external_name fmt fn = let ext = let typ = ml_external_type_of_fn ~concurrency ~errno fn Out in ({ ident = external_name; typ = typ; primname = stub_name; primname_byte = byte_stub_name stub_name typ; attributes = attributes fn; }) in Format.fprintf fmt "%a@." Emit_ML.extern ext let static_con c args = `Con (Ctypes_path.path_of_string ("CI." ^ c), args) let local_con c args = `Con (Ctypes_path.path_of_string c, args) let map_result_id = Ctypes_path.path_of_string "map_result" let make_ptr = Ctypes_path.path_of_string "CI.make_ptr" let make_fun_ptr = Ctypes_path.path_of_string "CI.make_fun_ptr" let make_structured = Ctypes_path.path_of_string "CI.make_structured" let map_result ~concurrency ~errno f e = let map_result f x = `Appl (`Appl (`Ident map_result_id, f), x) in match concurrency, errno, f with `Sequential, `Ignore_errno, `MakePtr x -> `MakePtr (`Ident (path_of_string x), e) | `Sequential, `Ignore_errno, `MakeFunPtr x -> `MakeFunPtr (`Ident (path_of_string x), e) | `Sequential, `Ignore_errno, `MakeStructured x -> `MakeStructured (`Ident (path_of_string x), e) | `Sequential, `Ignore_errno, `Appl x -> `Appl (`Ident (path_of_string x), e) | _, _, `MakePtr x -> map_result (`Appl (`Ident make_ptr, `Ident (path_of_string x))) e | _, _, `MakeFunPtr x -> map_result (`Appl (`Ident make_fun_ptr, `Ident (path_of_string x))) e | _, _, `MakeStructured x -> map_result (`Appl (`Ident make_structured, `Ident (path_of_string x))) e | _, _, `Appl x -> map_result (`Ident (path_of_string x)) e let rec pattern_and_exp_of_typ : type a. concurrency:concurrency_policy -> errno:errno_policy -> a typ -> ml_exp -> polarity -> (lident * ml_exp) list -> ml_pat * ml_exp option * (lident * ml_exp) list = fun ~concurrency ~errno typ e pol binds -> match typ with | Void -> (static_con "Void" [], None, binds) | Primitive p -> let id = Cstubs_public_name.constructor_cident_of_prim ~module_name:"CI" p in (static_con "Primitive" [`Con (id, [])], None, binds) | Pointer _ -> let x = fresh_var () in let pat = static_con "Pointer" [`Var x] in begin match pol with | In -> (pat, Some (`Appl (`Ident (path_of_string "CI.cptr"), e)), binds) | Out -> (pat, Some (map_result ~concurrency ~errno (`MakePtr x) e), binds) end | Funptr _ -> let x = fresh_var () in let pat = static_con "Funptr" [`Var x] in begin match pol with | In -> (pat, Some (`Appl (`Ident (path_of_string "CI.fptr"), e)), binds) | Out -> (pat, Some (map_result ~concurrency ~errno (`MakeFunPtr x) e), binds) end | Struct _ -> begin match pol with | In -> let pat = static_con "Struct" [`Underscore] in (pat, Some (`Appl (`Ident (path_of_string "CI.cptr"), `Appl (`Ident (path_of_string "Ctypes.addr"), e))), binds) | Out -> let x = fresh_var () in let pat = `As (static_con "Struct" [`Underscore], x) in (pat, Some (map_result ~concurrency ~errno (`MakeStructured x) e), binds) end | Union _ -> begin match pol with | In -> let pat = static_con "Union" [`Underscore] in (pat, Some (`Appl (`Ident (path_of_string "CI.cptr"), `Appl (`Ident (path_of_string "Ctypes.addr"), e))), binds) | Out -> let x = fresh_var () in let pat = `As (static_con "Union" [`Underscore], x) in (pat, Some (map_result ~concurrency ~errno (`MakeStructured x) e), binds) end | View { ty } -> begin match pol with | In -> let x = fresh_var () in let y = fresh_var () in let e = `Appl (`Ident (path_of_string x), e) in let (p, None, binds), e | (p, Some e, binds), _ = pattern_and_exp_of_typ ~concurrency ~errno ty e pol binds, e in let pat = static_con "View" [`Record [path_of_string "CI.ty", p; path_of_string "write", `Var x]] in (pat, Some (`Ident (Ctypes_path.path_of_string y)), (y, e) :: binds) | Out -> let (p, None, binds), e | (p, Some e, binds), _ = pattern_and_exp_of_typ ~concurrency ~errno ty e pol binds, e in let x = fresh_var () in let pat = static_con "View" [`Record [path_of_string "CI.ty", p; path_of_string "read", `Var x]] in (pat, Some (map_result ~concurrency ~errno (`Appl x) e), binds) end | OCaml ty -> begin match pol, ty with | In, String -> (static_con "OCaml" [static_con "String" []], None, binds) | In, Bytes -> (static_con "OCaml" [static_con "Bytes" []], None, binds) | In, FloatArray -> (static_con "OCaml" [static_con "FloatArray" []], None, binds) | Out, String -> Ctypes_static.unsupported "cstubs does not support OCaml strings as return values" | Out, Bytes -> Ctypes_static.unsupported "cstubs does not support OCaml bytes values as return values" | Out, FloatArray -> Ctypes_static.unsupported "cstubs does not support OCaml float arrays as return values" end | Abstract _ as ty -> internal_error "Unexpected abstract type encountered during ML code generation: %s" (Ctypes.string_of_typ ty) | Array _ as ty -> internal_error "Unexpected array type encountered during ML code generation: %s" (Ctypes.string_of_typ ty) | Bigarray _ as ty -> internal_error "Unexpected bigarray type encountered during ML code generation: %s" (Ctypes.string_of_typ ty) (* Build a pattern (without variables) that matches the argument *) let rec pattern_of_typ : type a. a typ -> ml_pat = function Void -> static_con "Void" [] | Primitive p -> let id = Cstubs_public_name.constructor_cident_of_prim ~module_name:"CI" p in static_con "Primitive" [`Con (id, [])] | Pointer _ -> static_con "Pointer" [`Underscore] | Funptr _ -> static_con "Funptr" [`Underscore] | Struct _ -> static_con "Struct" [`Underscore] | Union _ -> static_con "Union" [`Underscore] | View { ty } -> static_con "View" [`Record [path_of_string "CI.ty", pattern_of_typ ty]] | OCaml String -> Ctypes_static.unsupported "cstubs does not support OCaml strings as global values" | OCaml Bytes -> Ctypes_static.unsupported "cstubs does not support OCaml bytes values as global values" | OCaml FloatArray -> Ctypes_static.unsupported "cstubs does not support OCaml float arrays as global values" | Abstract _ as ty -> internal_error "Unexpected abstract type encountered during ML code generation: %s" (Ctypes.string_of_typ ty) | Array _ as ty -> internal_error "Unexpected array type encountered during ML code generation: %s" (Ctypes.string_of_typ ty) | Bigarray _ as ty -> internal_error "Unexpected bigarray type encountered during ML code generation: %s" (Ctypes.string_of_typ ty) type wrapper_state = { pat: ml_pat; exp: ml_exp; args: lident list; trivial: bool; binds: (lident * ml_exp) list; } let lwt_unix_run_job = Ctypes_path.path_of_string "Lwt_unix.run_job" let run_exp ~concurrency exp = match concurrency with `Sequential -> exp | `Lwt_jobs -> `Appl (`Ident lwt_unix_run_job, exp) let let_bind : (lident * ml_exp) list -> ml_exp -> ml_exp = fun binds e -> ListLabels.fold_left ~init:e binds ~f:(fun e' (x, e) -> `Let (x, e, e')) let rec wrapper_body : type a. concurrency:concurrency_policy -> errno:errno_policy -> a fn -> ml_exp -> polarity -> (lident * ml_exp) list -> wrapper_state = fun ~concurrency ~errno fn exp pol binds -> match fn with | Returns t -> let exp = run_exp ~concurrency exp in begin match pattern_and_exp_of_typ ~concurrency ~errno t exp (flip pol) binds with pat, None, binds -> { exp ; args = []; trivial = true; binds; pat = local_con "Returns" [pat] } | pat, Some exp, binds -> { exp; args = []; trivial = false; binds; pat = local_con "Returns" [pat] } end | Function (f, t) -> let x = fresh_var () in begin match pattern_and_exp_of_typ ~concurrency ~errno f (`Ident (path_of_string x)) pol binds with | fpat, None, binds -> let { exp; args; trivial; pat = tpat; binds } = wrapper_body ~concurrency ~errno t (`Appl (exp, `Ident (path_of_string x))) pol binds in { exp; args = x :: args; trivial; binds; pat = local_con "Function" [fpat; tpat] } | fpat, Some exp', binds -> let { exp; args = xs; trivial; pat = tpat; binds } = wrapper_body ~concurrency ~errno t (`Appl (exp, exp')) pol binds in { exp; args = x :: xs; trivial = false; binds; pat = local_con "Function" [fpat; tpat] } end let lwt_bind = Ctypes_path.path_of_string "Lwt.bind" let lwt_return = Ctypes_path.path_of_string "Lwt.return" let box_lwt = Ctypes_path.path_of_string "box_lwt" let use_value = Ctypes_path.path_of_string "CI.use_value" let return_result : args:lident list -> ml_exp = fun ~args -> let x = fresh_var () in (* fun v -> CI.use_value (x1,x2,....xn); Lwt.return v *) `Fun ([x], `Seq (`Appl (`Ident use_value, `Tuple (ListLabels.map args ~f:(fun x -> `Ident (Ctypes_path.path_of_string x)))), `Appl (`Ident lwt_return, `Ident (Ctypes_path.path_of_string x)))) let wrapper : type a. concurrency:concurrency_policy -> errno:errno_policy -> path -> a fn -> string -> polarity -> ml_pat * ml_exp = fun ~concurrency ~errno id fn f pol -> let p = wrapper_body ~concurrency ~errno fn (`Ident (path_of_string f)) pol [] in match p, concurrency with { trivial = true; pat; binds }, `Sequential -> (pat, let_bind binds (run_exp ~concurrency (`Ident id))) | { exp; args; pat; binds }, `Sequential -> (pat, `Fun (args, let_bind binds exp)) | { trivial = true; pat; args; binds }, `Lwt_jobs -> let exp : ml_exp = List.fold_left (fun f p -> `Appl (f, `Ident (path_of_string p))) (`Ident id) args in (pat, `Fun (args, let_bind binds (`Appl (`Ident box_lwt, `Appl (`Appl (`Ident lwt_bind, run_exp ~concurrency exp), return_result ~args:(args @ (List.map fst binds))))))) | { exp; args; pat; binds }, `Lwt_jobs -> (pat, `Fun (args, let_bind binds (`Appl (`Ident box_lwt, `Appl (`Appl (`Ident lwt_bind, exp), return_result ~args:(args @ (List.map fst binds))))))) let case ~concurrency ~errno ~stub_name ~external_name fmt fn = let p, e = wrapper ~concurrency ~errno (path_of_string external_name) fn external_name In in Format.fprintf fmt "@[@[|@ @[@[%a@],@ %S@]@ ->@]@ " Emit_ML.(ml_pat NoApplParens) p stub_name; Format.fprintf fmt "@[@[%a@]@]@]@." Emit_ML.(ml_exp ApplParens) e let val_case ~stub_name ~external_name fmt typ = let x = fresh_var () in let p = `As (pattern_of_typ typ, x) in let app = `Appl (`Ident (path_of_string external_name), `Unit) in let rhs = `MakePtr (`Ident (path_of_string x), app) in Format.fprintf fmt "@[@[|@ @[@[%a@],@ %S@]@ ->@]@ " Emit_ML.(ml_pat NoApplParens) p stub_name; Format.fprintf fmt "@[@[%a@]@]@]@." Emit_ML.(ml_exp (ApplParens)) rhs let constructor_decl : type a. concurrency:concurrency_policy -> errno:errno_policy -> string -> a fn -> Format.formatter -> unit = fun ~concurrency ~errno name fn fmt -> Format.fprintf fmt "@[|@ %s@ : (@[%a@])@ name@]@\n" name Emit_ML.ml_external_type (ml_external_type_of_fn ~concurrency ~errno fn In) let inverse_case ~register_name ~constructor name fmt fn : unit = let p, e = wrapper ~concurrency:`Sequential ~errno:`Ignore_errno (path_of_string "f") fn "f" Out in Format.fprintf fmt "|@[ @[%a, %S@] -> %s %s (%a)@]@\n" Emit_ML.(ml_pat NoApplParens) p name register_name constructor Emit_ML.(ml_exp ApplParens) e ocaml-ctypes-0.7.0/src/cstubs/cstubs_generate_ml.mli000066400000000000000000000017761274143137600226030ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* ML stub generation *) val extern : concurrency:[ `Sequential | `Lwt_jobs ] -> errno:[ `Ignore_errno | `Return_errno ] -> stub_name:string -> external_name:string -> Format.formatter -> ('a -> 'b) Ctypes.fn -> unit val case : concurrency:[ `Sequential | `Lwt_jobs ] -> errno:[ `Ignore_errno | `Return_errno ] -> stub_name:string -> external_name:string -> Format.formatter -> ('a -> 'b) Ctypes.fn -> unit val val_case : stub_name:string -> external_name:string -> Format.formatter -> 'a Ctypes.typ -> unit val constructor_decl : concurrency:[ `Sequential | `Lwt_jobs ] -> errno:[ `Ignore_errno | `Return_errno ] -> string -> 'a Ctypes.fn -> Format.formatter -> unit val inverse_case : register_name:string -> constructor:string -> string -> Format.formatter -> ('a -> 'b) Ctypes.fn -> unit ocaml-ctypes-0.7.0/src/cstubs/cstubs_internals.ml000066400000000000000000000074631274143137600221460ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Types and functions used by generated ML code. This is an internal interface and subject to change. *) type voidp = Ctypes_ptr.voidp type managed_buffer = Ctypes_memory_stubs.managed_buffer type 'a fatptr = 'a Ctypes.typ Ctypes_ptr.Fat.t type 'a fatfunptr = 'a Ctypes.fn Ctypes_ptr.Fat.t let make_structured reftyp buf = let open Ctypes_static in let managed = Obj.repr buf in let raw_ptr = Ctypes_memory_stubs.block_address buf in { structured = CPointer (Ctypes_ptr.Fat.make ~managed ~reftyp raw_ptr) } include Ctypes_static include Ctypes_primitive_types let make_ptr reftyp raw_ptr = CPointer (Ctypes_ptr.Fat.make ~reftyp raw_ptr) let make_fun_ptr reftyp raw_ptr = Static_funptr (Ctypes_ptr.Fat.make ~reftyp raw_ptr) let cptr (CPointer p) = p let fptr (Static_funptr p) = p let mkView : type a b. string -> a typ -> unexpected:(a -> b) -> (b * a) list -> b typ = fun name typ ~unexpected alist -> let rlist = List.map (fun (l, r) -> (r, l)) alist in let write k = List.assoc k alist and read k = try List.assoc k rlist with Not_found -> unexpected k and format_typ k fmt = Format.fprintf fmt "enum %s%t" name k in view typ ~format_typ ~read ~write let map_assocv f = List.map (fun (k, v) -> (k, f v)) let int8_of_int64 = Int64.to_int let int64_of_int8 = Int64.of_int let int16_of_int64 = Int64.to_int let int64_of_int16 = Int64.of_int let int32_of_int64 = Int64.to_int32 let int64_of_int32 = Int64.of_int32 let int64_of_int64 x = x (* For now we use conversion via strings: there's certainly room for improvement. The conversion from int64_t to uint8_t isn't safe in general, of course, so we don't have it available. However, we can be confident that conversion will work in this particular case, since we know that the underlying type is actually uint8_t, so the value can certainly be represented. In mitigation, these conversions are performed once during "startup", not each time we read and write enum values. *) let uint8_of_int64 x = Unsigned.UInt8.of_string (Int64.to_string x) let int64_of_uint8 x = Int64.of_int (Unsigned.UInt8.to_int x) let uint16_of_int64 x = Unsigned.UInt16.of_string (Int64.to_string x) let int64_of_uint16 x = Int64.of_int (Unsigned.UInt16.to_int x) let uint32_of_int64 x = Unsigned.UInt32.of_string (Int64.to_string x) let int64_of_uint32 x = Int64.of_string (Unsigned.UInt32.to_string x) let uint64_of_int64 = Unsigned.UInt64.of_int64 let int64_of_uint64 = Unsigned.UInt64.to_int64 let build_enum_type name underlying ?unexpected alist = let build_view t coerce uncoerce = let unexpected = match unexpected with Some u -> fun x -> u (uncoerce x) | None -> fun x -> Printf.ksprintf failwith "Unexpected enum value for %s: %Ld" name (uncoerce x) in mkView name t ~unexpected (map_assocv coerce alist) in match underlying with Ctypes_static.Int8 -> build_view Ctypes.int8_t int8_of_int64 int64_of_int8 | Ctypes_static.Int16 -> build_view Ctypes.int16_t int16_of_int64 int64_of_int16 | Ctypes_static.Int32 -> build_view Ctypes.int32_t int32_of_int64 int64_of_int32 | Ctypes_static.Int64 -> build_view Ctypes.int64_t int64_of_int64 int64_of_int64 | Ctypes_static.Uint8 -> build_view Ctypes.uint8_t uint8_of_int64 int64_of_uint8 | Ctypes_static.Uint16 -> build_view Ctypes.uint16_t uint16_of_int64 int64_of_uint16 | Ctypes_static.Uint32 -> build_view Ctypes.uint32_t uint32_of_int64 int64_of_uint32 | Ctypes_static.Uint64 -> build_view Ctypes.uint64_t uint64_of_int64 int64_of_uint64 | Ctypes_static.Float | Ctypes_static.Double -> Printf.ksprintf failwith "Enum type detected as floating type: %s" name let use_value v = Ctypes_memory_stubs.use_value v ocaml-ctypes-0.7.0/src/cstubs/cstubs_internals.mli000066400000000000000000000063201274143137600223060ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Types and functions used by generated ML code. This is an internal interface and subject to change. *) open Ctypes open Signed open Unsigned type voidp = Ctypes_ptr.voidp type managed_buffer = Ctypes_memory_stubs.managed_buffer type 'a fatptr = 'a typ Ctypes_ptr.Fat.t type 'a fatfunptr = 'a fn Ctypes_ptr.Fat.t val make_structured : ('a, 's) structured typ -> managed_buffer -> ('a, 's) structured val make_ptr : 'a typ -> voidp -> 'a ptr val make_fun_ptr : 'a fn -> voidp -> 'a Ctypes_static.static_funptr val cptr : 'a ptr -> 'a typ Ctypes_ptr.Fat.t val fptr : 'a Ctypes_static.static_funptr -> 'a fn Ctypes_ptr.Fat.t type 'a ocaml_type = 'a Ctypes_static.ocaml_type = String : string ocaml_type | Bytes : Bytes.t ocaml_type | FloatArray : float array ocaml_type type 'a typ = 'a Ctypes_static.typ = Void : unit typ | Primitive : 'a Ctypes_primitive_types.prim -> 'a typ | Pointer : 'a typ -> 'a ptr typ | Funptr : 'a fn -> 'a static_funptr typ | Struct : 'a Ctypes_static.structure_type -> 'a Ctypes_static.structure typ | Union : 'a Ctypes_static.union_type -> 'a Ctypes_static.union typ | Abstract : Ctypes_static.abstract_type -> 'a Ctypes_static.abstract typ | View : ('a, 'b) view -> 'a typ | Array : 'a typ * int -> 'a Ctypes_static.carray typ | Bigarray : (_, 'a) Ctypes_bigarray.t -> 'a typ | OCaml : 'a ocaml_type -> 'a ocaml typ and ('a, 'b) pointer = ('a, 'b) Ctypes_static.pointer = CPointer : 'a typ Ctypes_ptr.Fat.t -> ('a, [`C]) pointer | OCamlRef : int * 'a * 'a ocaml_type -> ('a, [`OCaml]) pointer and 'a ptr = ('a, [`C]) pointer and 'a ocaml = ('a, [`OCaml]) pointer and 'a static_funptr = 'a Ctypes_static.static_funptr = Static_funptr of 'a fn Ctypes_ptr.Fat.t and ('a, 'b) view = ('a, 'b) Ctypes_static.view = { read : 'b -> 'a; write : 'a -> 'b; format_typ: ((Format.formatter -> unit) -> Format.formatter -> unit) option; format: (Format.formatter -> 'a -> unit) option; ty: 'b typ; } type 'a fn = 'a Ctypes_static.fn = | Returns : 'a typ -> 'a fn | Function : 'a typ * 'b fn -> ('a -> 'b) fn type 'a prim = 'a Ctypes_primitive_types.prim = Char : char prim | Schar : int prim | Uchar : uchar prim | Bool : bool prim | Short : int prim | Int : int prim | Long : long prim | Llong : llong prim | Ushort : ushort prim | Sint : sint prim | Uint : uint prim | Ulong : ulong prim | Ullong : ullong prim | Size_t : size_t prim | Int8_t : int prim | Int16_t : int prim | Int32_t : int32 prim | Int64_t : int64 prim | Uint8_t : uint8 prim | Uint16_t : uint16 prim | Uint32_t : uint32 prim | Uint64_t : uint64 prim | Camlint : int prim | Nativeint : nativeint prim | Float : float prim | Double : float prim | Complex32 : Complex.t prim | Complex64 : Complex.t prim val build_enum_type : string -> Ctypes_static.arithmetic -> ?unexpected:(int64 -> 'a) -> ('a * int64) list -> 'a typ val use_value : 'a -> unit ocaml-ctypes-0.7.0/src/cstubs/cstubs_inverted.ml000066400000000000000000000134511274143137600217610ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Cstubs_inverted public interface. *) module type INTERNAL = sig val enum : (string * int64) list -> 'a Ctypes.typ -> unit val structure : _ Ctypes.structure Ctypes.typ -> unit val union : _ Ctypes.union Ctypes.typ -> unit val typedef : _ Ctypes.typ -> string -> unit val internal : ?runtime_lock:bool -> string -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) -> unit end module type BINDINGS = functor (F : INTERNAL) -> sig end type fn_meta = { fn_runtime_lock : bool; fn_name : string; } type fn_info = Fn : fn_meta * (_ -> _) Ctypes.fn -> fn_info type ty = Ty : _ Ctypes.typ -> ty type typedef = Typedef : _ Ctypes.typ * string -> typedef type enum = Enum : (string * int64) list * _ Ctypes.typ -> enum type decl = Decl_fn of fn_info | Decl_ty of ty | Decl_typedef of typedef | Decl_enum of enum let functions decls = List.concat (List.map (function Decl_fn fn -> [fn] | _ -> []) decls) let collector () : (module INTERNAL) * (unit -> decl list) = let decls = ref [] in let push d = decls := d :: !decls in ((module struct let enum constants typ = push (Decl_enum (Enum (constants, typ))) let structure typ = push (Decl_ty (Ty typ)) let union typ = push (Decl_ty (Ty typ)) let typedef typ name = push (Decl_typedef (Typedef (typ, name))) let internal ?(runtime_lock=false) name fn _ = let meta = { fn_runtime_lock = runtime_lock; fn_name = name } in push (Decl_fn ((Fn (meta, fn)))) end), (fun () -> List.rev !decls)) let format_enum_values fmt infos = List.iter (fun (Fn ({fn_name}, _)) -> Format.fprintf fmt "@[fn_%s,@]@ " fn_name) infos let c_prologue fmt register infos = Format.fprintf fmt "#include @\n"; Format.fprintf fmt "#include @\n"; Format.fprintf fmt "#include \"ctypes_cstubs_internals.h\"@\n@\n"; Format.fprintf fmt "enum functions@\n{@[@ %afn_count@]@\n};" format_enum_values infos; Format.fprintf fmt "@\n /* A table of OCaml \"callbacks\". */ static value functions[fn_count]; /* Record a value in the callback table. */ value %s(value i, value v) { CAMLparam2(i, v); functions[Int_val(i)] = v; caml_register_global_root(&functions[Int_val(i)]); CAMLreturn (Val_unit); }@\n" register let c_function fmt (Fn ({fn_name; fn_runtime_lock}, fn)) : unit = Cstubs_generate_c.inverse_fn ~stub_name:fn_name ~runtime_lock:fn_runtime_lock fmt fn let gen_c fmt register infos = begin c_prologue fmt register infos; List.iter (c_function fmt) infos end let c_declaration fmt (Fn ({fn_name; fn_runtime_lock}, fn)) : unit = Cstubs_generate_c.inverse_fn_decl ~stub_name:fn_name fmt fn let write_structure_declaration fmt (Ty ty) = Format.fprintf fmt "@[%a@];@\n@\n" (fun ty -> Ctypes.format_typ ty) ty let write_enum_declaration fmt (Enum (constants, ty)) = Format.fprintf fmt "@[%a@ {@\n@[@\n" (fun ty -> Ctypes.format_typ ty) ty; let last = List.length constants - 1 in List.iteri (fun i (name, value) -> (* Trailing commas are not allowed. *) if i < last then Format.fprintf fmt "@[%s@ =@ %Ld,@]@\n" name value else Format.fprintf fmt "@[%s@ =@ %Ld@]@\n" name value) constants; Format.fprintf fmt "@]@]@\n};@\n@\n" let write_typedef fmt (Typedef (ty, name)) = let write_name _ fmt = Format.fprintf fmt "@ %s" name in Format.fprintf fmt "@[typedef@ @["; Ctypes_type_printing.format_typ' ty write_name `nonarray fmt; Format.fprintf fmt "@]@];@\n@\n" let write_declaration fmt = function Decl_fn f -> c_declaration fmt f | Decl_ty s -> write_structure_declaration fmt s | Decl_typedef t -> write_typedef fmt t | Decl_enum e -> write_enum_declaration fmt e let write_c fmt ~prefix (module B : BINDINGS) : unit = let register = prefix ^ "_register" in let m, decls = collector () in let module M = B((val m)) in gen_c fmt register (functions (decls ())); Format.fprintf fmt "@." let write_c_header fmt ~prefix (module B : BINDINGS) : unit = let m, decls = collector () in let module M = B((val m)) in List.iter (write_declaration fmt) (decls ()); Format.fprintf fmt "@." let gen_ml fmt register (infos : fn_info list) : unit = Format.fprintf fmt "type 'a fn = 'a@\n@\n"; Format.fprintf fmt "module CI = Cstubs_internals@\n@\n"; Format.fprintf fmt "type 'a f = 'a CI.fn =@\n"; Format.fprintf fmt " | Returns : 'a CI.typ -> 'a f@\n"; Format.fprintf fmt " | Function : 'a CI.typ * 'b f -> ('a -> 'b) f@\n"; Format.fprintf fmt "type 'a name = @\n"; ListLabels.iter infos ~f:(fun (Fn ({fn_name}, fn)) -> Cstubs_generate_ml.constructor_decl ~concurrency:`Sequential ~errno:`Ignore_errno (Printf.sprintf "Fn_%s" fn_name) fn fmt); Format.fprintf fmt "@\n"; Format.fprintf fmt "@[external register_value : 'a name -> 'a fn -> unit =@\n@ @ \"%s\"@]@\n@\n" register; Format.fprintf fmt "@[let internal : "; Format.fprintf fmt "@[type a b.@ @[?runtime_lock:bool -> string -> (a -> b) Ctypes.fn -> (a -> b) -> unit@]@]@ =@\n"; Format.fprintf fmt "fun ?runtime_lock name fn f -> match fn, name with@\n@["; ListLabels.iter infos ~f:(fun (Fn ({fn_name}, fn)) -> Cstubs_generate_ml.inverse_case ~register_name:"register_value" ~constructor:(Printf.sprintf "Fn_%s" fn_name) fn_name fmt fn); Format.fprintf fmt "| _ -> failwith (\"Linking mismatch on name: \" ^ name)@]@]@]@\n@\n"; Format.fprintf fmt "let enum _ _ = () and structure _ = () and union _ = () and typedef _ _ = ()@." let write_ml fmt ~prefix (module B : BINDINGS) : unit = let register = prefix ^ "_register" in let m, decls = collector () in let module M = B((val m)) in gen_ml fmt register (functions (decls ())) ocaml-ctypes-0.7.0/src/cstubs/cstubs_inverted.mli000066400000000000000000000033441274143137600221320ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** Operations for exposing OCaml code as C libraries. *) module type INTERNAL = sig (* Expose type definitions to C. The types are printed to the header file generated by [write_c_header]. *) val enum : (string * int64) list -> 'a Ctypes.typ -> unit val structure : _ Ctypes.structure Ctypes.typ -> unit val union : _ Ctypes.union Ctypes.typ -> unit val typedef : _ Ctypes.typ -> string -> unit val internal : ?runtime_lock:bool -> string -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) -> unit end module type BINDINGS = functor (F : INTERNAL) -> sig end val write_c : Format.formatter -> prefix:string -> (module BINDINGS) -> unit (** [write_c fmt ~prefix bindings] generates C stubs for the functions bound with [internal] in [bindings]. The stubs are intended to be used in conjunction with the ML code generated by {!write_ml}. The generated code uses definitions exposed in the header file [cstubs_internals.h]. *) val write_c_header : Format.formatter -> prefix:string -> (module BINDINGS) -> unit (** [write_c_header fmt ~prefix bindings] generates a C header file for the functions bound with [internal] in [bindings]. The stubs are intended to be used in conjunction with the C code generated by {!write_c}. *) val write_ml : Format.formatter -> prefix:string -> (module BINDINGS) -> unit (** [write_ml fmt ~prefix bindings] generates ML bindings for the functions bound with [internal] in [bindings]. The generated code conforms to the {!INTERNAL} interface. The generated code uses definitions exposed in the module [Cstubs_internals]. *) ocaml-ctypes-0.7.0/src/cstubs/cstubs_public_name.ml000066400000000000000000000073671274143137600224300ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Publicly visible names for type values *) open Ctypes_path let ident_of_ml_prim : type a. a Ctypes_primitive_types.ml_prim -> path = let open Ctypes_primitive_types in function | ML_char -> path_of_string "char" | ML_bool -> path_of_string "bool" | ML_complex -> path_of_string "Complex.t" | ML_float -> path_of_string "float" | ML_int -> path_of_string "int" | ML_int32 -> path_of_string "int32" | ML_int64 -> path_of_string "int64" | ML_llong -> path_of_string "Signed.llong" | ML_long -> path_of_string "Signed.long" | ML_sint -> path_of_string "Signed.sint" | ML_nativeint -> path_of_string "nativeint" | ML_size_t -> path_of_string "Unsigned.size_t" | ML_uchar -> path_of_string "Unsigned.uchar" | ML_uint -> path_of_string "Unsigned.uint" | ML_uint16 -> path_of_string "Unsigned.uint16" | ML_uint32 -> path_of_string "Unsigned.uint32" | ML_uint64 -> path_of_string "Unsigned.uint64" | ML_uint8 -> path_of_string "Unsigned.uint8" | ML_ullong -> path_of_string "Unsigned.ullong" | ML_ulong -> path_of_string "Unsigned.ulong" | ML_ushort -> path_of_string "Unsigned.ushort" let constructor_ident_of_prim : type a. a Ctypes_primitive_types.prim -> path = let open Ctypes_primitive_types in function | Char -> path_of_string "Ctypes.char" | Schar -> path_of_string "Ctypes.schar" | Uchar -> path_of_string "Ctypes.uchar" | Bool -> path_of_string "Ctypes.bool" | Short -> path_of_string "Ctypes.short" | Int -> path_of_string "Ctypes.int" | Long -> path_of_string "Ctypes.long" | Llong -> path_of_string "Ctypes.llong" | Ushort -> path_of_string "Ctypes.ushort" | Sint -> path_of_string "Ctypes.sint" | Uint -> path_of_string "Ctypes.uint" | Ulong -> path_of_string "Ctypes.ulong" | Ullong -> path_of_string "Ctypes.ullong" | Size_t -> path_of_string "Ctypes.size_t" | Int8_t -> path_of_string "Ctypes.int8_t" | Int16_t -> path_of_string "Ctypes.int16_t" | Int32_t -> path_of_string "Ctypes.int32_t" | Int64_t -> path_of_string "Ctypes.int64_t" | Uint8_t -> path_of_string "Ctypes.uint8_t" | Uint16_t -> path_of_string "Ctypes.uint16_t" | Uint32_t -> path_of_string "Ctypes.uint32_t" | Uint64_t -> path_of_string "Ctypes.uint64_t" | Camlint -> path_of_string "Ctypes.camlint" | Nativeint -> path_of_string "Ctypes.nativeint" | Float -> path_of_string "Ctypes.float" | Double -> path_of_string "Ctypes.double" | Complex32 -> path_of_string "Ctypes.complex32" | Complex64 -> path_of_string "Ctypes.complex64" let constructor_cident_of_prim : type a. ?module_name:string -> a Ctypes_primitive_types.prim -> path = fun ?(module_name="Cstubs_internals") -> let path ident = path_of_string (Printf.sprintf "%s.%s" module_name ident) in Ctypes_primitive_types.(function | Char -> path "Char" | Schar -> path "Schar" | Uchar -> path "Uchar" | Bool -> path "Bool" | Short -> path "Short" | Int -> path "Int" | Long -> path "Long" | Llong -> path "Llong" | Ushort -> path "Ushort" | Sint -> path "Sint" | Uint -> path "Uint" | Ulong -> path "Ulong" | Ullong -> path "Ullong" | Size_t -> path "Size_t" | Int8_t -> path "Int8_t" | Int16_t -> path "Int16_t" | Int32_t -> path "Int32_t" | Int64_t -> path "Int64_t" | Uint8_t -> path "Uint8_t" | Uint16_t -> path "Uint16_t" | Uint32_t -> path "Uint32_t" | Uint64_t -> path "Uint64_t" | Camlint -> path "Camlint" | Nativeint -> path "Nativeint" | Float -> path "Float" | Double -> path "Double" | Complex32 -> path "Complex32" | Complex64 -> path "Complex64") ocaml-ctypes-0.7.0/src/cstubs/cstubs_public_name.mli000066400000000000000000000012141274143137600225620ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Publicly visible names for type values *) val ident_of_ml_prim : 'a Ctypes_primitive_types.ml_prim -> Ctypes_path.path (* The type that should appear in the extern signature *) val constructor_ident_of_prim : 'a Ctypes_primitive_types.prim -> Ctypes_path.path (* The path to a value that represents the primitive type *) val constructor_cident_of_prim : ?module_name:string -> 'a Ctypes_primitive_types.prim -> Ctypes_path.path (* The path to a constructor that represents the primitive type *) ocaml-ctypes-0.7.0/src/cstubs/cstubs_structs.ml000066400000000000000000000253371274143137600216560ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes module type TYPE = sig include Ctypes_types.TYPE type 'a const val constant : string -> 'a typ -> 'a const val enum : string -> ?unexpected:(int64 -> 'a) -> ('a * int64 const) list -> 'a typ end module type BINDINGS = functor (F : TYPE) -> sig end let cstring s = (* Format a string for output as a C string literal. *) let mappings = [Str.regexp "\"", "\\\""; Str.regexp "\n", "\\n"] in let escaped = List.fold_left (fun s (r, r') -> Str.(global_replace r r') s) s mappings in "\""^ escaped ^"\"" let cprologue = [ "#if !__USE_MINGW_ANSI_STDIO && (defined(__MINGW32__) || defined(__MINGW64__))"; "#define __USE_MINGW_ANSI_STDIO 1"; "#endif"; ""; "#include "; "#include "; "#include \"ctypes_cstubs_internals.h\""; ""; "int main(void)"; "{"; ] let cepilogue = [ " return 0;"; "}"; ] let mlprologue = [ "include Ctypes"; "let lift x = x"; "open Ctypes_static"; ] (* [puts fmt s] writes the call [puts(s);] on [fmt]. *) let puts fmt s = Format.fprintf fmt "@[puts@[(%s);@]@]@\n" (cstring s) (* [printf1 fmt s v] writes the call [printf(s, v);] on [fmt]. *) let printf1 fmt s v = Format.fprintf fmt "@[printf@[(%s,@ %t);@]@]@\n" (cstring s) v (* [printf2 fmt s u v] writes the call [printf(s, u, v);] on [fmt]. *) let printf2 fmt s u v = Format.fprintf fmt "@[printf@[(%s,@ %t,@ %t);@]@]@\n" (cstring s) u v (* [offsetof fmt t f] writes the call [offsetof(t, f)] on [fmt]. *) let offsetof fmt (t, f) = Format.fprintf fmt "@[offsetof@[(%s,@ %s)@]@]" t f (* [sizeof fmt t] writes the call [sizeof(t)] on [fmt]. *) let sizeof fmt t = Format.fprintf fmt "@[sizeof@[(%s)@]@]" t let alignmentof fmt t = offsetof fmt (Format.sprintf "struct { char c; %s x; }" t, "x") let write_c fmt body = List.iter (Format.fprintf fmt "@[%s@]@\n") cprologue; Format.fprintf fmt "@[@\n@[%t@]@]@\n" body; List.iter (Format.fprintf fmt "%s@\n") cepilogue let cases fmt list prologue epilogue ~case = List.iter (puts fmt) prologue; List.iter case list; List.iter (puts fmt) epilogue let write_field fmt specs = let case = function | `Struct (tag, typedef), fname -> let foffset fmt = offsetof fmt (typedef, fname) in puts fmt (Printf.sprintf " | Struct ({ tag = %S} as s'), %S ->" tag fname); printf1 fmt " let f = {ftype; fname; foffset = %zu} in \n" foffset; puts fmt " (s'.fields <- BoxedField f :: s'.fields; f)"; | `Union (tag, typedef), fname -> let foffset fmt = offsetof fmt (typedef, fname) in puts fmt (Printf.sprintf " | Union ({ utag = %S} as s'), %S ->" tag fname); printf1 fmt " let f = {ftype; fname; foffset = %zu} in \n" foffset; puts fmt " (s'.ufields <- BoxedField f :: s'.ufields; f)"; | _ -> raise (Unsupported "Adding a field to non-structured type") in cases fmt specs [""; "let rec field : type t a. t typ -> string -> a typ -> (a, t) field ="; " fun s fname ftype -> match s, fname with";] ~case [" | View { ty }, _ ->"; " let { ftype; foffset; fname } = field ty fname ftype in"; " { ftype; foffset; fname }"; " | _ -> failwith (\"Unexpected field \"^ fname)"] let write_seal fmt specs = let case = function | `Struct (tag, typedef) -> let ssize fmt = sizeof fmt typedef and salign fmt = alignmentof fmt typedef in puts fmt (Printf.sprintf " | Struct ({ tag = %S; spec = Incomplete _ } as s') ->" tag); printf2 fmt " s'.spec <- Complete { size = %zu; align = %zu }\n" ssize salign; | `Union (tag, typedef) -> let usize fmt = sizeof fmt typedef and ualign fmt = alignmentof fmt typedef in puts fmt (Printf.sprintf " | Union ({ utag = %S; uspec = None } as s') ->" tag); printf2 fmt " s'.uspec <- Some { size = %zu; align = %zu }\n" usize ualign; | `Other -> raise (Unsupported "Sealing a non-structured type") in cases fmt specs [""; "let rec seal : type a. a typ -> unit = function"] ~case [" | Struct { tag; spec = Complete _ } ->"; " raise (ModifyingSealedType tag)"; " | Union { utag; uspec = Some _ } ->"; " raise (ModifyingSealedType utag)"; " | View { ty } -> seal ty"; " | _ ->"; " raise (Unsupported \"Sealing a non-structured type\")"; ""] let primitive_format_string : type a. a Ctypes_primitive_types.prim -> string = fun p -> let open Ctypes_primitive_types in let sprintf = Printf.sprintf in let fail () = Printf.kprintf failwith "Cannot retrieve constants of type %s" (Ctypes_primitives.name p) in match p, Ctypes_primitives.format_string p with | _, None -> fail () | Char, Some fmt -> sprintf "Char.chr (((%s) + 256) mod 256)" fmt | Schar, Some fmt -> fmt | Uchar, Some fmt -> sprintf "Unsigned.UChar.of_string \"%s\"" fmt | Bool, Some fmt -> sprintf "((%s) <> 0)" fmt | Short, Some fmt -> fmt | Int, Some fmt -> fmt | Long, Some fmt -> sprintf "Signed.Long.of_string \"%s\"" fmt | Llong, Some fmt -> sprintf "Signed.LLong.of_string \"%s\"" fmt | Ushort, Some fmt -> sprintf "Unsigned.UShort.of_string \"%s\"" fmt | Sint, Some fmt -> sprintf "Signed.SInt.of_string \"%s\"" fmt | Uint, Some fmt -> sprintf "Unsigned.UInt.of_string \"%s\"" fmt | Ulong, Some fmt -> sprintf "Unsigned.ULong.of_string \"%s\"" fmt | Ullong, Some fmt -> sprintf "Unsigned.ULLong.of_string \"%s\"" fmt | Size_t, Some fmt -> sprintf "Unsigned.Size_t.of_string \"%s\"" fmt | Int8_t, Some fmt -> fmt | Int16_t, Some fmt -> fmt | Int32_t, Some fmt -> fmt ^"l" | Int64_t, Some fmt -> fmt ^"L" | Uint8_t, Some fmt -> sprintf "Unsigned.UInt8.of_string \"%s\"" fmt | Uint16_t, Some fmt -> sprintf "Unsigned.UInt16.of_string \"%s\"" fmt | Uint32_t, Some fmt -> sprintf "Unsigned.UInt32.of_string \"%s\"" fmt | Uint64_t, Some fmt -> sprintf "Unsigned.UInt64.of_string \"%s\"" fmt | Camlint, Some fmt -> fmt | Nativeint, Some fmt -> fmt ^"n" (* Integer constant expressions cannot have non-integer type *) | Complex32, _ -> fail () | Complex64, _ -> fail () | Float, _ -> fail () | Double, _ -> fail () let rec ml_pat_and_exp_of_typ : type a. a typ -> string * string = fun ty -> match ty with | Ctypes_static.View { Ctypes_static.ty } -> let p, e = ml_pat_and_exp_of_typ ty in let x = Cstubs_c_language.fresh_var ~prefix:"read" () in let p' = Printf.sprintf "Ctypes_static.View { Ctypes_static.read = %s; ty = %s }" x p and e' = Printf.sprintf "(%s (%s))" x e in (p', e') | Ctypes_static.Primitive p -> let pat = (Format.asprintf "Ctypes_static.Primitive %a" Ctypes_path.format_path (Cstubs_public_name.constructor_cident_of_prim p)) and exp = primitive_format_string p in (pat, exp) | _ -> failwith "constant of non-primitive" let write_consts fmt consts = let case = function (name, Ctypes_static.BoxedType ty) -> let p, e = ml_pat_and_exp_of_typ ty in Format.fprintf fmt "{@[@\n"; Format.fprintf fmt "enum { check_%s_const = (int)%s };@\n" name name; (* Since printf is variadic we can't rely on implicit conversions. We'll use assignment rather than casts to coerce to the correct type because casts typically result in silent truncation whereas narrowing assignments typically trigger warnings even on default compiler settings. *) Format.fprintf fmt "%a = (%s);@\n" (Ctypes.format_typ ~name:"v") ty name; printf1 fmt (Format.asprintf " | %s, %S ->@\n %s\n" p name e) (fun fmt -> Format.fprintf fmt "v"); Format.fprintf fmt "@]@\n}@\n" in cases fmt consts ["type 'a const = 'a"; "let constant (type t) name (t : t typ) : t = match t, name with"] ~case [" | _, s -> failwith (\"unmatched constant: \"^ s)"] let write_enums fmt enums = let case name = printf1 fmt (Format.sprintf " | %S -> \n Cstubs_internals.build_enum_type %S Ctypes_static.%%s ?unexpected alist\n" name name) (fun fmt -> Format.fprintf fmt "ctypes_arithmetic_type_name(CTYPES_CLASSIFY_ARITHMETIC_TYPE(enum %s))" name) in cases fmt enums [""; "let enum (type a) name ?unexpected (alist : (a * int64) list) ="; " match name with"] ~case [" | s ->"; " failwith (\"unmatched enum: \"^ s)"] let write_ml fmt fields structures consts enums = List.iter (puts fmt) mlprologue; write_field fmt fields; write_seal fmt structures; write_consts fmt consts; write_enums fmt enums let gen_c () = let fields = ref [] and structures = ref [] and consts = ref [] and enums = ref [] in let finally fmt = write_c fmt (fun fmt -> write_ml fmt !fields !structures !consts !enums) in let m = (module struct include Ctypes open Ctypes_static let rec field' : type a s r. string -> s typ -> string -> a typ -> (a, r) field = fun structname s fname ftype -> match s with | Struct { tag } -> fields := (`Struct (tag, structname), fname) :: !fields; { ftype; foffset = -1; fname} | Union { utag } -> fields := (`Union (utag, structname), fname) :: !fields; { ftype; foffset = -1; fname} | View { ty } -> field' structname ty fname ftype | _ -> raise (Unsupported "Adding a field to non-structured type") let field s fname ftype = field' (Ctypes.string_of_typ s) s fname ftype let rec seal' : type s. string -> s typ -> unit = fun structname -> function | Struct { tag } -> structures := `Struct (tag, structname) :: !structures | Union { utag } -> structures := `Union (utag, structname) :: !structures | View { ty } -> seal' structname ty | _ -> raise (Unsupported "Sealing a field to non-structured type") let seal ty = seal' (Ctypes.string_of_typ ty) ty type _ const = unit let constant name ty = consts := (name, Ctypes_static.BoxedType ty) :: !consts let enum name ?unexpected alist = let () = enums := name :: !enums in let format_typ k fmt = Format.fprintf fmt "enum %s%t" name k in (* a dummy value of type 'a typ, mostly unusable *) view void ~format_typ ~read:(fun _ -> assert false) ~write:(fun _ -> assert false) end : TYPE) in (m, finally) let write_c fmt (module B : BINDINGS) = let m, finally = gen_c () in let module M = B((val m)) in finally fmt ocaml-ctypes-0.7.0/src/cstubs/cstubs_structs.mli000066400000000000000000000007251274143137600220210ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) module type TYPE = sig include Ctypes_types.TYPE type 'a const val constant : string -> 'a typ -> 'a const val enum : string -> ?unexpected:(int64 -> 'a) -> ('a * int64 const) list -> 'a typ end module type BINDINGS = functor (F : TYPE) -> sig end val write_c : Format.formatter -> (module BINDINGS) -> unit ocaml-ctypes-0.7.0/src/ctypes-foreign-base/000077500000000000000000000000001274143137600205635ustar00rootroot00000000000000ocaml-ctypes-0.7.0/src/ctypes-foreign-base/ctypes_closure_properties.ml000066400000000000000000000047361274143137600264460ustar00rootroot00000000000000(* * 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-0.7.0/src/ctypes-foreign-base/ctypes_closure_properties.mli000066400000000000000000000013401274143137600266030ustar00rootroot00000000000000(* * 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-0.7.0/src/ctypes-foreign-base/ctypes_ffi.ml000066400000000000000000000201131274143137600232450ustar00rootroot00000000000000(* * 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 Ctypes_static open Libffi_abi (* Register the closure lookup function with C. *) let () = Ctypes_ffi_stubs.set_closure_callback Closure_properties.retrieve type _ ccallspec = Call : bool * (Ctypes_ptr.voidp -> 'a) -> 'a ccallspec | WriteArg : ('a -> Ctypes_ptr.voidp -> (Obj.t * int) array -> unit) * 'b ccallspec -> ('a -> 'b) ccallspec type arg_type = ArgType : 'a Ctypes_ffi_stubs.ffitype -> arg_type (* keep_alive ties the lifetimes of objects together. [keep_alive w ~while_live:v] ensures that [w] is not collected while [v] is still live. *) 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 (Ctypes_ffi_stubs.void_ffitype ()) | Primitive p as prim -> let ffitype = Ctypes_ffi_stubs.primitive_ffitype p in if ffitype = Ctypes_ptr.Raw.null then report_unpassable (Ctypes_type_printing.string_of_typ prim) else ArgType ffitype | Pointer _ -> ArgType (Ctypes_ffi_stubs.pointer_ffitype ()) | Funptr _ -> ArgType (Ctypes_ffi_stubs.pointer_ffitype ()) | OCaml _ -> ArgType (Ctypes_ffi_stubs.pointer_ffitype ()) | Union _ -> report_unpassable "unions" | Struct ({ spec = Complete _ } as s) -> struct_arg_type s | View { ty } -> arg_type ty | Array _ -> report_unpassable "arrays" | Bigarray _ -> report_unpassable "bigarrays" | Abstract _ -> (report_unpassable "values of abstract type") (* The following case should never happen; incomplete types are excluded during type construction. *) | Struct { spec = Incomplete _ } -> report_unpassable "incomplete types" and struct_arg_type : type s. s structure_type -> arg_type = fun ({fields} as s) -> let bufspec = Ctypes_ffi_stubs.allocate_struct_ffitype (List.length fields) in (* Ensure that `bufspec' stays alive as long as the type does. *) keep_alive bufspec ~while_live:s; List.iteri (fun i (BoxedField {ftype; foffset}) -> let ArgType t = arg_type ftype in Ctypes_ffi_stubs.struct_type_set_argument bufspec i t) fields; Ctypes_ffi_stubs.complete_struct_type bufspec; ArgType (Ctypes_ffi_stubs.ffi_type_of_struct_type bufspec) (* call addr callspec (fun buffer -> write arg_1 buffer v_1 write arg buffer v ... write arg_n buffer v_n) read_return_value *) let rec invoke : type a b. string option -> a ccallspec -> (Ctypes_ptr.voidp -> (Obj.t * int) array -> unit) list -> Ctypes_ffi_stubs.callspec -> b fn Ctypes_ptr.Fat.t -> a = fun name -> function | Call (check_errno, read_return_value) -> let name = match name with Some name -> name | None -> "" in fun writers callspec addr -> Ctypes_ffi_stubs.call name addr callspec (fun buf arr -> List.iter (fun w -> w buf arr) 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. Ctypes_ffi_stubs.callspec -> a typ -> int = fun callspec -> function | Void -> 0 | ty -> let ArgType ffitype = arg_type ty in Ctypes_ffi_stubs.add_argument callspec ffitype let prep_callspec callspec abi ty = let ArgType ctype = arg_type ty in Ctypes_ffi_stubs.prep_callspec callspec (abi_code abi) ctype let rec box_function : type a. abi -> a fn -> Ctypes_ffi_stubs.callspec -> a Ctypes_weak_ref.t -> Ctypes_ffi_stubs.boxedfn = fun abi fn callspec -> match fn with | Returns ty -> let () = prep_callspec callspec abi ty in let write_rv = Ctypes_memory.write ty in fun f -> let w = write_rv (Ctypes_weak_ref.get f) in Ctypes_ffi_stubs.Done ((fun p -> w (Ctypes_ptr.Fat.make ~reftyp:Void p)), callspec) | Function (p, f) -> let _ = add_argument callspec p in let box = box_function abi f callspec in let read = Ctypes_memory.build p in fun f -> Ctypes_ffi_stubs.Fn (fun buf -> let f' = try Ctypes_weak_ref.get f (read (Ctypes_ptr.Fat.make ~reftyp:Void buf)) with Ctypes_weak_ref.EmptyWeakReference -> raise Ctypes_ffi_stubs.CallToExpiredClosure in let v = box (Ctypes_weak_ref.make f') in let () = Gc.finalise (fun _ -> Ctypes_memory_stubs.use_value f') v in v) let write_arg : type a. a typ -> offset:int -> idx:int -> a -> Ctypes_ptr.voidp -> (Obj.t * int) array -> unit = let ocaml_arg elt_size = fun ~offset ~idx (OCamlRef (disp, obj, _)) dst mov -> mov.(idx) <- (Obj.repr obj, disp * elt_size) in function | OCaml String -> ocaml_arg 1 | OCaml Bytes -> ocaml_arg 1 | OCaml FloatArray -> ocaml_arg (Ctypes_primitives.sizeof Ctypes_primitive_types.Double) | ty -> (fun ~offset ~idx v dst mov -> Ctypes_memory.write ty v (Ctypes_ptr.Fat.(add_bytes (make ~reftyp:Void dst) offset))) (* callspec = allocate_callspec () add_argument callspec arg1 add_argument callspec arg2 ... add_argument callspec argn prep_callspec callspec rettype *) let rec build_ccallspec : type a. abi:abi -> check_errno:bool -> ?idx:int -> a fn -> Ctypes_ffi_stubs.callspec -> a ccallspec = fun ~abi ~check_errno ?(idx=0) fn callspec -> match fn with | Returns t -> let () = prep_callspec callspec abi t in let b = Ctypes_memory.build t in Call (check_errno, (fun p -> b (Ctypes_ptr.Fat.make ~reftyp:Void p))) | Function (p, f) -> let offset = add_argument callspec p in let rest = build_ccallspec ~abi ~check_errno ~idx:(idx+1) f callspec in WriteArg (write_arg p ~offset ~idx, rest) let build_function ?name ~abi ~release_runtime_lock ~check_errno fn = let c = Ctypes_ffi_stubs.allocate_callspec ~check_errno ~runtime_lock:release_runtime_lock in let e = build_ccallspec ~abi ~check_errno fn c in invoke name e [] c let funptr_of_rawptr fn raw_ptr = Static_funptr (Ctypes_ptr.Fat.make ~reftyp:fn raw_ptr) let function_of_pointer ?name ~abi ~check_errno ~release_runtime_lock fn = let f = build_function ?name ~abi ~check_errno ~release_runtime_lock fn in fun (Static_funptr p) -> f p let pointer_of_function ~abi ~acquire_runtime_lock fn = let cs' = Ctypes_ffi_stubs.allocate_callspec ~check_errno:false ~runtime_lock:acquire_runtime_lock in let cs = box_function abi fn cs' in fun f -> let boxed = cs (Ctypes_weak_ref.make f) in let id = Closure_properties.record (Obj.repr f) (Obj.repr boxed) in funptr_of_rawptr fn (Ctypes_ffi_stubs.make_function_pointer cs' id) end ocaml-ctypes-0.7.0/src/ctypes-foreign-base/ctypes_ffi.mli000066400000000000000000000024571274143137600234310ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) module type CLOSURE_PROPERTIES = sig val record : Obj.t -> Obj.t -> int (** [record c v] links the lifetimes of [c] and [v], ensuring that [v] is not collected while [c] is still live. The return value is a key that can be used to retrieve [v] while [v] is still live. *) val retrieve : int -> Obj.t (** [retrieve v] retrieves a value using a key returned by [record], or raises [Not_found] if [v] is no longer live. *) end module Make(Closure_properties : CLOSURE_PROPERTIES) : sig open Ctypes_static open Libffi_abi (** Dynamic function calls based on libffi *) val function_of_pointer : ?name:string -> abi:abi -> check_errno:bool -> release_runtime_lock:bool -> ('a -> 'b) fn -> ('a -> 'b) static_funptr -> ('a -> 'b) (** Build an OCaml function from a type specification and a pointer to a C function. *) val pointer_of_function : abi:abi -> acquire_runtime_lock:bool -> ('a -> 'b) fn -> ('a -> 'b) -> ('a -> 'b) static_funptr (** Build an C function from a type specification and an OCaml function. The C function pointer returned is callable as long as the OCaml function value is live. *) end ocaml-ctypes-0.7.0/src/ctypes-foreign-base/ctypes_ffi_stubs.ml000066400000000000000000000053061274143137600244740ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stubs for binding to libffi. *) open Ctypes_ptr (* The type of structure types *) type 'a ffitype = voidp type struct_ffitype external primitive_ffitype : 'a Ctypes_primitive_types.prim -> 'a ffitype = "ctypes_primitive_ffitype" external pointer_ffitype : unit -> voidp ffitype = "ctypes_pointer_ffitype" external void_ffitype : unit -> unit ffitype = "ctypes_void_ffitype" (* Allocate a new C typed buffer specification *) external allocate_struct_ffitype : int -> struct_ffitype = "ctypes_allocate_struct_ffitype" external struct_type_set_argument : struct_ffitype -> int -> _ ffitype -> unit = "ctypes_struct_ffitype_set_argument" (* Produce a structure type representation from the buffer specification. *) external complete_struct_type : struct_ffitype -> unit = "ctypes_complete_structspec" external ffi_type_of_struct_type : struct_ffitype -> _ ffitype = "ctypes_block_address" (* A specification of argument C-types and C-return values *) type callspec (* Allocate a new C call specification *) external allocate_callspec : check_errno:bool -> runtime_lock:bool -> callspec = "ctypes_allocate_callspec" (* Add an argument to the C buffer specification *) external add_argument : callspec -> _ ffitype -> int = "ctypes_add_argument" (* Pass the return type and conclude the specification preparation *) external prep_callspec : callspec -> int -> _ ffitype -> unit = "ctypes_prep_callspec" (* Call the function specified by `callspec' at the given address. The callback functions write the arguments to the buffer and read the return value. *) external call : string -> _ Ctypes_static.fn Fat.t -> callspec -> (voidp -> (Obj.t * int) array -> unit) -> (voidp -> 'a) -> 'a = "ctypes_call" (* nary callbacks *) type boxedfn = | Done of (voidp -> unit) * callspec | Fn of (voidp -> boxedfn) (* 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-0.7.0/src/ctypes-foreign-base/ctypes_foreign_basis.ml000066400000000000000000000031511274143137600253160ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) module Make(Closure_properties : Ctypes_ffi.CLOSURE_PROPERTIES) = struct open Dl open Ctypes module Ffi = Ctypes_ffi.Make(Closure_properties) exception CallToExpiredClosure = Ctypes_ffi_stubs.CallToExpiredClosure let funptr ?(abi=Libffi_abi.default_abi) ?name ?(check_errno=false) ?(runtime_lock=false) fn = let open Ffi in let read = function_of_pointer ~abi ~check_errno ~release_runtime_lock:runtime_lock ?name fn and write = pointer_of_function ~abi ~acquire_runtime_lock:runtime_lock fn in Ctypes_static.(view ~read ~write (static_funptr fn)) let funptr_opt ?abi ?name ?check_errno ?runtime_lock fn = Ctypes_std_views.nullable_funptr_view (funptr ?abi ?name ?check_errno ?runtime_lock fn) fn let funptr_of_raw_ptr p = Ctypes.funptr_of_raw_address (Ctypes_ptr.Raw.to_nativeint p) let ptr_of_raw_ptr p = Ctypes.ptr_of_raw_address (Ctypes_ptr.Raw.to_nativeint p) let foreign_value ?from symbol t = from_voidp t (ptr_of_raw_ptr (dlsym ?handle:from ~symbol)) let foreign ?(abi=Libffi_abi.default_abi) ?from ?(stub=false) ?(check_errno=false) ?(release_runtime_lock=false) symbol typ = try let coerce = Ctypes_coerce.coerce (static_funptr (void @-> returning void)) (funptr ~abi ~name:symbol ~check_errno ~runtime_lock:release_runtime_lock typ) in coerce (funptr_of_raw_ptr (dlsym ?handle:from ~symbol)) with | exn -> if stub then fun _ -> raise exn else raise exn end ocaml-ctypes-0.7.0/src/ctypes-foreign-base/ctypes_weak_ref.ml000066400000000000000000000006651274143137600242760ustar00rootroot00000000000000(* * 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-0.7.0/src/ctypes-foreign-base/ctypes_weak_ref.mli000066400000000000000000000012021274143137600244330ustar00rootroot00000000000000(* * 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-0.7.0/src/ctypes-foreign-base/dl.ml.unix000066400000000000000000000032061274143137600224770ustar00rootroot00000000000000(* * 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_LOCAL | RTLD_NODELETE | RTLD_NOLOAD | RTLD_DEEPBIND exception DL_error of string (* void *dlopen(const char *filename, int flag); *) external _dlopen : ?filename:string -> flags:int -> library option = "ctypes_dlopen" (* void *dlsym(void *handle, const char *symbol); *) external _dlsym : ?handle:library -> symbol:string -> nativeint option = "ctypes_dlsym" (* int dlclose(void *handle); *) external _dlclose : handle:library -> int = "ctypes_dlclose" (* char *dlerror(void); *) external _dlerror : unit -> string option = "ctypes_dlerror" external resolve_flag : flag -> int = "ctypes_resolve_dl_flag" let _report_dl_error noload = match _dlerror () with | Some error -> raise (DL_error (error)) | None -> if noload then raise (DL_error "library not loaded") else failwith "dl_error: expected error, but no error reported" let crush_flags f : 'a list -> int = List.fold_left (fun i o -> i lor (f o)) 0 let dlopen ?filename ~flags = match _dlopen ?filename ~flags:(crush_flags resolve_flag flags) with | Some library -> library | None -> _report_dl_error (List.mem RTLD_NOLOAD flags) let dlclose ~handle = match _dlclose ~handle with | 0 -> () | _ -> _report_dl_error false let dlsym ?handle ~symbol = match _dlsym ?handle ~symbol with | Some symbol -> Ctypes_ptr.Raw.of_nativeint symbol | None -> _report_dl_error false ocaml-ctypes-0.7.0/src/ctypes-foreign-base/dl.ml.win000066400000000000000000000061221274143137600223110ustar00rootroot00000000000000(* * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) type library type dlsym_ret = | Dlsy_unknown | Dlsy_nomem | Dlsy_enoent | Dlsy_error of string | Dlsy_ok of Ctypes_ptr.voidp external _dlsym_default: string -> dlsym_ret = "ctypes_win32_dlsym_rtld_default" external _dlsym: library -> string -> dlsym_ret = "ctypes_win32_dlsym" type dlopen_ret = | Dlop_unknown | Dlop_nomem | Dlop_notloaded | Dlop_error of string | Dlop_ok of library external _dlopen: string option -> int -> dlopen_ret = "ctypes_win32_dlopen" type dlclose_ret = | Dlcl_unknown | Dlcl_nomem | Dlcl_ok | Dlcl_error of string external _dlclose: library -> dlclose_ret = "ctypes_win32_dlclose" exception DL_error of string type flag = | RTLD_LAZY | RTLD_NOW | RTLD_GLOBAL | RTLD_LOCAL | RTLD_NODELETE | RTLD_NOLOAD | RTLD_DEEPBIND let unknown = "unknown_error" let nomem = "no memory" let nonl s = let l = String.length s in if l = 0 || s.[l-1] <> '\n' then s else let nl = if l > 1 && s.[l-2] = '\r' then l - 2 else l - 1 in String.sub s 0 nl let replace_slash s = let l = String.length s in let b = Bytes.create l in (* according to msdn, slashes are not supported for LoadLibrary *) for i = 0 to pred l do match s.[i] with | '/' -> Bytes.set b i '\\' | x -> Bytes.set b i x done; Bytes.unsafe_to_string b let dlopen_raise s msg = let s = match s with | None -> "NULL" | Some x -> x in let msg = Printf.sprintf "dlopen (%s): %s" s (nonl msg) in raise (DL_error msg) let dlopen ?filename ~flags = let filename = match filename with | None -> None | (Some x) as sx -> let s = if String.contains x '/' then replace_slash x else x in let ls = String.lowercase s in let s' = if Filename.check_suffix ls ".so" || Filename.check_suffix ls ".dylib" then Filename.chop_extension s ^ ".dll" else s in if s' == x then sx else Some s' in let iflags = (if List.mem RTLD_NOLOAD flags then 1 else 0) + (if List.mem RTLD_NODELETE flags then 2 else 0) in match _dlopen filename iflags with | Dlop_ok x -> x | Dlop_nomem -> dlopen_raise filename nomem | Dlop_unknown -> dlopen_raise filename unknown | Dlop_error s -> dlopen_raise filename s | Dlop_notloaded -> raise (DL_error "library not loaded") let draise y x = raise (DL_error ( y ^ ": " ^ nonl x)) let dlclose ~handle = match _dlclose handle with | Dlcl_ok -> () | Dlcl_unknown -> draise "dlclose" unknown | Dlcl_nomem -> draise "dlclose" nomem | Dlcl_error s -> draise "dlclose" s let dlsym ?handle ~symbol = let r = match handle with | None -> _dlsym_default symbol | Some x -> _dlsym x symbol in match r with | Dlsy_ok v -> v | Dlsy_unknown -> draise "dlsym" unknown | Dlsy_nomem -> draise "dlsym" nomem | Dlsy_enoent -> draise "dlsym" "no such symbol" | Dlsy_error x -> draise "dlsym" x ocaml-ctypes-0.7.0/src/ctypes-foreign-base/dl.mli000066400000000000000000000024761274143137600216760ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** Bindings to the dlopen / dlsym interface. *) type library (** The type of dynamic libraries, as returned by {!dlopen}. *) exception DL_error of string (** An error condition occurred when calling {!dlopen}, {!dlclose} or {!dlsym}. The argument is the string returned by the [dlerror] function. *) (** Flags for {!dlopen} Note for windows users: Only [RTLD_NOLOAD] and [RTLD_NODELETE] are supported. Passing no or any other flags to {!dlopen} will result in standard behaviour: just LoadLibrary is called. If [RTLD_NOLOAD] is specified and the module is not already loaded, a {!DL_error} with the string "library not loaded" is thrown; there is however no test, if such a library exists at all (like under linux). *) type flag = RTLD_LAZY | RTLD_NOW | RTLD_GLOBAL | RTLD_LOCAL | RTLD_NODELETE | RTLD_NOLOAD | RTLD_DEEPBIND val dlopen : ?filename:string -> flags:flag list -> library (** Open a dynamic library. Note for windows users: the filename must be encoded in UTF-8 *) val dlclose : handle:library -> unit (** Close a dynamic library. *) val dlsym : ?handle:library -> symbol:string -> Ctypes_ptr.voidp (** Look up a symbol in a dynamic library. *) ocaml-ctypes-0.7.0/src/ctypes-foreign-base/dl_stubs.c.unix000066400000000000000000000051371274143137600235360ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #define _GNU_SOURCE #include #include #include #include #include #include #define Val_none Val_int(0) #define Some_val(v) Field(v, 0) enum dl_flags_caml { _RTLD_LAZY, _RTLD_NOW, _RTLD_GLOBAL, _RTLD_LOCAL, #ifdef RTLD_NODELETE _RTLD_NODELETE, #endif /* RTLD_NODELETE */ #ifdef RTLD_NOLOAD _RTLD_NOLOAD, #endif /* RTLD_NOLOAD */ #ifdef RTLD_DEEPBIND _RTLD_DEEPBIND, #endif /* RTLD_DEEPBIND */ }; static value Val_some(value v) { CAMLparam1(v); CAMLlocal1(some); some = caml_alloc(1, 0); Store_field(some, 0, v); CAMLreturn(some); } /* ctypes_resolve_dl_flag : flag -> int */ value ctypes_resolve_dl_flag(value flag) { int rv; switch (Int_val(flag)) { case _RTLD_LAZY: rv = RTLD_LAZY; break; case _RTLD_NOW: rv = RTLD_NOW; break; case _RTLD_GLOBAL: rv = RTLD_GLOBAL; break; case _RTLD_LOCAL: rv = RTLD_LOCAL; break; #ifdef RTLD_NODELETE case _RTLD_NODELETE: rv = RTLD_NODELETE; break; #endif /* RTLD_NODELETE */ #ifdef RTLD_NOLOAD case _RTLD_NOLOAD: rv = RTLD_NOLOAD; break; #endif /* RTLD_NOLOAD */ #ifdef RTLD_DEEPBIND case _RTLD_DEEPBIND: rv = RTLD_DEEPBIND; break; #endif /* RTLD_DEEPBIND */ default: assert(0); } return Val_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_nativeint((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-0.7.0/src/ctypes-foreign-base/dl_stubs.c.win000066400000000000000000000154551274143137600233540ustar00rootroot00000000000000/* * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ /* for compatiblity with Windows Vista and XP */ #define PSAPI_VERSION 1 #include #include #include #include #include #define STUB_ERROR_UNKNOWN (Val_long(0)) #define STUB_ERROR_NOMEM (Val_long(1)) #define STUB_TAG_ERROR 0 static value get_tagged_error_msg(DWORD ecode) { CAMLparam0(); CAMLlocal1(msg); value ret=STUB_ERROR_UNKNOWN; if ( ecode ){ char buf[512]; DWORD len ; len = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL, ecode, MAKELANGID(LANG_NEUTRAL,SUBLANG_DEFAULT), buf, sizeof(buf), NULL); if (len){ msg=caml_copy_string(buf); ret=caml_alloc_small(1,STUB_TAG_ERROR); Field(ret,0)=msg; } } CAMLreturn(ret); } static value utf8_to_wstring(value utf8string) { CAMLparam1(utf8string); value ret; int n; WCHAR *result; n = MultiByteToWideChar(CP_UTF8,0,String_val(utf8string),-1, NULL,0); if (!n){ ret=Val_unit; goto endp; } ret = caml_alloc_string(n * sizeof(*result)); result = (WCHAR *)String_val(ret); if ( n != MultiByteToWideChar(CP_UTF8,0,String_val(utf8string),-1,result,n) ){ ret = Val_unit; } endp: CAMLreturn(ret); } /* In order to get a list of all used dlls, we can use the following approaches: - EnumProcessModules (psapi.dll on older windows versions) - RtlQueryProcessDebugInformation (no documented by microsoft, seems to be slower than EnumProcessModules) - CreateToolhelp32Snapshot (even slower, see http://securityxploded.com/enumheaps.php) - using NtQueryInformationProcess (low level and fiddly) details: https://sites.google.com/site/ericuday/EICAR2008_UserMode_Memory_Scanning_3.doc (Eric Uday Kumar: User-mode memory scanning on 32-bit & 64-bit windows) */ /* integer: 0: unknown error 1: nomem 2: enoent blocks of size 1: 0: error message 1: success handle */ value ctypes_win32_dlsym_rtld_default(value needle) { CAMLparam1(needle); CAMLlocal2(ret,tmp); HMODULE hmodules[128]; HMODULE *r_modules = hmodules; HANDLE proc = NULL; DWORD bytes_hmodules; DWORD bytes_hmodules_real; DWORD i; proc = OpenProcess( PROCESS_QUERY_INFORMATION | PROCESS_VM_READ, FALSE, GetCurrentProcessId() ); if ( !proc ){ ret=get_tagged_error_msg(GetLastError()); goto endp; } if( ! EnumProcessModules(proc, r_modules, sizeof(hmodules), &bytes_hmodules)){ DWORD ec = GetLastError(); CloseHandle(proc); ret=get_tagged_error_msg(ec); goto endp; } bytes_hmodules_real = bytes_hmodules; if ( bytes_hmodules > sizeof(hmodules) ){ r_modules=malloc(bytes_hmodules); if ( !r_modules ){ ret=STUB_ERROR_NOMEM; CloseHandle(proc); goto endp; } if(!EnumProcessModules(proc, r_modules, bytes_hmodules, &bytes_hmodules_real)){ DWORD ec = GetLastError(); free(r_modules); CloseHandle(proc); ret=get_tagged_error_msg(ec); goto endp; } bytes_hmodules_real = bytes_hmodules < bytes_hmodules_real ? bytes_hmodules : bytes_hmodules_real; } for ( i = 0; i < (bytes_hmodules_real / sizeof(HMODULE)); i++ ) { FARPROC result=GetProcAddress(r_modules[i],String_val(needle)); if ( result ){ if ( r_modules != hmodules ){ free(r_modules); } CloseHandle(proc); tmp=caml_copy_nativeint((intnat)result); ret=caml_alloc_small(1,1); Field(ret,0)=tmp; goto endp; } } ret=Val_long(2); /* enoent */ CloseHandle(proc); if ( r_modules != hmodules ){ free(r_modules); } endp: CAMLreturn(ret); } /* integer: 0: unknown error 1: nomem block of size one: 0: error message 1: success handle */ value ctypes_win32_dlsym(value handle,value sym) { CAMLparam2(handle,sym); CAMLlocal2(ret,tmp); PROC p = GetProcAddress((HMODULE)Nativeint_val(handle), String_val(sym)); if ( !p ){ ret=get_tagged_error_msg(GetLastError()); } else { tmp=caml_copy_nativeint((intnat)p); ret=caml_alloc_small(1,1); Field(ret,0)=tmp; } CAMLreturn(ret); } #define Val_none Val_long(0) #define Some_val(v) Field(v, 0) /* integer: 0: unknown error 1: nomem 2: not loaded block of size one: 0: error msg; 1: handle; */ value ctypes_win32_dlopen(value filename, value flags) { CAMLparam1(filename); CAMLlocal2(ret,tmp); if ( filename == Val_none ){ HMODULE p = GetModuleHandle(NULL); if ( !p ){ ret=get_tagged_error_msg(GetLastError()); } else { tmp = caml_copy_nativeint((intnat)p); ret=caml_alloc_small(1,1); Field(ret,0)=tmp; } } else { intnat iflags = Long_val(flags); HMODULE p; UINT e_mode; DWORD ec; filename=utf8_to_wstring(Some_val(filename)); if ( filename == Val_unit ){ tmp=caml_copy_string("invalid filename"); ret=caml_alloc_small(1,STUB_TAG_ERROR); Field(ret,0)=tmp; goto endp; } if ( iflags & 1 ){ /* RTLD_NOLOAD */ p= GetModuleHandleW((WCHAR *)String_val(filename)); if ( !p ){ ret=Val_long(2); goto endp; } /* Note: If GetModuleHandle succeeds, we still need to call LoadLibrary in order to increase the reference count for the module. */ } /* allocations first, so we are not responsible for not decreasing the reference count, if we are out of memory or another thread does something strange */ tmp = caml_copy_nativeint(0); ret = caml_alloc_small(1,1); Field(ret,0)=tmp; /* some windows version show a message box without this */ e_mode = SetErrorMode(SEM_FAILCRITICALERRORS|SEM_NOOPENFILEERRORBOX); p=LoadLibraryW((WCHAR *)String_val(filename)); if ( !p ){ ec = GetLastError(); } SetErrorMode(e_mode); /* restores the previous state */ if ( !p ){ ret=get_tagged_error_msg(ec); goto endp; } *((intnat *)Data_custom_val(tmp))=(intnat)p; if (iflags & 2 ){ /* RTLD_NODELETE */ GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_PIN, (WCHAR *)String_val(filename), &p); } } endp: CAMLreturn(ret); } /* integer: 0: unknown error 1: nomem 2: ok block of size one: 0: error msg */ value ctypes_win32_dlclose(value ohandle) { CAMLparam1(ohandle); CAMLlocal1(ret); ret= Val_long(2); HMODULE handle = (HMODULE) Nativeint_val(ohandle); if (handle && handle != GetModuleHandle(NULL)){ if (!FreeLibrary(handle)){ ret=get_tagged_error_msg(GetLastError()); } } CAMLreturn(ret); } ocaml-ctypes-0.7.0/src/ctypes-foreign-base/ffi_call_stubs.c000066400000000000000000000362111274143137600237110ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include "../ctypes/ctypes_managed_buffer_stubs.h" #include "../ctypes/ctypes_type_info_stubs.h" #include "../ctypes/ctypes_raw_pointer.h" /* TODO: support callbacks that raise exceptions? e.g. using caml_callback_exn etc. */ /* 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 callspec value. */ enum { BUILDING, CALLSPEC } state; /* A null-terminated array of size `nelements' types */ ffi_type **args; /* return value offset */ size_t roffset; /* return offset adjustment. libffi promotes return types that are less than the size of the system register to the word-sized type ffi_arg. On a big-endian system this means that the address where libffi writes the return value is not always the same as the address from which ctypes should read the value. */ size_t radjustment; /* The context in which the call should run: whether errno is checked, whether the runtime lock is released, and so on. */ struct call_context { int check_errno; int runtime_lock; } context; /* The libffi call interface structure. It would be nice for this member to be a value rather than a pointer (to save a layer of indirection) but the ffi_closure structure keeps the address of the structure, and the GC can move callspec values around. */ ffi_cif *cif; } callspec_prototype = { 0, 0, 0, 0, BUILDING, NULL, -1, 0, { 0, 0 }, NULL }; static void finalize_callspec(value v) { struct callspec *callspec = Data_custom_val(v); caml_stat_free(callspec->args); caml_stat_free(callspec->cif); } static struct custom_operations callspec_custom_ops = { "ocaml-ctypes:callspec", finalize_callspec, custom_compare_default, custom_hash_default, custom_serialize_default, custom_deserialize_default, custom_compare_ext_default }; /* We store two things in the callbuffer: a "scratch" area for passing arguments and receiving the return value, and an array of pointers into the scratch area; we pass that array to ffi_call along with a pointer to the return value space. The scratch area comes first, followed by the pointer array. The incomplete struct type gives a modicum of type safety over void *: the compiler should reject incompatible assignments, for example. */ typedef struct callbuffer callbuffer; /* Compute the size of the buffer needed to hold the pointer array used by ffi_call, the arguments and the return value */ static size_t compute_arg_buffer_size(struct callspec *callspec, size_t *arg_array_offset) { assert(callspec->state == CALLSPEC); size_t bytes = callspec->bytes; *arg_array_offset = aligned_offset(bytes, ffi_type_pointer.alignment); bytes = *arg_array_offset + callspec->nelements * sizeof(void *); return bytes; } /* Set the pointers in `arg_array' to the addresses of the argument slots in `callbuffer' as indicated by the elements of the ffitype array in the callspec. */ static void populate_arg_array(struct callspec *callspec, callbuffer *callbuffer, void **arg_array) { size_t i = 0, offset = 0; for (; i < callspec->nelements; i++) { offset = aligned_offset(offset, callspec->args[i]->alignment); arg_array[i] = (char *)callbuffer + offset; offset += callspec->args[i]->size; } } /* Allocate a new C call specification */ /* allocate_callspec : check_errno:bool -> runtime_lock:bool -> callspec */ value ctypes_allocate_callspec(value check_errno, value runtime_lock) { struct call_context context = { Int_val(check_errno), Int_val(runtime_lock), }; value block = caml_alloc_custom(&callspec_custom_ops, sizeof(struct callspec), 0, 1); struct callspec *spec = Data_custom_val(block); memcpy(spec, &callspec_prototype, sizeof(struct callspec)); spec->context = context; return block; } /* Add an argument to the C call specification */ /* add_argument : callspec -> 'a ffitype -> int */ value ctypes_add_argument(value callspec_, value argument_) { static const size_t increment_size = 8; CAMLparam2(callspec_, argument_); struct callspec *callspec = Data_custom_val(callspec_); ffi_type *argtype = CTYPES_TO_PTR(argument_); assert (callspec->state == BUILDING); /* If there's a possibility that this spec represents an argument list or a struct we might pass by value then we have to take care to maintain the args, capacity and nelements members. */ int offset = aligned_offset(callspec->bytes, argtype->alignment); callspec->bytes = offset + argtype->size; if (callspec->nelements + 2 >= callspec->capacity) { size_t new_size = ((callspec->capacity + increment_size) * sizeof *callspec->args); callspec->args = caml_stat_resize(callspec->args, new_size); callspec->capacity += increment_size; } callspec->args[callspec->nelements] = argtype; callspec->args[callspec->nelements + 1] = NULL; callspec->nelements += 1; callspec->max_align = argtype->alignment > callspec->max_align ? argtype->alignment : callspec->max_align; CAMLreturn(Val_int(offset)); } static int ffi_return_type_promotes(ffi_type *f) { /* libffi promotes integer return types that are smaller than a word */ if (f->size < sizeof(ffi_arg)) { switch (f->type) { case FFI_TYPE_INT: case FFI_TYPE_UINT8: case FFI_TYPE_SINT8: case FFI_TYPE_UINT16: case FFI_TYPE_SINT16: case FFI_TYPE_UINT32: case FFI_TYPE_SINT32: case FFI_TYPE_UINT64: case FFI_TYPE_SINT64: return 1; default: break; } } return 0; } static int ffi_return_type_adjustment(ffi_type *f) { #ifdef ARCH_BIG_ENDIAN /* An adjustment is needed (on bigendian systems) for integer types less than the size of a word */ if (ffi_return_type_promotes(f)) { return sizeof(ffi_arg) - f->size; } #endif return 0; } /* Pass the return type and conclude the specification preparation */ /* prep_callspec : callspec -> 'a ffitype -> int -> unit */ value ctypes_prep_callspec(value callspec_, value abi_, value rtype) { CAMLparam3(callspec_, abi_, rtype); struct callspec *callspec = Data_custom_val(callspec_); ffi_type *rffitype = CTYPES_TO_PTR(rtype); ffi_abi abi = Int_val(abi_); /* Allocate the cif structure */ callspec->cif = caml_stat_alloc(sizeof *callspec->cif); /* Add the (aligned) space needed for the return value */ callspec->roffset = aligned_offset(callspec->bytes, rffitype->alignment); callspec->radjustment = ffi_return_type_adjustment(rffitype); callspec->bytes = callspec->roffset + rffitype->size; /* Allocate an extra word after the return value space, to work around a bug in libffi which causes it to write past the return value space. https://github.com/atgreen/libffi/issues/35 */ callspec->bytes = aligned_offset(callspec->bytes, ffi_type_pointer.alignment); callspec->bytes += ffi_type_pointer.size; ffi_status status = ffi_prep_cif(callspec->cif, abi, callspec->nelements, rffitype, callspec->args); ctypes_check_ffi_status(status); callspec->state = CALLSPEC; CAMLreturn(Val_unit); } /* Call the function specified by `callspec', passing arguments and return values in `buffer' */ /* call : string -> _ fn Fat.t -> callspec -> (raw_pointer -> Obj.t array -> unit) -> (raw_pointer -> 'a) -> 'a */ value ctypes_call(value fnname, value function, value callspec_, value argwriter, value rvreader) { CAMLparam5(fnname, function, callspec_, argwriter, rvreader); CAMLlocal3(callback_arg_buf, callback_val_arr, callback_rv_buf); struct callspec *callspec = Data_custom_val(callspec_); int roffset = callspec->roffset; struct call_context context = callspec->context; size_t nelements = callspec->nelements; ffi_cif *cif = callspec->cif; assert(callspec->state == CALLSPEC); size_t arg_array_offset; size_t bytes = compute_arg_buffer_size(callspec, &arg_array_offset); char *callbuffer = alloca(bytes); char *return_write_slot = callbuffer + roffset; char *return_read_slot = return_write_slot + callspec->radjustment; populate_arg_array(callspec, (struct callbuffer *)callbuffer, (void **)(callbuffer + arg_array_offset)); callback_arg_buf = CTYPES_FROM_PTR(callbuffer); callback_val_arr = caml_alloc_tuple(nelements); caml_callback2(argwriter, callback_arg_buf, callback_val_arr); void **val_refs = alloca(sizeof(void*) * nelements); unsigned arg_idx; for(arg_idx = 0; arg_idx < Wosize_val(callback_val_arr); arg_idx++) { value arg_tuple = Field(callback_val_arr, arg_idx); /* <4.02 initialize to 0; >=4.02 initialize to unit. */ if(arg_tuple == 0 || arg_tuple == Val_unit) continue; value arg_ptr = Field(arg_tuple, 0); value arg_offset = Field(arg_tuple, 1); /* Only strings have defined semantics for now. */ assert(Is_block(arg_ptr) && Tag_val(arg_ptr) == String_tag); val_refs[arg_idx] = String_val(arg_ptr) + Int_val(arg_offset); ((void**)(callbuffer + arg_array_offset))[arg_idx] = &val_refs[arg_idx]; } void (*cfunction)(void) = (void (*)(void)) CTYPES_ADDR_OF_FATPTR(function); int check_errno = context.check_errno; int saved_errno = 0; if (context.runtime_lock) { caml_release_runtime_system(); } if (check_errno) { errno=0; } ffi_call(cif, cfunction, return_write_slot, (void **)(callbuffer + arg_array_offset)); if (check_errno) { saved_errno=errno; } if (context.runtime_lock) { caml_acquire_runtime_system(); } if (check_errno && saved_errno != 0) { char *buffer = alloca(caml_string_length(fnname) + 1); strcpy(buffer, String_val(fnname)); unix_error(saved_errno, buffer, Nothing); } callback_rv_buf = CTYPES_FROM_PTR(return_read_slot); CAMLreturn(caml_callback(rvreader, callback_rv_buf)); } typedef struct closure closure; struct closure { ffi_closure closure; int fnkey; struct call_context context; }; enum boxedfn_tags { Done, Fn }; /* callback_handler_with_lock must only be called while the runtime lock is held. */ static void callback_handler_with_lock(ffi_cif *cif, void *ret, void **args, void *user_data) { CAMLparam0 (); CAMLlocal2(boxedfn, argptr); closure *closure = user_data; boxedfn = retrieve_closure(closure->fnkey); int i, arity = cif->nargs; switch (arity) { case 0: { assert (Tag_val(boxedfn) == Fn); boxedfn = caml_callback(Field(boxedfn, 0), Val_unit); break; } default: { for (i = 0; i < arity; i++) { void *cvalue = args[i]; assert (Tag_val(boxedfn) == Fn); /* unbox and call */ argptr = CTYPES_FROM_PTR(cvalue); boxedfn = caml_callback(Field(boxedfn, 0), argptr); } break; } } /* now store the return value */ assert (Tag_val(boxedfn) == Done); if (ffi_return_type_promotes(cif->rtype)) { *(ffi_arg *)ret = 0; } argptr = CTYPES_FROM_PTR(ret + ffi_return_type_adjustment(cif->rtype)); caml_callback(Field(boxedfn, 0), argptr); CAMLreturn0; } static void callback_handler(ffi_cif *cif, void *ret, void **args, void *user_data) { closure *closure = user_data; if (closure->context.runtime_lock) { caml_acquire_runtime_system(); } callback_handler_with_lock(cif, ret, args, user_data); if (closure->context.runtime_lock) { caml_release_runtime_system(); } } /* 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); closure->context = callspec->context; ffi_status status = ffi_prep_closure_loc ((ffi_closure *)closure, callspec->cif, callback_handler, closure, (void *)code_address); ctypes_check_ffi_status(status); codeptr = CTYPES_FROM_PTR((void *)code_address); CAMLreturn (codeptr); } } ocaml-ctypes-0.7.0/src/ctypes-foreign-base/ffi_type_stubs.c000066400000000000000000000132411274143137600237550ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #include #include #include #include #include #include "../ctypes/ctypes_primitives.h" #include "../ctypes/ctypes_raw_pointer.h" #include "../ctypes/ctypes_managed_buffer_stubs.h" #if CHAR_MIN < 0 #define ctypes_ffi_type_char ffi_type_schar #else #define ctypes_ffi_type_char ffi_type_uchar #endif /* We need a pointer-sized integer type. SIZEOF_PTR is from caml/config.h. */ #if SIZEOF_PTR == 4 #define ctypes_ffi_type_camlint ffi_type_sint32 #elif SIZEOF_PTR == 8 #define ctypes_ffi_type_camlint ffi_type_sint64 #else #error "No suitable pointer-sized integer type available" #endif /* long long is at least 64 bits. */ #if LLONG_MAX == 9223372036854775807LL #define ctypes_ffi_type_sllong ffi_type_sint64 #define ctypes_ffi_type_ullong ffi_type_uint64 #else # error "No suitable OCaml type available for representing longs" #endif #if SIZE_MAX == 65535U #define ctypes_ffi_type_size_t ffi_type_uint16 #elif SIZE_MAX == 4294967295UL #define ctypes_ffi_type_size_t ffi_type_uint32 #elif SIZE_MAX == 18446744073709551615ULL #define ctypes_ffi_type_size_t ffi_type_uint64 #else # error "No suitable OCaml type available for representing size_t values" #endif static ffi_type *bool_ffi_type(void) { switch (sizeof(bool)) { case sizeof(uint8_t): return &ffi_type_uint8; case sizeof(uint16_t): return &ffi_type_uint16; case sizeof(uint32_t): return &ffi_type_uint32; case sizeof(uint64_t): return &ffi_type_uint64; default: return NULL; } } /* primitive_ffitype : 'a prim -> 'a ffitype */ value ctypes_primitive_ffitype(value prim) { void *ft = NULL; switch ((enum ctypes_primitive)Int_val(prim)) { case Ctypes_Char: ft = &ctypes_ffi_type_char; break; /* Char */ case Ctypes_Schar: ft = &ffi_type_schar; break; /* Schar */ case Ctypes_Uchar: ft = &ffi_type_uchar; break; /* Uchar */ case Ctypes_Bool: ft = bool_ffi_type(); break; case Ctypes_Short: ft = &ffi_type_sshort; break; /* Short */ case Ctypes_Int: ft = &ffi_type_sint; break; /* Int */ case Ctypes_Long: ft = &ffi_type_slong; break; /* Long */ case Ctypes_Llong: ft = &ctypes_ffi_type_sllong; break; /* Llong */ case Ctypes_Ushort: ft = &ffi_type_ushort; break; /* Ushort */ case Ctypes_Sint: ft = &ffi_type_sint; break; /* Sint */ case Ctypes_Uint: ft = &ffi_type_uint; break; /* Uint */ case Ctypes_Ulong: ft = &ffi_type_ulong; break; /* Ulong */ case Ctypes_Ullong: ft = &ctypes_ffi_type_ullong; break; /* Ullong */ case Ctypes_Size_t: ft = &ctypes_ffi_type_size_t; break; /* Size */ case Ctypes_Int8_t: ft = &ffi_type_sint8; break; /* Int8 */ case Ctypes_Int16_t: ft = &ffi_type_sint16; break; /* Int16 */ case Ctypes_Int32_t: ft = &ffi_type_sint32; break; /* Int32 */ case Ctypes_Int64_t: ft = &ffi_type_sint64; break; /* Int64 */ case Ctypes_Uint8_t: ft = &ffi_type_uint8; break; /* Uint8 */ case Ctypes_Uint16_t: ft = &ffi_type_uint16; break; /* Uint16 */ case Ctypes_Uint32_t: ft = &ffi_type_uint32; break; /* Uint32 */ case Ctypes_Uint64_t: ft = &ffi_type_uint64; break; /* Uint64 */ case Ctypes_Camlint: ft = &ctypes_ffi_type_camlint; break; /* Camlint */ case Ctypes_Nativeint: ft = &ctypes_ffi_type_camlint; break; /* Nativeint */ case Ctypes_Float: ft = &ffi_type_float; break; /* Float */ case Ctypes_Double: ft = &ffi_type_double; break; /* Double */ case Ctypes_Complex32: ft = NULL; break; /* Complex32 */ case Ctypes_Complex64: ft = NULL; break; /* Complex64 */ } return CTYPES_FROM_PTR(ft); } /* pointer_ffitype : unit -> voidp ffitype */ value ctypes_pointer_ffitype(value _) { return CTYPES_FROM_PTR(&ffi_type_pointer); } /* void_ffitype : unit -> unit ffitype */ value ctypes_void_ffitype(value _) { return CTYPES_FROM_PTR(&ffi_type_void); } #define Struct_ffitype_val(v) (*(ffi_type **)Data_custom_val(v)) /* allocate_struct_ffitype : int -> managed_buffer */ value ctypes_allocate_struct_ffitype(value nargs_) { CAMLparam1(nargs_); int nargs = Int_val(nargs_); /* Space for the struct ffi_type plus a null-terminated array of arguments */ int size = sizeof (ffi_type) + (1 + nargs) * sizeof (ffi_type *); CAMLlocal1(block); block = ctypes_allocate(Val_int(1), Val_int(size)); ffi_type *struct_type = Struct_ffitype_val(block); struct_type->size = 0; struct_type->alignment = 0; struct_type->type = FFI_TYPE_STRUCT; struct_type->elements = (ffi_type **)(struct_type + 1); struct_type->elements[nargs] = NULL; CAMLreturn (block); } /* struct_ffitype_set_argument : managed_buffer -> int -> _ ffitype -> unit */ value ctypes_struct_ffitype_set_argument(value struct_type_, value index_, value arg_) { int index = Int_val(index_); ffi_type *arg = CTYPES_TO_PTR(arg_); ffi_type *struct_type = Struct_ffitype_val(struct_type_); struct_type->elements[index] = arg; return Val_unit; } extern void ctypes_check_ffi_status(ffi_status); /* complete_struct_type : managed_buffer -> unit */ value ctypes_complete_structspec(value struct_type_) { ffi_cif _dummy_cif; ffi_type *struct_type = Struct_ffitype_val(struct_type_); ffi_status status = ffi_prep_cif(&_dummy_cif, FFI_DEFAULT_ABI, 0, struct_type, NULL); ctypes_check_ffi_status(status); return Val_unit; } ocaml-ctypes-0.7.0/src/ctypes-foreign-base/libffi_abi.mli000066400000000000000000000012661274143137600233410ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** Support for various ABIs. *) type abi val aix : abi val darwin : abi val eabi : abi val fastcall : abi val gcc_sysv : abi val linux : abi val linux64 : abi val linux_soft_float : abi val ms_cdecl : abi val n32 : abi val n32_soft_float : abi val n64 : abi val n64_soft_float : abi val o32 : abi val o32_soft_float : abi val osf : abi val pa32 : abi val stdcall : abi val sysv : abi val thiscall : abi val unix : abi val unix64 : abi val v8 : abi val v8plus : abi val v9 : abi val vfp : abi val default_abi : abi val abi_code : abi -> int ocaml-ctypes-0.7.0/src/ctypes-foreign-threaded/000077500000000000000000000000001274143137600214315ustar00rootroot00000000000000ocaml-ctypes-0.7.0/src/ctypes-foreign-threaded/foreign.ml000066400000000000000000000003361274143137600234160ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) include Ctypes_foreign_basis.Make(Ctypes_closure_properties.Make(Mutex)) ocaml-ctypes-0.7.0/src/ctypes-foreign-threaded/foreign.mli000066400000000000000000000070721274143137600235730ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** High-level bindings for C functions and values *) val foreign : ?abi:Libffi_abi.abi -> ?from:Dl.library -> ?stub:bool -> ?check_errno:bool -> ?release_runtime_lock:bool -> string -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) (** [foreign name typ] exposes the C function of type [typ] named by [name] as an OCaml value. The argument [?from], if supplied, is a library handle returned by {!Dl.dlopen}. The argument [?stub], if [true] (defaults to [false]), indicates that the function should not raise an exception if [name] is not found but return an OCaml value that raises an exception when called. The value [?check_errno], which defaults to [false], indicates whether {!Unix.Unix_error} should be raised if the C function modifies [errno]. Please note that a function that succeeds is allowed to change errno. So use this option with caution. The value [?release_runtime_lock], which defaults to [false], indicates whether the OCaml runtime lock should be released during the call to the C function, allowing other threads to run. If the runtime lock is released then the C function must not access OCaml heap objects, such as arguments passed using {!Ctypes.ocaml_string} and {!Ctypes.ocaml_bytes}, and must not call back into OCaml. @raise Dl.DL_error if [name] is not found in [?from] and [?stub] is [false]. *) val foreign_value : ?from:Dl.library -> string -> 'a Ctypes.typ -> 'a Ctypes.ptr (** [foreign_value name typ] exposes the C value of type [typ] named by [name] as an OCaml value. The argument [?from], if supplied, is a library handle returned by {!Dl.dlopen}. *) val funptr : ?abi:Libffi_abi.abi -> ?name:string -> ?check_errno:bool -> ?runtime_lock:bool -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) Ctypes.typ (** Construct a function pointer type from a function type. The ctypes library, like C itself, distinguishes functions and function pointers. Functions are not first class: it is not possible to use them as arguments or return values of calls, or store them in addressable memory. Function pointers are first class, and so have none of these restrictions. The value [?check_errno], which defaults to [false], indicates whether {!Unix.Unix_error} should be raised if the C function modifies [errno]. The value [?runtime_lock], which defaults to [false], indicates whether the OCaml runtime lock should be released during the call to the C function, allowing other threads to run. If the runtime lock is released then the C function must not access OCaml heap objects, such as arguments passed using {!Ctypes.ocaml_string} and {!Ctypes.ocaml_bytes}, and must not call back into OCaml. If the function pointer is used to call into OCaml from C then the [?runtime_lock] argument indicates whether the lock should be acquired and held during the call. @raise Dl.DL_error if [name] is not found in [?from] and [?stub] is [false]. *) val funptr_opt : ?abi:Libffi_abi.abi -> ?name:string -> ?check_errno:bool -> ?runtime_lock:bool -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) option Ctypes.typ (** Construct a function pointer type from a function type. This behaves like {!funptr}, except that null pointers appear in OCaml as [None]. *) exception CallToExpiredClosure (** A closure passed to C was collected by the OCaml garbage collector before it was called. *) ocaml-ctypes-0.7.0/src/ctypes-foreign-unthreaded/000077500000000000000000000000001274143137600217745ustar00rootroot00000000000000ocaml-ctypes-0.7.0/src/ctypes-foreign-unthreaded/ctypes_gc_mutex.ml000066400000000000000000000016231274143137600255320ustar00rootroot00000000000000(* * 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-0.7.0/src/ctypes-foreign-unthreaded/foreign.ml000066400000000000000000000003501274143137600237550ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) include Ctypes_foreign_basis.Make(Ctypes_closure_properties.Make(Ctypes_gc_mutex)) ocaml-ctypes-0.7.0/src/ctypes-foreign-unthreaded/foreign.mli000066400000000000000000000070721274143137600241360ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** High-level bindings for C functions and values *) val foreign : ?abi:Libffi_abi.abi -> ?from:Dl.library -> ?stub:bool -> ?check_errno:bool -> ?release_runtime_lock:bool -> string -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) (** [foreign name typ] exposes the C function of type [typ] named by [name] as an OCaml value. The argument [?from], if supplied, is a library handle returned by {!Dl.dlopen}. The argument [?stub], if [true] (defaults to [false]), indicates that the function should not raise an exception if [name] is not found but return an OCaml value that raises an exception when called. The value [?check_errno], which defaults to [false], indicates whether {!Unix.Unix_error} should be raised if the C function modifies [errno]. Please note that a function that succeeds is allowed to change errno. So use this option with caution. The value [?release_runtime_lock], which defaults to [false], indicates whether the OCaml runtime lock should be released during the call to the C function, allowing other threads to run. If the runtime lock is released then the C function must not access OCaml heap objects, such as arguments passed using {!Ctypes.ocaml_string} and {!Ctypes.ocaml_bytes}, and must not call back into OCaml. @raise Dl.DL_error if [name] is not found in [?from] and [?stub] is [false]. *) val foreign_value : ?from:Dl.library -> string -> 'a Ctypes.typ -> 'a Ctypes.ptr (** [foreign_value name typ] exposes the C value of type [typ] named by [name] as an OCaml value. The argument [?from], if supplied, is a library handle returned by {!Dl.dlopen}. *) val funptr : ?abi:Libffi_abi.abi -> ?name:string -> ?check_errno:bool -> ?runtime_lock:bool -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) Ctypes.typ (** Construct a function pointer type from a function type. The ctypes library, like C itself, distinguishes functions and function pointers. Functions are not first class: it is not possible to use them as arguments or return values of calls, or store them in addressable memory. Function pointers are first class, and so have none of these restrictions. The value [?check_errno], which defaults to [false], indicates whether {!Unix.Unix_error} should be raised if the C function modifies [errno]. The value [?runtime_lock], which defaults to [false], indicates whether the OCaml runtime lock should be released during the call to the C function, allowing other threads to run. If the runtime lock is released then the C function must not access OCaml heap objects, such as arguments passed using {!Ctypes.ocaml_string} and {!Ctypes.ocaml_bytes}, and must not call back into OCaml. If the function pointer is used to call into OCaml from C then the [?runtime_lock] argument indicates whether the lock should be acquired and held during the call. @raise Dl.DL_error if [name] is not found in [?from] and [?stub] is [false]. *) val funptr_opt : ?abi:Libffi_abi.abi -> ?name:string -> ?check_errno:bool -> ?runtime_lock:bool -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) option Ctypes.typ (** Construct a function pointer type from a function type. This behaves like {!funptr}, except that null pointers appear in OCaml as [None]. *) exception CallToExpiredClosure (** A closure passed to C was collected by the OCaml garbage collector before it was called. *) ocaml-ctypes-0.7.0/src/ctypes-top/000077500000000000000000000000001274143137600170245ustar00rootroot00000000000000ocaml-ctypes-0.7.0/src/ctypes-top/ctypes_printers.ml000066400000000000000000000047771274143137600226320ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) let format_typ fmt t = Ctypes.format_typ fmt t let format_fn fmt fn = Ctypes.format_fn fmt fn let format_sint fmt v = Format.fprintf fmt "" (Signed.SInt.to_string v) let format_long fmt v = Format.fprintf fmt "" (Signed.Long.to_string v) let format_llong fmt v = Format.fprintf fmt "" (Signed.LLong.to_string v) let format_uchar fmt v = Format.fprintf fmt "" (Unsigned.UChar.to_string v) let format_uint8 fmt v = Format.fprintf fmt "" (Unsigned.UInt8.to_string v) let format_uint16 fmt v = Format.fprintf fmt "" (Unsigned.UInt16.to_string v) let format_uint32 fmt v = Format.fprintf fmt "" (Unsigned.UInt32.to_string v) let format_uint64 fmt v = Format.fprintf fmt "" (Unsigned.UInt64.to_string v) let format_ushort fmt v = Format.fprintf fmt "" (Unsigned.UShort.to_string v) let format_uint fmt v = Format.fprintf fmt "" (Unsigned.UInt.to_string v) let format_ulong fmt v = Format.fprintf fmt "" (Unsigned.ULong.to_string v) let format_ullong fmt v = Format.fprintf fmt "" (Unsigned.ULLong.to_string v) let format_pointer fmt v = let open Ctypes in let typ = ptr (reference_type v) in Format.fprintf fmt "(%a) %a" (fun fmt -> format_typ fmt) typ (format typ) v let format_struct fmt v = Ctypes.(format (reference_type (addr v)) fmt v) let format_union fmt v = Ctypes.(format (reference_type (addr v)) fmt v) let format_array fmt v = Ctypes.(format CArray.(array (length v) (reference_type (start v))) fmt v) let format_ocaml fmt (Ctypes_static.OCamlRef (_, _, ty) as v) = Ctypes.format (Ctypes_static.OCaml ty) fmt v let format_clock_t fmt v = Ctypes.format PosixTypes.clock_t fmt v let format_dev_t fmt v = Ctypes.format PosixTypes.dev_t fmt v let format_ino_t fmt v = Ctypes.format PosixTypes.ino_t fmt v let format_mode_t fmt v = Ctypes.format PosixTypes.mode_t fmt v let format_nlink_t fmt v = Ctypes.format PosixTypes.nlink_t fmt v let format_off_t fmt v = Ctypes.format PosixTypes.off_t fmt v let format_pid_t fmt v = Ctypes.format PosixTypes.pid_t fmt v let format_size_t fmt v = Ctypes.format PosixTypes.size_t fmt v let format_ssize_t fmt v = Ctypes.format PosixTypes.ssize_t fmt v let format_time_t fmt v = Ctypes.format PosixTypes.time_t fmt v let format_useconds_t fmt v = Ctypes.format PosixTypes.useconds_t fmt v ocaml-ctypes-0.7.0/src/ctypes-top/ctypes_printers.mli000066400000000000000000000035631274143137600227730ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Format val format_typ : formatter -> 'a Ctypes.typ -> unit val format_fn : formatter -> 'a Ctypes.fn -> unit val format_sint : formatter -> Signed.SInt.t -> unit val format_long : formatter -> Signed.Long.t -> unit val format_llong : formatter -> Signed.LLong.t -> unit val format_uchar : formatter -> Unsigned.UChar.t -> unit val format_uint8 : formatter -> Unsigned.UInt8.t -> unit val format_uint16 : formatter -> Unsigned.UInt16.t -> unit val format_uint32 : formatter -> Unsigned.UInt32.t -> unit val format_uint64 : formatter -> Unsigned.UInt64.t -> unit val format_ushort : formatter -> Unsigned.UShort.t -> unit val format_uint : formatter -> Unsigned.UInt.t -> unit val format_ulong : formatter -> Unsigned.ULong.t -> unit val format_ullong : formatter -> Unsigned.ULLong.t -> unit val format_pointer : formatter -> 'a Ctypes.ptr -> unit val format_struct : formatter -> ('a, 'b) Ctypes.structured -> unit val format_union : formatter -> ('a, 'b) Ctypes.structured -> unit val format_array : formatter -> 'a Ctypes.CArray.t -> unit val format_ocaml : formatter -> 'a Ctypes.ocaml -> unit val format_clock_t : formatter -> PosixTypes.clock_t -> unit val format_dev_t : formatter -> PosixTypes.dev_t -> unit val format_ino_t : formatter -> PosixTypes.ino_t -> unit val format_mode_t : formatter -> PosixTypes.mode_t -> unit val format_nlink_t : formatter -> PosixTypes.nlink_t -> unit val format_off_t : formatter -> PosixTypes.off_t -> unit val format_pid_t : formatter -> PosixTypes.pid_t -> unit val format_size_t : formatter -> PosixTypes.size_t -> unit val format_ssize_t : formatter -> PosixTypes.ssize_t -> unit val format_time_t : formatter -> PosixTypes.time_t -> unit val format_useconds_t : formatter -> PosixTypes.useconds_t -> unit ocaml-ctypes-0.7.0/src/ctypes-top/install_ctypes_printers.ml000066400000000000000000000041501274143137600243410ustar00rootroot00000000000000(* Adapted from Anil Madhavapeddy's ocaml-uri package. *) let printers = [ "Ctypes_printers.format_typ"; "Ctypes_printers.format_fn"; "Ctypes_printers.format_sint"; "Ctypes_printers.format_long"; "Ctypes_printers.format_llong"; "Ctypes_printers.format_uchar"; "Ctypes_printers.format_uint8"; "Ctypes_printers.format_uint16"; "Ctypes_printers.format_uint32"; "Ctypes_printers.format_uint64"; "Ctypes_printers.format_size_t"; "Ctypes_printers.format_ushort"; "Ctypes_printers.format_uint"; "Ctypes_printers.format_ulong"; "Ctypes_printers.format_ullong"; "Ctypes_printers.format_pointer"; "Ctypes_printers.format_struct"; "Ctypes_printers.format_union"; "Ctypes_printers.format_array"; "Ctypes_printers.format_ocaml"; "Ctypes_printers.format_clock_t"; "Ctypes_printers.format_dev_t"; "Ctypes_printers.format_ino_t"; "Ctypes_printers.format_mode_t"; "Ctypes_printers.format_nlink_t"; "Ctypes_printers.format_off_t"; "Ctypes_printers.format_pid_t"; "Ctypes_printers.format_size_t"; "Ctypes_printers.format_ssize_t"; "Ctypes_printers.format_time_t"; "Ctypes_printers.format_useconds_t";] 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-0.7.0/src/ctypes/000077500000000000000000000000001274143137600162245ustar00rootroot00000000000000ocaml-ctypes-0.7.0/src/ctypes/coerce.mli000066400000000000000000000004721274143137600201720ustar00rootroot00000000000000(* * 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 Ctypes_static.typ -> 'b Ctypes_static.typ -> 'a -> 'b val coerce_fn : 'a Ctypes_static.fn -> 'b Ctypes_static.fn -> 'a -> 'b ocaml-ctypes-0.7.0/src/ctypes/complex_stubs.c000066400000000000000000000021541274143137600212610ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #include #include #include #include "ctypes_complex_stubs.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; } /* ctypes_copy_float_complex : float complex -> Complex.t */ value ctypes_copy_float_complex(float complex c) { return allocate_complex_value(crealf(c), cimagf(c)); } /* ctypes_copy_double_complex : double complex -> Complex.t */ value ctypes_copy_double_complex(double complex c) { return allocate_complex_value(creal(c), cimag(c)); } /* ctypes_float_complex_val : Complex.t -> float complex */ float complex ctypes_float_complex_val(value v) { return Double_field(v, 0) + Double_field(v, 1) * I; } /* ctypes_double_complex_val : Complex.t -> double complex */ double complex ctypes_double_complex_val(value v) { return Double_field(v, 0) + Double_field(v, 1) * I; } ocaml-ctypes-0.7.0/src/ctypes/cstubs_internals.h000066400000000000000000000006111274143137600217550ustar00rootroot00000000000000/* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef CSTUBS_INTERNALS_H #define CSTUBS_INTERNALS_H /* This is just here for backwards compatibility and will eventually be removed. */ /* Include the real header. */ #include "ctypes_cstubs_internals.h" #endif /* CSTUBS_INTERNALS_H */ ocaml-ctypes-0.7.0/src/ctypes/ctypes.ml000066400000000000000000000005451274143137600200710ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) include Ctypes_static include Ctypes_structs_computed include Ctypes_type_printing include Ctypes_memory include Ctypes_std_views include Ctypes_value_printing include Ctypes_coerce let lift_typ x = x ocaml-ctypes-0.7.0/src/ctypes/ctypes.mli000066400000000000000000000432321274143137600202420ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** The core ctypes module. The main points of interest are the set of functions for describing C types (see {!types}) and the set of functions for accessing C values (see {!values}). The {!Foreign.foreign} function uses C type descriptions to bind external C values. *) (** {4:pointer_types Pointer types} *) type ('a, 'b) pointer = ('a, 'b) Ctypes_static.pointer (** The type of pointer values. A value of type [('a, [`C]) pointer] contains a C-compatible pointer, and a value of type [('a, [`OCaml]) pointer] contains a pointer to a value that can be moved by OCaml runtime. *) (** {4 C-compatible pointers} *) type 'a ptr = ('a, [`C]) pointer (** The type of C-compatible pointer values. A value of type [t ptr] can be used to read and write values of type [t] at particular addresses. *) type 'a ocaml = 'a Ctypes_static.ocaml (** The type of pointer values pointing directly into OCaml values. {b Pointers of this type should never be captured by external code}. In particular, functions accepting ['a ocaml] pointers must not invoke any OCaml code. *) (** {4 C array types} *) type 'a carray = 'a Ctypes_static.carray (** The type of C array values. A value of type [t carray] can be used to read and write array objects in C-managed storage. *) (** {4 Bigarray types} *) type 'a bigarray_class = 'a Ctypes_static.bigarray_class (** The type of Bigarray classes. There are four instances, one for each of the Bigarray submodules. *) val genarray : < element: 'a; ba_repr: 'b; bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t; carray: 'a carray; dims: int 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 carray; 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 carray carray; 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 carray carray carray; dims: int * int * int > bigarray_class (** The class of {!Bigarray.Array3.t} values *) (** {3 Struct and union types} *) type ('a, 'kind) structured = ('a, 'kind) Ctypes_static.structured (** The base type of values representing C struct and union types. The ['kind] parameter is a polymorphic variant type indicating whether the type represents a struct ([`Struct]) or a union ([`Union]). *) type 'a structure = ('a, [`Struct]) structured (** The type of values representing C struct types. *) type 'a union = ('a, [`Union]) structured (** The type of values representing C union types. *) type ('a, 't) field = ('a, 't) Ctypes_static.field (** The type of values representing C struct or union members (called "fields" here). A value of type [(a, s) field] represents a field of type [a] in a struct or union of type [s]. *) type 'a abstract = 'a Ctypes_static.abstract (** The type of abstract values. The purpose of the [abstract] type is to represent values whose type varies from platform to platform. For example, the type [pthread_t] is a pointer on some platforms, an integer on other platforms, and a struct on a third set of platforms. One way to deal with this kind of situation is to have possibly-platform-specific code which interrogates the C type in some way to help determine an appropriate representation. Another way is to use [abstract], leaving the representation opaque. (Note, however, that although [pthread_t] is a convenient example, since the type used to implement it varies significantly across platforms, it's not actually a good match for [abstract], since values of type [pthread_t] are passed and returned by value.) *) include Ctypes_types.TYPE with type 'a typ = 'a Ctypes_static.typ and type ('a, 's) field := ('a, 's) field (** {3 Operations on types} *) val sizeof : 'a typ -> int (** [sizeof t] computes the size in bytes of the type [t]. The exception {!IncompleteType} is raised if [t] is incomplete. *) val alignment : 'a typ -> int (** [alignment t] computes the alignment requirements of the type [t]. The exception {!IncompleteType} is raised if [t] is incomplete. *) val format_typ : ?name:string -> Format.formatter -> 'a typ -> unit (** Pretty-print a C representation of the type to the specified formatter. *) val format_fn : ?name:string -> Format.formatter -> 'a fn -> unit (** Pretty-print a C representation of the function type to the specified formatter. *) val string_of_typ : ?name:string -> 'a typ -> string (** Return a C representation of the type. *) val string_of_fn : ?name:string -> 'a fn -> string (** Return a C representation of the function type. *) (** {2:values Values representing C values} *) val format : 'a typ -> Format.formatter -> 'a -> unit (** Pretty-print a representation of the C value to the specified formatter. *) val string_of : 'a typ -> 'a -> string (** Return a string representation of the C value. *) (** {3 Pointer values} *) val null : unit ptr (** A null pointer. *) val (!@) : 'a ptr -> 'a (** [!@ p] dereferences the pointer [p]. If the reference type is a scalar type then dereferencing constructs a new value. If the reference type is an aggregate type then dereferencing returns a value that references the memory pointed to by [p]. *) val (<-@) : 'a ptr -> 'a -> unit (** [p <-@ v] writes the value [v] to the address [p]. *) val (+@) : ('a, 'b) pointer -> int -> ('a, 'b) pointer (** If [p] is a pointer to an array element then [p +@ n] computes the address of the [n]th next element. *) val (-@) : ('a, 'b) pointer -> int -> ('a, 'b) pointer (** If [p] is a pointer to an array element then [p -@ n] computes the address of the nth previous element. *) val ptr_diff : ('a, 'b) pointer -> ('a, 'b) pointer -> int (** [ptr_diff p q] computes [q - p]. As in C, both [p] and [q] must point into the same array, and the result value is the difference of the subscripts of the two array elements. *) val from_voidp : 'a typ -> unit ptr -> 'a ptr (** Conversion from [void *]. *) val to_voidp : _ ptr -> unit ptr (** Conversion to [void *]. *) val allocate : ?finalise:('a ptr -> unit) -> 'a typ -> 'a -> 'a ptr (** [allocate t v] allocates a fresh value of type [t], initialises it with [v] and returns its address. The argument [?finalise], if present, will be called just before the memory is freed. The value will be automatically freed after no references to the pointer remain within the calling OCaml program. *) val allocate_n : ?finalise:('a ptr -> unit) -> 'a typ -> count:int -> 'a ptr (** [allocate_n t ~count:n] allocates a fresh array with element type [t] and length [n], and returns its address. The argument [?finalise], if present, will be called just before the memory is freed. The array will be automatically freed after no references to the pointer remain within the calling OCaml program. The memory is allocated with libc's [calloc] and is guaranteed to be zero-filled. *) val ptr_compare : 'a ptr -> 'a ptr -> int (** If [p] and [q] are pointers to elements [i] and [j] of the same array then [ptr_compare p q] compares the indexes of the elements. The result is negative if [i] is less than [j], positive if [i] is greater than [j], and zero if [i] and [j] are equal. *) val reference_type : 'a ptr -> 'a typ (** Retrieve the reference type of a pointer. *) val ptr_of_raw_address : nativeint -> unit ptr (** Convert the numeric representation of an address to a pointer *) val funptr_of_raw_address : nativeint -> (unit -> unit) Ctypes_static.static_funptr (** Convert the numeric representation of an address to a function pointer *) val raw_address_of_ptr : unit ptr -> nativeint (** [raw_address_of_ptr p] returns the numeric representation of p. Note that the return value remains valid only as long as the pointed-to object is alive. If [p] is a managed object (e.g. a value returned by {!make}) then unless the caller retains a reference to [p], the object may be collected, invalidating the returned address. *) val string_from_ptr : char ptr -> length:int -> string (** [string_from_ptr p ~length] creates a string initialized with the [length] characters at address [p]. Raise [Invalid_argument "Ctypes.string_from_ptr"] if [length] is negative. *) val ocaml_string_start : string -> string ocaml (** [ocaml_string_start s] allows to pass a pointer to the contents of an OCaml string directly to a C function. *) val ocaml_bytes_start : Bytes.t -> Bytes.t ocaml (** [ocaml_bytes_start s] allows to pass a pointer to the contents of an OCaml byte array directly to a C function. *) (** {3 Array values} *) (** {4 C array values} *) module CArray : sig type 'a t = 'a carray val get : 'a t -> int -> 'a (** [get a n] returns the [n]th element of the zero-indexed array [a]. The semantics for non-scalar types are non-copying, as for {!(!@)}. If you rebind the [CArray] module to [Array] then you can also use the syntax [a.(n)] instead of [Array.get a n]. Raise [Invalid_argument "index out of bounds"] if [n] is outside of the range [0] to [(CArray.length a - 1)]. *) val set : 'a t -> int -> 'a -> unit (** [set a n v] overwrites the [n]th element of the zero-indexed array [a] with [v]. If you rebind the [CArray] module to [Array] then you can also use the [a.(n) <- v] syntax instead of [Array.set a n v]. Raise [Invalid_argument "index out of bounds"] if [n] is outside of the range [0] to [(CArray.length a - 1)]. *) val unsafe_get : 'a t -> int -> 'a (** [unsafe_get a n] behaves like [get a n] except that the check that [n] between [0] and [(CArray.length a - 1)] is not performed. *) val unsafe_set : 'a t -> int -> 'a -> unit (** [unsafe_set a n v] behaves like [set a n v] except that the check that [n] between [0] and [(CArray.length a - 1)] is not performed. *) val of_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 t -> '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 (** [bigarray_of_ptr c dims k p] converts the C pointer [p] to a bigarray value. No copy is made; the bigarray references the memory pointed to by [p]. *) val array_of_bigarray : < element: _; ba_repr: _; bigarray: 'b; carray: 'c; dims: _ > bigarray_class -> 'b -> 'c (** [array_of_bigarray c b] converts the bigarray value [b] to a value of type {!CArray.t}. No copy is made; the result occupies the same memory as [b]. *) (** Convert a Bigarray value to a C array. *) val bigarray_of_array : < element: 'a; ba_repr: 'f; bigarray: 'b; carray: 'c carray; dims: 'i > bigarray_class -> ('a, 'f) Bigarray.kind -> 'c carray -> 'b (** [bigarray_of_array c k a] converts the {!CArray.t} value [c] to a bigarray value. No copy is made; the result occupies the same memory as [c]. *) (** {3 Struct and union values} *) val make : ?finalise:('s -> unit) -> ((_, _) structured as 's) typ -> 's (** Allocate a fresh, uninitialised structure or union value. The argument [?finalise], if present, will be called just before the underlying memory is freed. *) val setf : ((_, _) structured as 's) -> ('a, 's) field -> 'a -> unit (** [setf s f v] overwrites the value of the field [f] in the structure or union [s] with [v]. *) val getf : ((_, _) structured as 's) -> ('a, 's) field -> 'a (** [getf s f] retrieves the value of the field [f] in the structure or union [s]. The semantics for non-scalar types are non-copying, as for {!(!@)}.*) val (@.) : ((_, _) structured as 's) -> ('a, 's) field -> 'a ptr (** [s @. f] computes the address of the field [f] in the structure or union value [s]. *) val (|->) : ((_, _) structured as 's) ptr -> ('a, 's) field -> 'a ptr (** [p |-> f] computes the address of the field [f] in the structure or union value pointed to by [p]. *) val offsetof : (_, _ structure) field -> int (** [offsetof f] returns the offset, in bytes, of the field [f] from the beginning of the associated struct type. *) val field_type : ('a, _) field -> 'a typ (** [field_type f] returns the type of the field [f]. *) val field_name : (_, _) field -> string (** [field_name f] returns the name of the field [f]. *) val addr : ((_, _) structured as 's) -> 's ptr (** [addr s] returns the address of the structure or union [s]. *) (** {3 Coercions} *) val coerce : 'a typ -> 'b typ -> 'a -> 'b (** [coerce t1 t2] returns a coercion function between the types represented by [t1] and [t2]. If [t1] cannot be coerced to [t2], [coerce] raises {!Uncoercible}. The following coercions are currently supported: - All function and object pointer types are intercoercible. - Any type may be coerced to {!void} - There is a coercion between a {!view} and another type [t] (in either direction) if there is a coercion between the representation type underlying the view and [t]. - Coercion is transitive: if [t1] is coercible to [t2] and [t2] is coercible to [t3], then [t1] is directly coercible to [t3]. The set of supported coercions is subject to change. Future versions of ctypes may both add new types of coercion and restrict the existing coercions. *) val coerce_fn : 'a fn -> 'b fn -> 'a -> 'b (** [coerce_fn f1 f2] returns a coercion function between the function types represented by [f1] and [f2]. If [f1] cannot be coerced to [f2], [coerce_fn] raises {!Uncoercible}. A function type [f1] may be coerced to another function type [f2] if all of the following hold: - the C types described by [f1] and [f2] have the same arity - each argument of [f2] may be coerced to the corresponding argument of [f1] - the return type of [f1] may be coerced to the return type of [f2] The set of supported coercions is subject to change. Future versions of ctypes may both add new types of coercion and restrict the existing coercions. *) (** {2:roots Registration of OCaml values as roots} *) module Root : sig val create : 'a -> unit ptr (** [create v] allocates storage for the address of the OCaml value [v], registers the storage as a root, and returns its address. *) val get : unit ptr -> 'a (** [get p] retrieves the OCaml value whose address is stored at [p]. *) val set : unit ptr -> 'a -> unit (** [set p v] updates the OCaml value stored as a root at [p]. *) val release : unit ptr -> unit (** [release p] unregsiters the root [p]. *) end (** {2 Exceptions} *) exception Unsupported of string (** An attempt was made to use a feature not currently supported by ctypes. In practice this refers to attempts to use an union, array or abstract type as an argument or return type of a function. *) exception ModifyingSealedType of string (** An attempt was made to modify a sealed struct or union type description. *) exception IncompleteType (** An attempt was made to compute the size or alignment of an incomplete type. The incomplete types are struct and union types that have not been sealed, and the void type. It is not permitted to compute the size or alignment requirements of an incomplete type, to use it as a struct or union member, to read or write a value of the type through a pointer or to use it as the referenced type in pointer arithmetic. Additionally, incomplete struct and union types cannot be used as argument or return types. *) type uncoercible_info exception Uncoercible of uncoercible_info (** An attempt was made to coerce between uncoercible types. *) ocaml-ctypes-0.7.0/src/ctypes/ctypes_bigarray.ml000066400000000000000000000111131274143137600217420ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes_bigarray_stubs let prim_of_kind : type a. a kind -> a Ctypes_primitive_types.prim = let open Ctypes_primitive_types in function Kind_float32 -> Float | Kind_float64 -> Double | Kind_int8_signed -> Int8_t | Kind_int8_unsigned -> Int8_t | Kind_int16_signed -> Int16_t | Kind_int16_unsigned -> Int16_t | Kind_int32 -> Int32_t | Kind_int64 -> Int64_t | Kind_int -> Camlint | Kind_nativeint -> Nativeint | Kind_complex32 -> Complex32 | Kind_complex64 -> Complex64 | Kind_char -> Char let bigarray_kind_sizeof k = Ctypes_primitives.sizeof (prim_of_kind k) let bigarray_kind_alignment k = Ctypes_primitives.alignment (prim_of_kind k) type (_, _) dims = | DimsGen : int array -> ('a, ('a, _, 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 element_type (_, k) = prim_of_kind k let dimensions : type a b. (b, a) t -> int array = function | DimsGen dims, _ -> dims | Dims1 x, _ -> [| x |] | Dims2 (x, y), _ -> [| x; y |] | Dims3 (x, y, z), _ -> [| x; y; z |] let sizeof (d, k) = elements d * bigarray_kind_sizeof k let alignment (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 path_of_string = Ctypes_path.path_of_string let type_name : type a b. (b, a) dims -> Ctypes_path.path = function | DimsGen _ -> path_of_string "Bigarray.Genarray.t" | Dims1 _ -> path_of_string "Bigarray.Array1.t" | Dims2 _ -> path_of_string "Bigarray.Array2.t" | Dims3 _ -> path_of_string "Bigarray.Array3.t" let kind_type_names : type a. a kind -> _ = function | Kind_float32 -> (`Ident (path_of_string "float"), `Ident (path_of_string "Bigarray.float32_elt")) | Kind_float64 -> (`Ident (path_of_string "float"), `Ident (path_of_string "Bigarray.float64_elt")) | Kind_int8_signed -> (`Ident (path_of_string "int"), `Ident (path_of_string "Bigarray.int8_signed_elt")) | Kind_int8_unsigned -> (`Ident (path_of_string "int"), `Ident (path_of_string "Bigarray.int8_unsigned_elt")) | Kind_int16_signed -> (`Ident (path_of_string "int"), `Ident (path_of_string "Bigarray.int16_signed_elt")) | Kind_int16_unsigned -> (`Ident (path_of_string "int"), `Ident (path_of_string "Bigarray.int16_unsigned_elt")) | Kind_int32 -> (`Ident (path_of_string "int32"), `Ident (path_of_string "Bigarray.int32_elt")) | Kind_int64 -> (`Ident (path_of_string "int64"), `Ident (path_of_string "Bigarray.int64_elt")) | Kind_int -> (`Ident (path_of_string "int"), `Ident (path_of_string "Bigarray.int_elt")) | Kind_nativeint -> (`Ident (path_of_string "nativeint"), `Ident (path_of_string "Bigarray.nativeint_elt")) | Kind_complex32 -> (`Ident (path_of_string "Complex.t"), `Ident (path_of_string "Bigarray.complex32_elt")) | Kind_complex64 -> (`Ident (path_of_string "Complex.t"), `Ident (path_of_string "Bigarray.complex64_elt")) | Kind_char -> (`Ident (path_of_string "char"), `Ident (path_of_string "Bigarray.int8_unsigned_elt")) let type_expression : type a b. (a, b) t -> _ = fun (t, ck) -> begin let a, b = kind_type_names ck in let layout = `Ident (path_of_string "Bigarray.c_layout") in (`Appl (type_name t, [a; b; layout]) : [> `Ident of Ctypes_path.path | `Appl of Ctypes_path.path * 'a list ] as 'a) end let prim_of_kind k = prim_of_kind (kind k) let unsafe_address b = Ctypes_bigarray_stubs.address b let view : type a b. (a, b) t -> _ Ctypes_ptr.Fat.t -> b = let open Ctypes_bigarray_stubs in fun (dims, kind) ptr -> let ba : b = match dims with | DimsGen ds -> view kind ~dims:ds ptr | Dims1 d -> view1 kind ~dims:[| d |] ptr | Dims2 (d1, d2) -> view2 kind ~dims:[| d1; d2 |] ptr | Dims3 (d1, d2, d3) -> view3 kind ~dims:[| d1; d2; d3 |] ptr in match Ctypes_ptr.Fat.managed ptr with | None -> ba | Some src -> Gc.finalise (fun _ -> Ctypes_memory_stubs.use_value src) ba; ba ocaml-ctypes-0.7.0/src/ctypes/ctypes_bigarray.mli000066400000000000000000000046201274143137600221200ustar00rootroot00000000000000(* * 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]. *) (** {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 Ctypes_primitive_types.prim (** Create a {!Ctypes_ptr.Types.ctype} for a {!Bigarray.kind}. *) (** {3 Type eliminators *) val sizeof : (_, _) t -> int (** Compute the size of a bigarray type. *) val alignment : (_, _) t -> int (** Compute the alignment of a bigarray type. *) val element_type : ('a, _) t -> 'a Ctypes_primitive_types.prim (** Compute the element type of a bigarray type. *) val dimensions : (_, _) t -> int array (** Compute the dimensions of a bigarray type. *) val type_expression : ('a, 'b) t -> ([> `Appl of Ctypes_path.path * 'c list | `Ident of Ctypes_path.path ] as 'c) (** Compute a type expression that denotes a bigarray type. *) (** {2 Values *) val unsafe_address : 'a -> Ctypes_ptr.voidp (** Return the address of a bigarray value. This function is unsafe because it dissociates the raw address of the C array from the OCaml object that manages the lifetime of the array. If the caller does not hold a reference to the OCaml object then the array might be freed, invalidating the address. *) val view : (_, 'a) t -> _ Ctypes_ptr.Fat.t -> 'a (** [view b ptr] creates a bigarray view onto existing memory. If [ptr] references an OCaml object then [view] will ensure that that object is not collected before the bigarray returned by [view]. *) ocaml-ctypes-0.7.0/src/ctypes/ctypes_bigarray_stubs.ml000066400000000000000000000032421274143137600231660ustar00rootroot00000000000000(* * 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. In OCaml <= 4.01.0, Bigarray.char and Bigarray.int8_unsigned are indistinguishable, so the 'kind' function will never return Kind_char. OCaml 4.02.0 gives the types distinct representations. *) = "%identity" external address : 'b -> Ctypes_ptr.voidp = "ctypes_bigarray_address" external view : 'a kind -> dims:int array -> _ Ctypes_ptr.Fat.t -> ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t = "ctypes_bigarray_view" external view1 : 'a kind -> dims:int array -> _ Ctypes_ptr.Fat.t -> ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t = "ctypes_bigarray_view" external view2 : 'a kind -> dims:int array -> _ Ctypes_ptr.Fat.t -> ('a, 'b, Bigarray.c_layout) Bigarray.Array2.t = "ctypes_bigarray_view" external view3 : 'a kind -> dims:int array -> _ Ctypes_ptr.Fat.t -> ('a, 'b, Bigarray.c_layout) Bigarray.Array3.t = "ctypes_bigarray_view" ocaml-ctypes-0.7.0/src/ctypes/ctypes_bigarrays.c000066400000000000000000000015631274143137600217470ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #include #include #include "ctypes_raw_pointer.h" /* address : 'b -> pointer */ value ctypes_bigarray_address(value ba) { return CTYPES_FROM_PTR(Caml_ba_data_val(ba)); } /* _view : ('a, 'b) kind -> dims:int array -> fatptr -> ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t */ value ctypes_bigarray_view(value kind_, value dims_, value ptr_) { int kind = Int_val(kind_); int ndims = Wosize_val(dims_); 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 = CTYPES_ADDR_OF_FATPTR(ptr_); return caml_ba_alloc(flags, ndims, data, dims); } ocaml-ctypes-0.7.0/src/ctypes/ctypes_coerce.ml000066400000000000000000000104311274143137600214040ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Coercions *) open Ctypes_static type uncoercible_info = Types : _ typ * _ typ -> uncoercible_info | Functions : _ fn * _ fn -> uncoercible_info exception Uncoercible of uncoercible_info let show_uncoercible = function Uncoercible (Types (l, r)) -> let pr ty = Ctypes_type_printing.string_of_typ ty in Some (Format.sprintf "Coercion failure: %s is not coercible to %s" (pr l) (pr r)) | Uncoercible (Functions (l, r)) -> let pr ty = Ctypes_type_printing.string_of_fn ty in Some (Format.sprintf "Coercion failure: %s is not coercible to %s" (pr l) (pr r)) | _ -> None let () = Printexc.register_printer show_uncoercible let uncoercible : 'a 'b 'c. 'a typ -> 'b typ -> 'c = fun l r -> raise (Uncoercible (Types (l, r))) let uncoercible_functions : 'a 'b 'c. 'a fn -> 'b fn -> 'c = fun l r -> raise (Uncoercible (Functions (l, r))) let id x = x type (_, _) coercion = | Id : ('a, 'a) coercion | Coercion : ('a -> 'b) -> ('a, 'b) coercion let ml_prim_coercion : type a b. a Ctypes_primitive_types.ml_prim -> b Ctypes_primitive_types.ml_prim -> (a, b) coercion option = let open Ctypes_primitive_types in fun l r -> match l, r with | ML_char, ML_char -> Some Id | ML_complex, ML_complex -> Some Id | ML_float, ML_float -> Some Id | ML_int, ML_int -> Some Id | ML_int32, ML_int32 -> Some Id | ML_int64, ML_int64 -> Some Id | ML_llong, ML_llong -> Some Id | ML_long, ML_long -> Some Id | ML_nativeint, ML_nativeint -> Some Id | ML_size_t, ML_size_t -> Some Id | ML_uchar, ML_uchar -> Some Id | ML_bool, ML_bool -> Some Id | ML_uint, ML_uint -> Some Id | ML_uint16, ML_uint16 -> Some Id | ML_uint32, ML_uint32 -> Some Id | ML_uint64, ML_uint64 -> Some Id | ML_uint8, ML_uint8 -> Some Id | ML_ullong, ML_ullong -> Some Id | ML_ulong, ML_ulong -> Some Id | ML_ushort, ML_ushort -> Some Id | l, r -> None let rec coercion : type a b. a typ -> b typ -> (a, b) coercion = fun atyp btyp -> match atyp, btyp with | _, Void -> Coercion ignore | Primitive l, Primitive r -> (match Ctypes_primitive_types.(ml_prim_coercion (ml_prim l) (ml_prim r)) with Some c -> c | None -> uncoercible atyp btyp) | View av, b -> begin match coercion av.ty b with | Id -> Coercion av.write | Coercion coerce -> Coercion (fun v -> coerce (av.write v)) end | a, View bv -> begin match coercion a bv.ty with | Id -> Coercion bv.read | Coercion coerce -> Coercion (fun v -> bv.read (coerce v)) end | Pointer a, Pointer b -> begin try begin match coercion a b with | Id -> Id | Coercion _ -> Coercion (fun (CPointer p) -> CPointer (Ctypes_ptr.Fat.coerce p b)) end with Uncoercible _ -> Coercion (fun (CPointer p) -> CPointer (Ctypes_ptr.Fat.coerce p b)) end | Pointer a, Funptr b -> Coercion (fun (CPointer p) -> Static_funptr (Ctypes_ptr.Fat.coerce p b)) | Funptr a, Pointer b -> Coercion (fun (Static_funptr p) -> CPointer (Ctypes_ptr.Fat.coerce p b)) | Funptr a, Funptr b -> begin try begin match fn_coercion a b with | Id -> Id | Coercion _ -> Coercion (fun (Static_funptr p) -> Static_funptr (Ctypes_ptr.Fat.coerce p b)) end with Uncoercible _ -> Coercion (fun (Static_funptr p) -> Static_funptr (Ctypes_ptr.Fat.coerce p b)) end | l, r -> uncoercible l r and fn_coercion : type a b. a fn -> b fn -> (a, b) coercion = fun afn bfn -> match afn, bfn with | Function (af, at), Function (bf, bt) -> begin match coercion bf af, fn_coercion at bt with | Id, Id -> Id | Id, Coercion h -> Coercion (fun g x -> h (g x)) | Coercion f, Id -> Coercion (fun g x -> g (f x)) | Coercion f, Coercion h -> Coercion (fun g x -> h (g (f x))) end | Returns at, Returns bt -> coercion at bt | l, r -> uncoercible_functions l r let coerce : type a b. a typ -> b typ -> a -> b = fun atyp btyp -> match coercion atyp btyp with | Id -> id | Coercion c -> c let coerce_fn : type a b. a fn -> b fn -> a -> b = fun afn bfn -> match fn_coercion afn bfn with | Id -> id | Coercion c -> c ocaml-ctypes-0.7.0/src/ctypes/ctypes_complex_stubs.h000066400000000000000000000013451274143137600226560ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef CTYPES_COMPLEX_STUBS_H #define CTYPES_COMPLEX_STUBS_H #include #include /* ctypes_copy_float_complex : float complex -> Complex.t */ value ctypes_copy_float_complex(float complex); /* ctypes_copy_double_complex : double complex -> Complex.t */ value ctypes_copy_double_complex(double complex); /* ctypes_float_complex_val : Complex.t -> float complex */ float complex ctypes_float_complex_val(value); /* ctypes_double_complex_val : Complex.t -> double complex */ double complex ctypes_double_complex_val(value); #endif /* CTYPES_COMPLEX_STUBS_H */ ocaml-ctypes-0.7.0/src/ctypes/ctypes_cstubs_internals.h000066400000000000000000000016201274143137600233450ustar00rootroot00000000000000/* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef CTYPES_CSTUBS_INTERNALS_H #define CTYPES_CSTUBS_INTERNALS_H /* Types and functions used by generated C code. */ #include "ctypes_primitives.h" #include "ctypes_complex_stubs.h" #include "ctypes_raw_pointer.h" #include "ctypes_managed_buffer_stubs.h" #include #define CTYPES_PTR_OF_OCAML_STRING(s) \ (String_val(Field(s, 1)) + Int_val(Field(s, 0))) #define Ctypes_val_char(c) \ (Val_int((c + 256) % 256)) #define CTYPES_PAIR_WITH_ERRNO(v) #include #include static inline value ctypes_pair_with_errno(value p) { CAMLparam1 (p); CAMLlocal1 (v); v = caml_alloc_tuple(2); Store_field (v, 0, p); Store_field (v, 1, ctypes_copy_sint(errno)); CAMLreturn (v); } #endif /* CTYPES_CSTUBS_INTERNALS_H */ ocaml-ctypes-0.7.0/src/ctypes/ctypes_managed_buffer_stubs.h000066400000000000000000000012451274143137600241330ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef CTYPES_MANAGED_BUFFER_STUBS_H #define CTYPES_MANAGED_BUFFER_STUBS_H #include /* copy_bytes : void * -> size_t -> managed_buffer */ extern value ctypes_copy_bytes(void *, size_t); /* allocate : int -> int -> managed_buffer */ extern value ctypes_allocate(value count, value size); /* block_address : managed_buffer -> immediate_pointer */ extern value ctypes_block_address(value managed_buffer); /* CTYPES_FROM_FAT_PTR : _ Ctypes_ptr.Fat.t -> void * */ #endif /* CTYPES_MANAGED_BUFFER_STUBS_H */ ocaml-ctypes-0.7.0/src/ctypes/ctypes_memory.ml000066400000000000000000000257071274143137600214700ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes_static module Stubs = Ctypes_memory_stubs module Raw = Ctypes_ptr.Raw module Fat = Ctypes_ptr.Fat let castp reftype (CPointer p) = CPointer (Fat.coerce p reftype) (* Describes how to read a value, e.g. from a return buffer *) let rec build : type a b. a typ -> b typ Fat.t -> a = function | Void -> fun _ -> () | Primitive p -> Stubs.read p | Struct { spec = Incomplete _ } -> raise IncompleteType | Struct { spec = Complete { size } } as reftyp -> (fun buf -> let managed = Stubs.allocate 1 size in let dst = Fat.make ~managed ~reftyp (Stubs.block_address managed) in let () = Stubs.memcpy ~size ~dst ~src:buf in { structured = CPointer dst}) | Pointer reftyp -> (fun buf -> CPointer (Fat.make ~reftyp (Stubs.Pointer.read buf))) | Funptr fn -> (fun buf -> Static_funptr (Fat.make ~reftyp:fn (Stubs.Pointer.read buf))) | View { read; ty } -> let buildty = build ty in (fun buf -> read (buildty buf)) | OCaml _ -> (fun buf -> assert false) (* The following cases should never happen; non-struct aggregate types are excluded during type construction. *) | Union _ -> assert false | Array _ -> assert false | Bigarray _ -> assert false | Abstract _ -> assert false let rec write : type a b. a typ -> a -> b Fat.t -> unit = let write_aggregate size { structured = CPointer src } dst = Stubs.memcpy ~size ~dst ~src in function | Void -> (fun _ _ -> ()) | Primitive p -> Stubs.write p | Pointer _ -> (fun (CPointer p) dst -> Stubs.Pointer.write p dst) | Funptr _ -> (fun (Static_funptr p) dst -> Stubs.Pointer.write p dst) | Struct { spec = Incomplete _ } -> raise IncompleteType | Struct { spec = Complete _ } as s -> write_aggregate (sizeof s) | Union { uspec = None } -> raise IncompleteType | Union { uspec = Some { size } } -> write_aggregate size | Abstract { asize } -> write_aggregate asize | Array _ as a -> let size = sizeof a in (fun { astart = CPointer src } dst -> Stubs.memcpy ~size ~dst ~src) | Bigarray b as t -> let size = sizeof t in (fun ba dst -> let src = Fat.make ~managed:ba ~reftyp:Void (Ctypes_bigarray.unsafe_address ba) in Stubs.memcpy ~size ~dst ~src) | View { write = w; ty } -> let writety = write ty in (fun v -> writety (w v)) | OCaml _ -> raise IncompleteType let null : unit ptr = CPointer (Fat.make ~reftyp:Void Raw.null) let rec (!@) : type a. a ptr -> a = fun (CPointer cptr as ptr) -> match Fat.reftype cptr with | Void -> raise IncompleteType | Union { uspec = None } -> raise IncompleteType | Struct { spec = Incomplete _ } -> raise IncompleteType | View { read; ty } -> read (!@ (CPointer (Fat.coerce cptr ty))) (* If it's a reference type then we take a reference *) | Union _ -> { structured = ptr } | Struct _ -> { structured = ptr } | Array (elemtype, alength) -> { astart = CPointer (Fat.coerce cptr elemtype); alength } | Bigarray b -> Ctypes_bigarray.view b cptr | Abstract _ -> { structured = ptr } | OCaml _ -> raise IncompleteType (* If it's a value type then we cons a new value. *) | _ -> build (Fat.reftype cptr) cptr let ptr_diff : type a b. (a, b) pointer -> (a, b) pointer -> int = fun l r -> match l, r with | CPointer lp, CPointer rp -> (* We assume the pointers are properly aligned, or at least that the difference is a multiple of sizeof reftype. *) Fat.diff_bytes lp rp / sizeof (Fat.reftype lp) | OCamlRef (lo, l, _), OCamlRef (ro, r, _) -> if l != r then invalid_arg "Ctypes.ptr_diff"; ro - lo let (+@) : type a b. (a, b) pointer -> int -> (a, b) pointer = fun p x -> match p with | CPointer p -> CPointer (Fat.add_bytes p (x * sizeof (Fat.reftype p))) | OCamlRef (offset, obj, ty) -> OCamlRef (offset + x, obj, ty) let (-@) p x = p +@ (-x) let (<-@) : type a. a ptr -> a -> unit = fun (CPointer p) -> fun v -> write (Fat.reftype p) v p let from_voidp = castp let to_voidp p = castp Void p let allocate_n : type a. ?finalise:(a ptr -> unit) -> a typ -> count:int -> a ptr = fun ?finalise reftyp ~count -> let package p = CPointer (Fat.make ~managed:p ~reftyp (Stubs.block_address p)) in let finalise = match finalise with | Some f -> Gc.finalise (fun p -> f (package p)) | None -> ignore in let p = Stubs.allocate count (sizeof reftyp) in begin finalise p; package p end let allocate : type a. ?finalise:(a ptr -> unit) -> a typ -> a -> a ptr = fun ?finalise reftype v -> let p = allocate_n ?finalise ~count:1 reftype in begin p <-@ v; p end let ptr_compare (CPointer l) (CPointer r) = Fat.(compare l r) let reference_type (CPointer p) = Fat.reftype p let ptr_of_raw_address addr = CPointer (Fat.make ~reftyp:Void (Raw.of_nativeint addr)) let funptr_of_raw_address addr = Static_funptr (Fat.make ~reftyp:(void @-> returning void) (Raw.of_nativeint addr)) let raw_address_of_ptr (CPointer p) = (* This is unsafe by definition: if the object to which [p] refers is collected at this point then the returned address is invalid. If there is an OCaml object associated with [p] then it is vital that the caller retains a reference to it. *) Raw.to_nativeint (Fat.unsafe_raw_addr p) module CArray = struct type 'a t = 'a carray let check_bound { alength } i = if i >= 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 (|->) (CPointer p) { ftype; foffset } = CPointer (Fat.(add_bytes (Fat.coerce p ftype) foffset)) let (@.) { structured = p } f = p |-> f let setf s field v = (s @. field) <-@ v let getf s field = !@(s @. field) let addr { structured } = structured open Bigarray let _bigarray_start kind ba = let raw_address = Ctypes_bigarray.unsafe_address ba in let reftyp = Primitive (Ctypes_bigarray.prim_of_kind kind) in CPointer (Fat.make ~managed:ba ~reftyp raw_address) let bigarray_kind : type a b c d f. < element: a; ba_repr: f; bigarray: b; carray: c; dims: d > bigarray_class -> b -> (a, f) Bigarray.kind = function | Genarray -> Genarray.kind | Array1 -> Array1.kind | Array2 -> Array2.kind | Array3 -> Array3.kind let bigarray_start spec ba = _bigarray_start (bigarray_kind spec ba) ba let array_of_bigarray : type a b c d e. < element: a; ba_repr: e; bigarray: b; carray: c; dims: d > bigarray_class -> b -> c = fun spec ba -> let CPointer p as element_ptr = bigarray_start spec ba in match spec with | Genarray -> let ds = Genarray.dims ba in CArray.from_ptr element_ptr (Array.fold_left ( * ) 1 ds) | Array1 -> let d = Array1.dim ba in CArray.from_ptr element_ptr d | Array2 -> let d1 = Array2.dim1 ba and d2 = Array2.dim2 ba in CArray.from_ptr (castp (array d2 (Fat.reftype p)) element_ptr) d1 | Array3 -> let d1 = Array3.dim1 ba and d2 = Array3.dim2 ba and d3 = Array3.dim3 ba in CArray.from_ptr (castp (array d2 (array d3 (Fat.reftype p))) element_ptr) d1 let bigarray_elements : type a b c d f. < element: a; ba_repr: f; bigarray: b; carray: c; dims: d > bigarray_class -> d -> int = fun spec dims -> match spec, dims with | Genarray, ds -> Array.fold_left ( * ) 1 ds | Array1, d -> d | Array2, (d1, d2) -> d1 * d2 | Array3, (d1, d2, d3) -> d1 * d2 * d3 let bigarray_of_ptr spec dims kind ptr = !@ (castp (bigarray spec dims kind) ptr) let array_dims : type a b c d f. < element: a; ba_repr: f; bigarray: b; carray: c carray; dims: d > bigarray_class -> c carray -> d = let unsupported () = raise (Unsupported "taking dimensions of non-array type") in fun spec a -> match spec with | Genarray -> [| a.alength |] | Array1 -> a.alength | Array2 -> begin match a.astart with | CPointer p -> begin match Fat.reftype p with | Array (_, n) -> (a.alength, n) | _ -> unsupported () end | _ -> unsupported () end | Array3 -> begin match a.astart with | CPointer p -> begin match Fat.reftype p with | Array (Array (_, m), n) -> (a.alength, n, m) | _ -> unsupported () end | _ -> unsupported () end let bigarray_of_array spec kind a = let dims = array_dims spec a in !@ (castp (bigarray spec dims kind) (CArray.start a)) let genarray = Genarray let array1 = Array1 let array2 = Array2 let array3 = Array3 let typ_of_bigarray_kind k = Primitive (Ctypes_bigarray.prim_of_kind k) let string_from_ptr (CPointer p) ~length:len = if len < 0 then invalid_arg "Ctypes.string_from_ptr" else Stubs.string_of_array p ~len let ocaml_string_start str = OCamlRef (0, str, String) let ocaml_bytes_start str = OCamlRef (0, str, Bytes) let ocaml_float_array_start arr = OCamlRef (0, arr, FloatArray) module Root = struct module Stubs = Ctypes_roots_stubs (* Roots are not managed values so it's safe to call unsafe_raw_addr. *) let raw_addr : unit ptr -> Raw.t = fun (CPointer p) -> Fat.unsafe_raw_addr p let create : 'a. 'a -> unit ptr = fun v -> CPointer (Fat.make ~reftyp:void (Stubs.root v)) let get : 'a. unit ptr -> 'a = fun p -> Stubs.get (raw_addr p) let set : 'a. unit ptr -> 'a -> unit = fun p v -> Stubs.set (raw_addr p) v let release : 'a. unit ptr -> unit = fun p -> Stubs.release (raw_addr p) end let is_null (CPointer p) = Fat.is_null p ocaml-ctypes-0.7.0/src/ctypes/ctypes_memory_stubs.ml000066400000000000000000000026131274143137600226770ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stubs for reading and writing memory. *) open Ctypes_ptr (* A reference, managed by the garbage collector, to a region of memory in the C heap. *) type managed_buffer (* Allocate a region of stable, zeroed memory managed by a custom block. *) external allocate : int -> int -> managed_buffer = "ctypes_allocate" (* Obtain the address of the managed block. *) external block_address : managed_buffer -> voidp = "ctypes_block_address" (* Read a C value from a block of memory *) external read : 'a Ctypes_primitive_types.prim -> _ Fat.t -> 'a = "ctypes_read" (* Write a C value to a block of memory *) external write : 'a Ctypes_primitive_types.prim -> 'a -> _ Fat.t -> unit = "ctypes_write" module Pointer = struct external read : _ Fat.t -> voidp = "ctypes_read_pointer" external write : _ Fat.t -> _ Fat.t -> unit = "ctypes_write_pointer" end (* Copy [size] bytes from [src] to [dst]. *) external memcpy : dst:_ Fat.t -> src:_ Fat.t -> size:int -> unit = "ctypes_memcpy" (* Read a fixed length OCaml string from memory *) external string_of_array : _ Fat.t -> len:int -> string = "ctypes_string_of_array" (* Do nothing, concealing from the optimizer that nothing is being done. *) external use_value : 'a -> unit = "ctypes_use" ocaml-ctypes-0.7.0/src/ctypes/ctypes_path.ml000066400000000000000000000012761274143137600211070ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Paths (long identifiers) *) type path = string list let is_uident s = Str.(string_match (regexp "[A-Z][a-zA-Z0-9_]*") s 0);; let is_ident s = Str.(string_match (regexp "[A-Za-z_][a-zA-Z0-9_]*") s 0);; let rec is_valid_path = function | [] -> false | [l] -> is_ident l | u :: p -> is_uident u && is_valid_path p let path_of_string s = let p = Str.(split (regexp_string ".") s) in if is_valid_path p then p else invalid_arg "Ctypes_ident.path_of_string" let format_path fmt p = Format.pp_print_string fmt (String.concat "." p) ocaml-ctypes-0.7.0/src/ctypes/ctypes_path.mli000066400000000000000000000004351274143137600212540ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Value paths (long identifiers) *) type path val path_of_string : string -> path val format_path : Format.formatter -> path -> unit ocaml-ctypes-0.7.0/src/ctypes/ctypes_primitive_types.ml000066400000000000000000000042201274143137600233770ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Unsigned open Signed type _ prim = | Char : char prim | Schar : int prim | Uchar : uchar prim | Bool : bool prim | Short : int prim | Int : int prim | Long : long prim | Llong : llong prim | Ushort : ushort prim | Sint : sint prim | Uint : uint prim | Ulong : ulong prim | Ullong : ullong prim | Size_t : size_t prim | Int8_t : int prim | Int16_t : int prim | Int32_t : int32 prim | Int64_t : int64 prim | Uint8_t : uint8 prim | Uint16_t : uint16 prim | Uint32_t : uint32 prim | Uint64_t : uint64 prim | Camlint : int prim | Nativeint : nativeint prim | Float : float prim | Double : float prim | Complex32 : Complex.t prim | Complex64 : Complex.t prim type _ ml_prim = | ML_char : char ml_prim | ML_complex : Complex.t ml_prim | ML_float : float ml_prim | ML_int : int ml_prim | ML_int32 : int32 ml_prim | ML_int64 : int64 ml_prim | ML_llong : llong ml_prim | ML_long : long ml_prim | ML_sint : sint ml_prim | ML_nativeint : nativeint ml_prim | ML_size_t : size_t ml_prim | ML_uchar : uchar ml_prim | ML_bool : bool ml_prim | ML_uint : uint ml_prim | ML_uint16 : uint16 ml_prim | ML_uint32 : uint32 ml_prim | ML_uint64 : uint64 ml_prim | ML_uint8 : uint8 ml_prim | ML_ullong : ullong ml_prim | ML_ulong : ulong ml_prim | ML_ushort : ushort ml_prim let ml_prim : type a. a prim -> a ml_prim = function | Char -> ML_char | Schar -> ML_int | Uchar -> ML_uchar | Bool -> ML_bool | Short -> ML_int | Int -> ML_int | Long -> ML_long | Llong -> ML_llong | Ushort -> ML_ushort | Sint -> ML_sint | Uint -> ML_uint | Ulong -> ML_ulong | Ullong -> ML_ullong | Size_t -> ML_size_t | Int8_t -> ML_int | Int16_t -> ML_int | Int32_t -> ML_int32 | Int64_t -> ML_int64 | Uint8_t -> ML_uint8 | Uint16_t -> ML_uint16 | Uint32_t -> ML_uint32 | Uint64_t -> ML_uint64 | Camlint -> ML_int | Nativeint -> ML_nativeint | Float -> ML_float | Double -> ML_float | Complex32 -> ML_complex | Complex64 -> ML_complex ocaml-ctypes-0.7.0/src/ctypes/ctypes_primitive_types.mli000066400000000000000000000031321274143137600235510ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Representation of primitive C types. Internal representation, not for public use. *) open Unsigned open Signed type _ prim = | Char : char prim | Schar : int prim | Uchar : uchar prim | Bool : bool prim | Short : int prim | Int : int prim | Long : long prim | Llong : llong prim | Ushort : ushort prim | Sint : sint prim | Uint : uint prim | Ulong : ulong prim | Ullong : ullong prim | Size_t : size_t prim | Int8_t : int prim | Int16_t : int prim | Int32_t : int32 prim | Int64_t : int64 prim | Uint8_t : uint8 prim | Uint16_t : uint16 prim | Uint32_t : uint32 prim | Uint64_t : uint64 prim | Camlint : int prim | Nativeint : nativeint prim | Float : float prim | Double : float prim | Complex32 : Complex.t prim | Complex64 : Complex.t prim type _ ml_prim = | ML_char : char ml_prim | ML_complex : Complex.t ml_prim | ML_float : float ml_prim | ML_int : int ml_prim | ML_int32 : int32 ml_prim | ML_int64 : int64 ml_prim | ML_llong : llong ml_prim | ML_long : long ml_prim | ML_sint : sint ml_prim | ML_nativeint : nativeint ml_prim | ML_size_t : size_t ml_prim | ML_uchar : uchar ml_prim | ML_bool : bool ml_prim | ML_uint : uint ml_prim | ML_uint16 : uint16 ml_prim | ML_uint32 : uint32 ml_prim | ML_uint64 : uint64 ml_prim | ML_uint8 : uint8 ml_prim | ML_ullong : ullong ml_prim | ML_ulong : ulong ml_prim | ML_ushort : ushort ml_prim val ml_prim : 'a prim -> 'a ml_prim ocaml-ctypes-0.7.0/src/ctypes/ctypes_primitives.h000066400000000000000000000132621274143137600221630ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef CTYPES_PRIMITIVES_H #define CTYPES_PRIMITIVES_H #include #include #include #include "ctypes_unsigned_stubs.h" /* The order here must correspond to the constructor order in primitives.ml */ enum ctypes_primitive { Ctypes_Char, Ctypes_Schar, Ctypes_Uchar, Ctypes_Bool, Ctypes_Short, Ctypes_Int, Ctypes_Long, Ctypes_Llong, Ctypes_Ushort, Ctypes_Sint, Ctypes_Uint, Ctypes_Ulong, Ctypes_Ullong, Ctypes_Size_t, Ctypes_Int8_t, Ctypes_Int16_t, Ctypes_Int32_t, Ctypes_Int64_t, Ctypes_Uint8_t, Ctypes_Uint16_t, Ctypes_Uint32_t, Ctypes_Uint64_t, Ctypes_Camlint, Ctypes_Nativeint, Ctypes_Float, Ctypes_Double, Ctypes_Complex32, Ctypes_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 #error "No suitable OCaml type available for representing signed int values" #define ctypes_uint_val Uint16_val #define ctypes_copy_uint ctypes_copy_uint16 #elif UINT_MAX == UINT32_MAX #define ctypes_sint_val Int32_val #define ctypes_uint_val Uint32_val #define ctypes_copy_sint caml_copy_int32 #define ctypes_copy_uint ctypes_copy_uint32 #elif UINT_MAX == UINT64_MAX #define ctypes_sint_val Int64_val #define ctypes_uint_val Uint64_val #define ctypes_copy_sint caml_copy_int64 #define ctypes_copy_uint ctypes_copy_uint64 #else # error "No suitable OCaml type available for representing unsigned int values" #endif /* long is at least 32 bits. */ #if ULONG_MAX == UINT32_MAX #define ctypes_long_val Int32_val #define ctypes_ulong_val Uint32_val #define ctypes_copy_long caml_copy_int32 #define ctypes_copy_ulong 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 64 bits. */ #if ULLONG_MAX == UINT64_MAX #define ctypes_llong_val Int64_val #define ctypes_ullong_val Uint64_val #define ctypes_copy_llong caml_copy_int64 #define ctypes_copy_ullong 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 /* Detection of arithmetic types */ enum ctypes_arithmetic_type { Ctypes_arith_Int8, Ctypes_arith_Int16, Ctypes_arith_Int32, Ctypes_arith_Int64, Ctypes_arith_Uint8, Ctypes_arith_Uint16, Ctypes_arith_Uint32, Ctypes_arith_Uint64, Ctypes_arith_Float, Ctypes_arith_Double }; #define CTYPES_FLOATING_FLAG_BIT 15 #define CTYPES_UNSIGNED_FLAG_BIT 14 #define CTYPES_FLOATING ((size_t)1u << CTYPES_FLOATING_FLAG_BIT) #define CTYPES_UNSIGNED ((size_t)1u << CTYPES_UNSIGNED_FLAG_BIT) #define CTYPES_CHECK_FLOATING(TYPENAME) \ ((unsigned)(((TYPENAME) 0.5) != 0) << CTYPES_FLOATING_FLAG_BIT) #define CTYPES_CHECK_UNSIGNED(TYPENAME) \ ((unsigned)(((TYPENAME) -1) > 0) << CTYPES_UNSIGNED_FLAG_BIT) #define CTYPES_CLASSIFY(TYPENAME) (CTYPES_CHECK_FLOATING(TYPENAME) \ | CTYPES_CHECK_UNSIGNED(TYPENAME)) #define CTYPES_ARITHMETIC_TYPEINFO(TYPENAME) (CTYPES_CLASSIFY(TYPENAME) \ | sizeof(TYPENAME)) #define CTYPES_CLASSIFY_ARITHMETIC_TYPE(TYPENAME) \ ctypes_classify_arithmetic_type(CTYPES_ARITHMETIC_TYPEINFO(TYPENAME)) static inline enum ctypes_arithmetic_type ctypes_classify_arithmetic_type(size_t typeinfo) { switch (typeinfo) { case CTYPES_FLOATING | sizeof(float): return Ctypes_arith_Float; case CTYPES_FLOATING | sizeof(double): return Ctypes_arith_Double; case CTYPES_UNSIGNED | sizeof(uint8_t): return Ctypes_arith_Uint8; case CTYPES_UNSIGNED | sizeof(uint16_t): return Ctypes_arith_Uint16; case CTYPES_UNSIGNED | sizeof(uint32_t): return Ctypes_arith_Uint32; case CTYPES_UNSIGNED | sizeof(uint64_t): return Ctypes_arith_Uint64; case sizeof(int8_t): return Ctypes_arith_Int8; case sizeof(int16_t): return Ctypes_arith_Int16; case sizeof(int32_t): return Ctypes_arith_Int32; case sizeof(int64_t): return Ctypes_arith_Int64; default: assert(0); } } static inline const char *ctypes_arithmetic_type_name(enum ctypes_arithmetic_type t) { switch (t) { case Ctypes_arith_Int8: return "Int8"; case Ctypes_arith_Int16: return "Int16"; case Ctypes_arith_Int32: return "Int32"; case Ctypes_arith_Int64: return "Int64"; case Ctypes_arith_Uint8: return "Uint8"; case Ctypes_arith_Uint16: return "Uint16"; case Ctypes_arith_Uint32: return "Uint32"; case Ctypes_arith_Uint64: return "Uint64"; case Ctypes_arith_Float: return "Float"; case Ctypes_arith_Double: return "Double"; default: assert(0); } } #endif /* CTYPES_PRIMITIVES_H */ ocaml-ctypes-0.7.0/src/ctypes/ctypes_ptr.ml000066400000000000000000000047301274143137600207560ustar00rootroot00000000000000(* * 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 Raw : sig include Signed.S val null : t end = struct include Nativeint module Infix = struct 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 end let of_nativeint x = x let to_nativeint x = x let of_int64 = Int64.to_nativeint let to_int64 = Int64.of_nativeint let null = zero end type voidp = Raw.t module Fat : sig (** A fat pointer, which holds a reference to the reference type, the C memory location, and an OCaml object. *) type _ t (** [make ?managed ~reftyp raw] builds a fat pointer from the reference type [reftyp], the C memory location [raw], and (optionally) an OCaml value, [managed]. The [managed] argument may be used to manage the lifetime of the C object; a typical use it to attach a finaliser to [managed] which releases the memory associated with the C object whose address is stored in [raw_ptr]. *) val make : ?managed:_ -> reftyp:'typ -> voidp -> 'typ t val is_null : _ t -> bool val reftype : 'typ t -> 'typ val managed : _ t -> Obj.t option val coerce : _ t -> 'typ -> 'typ t (** Return the raw pointer address. The function is unsafe in the sense that it dissociates the address from the value which manages the memory, which may trigger associated finalisers, invalidating the address. *) val unsafe_raw_addr : _ t -> voidp val add_bytes : 'typ t -> int -> 'typ t val compare : 'typ t -> 'typ t -> int val diff_bytes : 'typ t -> 'typ t -> int end = struct type 'typ t = { reftyp : 'typ; raw : voidp; managed : Obj.t option; } let make ?managed ~reftyp raw = match managed with | None -> { reftyp; raw; managed = None } | Some v -> { reftyp; raw; managed = Some (Obj.repr v) } let is_null { raw } = Raw.(compare zero) raw = 0 let reftype { reftyp } = reftyp let managed { managed } = managed let coerce p reftyp = { p with reftyp } let unsafe_raw_addr { raw } = raw let add_bytes p bytes = { p with raw = Raw.(add p.raw (of_int bytes)) } let compare l r = Raw.compare l.raw r.raw let diff_bytes l r = Raw.(to_int (sub r.raw l.raw)) end ocaml-ctypes-0.7.0/src/ctypes/ctypes_raw_pointer.h000066400000000000000000000010651274143137600223170ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef CTYPES_RAW_POINTER_STUBS_H #define CTYPES_RAW_POINTER_STUBS_H #include #include #include #define CTYPES_FROM_PTR(P) caml_copy_nativeint((intptr_t)P) #define CTYPES_TO_PTR(I) ((void *)Nativeint_val(I)) /* CTYPES_ADDR_OF_FATPTR : _ Ctypes_ptr.Fat.t -> void * */ #define CTYPES_ADDR_OF_FATPTR(P) CTYPES_TO_PTR(Field(P, 1)) #endif /* CTYPES_RAW_POINTER_STUBS_H */ ocaml-ctypes-0.7.0/src/ctypes/ctypes_roots.c000066400000000000000000000014331274143137600211260ustar00rootroot00000000000000#include #include #include "ctypes_raw_pointer.h" /* 'a -> voidp */ value ctypes_caml_roots_create(value v) { value *p = caml_stat_alloc(sizeof *p); *p = v; caml_register_generational_global_root(p); return CTYPES_FROM_PTR(p); } /* voidp -> 'a -> unit */ value ctypes_caml_roots_set(value p_, value v) { value *p = CTYPES_TO_PTR(p_); caml_modify_generational_global_root(p, v); return Val_unit; } /* voidp -> 'a */ value ctypes_caml_roots_get(value p_) { value *p = CTYPES_TO_PTR(p_); return *p; } /* voidp -> unit */ value ctypes_caml_roots_release(value p_) { value *p = CTYPES_TO_PTR(p_); caml_remove_generational_global_root(p); caml_stat_free(p); return Val_unit; } /* 'a -> unit */ value ctypes_use(value v) { return v; } ocaml-ctypes-0.7.0/src/ctypes/ctypes_roots_stubs.ml000066400000000000000000000006661274143137600225430ustar00rootroot00000000000000(* * Copyright (c) 2015 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) external root : 'a -> Ctypes_ptr.voidp = "ctypes_caml_roots_create" external set : Ctypes_ptr.voidp -> 'a -> unit = "ctypes_caml_roots_set" external get : Ctypes_ptr.voidp -> 'a = "ctypes_caml_roots_get" external release : Ctypes_ptr.voidp -> unit = "ctypes_caml_roots_release" ocaml-ctypes-0.7.0/src/ctypes/ctypes_static.ml000066400000000000000000000216711274143137600214430ustar00rootroot00000000000000(* * 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 let unsupported fmt = Printf.ksprintf (fun s -> raise (Unsupported s)) fmt type incomplete_size = { mutable isize: int } type structured_spec = { size: int; align: int; } type 'a structspec = Incomplete of incomplete_size | Complete of structured_spec type abstract_type = { aname : string; asize : int; aalignment : int; } type _ ocaml_type = String : string ocaml_type | Bytes : Bytes.t ocaml_type | FloatArray : float array ocaml_type type _ typ = Void : unit typ | Primitive : 'a Ctypes_primitive_types.prim -> 'a typ | Pointer : 'a typ -> 'a ptr typ | Funptr : 'a fn -> 'a static_funptr typ | Struct : 'a structure_type -> 'a structure typ | Union : 'a union_type -> 'a union typ | Abstract : abstract_type -> 'a abstract typ | View : ('a, 'b) view -> 'a typ | Array : 'a typ * int -> 'a carray typ | Bigarray : (_, 'a) Ctypes_bigarray.t -> 'a typ | OCaml : 'a ocaml_type -> 'a ocaml typ and 'a carray = { astart : 'a ptr; alength : int } and ('a, 'kind) structured = { structured : ('a, 'kind) structured ptr } and 'a union = ('a, [`Union]) structured and 'a structure = ('a, [`Struct]) structured and 'a abstract = ('a, [`Abstract]) structured and (_, _) pointer = CPointer : 'a typ Ctypes_ptr.Fat.t -> ('a, [`C]) pointer | OCamlRef : int * 'a * 'a ocaml_type -> ('a, [`OCaml]) pointer and 'a ptr = ('a, [`C]) pointer and 'a ocaml = ('a, [`OCaml]) pointer and 'a static_funptr = Static_funptr of 'a fn Ctypes_ptr.Fat.t and ('a, 'b) view = { read : 'b -> 'a; write : 'a -> 'b; format_typ: ((Format.formatter -> unit) -> Format.formatter -> unit) option; format: (Format.formatter -> 'a -> unit) option; ty: 'b typ; } and ('a, 's) field = { ftype: 'a typ; foffset: int; fname: string; } and 'a structure_type = { tag: string; mutable spec: 'a structspec; (* fields are in reverse order iff the struct type is incomplete *) mutable fields : 'a structure boxed_field list; } and 'a union_type = { utag: string; mutable uspec: structured_spec option; (* fields are in reverse order iff the union type is incomplete *) mutable ufields : 'a union boxed_field list; } and 's boxed_field = BoxedField : ('a, 's) field -> 's boxed_field and _ fn = | Returns : 'a typ -> 'a fn | Function : 'a typ * 'b fn -> ('a -> 'b) fn type _ bigarray_class = Genarray : < element: 'a; dims: int array; ba_repr: 'b; bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t; carray: 'a carray > bigarray_class | Array1 : < element: 'a; dims: int; ba_repr: 'b; bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t; carray: 'a carray > bigarray_class | Array2 : < element: 'a; dims: int * int; ba_repr: 'b; bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Array2.t; carray: 'a carray carray > bigarray_class | Array3 : < element: 'a; dims: int * int * int; ba_repr: 'b; bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Array3.t; carray: 'a carray carray carray > bigarray_class type boxed_typ = BoxedType : 'a typ -> boxed_typ let rec sizeof : type a. a typ -> int = function Void -> raise IncompleteType | Primitive p -> Ctypes_primitives.sizeof p | Struct { spec = Incomplete _ } -> raise IncompleteType | Struct { spec = Complete { size } } -> size | Union { uspec = None } -> raise IncompleteType | Union { uspec = Some { size } } -> size | Array (t, i) -> i * sizeof t | Bigarray ba -> Ctypes_bigarray.sizeof ba | Abstract { asize } -> asize | Pointer _ -> Ctypes_primitives.pointer_size | Funptr _ -> Ctypes_primitives.pointer_size | OCaml _ -> raise IncompleteType | View { ty } -> sizeof ty let rec alignment : type a. a typ -> int = function Void -> raise IncompleteType | Primitive p -> Ctypes_primitives.alignment p | Struct { spec = Incomplete _ } -> raise IncompleteType | Struct { spec = Complete { align } } -> align | Union { uspec = None } -> raise IncompleteType | Union { uspec = Some { align } } -> align | Array (t, _) -> alignment t | Bigarray ba -> Ctypes_bigarray.alignment ba | Abstract { aalignment } -> aalignment | Pointer _ -> Ctypes_primitives.pointer_alignment | Funptr _ -> Ctypes_primitives.pointer_alignment | OCaml _ -> raise IncompleteType | View { ty } -> alignment ty let rec passable : type a. a typ -> bool = function Void -> true | Primitive _ -> true | Struct { spec = Incomplete _ } -> raise IncompleteType | Struct { spec = Complete _ } -> true | Union { uspec = None } -> raise IncompleteType | Union { uspec = Some _ } -> true | Array _ -> false | Bigarray _ -> false | Pointer _ -> true | Funptr _ -> true | Abstract _ -> false | OCaml _ -> true | View { ty } -> passable ty let void = Void let char = Primitive Ctypes_primitive_types.Char let schar = Primitive Ctypes_primitive_types.Schar let float = Primitive Ctypes_primitive_types.Float let double = Primitive Ctypes_primitive_types.Double let complex32 = Primitive Ctypes_primitive_types.Complex32 let complex64 = Primitive Ctypes_primitive_types.Complex64 let short = Primitive Ctypes_primitive_types.Short let int = Primitive Ctypes_primitive_types.Int let sint = Primitive Ctypes_primitive_types.Sint let long = Primitive Ctypes_primitive_types.Long let llong = Primitive Ctypes_primitive_types.Llong let nativeint = Primitive Ctypes_primitive_types.Nativeint let int8_t = Primitive Ctypes_primitive_types.Int8_t let int16_t = Primitive Ctypes_primitive_types.Int16_t let int32_t = Primitive Ctypes_primitive_types.Int32_t let int64_t = Primitive Ctypes_primitive_types.Int64_t let camlint = Primitive Ctypes_primitive_types.Camlint let uchar = Primitive Ctypes_primitive_types.Uchar let bool = Primitive Ctypes_primitive_types.Bool let uint8_t = Primitive Ctypes_primitive_types.Uint8_t let uint16_t = Primitive Ctypes_primitive_types.Uint16_t let uint32_t = Primitive Ctypes_primitive_types.Uint32_t let uint64_t = Primitive Ctypes_primitive_types.Uint64_t let size_t = Primitive Ctypes_primitive_types.Size_t let ushort = Primitive Ctypes_primitive_types.Ushort let uint = Primitive Ctypes_primitive_types.Uint let ulong = Primitive Ctypes_primitive_types.Ulong let ullong = Primitive Ctypes_primitive_types.Ullong let array i t = Array (t, i) let ocaml_string = OCaml String let ocaml_bytes = OCaml Bytes let ocaml_float_array = OCaml FloatArray let ptr t = Pointer t let ( @->) f t = if not (passable f) then raise (Unsupported "Unsupported argument type") else Function (f, t) let abstract ~name ~size ~alignment = Abstract { aname = name; asize = size; aalignment = alignment } let view ?format_typ ?format ~read ~write ty = View { read; write; format_typ; format; ty } let id v = v let typedef old name = view ~format_typ:(fun k fmt -> Format.fprintf fmt "%s%t" name k) ~read:id ~write:id old let bigarray : type a b c d e. < 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 static_funptr fn = Funptr fn let structure tag = Struct { spec = Incomplete { isize = 0 }; tag; fields = [] } let union utag = Union { utag; uspec = None; ufields = [] } let offsetof { foffset } = foffset let field_type { ftype } = ftype let field_name { fname } = fname (* This corresponds to the enum in ctypes_primitives.h *) type arithmetic = Int8 | Int16 | Int32 | Int64 | Uint8 | Uint16 | Uint32 | Uint64 | Float | Double ocaml-ctypes-0.7.0/src/ctypes/ctypes_static.mli000066400000000000000000000127551274143137600216170ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* C type construction. Internal representation, not for public use. *) type abstract_type = { aname : string; asize : int; aalignment : int; } type _ ocaml_type = String : string ocaml_type | Bytes : Bytes.t ocaml_type | FloatArray : float array ocaml_type type incomplete_size = { mutable isize: int } type structured_spec = { size: int; align: int; } type 'a structspec = Incomplete of incomplete_size | Complete of structured_spec type _ typ = Void : unit typ | Primitive : 'a Ctypes_primitive_types.prim -> 'a typ | Pointer : 'a typ -> 'a ptr typ | Funptr : 'a fn -> 'a static_funptr typ | Struct : 'a structure_type -> 'a structure typ | Union : 'a union_type -> 'a union typ | Abstract : abstract_type -> 'a abstract typ | View : ('a, 'b) view -> 'a typ | Array : 'a typ * int -> 'a carray typ | Bigarray : (_, 'a) Ctypes_bigarray.t -> 'a typ | OCaml : 'a ocaml_type -> 'a ocaml typ and 'a carray = { astart : 'a ptr; alength : int } and ('a, 'kind) structured = { structured : ('a, 'kind) structured ptr } and 'a union = ('a, [`Union]) structured and 'a structure = ('a, [`Struct]) structured and 'a abstract = ('a, [`Abstract]) structured and (_, _) pointer = CPointer : 'a typ Ctypes_ptr.Fat.t -> ('a, [`C]) pointer | OCamlRef : int * 'a * 'a ocaml_type -> ('a, [`OCaml]) pointer and 'a ptr = ('a, [`C]) pointer and 'a ocaml = ('a, [`OCaml]) pointer and 'a static_funptr = Static_funptr of 'a fn Ctypes_ptr.Fat.t and ('a, 'b) view = { read : 'b -> 'a; write : 'a -> 'b; format_typ: ((Format.formatter -> unit) -> Format.formatter -> unit) option; format: (Format.formatter -> 'a -> unit) option; ty: 'b typ; } and ('a, 's) field = { ftype: 'a typ; foffset: int; fname: string; } and 'a structure_type = { tag: string; mutable spec: 'a structspec; mutable fields : 'a structure boxed_field list; } and 'a union_type = { utag: string; mutable uspec: structured_spec option; mutable ufields : 'a union boxed_field list; } and 's boxed_field = BoxedField : ('a, 's) field -> 's boxed_field and _ fn = | Returns : 'a typ -> 'a fn | Function : 'a typ * 'b fn -> ('a -> 'b) fn type _ bigarray_class = Genarray : < element: 'a; dims: int array; ba_repr: 'b; bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t; carray: 'a carray > bigarray_class | Array1 : < element: 'a; dims: int; ba_repr: 'b; bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t; carray: 'a carray > bigarray_class | Array2 : < element: 'a; dims: int * int; ba_repr: 'b; bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Array2.t; carray: 'a carray carray > bigarray_class | Array3 : < element: 'a; dims: int * int * int; ba_repr: 'b; bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Array3.t; carray: 'a carray carray carray > bigarray_class type boxed_typ = BoxedType : 'a typ -> boxed_typ val sizeof : 'a typ -> int val alignment : 'a typ -> int val passable : 'a typ -> bool val void : unit typ val char : char typ val schar : int typ val float : float typ val double : float typ val complex32 : Complex.t typ val complex64 : Complex.t typ val short : int typ val int : int typ val sint : Signed.sint typ val long : Signed.long typ val llong : Signed.llong typ val nativeint : nativeint typ val int8_t : int typ val int16_t : int typ val int32_t : Signed.Int32.t typ val int64_t : Signed.Int64.t typ val camlint : int typ val uchar : Unsigned.uchar typ val bool : bool typ val uint8_t : Unsigned.UInt8.t typ val uint16_t : Unsigned.UInt16.t typ val uint32_t : Unsigned.UInt32.t typ val uint64_t : Unsigned.UInt64.t typ val size_t : Unsigned.size_t typ val ushort : Unsigned.ushort typ val uint : Unsigned.uint typ val ulong : Unsigned.ulong typ val ullong : Unsigned.ullong typ val array : int -> 'a typ -> 'a carray typ val ocaml_string : string ocaml typ val ocaml_bytes : Bytes.t ocaml typ val ocaml_float_array : float array ocaml typ val ptr : 'a typ -> 'a ptr typ val ( @-> ) : 'a typ -> 'b fn -> ('a -> 'b) fn val abstract : name:string -> size:int -> alignment:int -> 'a abstract typ val view : ?format_typ:((Format.formatter -> unit) -> Format.formatter -> unit) -> ?format: (Format.formatter -> 'b -> unit) -> read:('a -> 'b) -> write:('b -> 'a) -> 'a typ -> 'b typ val typedef: 'a typ -> string -> 'a typ val bigarray : < ba_repr : 'c; bigarray : 'd; carray : 'e; dims : 'b; element : 'a > bigarray_class -> 'b -> ('a, 'c) Bigarray.kind -> 'd typ val returning : 'a typ -> 'a fn val static_funptr : 'a fn -> 'a static_funptr typ val structure : string -> 'a structure typ val union : string -> 'a union typ val offsetof : ('a, 'b) field -> int val field_type : ('a, 'b) field -> 'a typ val field_name : ('a, 'b) field -> string exception IncompleteType exception ModifyingSealedType of string exception Unsupported of string val unsupported : ('a, unit, string, _) format4 -> 'a (* This corresponds to the enum in ctypes_primitives.h *) type arithmetic = Int8 | Int16 | Int32 | Int64 | Uint8 | Uint16 | Uint32 | Uint64 | Float | Double ocaml-ctypes-0.7.0/src/ctypes/ctypes_std_view_stubs.ml000066400000000000000000000014261274143137600232140ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stubs for standard views. *) (* Convert a C string to an OCaml string *) external string_of_cstring : char Ctypes_static.typ Ctypes_ptr.Fat.t -> string = "ctypes_string_of_cstring" (* Convert an OCaml string to a C string *) external cstring_of_string : string -> Ctypes_memory_stubs.managed_buffer = "ctypes_cstring_of_string" (* Size information for uintptr_t *) external uintptr_t_size : unit -> int = "ctypes_uintptr_t_size" (* Size information for uintptr_t *) external intptr_t_size : unit -> int = "ctypes_intptr_t_size" (* Size information for ptrdiff_t *) external ptrdiff_t_size : unit -> int = "ctypes_ptrdiff_t_size" ocaml-ctypes-0.7.0/src/ctypes/ctypes_std_views.ml000066400000000000000000000072111274143137600221550ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) let string_of_char_ptr (Ctypes_static.CPointer p) = Ctypes_std_view_stubs.string_of_cstring p let char_ptr_of_string s = let managed = Ctypes_std_view_stubs.cstring_of_string s in Ctypes_static.CPointer (Ctypes_ptr.Fat.make ~managed ~reftyp:Ctypes_static.char (Ctypes_memory_stubs.block_address managed)) let string = Ctypes_static.(view (ptr char)) ~read:string_of_char_ptr ~write:char_ptr_of_string let read_nullable t reftyp = let coerce = Ctypes_coerce.coerce Ctypes_static.(ptr reftyp) t in fun p -> if Ctypes_memory.is_null p then None else Some (coerce p) let write_nullable t reftyp = let coerce = Ctypes_coerce.coerce t Ctypes_static.(ptr reftyp) in Ctypes_memory.(function None -> from_voidp reftyp null | Some f -> coerce f) let nullable_view ?format_typ ?format t reftyp = let read = read_nullable t reftyp and write = write_nullable t reftyp in Ctypes_static.(view ~read ~write ?format_typ ?format (ptr reftyp)) let read_nullable_funptr t reftyp = let coerce = Ctypes_coerce.coerce (Ctypes_static.static_funptr reftyp) t in fun (Ctypes_static.Static_funptr p as ptr) -> if Ctypes_ptr.Fat.is_null p then None else Some (coerce ptr) let write_nullable_funptr t reftyp = let coerce = Ctypes_coerce.coerce t Ctypes_static.(static_funptr reftyp) in function None -> Ctypes_static.Static_funptr (Ctypes_ptr.Fat.make ~reftyp Ctypes_ptr.Raw.null) | Some f -> coerce f let nullable_funptr_view ?format_typ ?format t reftyp = let read = read_nullable_funptr t reftyp and write = write_nullable_funptr t reftyp in Ctypes_static.(view ~read ~write ?format_typ ?format (static_funptr reftyp)) let ptr_opt t = nullable_view (Ctypes_static.ptr t) t let string_opt = nullable_view string Ctypes_static.char module type Signed_type = sig include Signed.S val t : t Ctypes_static.typ end module type Unsigned_type = sig include Unsigned.S val t : t Ctypes_static.typ end let signed_typedef name ~size : (module Signed_type) = match size with 1 -> (module struct include Signed.Int let t = Ctypes_static.(typedef int8_t name) end) | 2 -> (module struct include Signed.Int let t = Ctypes_static.(typedef int16_t name) end) | 4 -> (module struct include Signed.Int32 let t = Ctypes_static.(typedef int32_t name) end) | 8 -> (module struct include Signed.Int64 let t = Ctypes_static.(typedef int64_t name) end) | n -> Printf.kprintf failwith "size %d not supported for %s\n" n name let unsigned_typedef name ~size : (module Unsigned_type) = match size with | 1 -> (module struct include Unsigned.UInt8 let t = Ctypes_static.(typedef uint8_t name) end) | 2 -> (module struct include Unsigned.UInt16 let t = Ctypes_static.(typedef uint16_t name) end) | 4 -> (module struct include Unsigned.UInt32 let t = Ctypes_static.(typedef uint32_t name) end) | 8 -> (module struct include Unsigned.UInt64 let t = Ctypes_static.(typedef uint64_t name) end) | n -> Printf.kprintf failwith "size %d not supported for %s\n" n name module Intptr = (val signed_typedef "intptr_t" ~size:(Ctypes_std_view_stubs.intptr_t_size ())) module Uintptr = (val unsigned_typedef "uintptr_t" ~size:(Ctypes_std_view_stubs.uintptr_t_size ())) let intptr_t = Intptr.t let uintptr_t = Uintptr.t module Ptrdiff = (val signed_typedef "ptrdiff_t" ~size:(Ctypes_std_view_stubs.ptrdiff_t_size ())) let ptrdiff_t = Ptrdiff.t ocaml-ctypes-0.7.0/src/ctypes/ctypes_structs.ml000066400000000000000000000006301274143137600216530ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes_static module type S = sig type (_, _) field val field : 't typ -> string -> 'a typ -> ('a, (('s, [<`Struct | `Union]) structured as 't)) field val seal : (_, [< `Struct | `Union]) Ctypes_static.structured Ctypes_static.typ -> unit end ocaml-ctypes-0.7.0/src/ctypes/ctypes_structs.mli000066400000000000000000000006301274143137600220240ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes_static module type S = sig type (_, _) field val field : 't typ -> string -> 'a typ -> ('a, (('s, [<`Struct | `Union]) structured as 't)) field val seal : (_, [< `Struct | `Union]) Ctypes_static.structured Ctypes_static.typ -> unit end ocaml-ctypes-0.7.0/src/ctypes/ctypes_structs_computed.ml000066400000000000000000000044271274143137600235630ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes_static let max_field_alignment fields = List.fold_left (fun align (BoxedField {ftype}) -> max align (alignment ftype)) 0 fields let max_field_size fields = List.fold_left (fun size (BoxedField {ftype}) -> max size (sizeof ftype)) 0 fields let aligned_offset offset alignment = match offset mod alignment with 0 -> offset | overhang -> offset - overhang + alignment let rec field : type t a. t typ -> string -> a typ -> (a, t) field = fun structured label ftype -> match structured with | Struct ({ spec = Incomplete spec } as s) -> let foffset = aligned_offset spec.isize (alignment ftype) in let field = { ftype; foffset; fname = label } in begin spec.isize <- foffset + sizeof ftype; s.fields <- BoxedField field :: s.fields; field end | Union ({ uspec = None } as u) -> let field = { ftype; foffset = 0; fname = label } in u.ufields <- BoxedField field :: u.ufields; field | Struct { tag; spec = Complete _ } -> raise (ModifyingSealedType tag) | Union { utag } -> raise (ModifyingSealedType utag) | View { ty } -> let { ftype; foffset; fname } = field ty label ftype in { ftype; foffset; fname } | _ -> raise (Unsupported "Adding a field to non-structured type") let rec seal : type a. a typ -> unit = function | Struct { fields = [] } -> raise (Unsupported "struct with no fields") | Struct { spec = Complete _; tag } -> raise (ModifyingSealedType tag) | Struct ({ spec = Incomplete { isize } } as s) -> s.fields <- List.rev s.fields; let align = max_field_alignment s.fields in let size = aligned_offset isize align in s.spec <- Complete { (* sraw_io; *)size; align } | Union { utag; uspec = Some _ } -> raise (ModifyingSealedType utag) | Union { ufields = [] } -> raise (Unsupported "union with no fields") | Union u -> begin u.ufields <- List.rev u.ufields; let size = max_field_size u.ufields and align = max_field_alignment u.ufields in u.uspec <- Some { align; size = aligned_offset size align } end | View { ty } -> seal ty | _ -> raise (Unsupported "Sealing a non-structured type") ocaml-ctypes-0.7.0/src/ctypes/ctypes_structs_computed.mli000066400000000000000000000005551274143137600237320ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (** Structs and unions whose layouts are computed from the sizes and alignment requirements of the constituent field types. *) include Ctypes_structs.S with type ('a, 's) field := ('a, 's) Ctypes_static.field ocaml-ctypes-0.7.0/src/ctypes/ctypes_type_info_stubs.h000066400000000000000000000011041274143137600231740ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef CTYPES_TYPE_INFO_STUBS_H #define CTYPES_TYPE_INFO_STUBS_H #include /* Read a C value from a block of memory */ /* read : 'a prim -> raw_pointer -> 'a */ extern value ctypes_read(value ctype, value buffer); /* Write a C value to a block of memory */ /* write : 'a prim -> 'a -> raw_pointer -> unit */ extern value ctypes_write(value ctype, value v, value buffer); #endif /* CTYPES_TYPE_INFO_STUBS_H */ ocaml-ctypes-0.7.0/src/ctypes/ctypes_type_printing.ml000066400000000000000000000103161274143137600230410ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes_static (* See type_printing.mli for the documentation of [format context]. *) type format_context = [ `toplevel | `array | `nonarray ] let rec format_typ' : type a. a typ -> (format_context -> Format.formatter -> unit) -> (format_context -> Format.formatter -> unit) = let fprintf = Format.fprintf in fun t k context fmt -> match t with | Void -> fprintf fmt "void%t" (k `nonarray) | Primitive p -> let name = Ctypes_primitives.name p in fprintf fmt "%s%t" name (k `nonarray) | View { format_typ = Some format } -> format (k `nonarray) fmt | View { ty } -> format_typ' ty k context fmt | Abstract { aname } -> fprintf fmt "%s%t" aname (k `nonarray) | Struct { tag ; 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 | Funptr fn -> format_fn' fn (fun fmt -> Format.fprintf fmt "(*%t)" (k `nonarray)) fmt | Array (ty, n) -> format_typ' ty (fun _ fmt -> fprintf fmt "%t[%d]" (k `array) n) `nonarray fmt | Bigarray ba -> let elem = Ctypes_bigarray.element_type ba and dims = Ctypes_bigarray.dimensions ba in let name = Ctypes_primitives.name elem in fprintf fmt "%s%t%t" name (k `array) (fun fmt -> (Array.iter (Format.fprintf fmt "[%d]") dims)) | OCaml String -> format_typ' (ptr char) k context fmt | OCaml Bytes -> format_typ' (ptr char) k context fmt | OCaml FloatArray -> format_typ' (ptr double) k context fmt and format_fields : type a. a boxed_field list -> Format.formatter -> unit = fun fields fmt -> let open Format in List.iteri (fun i (BoxedField {ftype=t; fname}) -> fprintf fmt "@["; format_typ' t (fun _ fmt -> fprintf fmt " %s" fname) `nonarray fmt; fprintf fmt "@];@;") fields and format_parameter_list parameters k fmt = Format.fprintf fmt "%t(@[@[" k; if parameters = [] then Format.fprintf fmt "void" else List.iteri (fun i (BoxedType t) -> if i <> 0 then Format.fprintf fmt "@], @["; format_typ' t (fun _ _ -> ()) `nonarray fmt) parameters; Format.fprintf fmt "@]@])" and format_fn' : 'a. 'a fn -> (Format.formatter -> unit) -> (Format.formatter -> unit) = let rec gather : type a. a fn -> boxed_typ list * boxed_typ = function | Returns ty -> [], BoxedType ty | Function (Void, fn) -> gather fn | Function (p, fn) -> let ps, r = gather fn in BoxedType p :: ps, r in fun fn k fmt -> let ps, BoxedType r = gather fn in format_typ' r (fun context fmt -> format_parameter_list ps k fmt) `nonarray fmt let format_name ?name fmt = match name with | Some name -> Format.fprintf fmt " %s" name | None -> () let format_typ : ?name:string -> Format.formatter -> 'a typ -> unit = fun ?name fmt typ -> Format.fprintf fmt "@["; format_typ' typ (fun context -> format_name ?name) `toplevel fmt; Format.fprintf fmt "@]" let format_fn : ?name:string -> Format.formatter -> 'a fn -> unit = fun ?name fmt fn -> Format.fprintf fmt "@["; format_fn' fn (format_name ?name) fmt; Format.fprintf fmt "@]" let string_of_typ ?name ty = Format.asprintf "%a" (format_typ ?name) ty let string_of_fn ?name fn = Format.asprintf "%a" (format_fn ?name) fn ocaml-ctypes-0.7.0/src/ctypes/ctypes_type_printing.mli000066400000000000000000000026771274143137600232250ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes_static (* The format context affects the formatting of pointer, struct and union types. There are three printing contexts: *) type format_context = [ (* In the top-level context struct and union types are printed in full, with member lists. Pointer types are unparenthesized; for example, pointer-to-void is printed as "void *", not as "void ( * )". *) | `toplevel (* In the array context, struct and union types are printed in abbreviated form, which consists of just a keyword and the tag name. Pointer types are parenthesized; for example, pointer-to-array-of-int is printed as "int ( * )[]", not as "int *[]". *) | `array (* In the non-array context, struct and union types are printed in abbreviated form and pointer types are unparenthesized. *) | `nonarray] val format_name : ?name:string -> Format.formatter -> unit val format_typ' : 'a Ctypes_static.typ -> (format_context -> Format.formatter -> unit) -> format_context -> Format.formatter -> unit val format_typ : ?name:string -> Format.formatter -> 'a typ -> unit val format_fn' : 'a fn -> (Format.formatter -> unit) -> Format.formatter -> unit val format_fn : ?name:string -> Format.formatter -> 'a fn -> unit val string_of_typ : ?name:string -> 'a typ -> string val string_of_fn : ?name:string -> 'a fn -> string ocaml-ctypes-0.7.0/src/ctypes/ctypes_types.mli000066400000000000000000000302721274143137600214660ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Signed open Unsigned (** Abstract interface to C object type descriptions *) module type TYPE = sig (** {2:types Values representing C types} *) type 'a typ (** The type of values representing C types. There are two types associated with each [typ] value: the C type used to store and pass values, and the corresponding OCaml type. The type parameter indicates the OCaml type, so a value of type [t typ] is used to read and write OCaml values of type [t]. There are various uses of [typ] values, including - constructing function types for binding native functions using {!Foreign.foreign} - constructing pointers for reading and writing locations in C-managed storage using {!ptr} - describing the fields of structured types built with {!structure} and {!union}. *) (** {3 The void type} *) val void : unit typ (** Value representing the C void type. Void values appear in OCaml as the unit type, so using void in an argument or result type specification produces a function which accepts or returns unit. Dereferencing a pointer to void is an error, as in C, and will raise {!IncompleteType}. *) (** {3 Scalar types} The scalar types consist of the {!arithmetic_types} and the {!pointer_types}. *) (** {4:arithmetic_types Arithmetic types} The arithmetic types consist of the signed and unsigned integer types (including character types) and the floating types. There are values representing both exact-width integer types (of 8, 16, 32 and 64 bits) and types whose size depend on the platform (signed and unsigned short, int, long, long long). *) val char : char typ (** Value representing the C type [char]. *) (** {5 Signed integer types} *) val schar : int typ (** Value representing the C type [signed char]. *) val short : int typ (** Value representing the C type ([signed]) [short]. *) val int : int typ (** Value representing the C type ([signed]) [int]. *) val long : long typ (** Value representing the C type ([signed]) [long]. *) val llong : llong typ (** Value representing the C type ([signed]) [long long]. *) val nativeint : nativeint typ (** Value representing the C type ([signed]) [int]. *) val int8_t : int typ (** Value representing an 8-bit signed integer C type. *) val int16_t : int typ (** Value representing a 16-bit signed integer C type. *) val int32_t : int32 typ (** Value representing a 32-bit signed integer C type. *) val int64_t : int64 typ (** Value representing a 64-bit signed integer C type. *) module Intptr : Signed.S val intptr_t : Intptr.t typ (** Value representing the C type [intptr_t]. *) module Ptrdiff : Signed.S val ptrdiff_t : Ptrdiff.t typ (** Value representing the C type [ptrdiff_t]. *) val camlint : int typ (** Value representing an integer type with the same storage requirements as an OCaml [int]. *) (** {5 Unsigned integer types} *) val uchar : uchar typ (** Value representing the C type [unsigned char]. *) val bool : bool typ (** Value representing the C type [bool]. *) val uint8_t : uint8 typ (** Value representing an 8-bit unsigned integer C type. *) val uint16_t : uint16 typ (** Value representing a 16-bit unsigned integer C type. *) val uint32_t : uint32 typ (** Value representing a 32-bit unsigned integer C type. *) val uint64_t : uint64 typ (** Value representing a 64-bit unsigned integer C type. *) val size_t : size_t typ (** Value representing the C type [size_t], an alias for one of the unsigned integer types. The actual size and alignment requirements for [size_t] vary between platforms. *) val ushort : ushort typ (** Value representing the C type [unsigned short]. *) val sint : sint typ (** Value representing the C type [int]. *) val uint : uint typ (** Value representing the C type [unsigned int]. *) val ulong : ulong typ (** Value representing the C type [unsigned long]. *) val ullong : ullong typ (** Value representing the C type [unsigned long long]. *) module Uintptr : Unsigned.S val uintptr_t : Uintptr.t typ (** Value representing the C type [uintptr_t]. *) (** {5 Floating types} *) val float : float typ (** Value representing the C single-precision [float] type. *) val double : float typ (** Value representing the C type [double]. *) (** {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} *) (** {5 C-compatible pointers} *) val ptr : 'a typ -> 'a Ctypes_static.ptr typ (** Construct a pointer type from an existing type (called the {i reference type}). *) val ptr_opt : 'a typ -> 'a Ctypes_static.ptr option typ (** Construct a pointer type from an existing type (called the {i reference type}). This behaves like {!ptr}, except that null pointers appear in OCaml as [None]. *) val string : string typ (** A high-level representation of the string type. On the C side this behaves like [char *]; on the OCaml side values read and written using {!string} are simply native OCaml strings. To avoid problems with the garbage collector, values passed using {!string} are copied into immovable C-managed storage before being passed to C. *) val string_opt : string option typ (** A high-level representation of the string type. This behaves like {!string}, except that null pointers appear in OCaml as [None]. *) (** {5 OCaml pointers} *) val ocaml_string : string Ctypes_static.ocaml typ (** Value representing the directly mapped storage of an OCaml string. *) val ocaml_bytes : Bytes.t Ctypes_static.ocaml typ (** Value representing the directly mapped storage of an OCaml byte array. *) (** {3 Array types} *) (** {4 C array types} *) val array : int -> 'a typ -> 'a Ctypes_static.carray typ (** Construct a sized array type from a length and an existing type (called the {i element type}). *) (** {4 Bigarray types} *) val bigarray : < element: 'a; ba_repr: 'b; dims: 'dims; bigarray: 'bigarray; carray: _ > Ctypes_static.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}. *) val typ_of_bigarray_kind : ('a, 'b) Bigarray.kind -> 'a typ (** [typ_of_bigarray_kind k] is the type corresponding to the Bigarray kind [k]. *) (** {3 Struct and union types} *) type ('a, 't) field val structure : string -> 's Ctypes_static.structure typ (** Construct a new structure type. The type value returned is incomplete and can be updated using {!field} until it is passed to {!seal}, at which point the set of fields is fixed. The type (['_s structure typ]) of the expression returned by the call [structure tag] includes a weak type variable, which can be explicitly instantiated to ensure that the OCaml values representing different C structure types have incompatible types. Typical usage is as follows: [type tagname] [let tagname : tagname structure typ = structure "tagname"] *) val union : string -> 's Ctypes_static.union typ (** Construct a new union type. This behaves analogously to {!structure}; fields are added with {!field}. *) val field : 't typ -> string -> 'a typ -> ('a, (('s, [<`Struct | `Union]) Ctypes_static.structured as 't)) field (** [field ty label ty'] adds a field of type [ty'] with label [label] to the structure or union type [ty] and returns a field value that can be used to read and write the field in structure or union instances (e.g. using {!getf} and {!setf}). Attempting to add a field to a union type that has been sealed with [seal] is an error, and will raise {!ModifyingSealedType}. *) val seal : (_, [< `Struct | `Union]) Ctypes_static.structured typ -> unit (** [seal t] completes the struct or union type [t] so that no further fields can be added. Struct and union types must be sealed before they can be used in a way that involves their size or alignment; see the documentation for {!IncompleteType} for further details. *) (** {3 View types} *) val view : ?format_typ:((Format.formatter -> unit) -> Format.formatter -> unit) -> ?format:(Format.formatter -> 'b -> unit) -> read:('a -> 'b) -> write:('b -> 'a) -> 'a typ -> 'b typ (** [view ~read:r ~write:w t] creates a C type representation [t'] which behaves like [t] except that values read using [t'] are subsequently transformed using the function [r] and values written using [t'] are first transformed using the function [w]. For example, given suitable definitions of [string_of_char_ptr] and [char_ptr_of_string], the type representation [view ~read:string_of_char_ptr ~write:char_ptr_of_string (ptr char)] can be used to pass OCaml strings directly to and from bound C functions, or to read and write string members in structs and arrays. (In fact, the {!string} type representation is defined in exactly this way.) The optional argument [format_typ] is used by the {!Ctypes.format_typ} and {!string_of_typ} functions to print the type at the top level and elsewhere. If [format_typ] is not supplied the printer for [t] is used instead. The optional argument [format] is used by the {!Ctypes.format} and {!string_of} functions to print the values. If [format_val] is not supplied the printer for [t] is used instead. *) val typedef : 'a typ -> string -> 'a typ (** [typedef t name] creates a C type representation [t'] which is equivalent to [t] except its name is printed as [name]. This is useful when generating C stubs involving "anonymous" types, for example: [typedef struct { int f } typedef_name;] *) (** {3 Abstract types} *) val abstract : name:string -> size:int -> alignment:int -> 'a Ctypes_static.abstract typ (** Create an abstract type specification from the size and alignment requirements for the type. *) (** {3 Injection of concrete types} *) val lift_typ : 'a Ctypes_static.typ -> 'a typ (** [lift_typ t] turns a concrete type representation into an abstract type representation. For example, retrieving struct layout from C involves working with an abstract representation of types which do not support operations such as [sizeof]. The [lift_typ] function makes it possible to use concrete type representations wherever such abstract type representations are needed. *) (** {3 Function types} *) (** Abstract interface to C function type descriptions *) type 'a fn = 'a Ctypes_static.fn (** The type of values representing C function types. A value of type [t fn] can be used to bind to C functions and to describe type of OCaml functions passed to C. *) val ( @-> ) : 'a typ -> 'b fn -> ('a -> 'b) fn (** Construct a function type from a type and an existing function type. This corresponds to prepending a parameter to a C function parameter list. For example, [int @-> ptr void @-> returning float] describes a function type that accepts two arguments -- an integer and a pointer to void -- and returns a float. *) val returning : 'a typ -> 'a fn (** Give the return type of a C function. Note that [returning] is intended to be used together with {!(@->)}; see the documentation for {!(@->)} for an example. *) (** {3 Function pointer types} *) type 'a static_funptr = 'a Ctypes_static.static_funptr (** The type of values representing C function pointer types. *) val static_funptr : 'a fn -> 'a Ctypes_static.static_funptr typ (** Construct a function pointer type from an existing function type (called the {i reference type}). *) end ocaml-ctypes-0.7.0/src/ctypes/ctypes_unsigned_stubs.h000066400000000000000000000062611274143137600230250ustar00rootroot00000000000000/* * 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); \ /* 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-0.7.0/src/ctypes/ctypes_value_printing.ml000066400000000000000000000065401274143137600232000ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes_static open Ctypes_memory let rec format : type a. a typ -> Format.formatter -> a -> unit = fun typ fmt v -> match typ with Void -> Format.pp_print_string fmt "" | Primitive p -> Format.pp_print_string fmt (Ctypes_value_printing_stubs.string_of_prim p v) | Pointer _ -> format_ptr fmt v | Funptr _ -> format_funptr fmt v | Struct _ -> format_structured fmt v | Union _ -> format_structured fmt v | Array (a, n) -> format_array fmt v | Bigarray ba -> Format.fprintf fmt "" (fun fmt -> Ctypes_type_printing.format_typ fmt) typ | Abstract _ -> format_structured fmt v | OCaml _ -> format_ocaml fmt v | View {write; ty; format=f} -> begin match f with | None -> format ty fmt (write v) | Some f -> f fmt v end and format_structured : type a b. Format.formatter -> (a, b) structured -> unit = fun fmt ({structured = CPointer p} as s) -> let open Format in match Ctypes_ptr.Fat.reftype p with | Struct {fields} -> fprintf fmt "{@;<1 2>@["; format_fields "," fields fmt s; fprintf fmt "@]@;<1 0>}" | Union {ufields} -> fprintf fmt "{@;<1 2>@["; format_fields " |" ufields fmt s; fprintf fmt "@]@;<1 0>}" | Abstract abs -> pp_print_string fmt "" | _ -> raise (Unsupported "unknown structured type") and format_array : type a. Format.formatter -> a carray -> unit = fun fmt ({astart = CPointer p; alength} as arr) -> let open Format in fprintf fmt "{@;<1 2>@["; for i = 0 to alength - 1 do format (Ctypes_ptr.Fat.reftype p) fmt (CArray.get arr i); if i <> alength - 1 then fprintf fmt ",@;" done; fprintf fmt "@]@;<1 0>}" and format_ocaml : type a. Format.formatter -> a ocaml -> unit = let offset fmt = function | 0 -> () | n -> Format.fprintf fmt "@ @[[offset:%d]@]" n and float_array fmt arr = Format.fprintf fmt "[|@;<1 2>@["; let len = Array.length arr in for i = 0 to len - 1 do Format.pp_print_float fmt arr.(i); if i <> len - 1 then Format.fprintf fmt ",@;" done; Format.fprintf fmt "@]@;<1 0>|]" in fun fmt (OCamlRef (off, obj, ty)) -> match ty with | String -> Format.fprintf fmt "%S%a" obj offset off | Bytes -> Format.fprintf fmt "%S%a" (Bytes.to_string obj) offset off | FloatArray -> Format.fprintf fmt "%a%a" float_array obj offset off and format_fields : type a b. string -> (a, b) structured boxed_field list -> Format.formatter -> (a, b) structured -> unit = fun sep fields fmt s -> let last_field = List.length fields - 1 in let open Format in List.iteri (fun i (BoxedField ({ftype; foffset; fname} as f)) -> fprintf fmt "@[%s@] = @[%a@]%s@;" fname (format ftype) (getf s f) (if i <> last_field then sep else "")) fields and format_ptr : type a. Format.formatter -> a ptr -> unit = fun fmt (CPointer p) -> Format.fprintf fmt "%s" (Ctypes_value_printing_stubs.string_of_pointer p) and format_funptr : type a. Format.formatter -> a static_funptr -> unit = fun fmt (Static_funptr p) -> Format.fprintf fmt "%s" (Ctypes_value_printing_stubs.string_of_pointer p) let string_of typ v = Format.asprintf "%a" (format typ) v ocaml-ctypes-0.7.0/src/ctypes/ctypes_value_printing_stubs.ml000066400000000000000000000006541274143137600244200ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stubs for formatting C values. *) (* Return a string representation of a C value *) external string_of_prim : 'a Ctypes_primitive_types.prim -> 'a -> string = "ctypes_string_of_prim" external string_of_pointer : _ Ctypes_ptr.Fat.t -> string = "ctypes_string_of_pointer" ocaml-ctypes-0.7.0/src/ctypes/managed_buffer_stubs.c000066400000000000000000000042271274143137600225420ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #include #include #include #include #include #include #include "ctypes_raw_pointer.h" #include "ctypes_managed_buffer_stubs.h" static void finalize_free(value v) { free(*((void **)Data_custom_val(v))); } static int compare_pointers(value l_, value r_) { /* pointer comparison */ intptr_t l = (intptr_t)*(void **)Data_custom_val(l_); intptr_t r = (intptr_t)*(void **)Data_custom_val(r_); return (l > r) - (l < r); } static intnat hash_address(value l) { /* address hashing */ return (intnat)*(void **)Data_custom_val(l); } static struct custom_operations managed_buffer_custom_ops = { "ocaml-ctypes:managed_buffer", finalize_free, compare_pointers, hash_address, /* Managed buffers are not serializable. */ custom_serialize_default, custom_deserialize_default, custom_compare_ext_default }; /* copy_bytes : void * -> size_t -> managed_buffer */ value ctypes_copy_bytes(void *src, size_t size) { CAMLparam0(); CAMLlocal1(block); block = caml_alloc_custom(&managed_buffer_custom_ops, sizeof(void*), 0, 1); void *dst = malloc(size); if (dst == NULL && size != 0) caml_raise_out_of_memory(); *(void **)Data_custom_val(block) = memcpy(dst, src, size); CAMLreturn(block); } /* allocate : int -> int -> managed_buffer */ value ctypes_allocate(value count_, value size_) { CAMLparam2(count_, size_); int size = Int_val(size_); int count = Int_val(count_); CAMLlocal1(block); block = caml_alloc_custom(&managed_buffer_custom_ops, sizeof(void*), 0, 1); // libc's calloc guarantees the memory is zero-filled // malloc may not be used internally void *p = calloc(count, size); if (p == NULL && count != 0 && size != 0) caml_raise_out_of_memory(); void **d = (void **)Data_custom_val(block); *d = p; CAMLreturn(block); } /* block_address : managed_buffer -> immediate_pointer */ value ctypes_block_address(value managed_buffer) { return CTYPES_FROM_PTR(*(void **)Data_custom_val(managed_buffer)); } ocaml-ctypes-0.7.0/src/ctypes/posixTypes.ml000066400000000000000000000107611274143137600207520ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) module type Abstract = sig type t val t : t Ctypes.typ end let mkAbstract : 'a. 'a Ctypes.typ -> (module Abstract) = fun (type a) (ty : a Ctypes.typ) -> (module struct type t = a let t = ty end : Abstract) let mkAbstractSized : name:string -> size:int -> alignment:int -> (module Abstract) = fun ~name ~size ~alignment:a -> (module struct open Ctypes type t = unit Ctypes.abstract let t = abstract ~name ~size ~alignment:a end : Abstract) let mkArithmetic_abstract = let open Ctypes in function Ctypes_static.Int8 -> mkAbstract int8_t | Ctypes_static.Int16 -> mkAbstract int16_t | Ctypes_static.Int32 -> mkAbstract int32_t | Ctypes_static.Int64 -> mkAbstract int64_t | Ctypes_static.Uint8 -> mkAbstract uint8_t | Ctypes_static.Uint16 -> mkAbstract uint16_t | Ctypes_static.Uint32 -> mkAbstract uint32_t | Ctypes_static.Uint64 -> mkAbstract uint64_t | Ctypes_static.Float -> mkAbstract float | Ctypes_static.Double -> mkAbstract double let mkSigned name = function | Ctypes_static.Int8 -> Ctypes_std_views.signed_typedef name ~size:1 | Ctypes_static.Int16 -> Ctypes_std_views.signed_typedef name ~size:2 | Ctypes_static.Int32 -> Ctypes_std_views.signed_typedef name ~size:4 | Ctypes_static.Int64 -> Ctypes_std_views.signed_typedef name ~size:8 | _ -> assert false let mkUnsigned name = function | Ctypes_static.Uint8 -> Ctypes_std_views.unsigned_typedef name ~size:1 | Ctypes_static.Uint16 -> Ctypes_std_views.unsigned_typedef name ~size:2 | Ctypes_static.Uint32 -> Ctypes_std_views.unsigned_typedef name ~size:4 | Ctypes_static.Uint64 -> Ctypes_std_views.unsigned_typedef name ~size:8 | _ -> assert false let mkArithmetic name : _ -> (module Ctypes_std_views.Unsigned_type) = let open Ctypes_static in function | Uint8 | Uint16 | Uint32 | Uint64 as u -> let module U = (val mkUnsigned name u) in (module U) | Int8 | Int16 | Int32 | Int64 as u -> let module S = (val mkSigned name u) in (module S) | _ -> assert false (* Arithmetic types *) external typeof_clock_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_clock_t" external typeof_dev_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_dev_t" external typeof_ino_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_ino_t" external typeof_mode_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_mode_t" external typeof_nlink_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_nlink_t" external typeof_off_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_off_t" external typeof_pid_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_pid_t" external typeof_ssize_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_ssize_t" external typeof_time_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_time_t" external typeof_useconds_t : unit -> Ctypes_static.arithmetic = "ctypes_typeof_useconds_t" module Clock = (val mkArithmetic_abstract (typeof_clock_t ()) : Abstract) module Dev = (val mkArithmetic "dev_t" (typeof_dev_t ())) module Ino = (val mkArithmetic "ino_t" (typeof_ino_t ())) module Mode = (val mkArithmetic "mode_t" (typeof_mode_t ())) module Nlink = (val mkArithmetic "nlink_t" (typeof_nlink_t ())) module Off = (val mkSigned "off_t" (typeof_off_t ())) module Pid = (val mkSigned "pid_t" (typeof_pid_t ())) module Size = struct type t = Unsigned.size_t let t = Ctypes.size_t end module Ssize = (val mkSigned "ssize_t" (typeof_ssize_t ())) module Time = (val mkArithmetic "time_t" (typeof_time_t ())) module Useconds = (val mkArithmetic_abstract (typeof_useconds_t ()) : Abstract) type clock_t = Clock.t type dev_t = Dev.t type ino_t = Ino.t type mode_t = Mode.t type nlink_t = Nlink.t type off_t = Off.t type pid_t = Pid.t type size_t = Size.t type ssize_t = Ssize.t type time_t = Time.t type useconds_t = Useconds.t let clock_t = Clock.t let dev_t = Dev.t let ino_t = Ino.t let mode_t = Mode.t let nlink_t = Nlink.t let off_t = Off.t let pid_t = Pid.t let size_t = Size.t let ssize_t = Ssize.t let time_t = Time.t let useconds_t = Useconds.t (* Non-arithmetic types *) external sizeof_sigset_t : unit -> int = "ctypes_sizeof_sigset_t" external alignmentof_sigset_t : unit -> int = "ctypes_alignmentof_sigset_t" module Sigset = (val mkAbstractSized ~name:"sigset_t" ~size:(sizeof_sigset_t ()) ~alignment:(alignmentof_sigset_t ()) : Abstract) type sigset_t = Sigset.t let sigset_t = Sigset.t ocaml-ctypes-0.7.0/src/ctypes/posixTypes.mli000066400000000000000000000023531274143137600211210ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes (** Some POSIX types. *) (* arithmetic types from *) (** {2 POSIX arithmetic types} *) module Dev : Unsigned.S module Ino : Unsigned.S module Mode : Unsigned.S module Nlink : Unsigned.S module Off : Signed.S module Pid : Signed.S module Ssize : Signed.S module Time : Unsigned.S type clock_t type dev_t = Dev.t type ino_t = Ino.t type mode_t = Mode.t type nlink_t = Nlink.t type off_t = Off.t type pid_t = Pid.t type size_t = Unsigned.size_t type ssize_t = Ssize.t type time_t = Time.t type useconds_t (** {3 Values representing POSIX arithmetic types} *) val clock_t : clock_t typ val dev_t : dev_t typ val ino_t : ino_t typ val mode_t : mode_t typ val nlink_t : nlink_t typ val off_t : off_t typ val pid_t : pid_t typ val size_t : size_t typ val ssize_t : ssize_t typ val time_t : time_t typ val useconds_t : useconds_t typ (* non-arithmetic types from *) (** {2 POSIX non-arithmetic types} *) type sigset_t (** {3 Values representing POSIX non-arithmetic types} *) val sigset_t : sigset_t typ ocaml-ctypes-0.7.0/src/ctypes/posix_types_stubs.c000066400000000000000000000044771274143137600222120ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #include "ctypes_primitives.h" #define _XOPEN_SOURCE 500 #include #include #include #include #include #if (!defined _WIN32 || defined __CYGWIN__) && !defined MINIOS #include #endif #include #include #define EXPOSE_TYPEINFO_COMMON(TYPENAME,STYPENAME) \ value ctypes_typeof_ ## TYPENAME(value unit) \ { \ enum ctypes_arithmetic_type underlying = \ CTYPES_CLASSIFY_ARITHMETIC_TYPE(STYPENAME); \ return Val_int(underlying); \ } #define EXPOSE_ALIGNMENT_COMMON(TYPENAME,STYPENAME) \ value ctypes_alignmentof_ ## TYPENAME(value unit) \ { \ struct s { char c; STYPENAME t; }; \ return Val_int(offsetof(struct s, t)); \ } #define EXPOSE_TYPESIZE_COMMON(TYPENAME,STYPENAME) \ value ctypes_sizeof_ ## TYPENAME(value unit) \ { \ return Val_int(sizeof(STYPENAME)); \ } #if !defined _WIN32 || defined __CYGWIN__ #define UNDERSCORE(X) X #else #define UNDERSCORE(X) _## X #endif #define EXPOSE_TYPEINFO(X) EXPOSE_TYPEINFO_COMMON(X, X) #define EXPOSE_TYPEINFO_S(X) EXPOSE_TYPEINFO_COMMON(X, UNDERSCORE(X)) #define EXPOSE_TYPESIZE(X) EXPOSE_TYPESIZE_COMMON(X, X) #define EXPOSE_TYPESIZE_S(X) EXPOSE_TYPESIZE_COMMON(X, UNDERSCORE(X)) #define EXPOSE_ALIGNMENT(X) EXPOSE_ALIGNMENT_COMMON(X, X) #define EXPOSE_ALIGNMENT_S(X) EXPOSE_ALIGNMENT_COMMON(X, UNDERSCORE(X)) EXPOSE_TYPEINFO(clock_t) EXPOSE_TYPEINFO_S(dev_t) EXPOSE_TYPEINFO_S(ino_t) EXPOSE_TYPEINFO_S(mode_t) EXPOSE_TYPEINFO_S(off_t) EXPOSE_TYPEINFO_S(pid_t) EXPOSE_TYPEINFO(ssize_t) EXPOSE_TYPEINFO(time_t) EXPOSE_TYPEINFO(useconds_t) #if !defined _WIN32 || defined __CYGWIN__ EXPOSE_TYPEINFO(nlink_t) #else /* the mingw port of fts uses an int for nlink_t */ EXPOSE_TYPEINFO_COMMON(nlink_t, int) #endif EXPOSE_TYPESIZE_S(sigset_t) EXPOSE_ALIGNMENT_S(sigset_t) ocaml-ctypes-0.7.0/src/ctypes/raw_pointer_stubs.c000066400000000000000000000027061274143137600221460ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #include #include #include #include "ctypes_managed_buffer_stubs.h" #include "ctypes_type_info_stubs.h" #include "ctypes_raw_pointer.h" /* memcpy : dst:fat_pointer -> src:fat_pointer -> size:int -> unit */ value ctypes_memcpy(value dst, value src, value size) { CAMLparam3(dst, src, size); memcpy(CTYPES_ADDR_OF_FATPTR(dst), CTYPES_ADDR_OF_FATPTR(src), Int_val(size)); CAMLreturn(Val_unit); } /* string_of_cstring : raw_ptr -> int -> string */ value ctypes_string_of_cstring(value p) { return caml_copy_string(CTYPES_ADDR_OF_FATPTR(p)); } /* string_of_array : fat_ptr -> len:int -> string */ value ctypes_string_of_array(value p, value vlen) { CAMLparam2(p, vlen); CAMLlocal1(dst); int len = Int_val(vlen); if (len < 0) caml_invalid_argument("ctypes_string_of_array"); dst = caml_alloc_string(len); memcpy(String_val(dst), CTYPES_ADDR_OF_FATPTR(p), len); CAMLreturn(dst); } /* cstring_of_string : string -> managed_buffer */ value ctypes_cstring_of_string(value s) { CAMLparam1(s); CAMLlocal1(buffer); int len = caml_string_length(s); buffer = ctypes_allocate(Val_int(1), 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-0.7.0/src/ctypes/signed.ml000066400000000000000000000055601274143137600200350ustar00rootroot00000000000000(* * 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_nativeint : nativeint -> t val to_nativeint : t -> nativeint 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 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 Int = struct module Basics = struct type t = int let add = ( + ) let sub = ( - ) let mul = ( * ) let div = ( / ) let rem = ( mod ) let max_int = Pervasives.max_int let min_int = Pervasives.min_int let logand = ( land ) let logor = ( lor ) let logxor = ( lxor ) let shift_left = ( lsl ) let shift_right = ( asr ) let shift_right_logical = ( lsr ) let of_int x = x let to_int x = x let of_string = int_of_string let to_string = string_of_int let zero = 0 let one = 1 let minus_one = -1 let lognot = lnot let succ = Pervasives.succ let pred = Pervasives.pred let compare = Pervasives.compare end include Basics module Infix = MakeInfix(Basics) let to_int64 = Int64.of_int let of_int64 = Int64.to_int let to_nativeint = Nativeint.of_int let of_nativeint = Nativeint.to_int let abs = Pervasives.abs let neg x = -x end module Int32 = struct include Int32 module Infix = MakeInfix(Int32) let of_nativeint = Nativeint.to_int32 let to_nativeint = Nativeint.of_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 int_size : unit -> int = "ctypes_uint_size" 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 SInt = (val pick ~size:(int_size ())) module Long = (val pick ~size:(long_size ())) module LLong = (val pick ~size:(llong_size ())) type sint = SInt.t type long = Long.t type llong = LLong.t ocaml-ctypes-0.7.0/src/ctypes/signed.mli000066400000000000000000000032151274143137600202010ustar00rootroot00000000000000(* * 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_nativeint : nativeint -> t (** Convert the given nativeint value to a signed integer. *) val to_nativeint : t -> nativeint (** Convert the given signed integer to a nativeint value. *) 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 Int : S with type t = int (** Signed integer type and 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 SInt : S (** C's signed 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 sint = SInt.t (** C's signed integer type. *) type long = Long.t (** The signed long integer type. *) type llong = LLong.t (** The signed long long integer type. *) ocaml-ctypes-0.7.0/src/ctypes/type_info_stubs.c000066400000000000000000000216031274143137600216060ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #if !__USE_MINGW_ANSI_STDIO && (defined(__MINGW32__) || defined(__MINGW64__)) #define __USE_MINGW_ANSI_STDIO 1 #endif #include #include #include #include #include #include #include #include #include "ctypes_type_info_stubs.h" #include "ctypes_unsigned_stubs.h" #include "ctypes_complex_stubs.h" #include "ctypes_raw_pointer.h" #include "ctypes_primitives.h" #if __USE_MINGW_ANSI_STDIO && defined(__MINGW64__) #define REAL_ARCH_INTNAT_PRINTF_FORMAT "ll" #else #define REAL_ARCH_INTNAT_PRINTF_FORMAT ARCH_INTNAT_PRINTF_FORMAT #endif /* Read a C value from a block of memory */ /* read : 'a prim -> fat_pointer -> 'a */ value ctypes_read(value prim_, value buffer_) { CAMLparam2(prim_, buffer_); CAMLlocal1(b); void *buf = CTYPES_ADDR_OF_FATPTR(buffer_); switch (Int_val(prim_)) { case Ctypes_Char: b = Val_int(*(unsigned char*)buf); break; case Ctypes_Schar: b = Val_int(*(signed char *)buf); break; case Ctypes_Uchar: b = ctypes_copy_uint8(*(unsigned char *)buf); break; case Ctypes_Bool: b = Val_bool(*(bool *)buf); break; case Ctypes_Short: b = Val_int(*(short *)buf); break; case Ctypes_Int: b = Val_int(*(int *)buf); break; case Ctypes_Long: b = ctypes_copy_long(*(long *)buf); break; case Ctypes_Llong: b = ctypes_copy_llong(*(long long *)buf); break; case Ctypes_Ushort: b = ctypes_copy_ushort(*(unsigned short *)buf); break; case Ctypes_Sint: b = ctypes_copy_sint(*(int *)buf); break; case Ctypes_Uint: b = ctypes_copy_uint(*(unsigned int *)buf); break; case Ctypes_Ulong: b = ctypes_copy_ulong(*(unsigned long *)buf); break; case Ctypes_Ullong: b = ctypes_copy_ullong(*(unsigned long long *)buf); break; case Ctypes_Size_t: b = ctypes_copy_size_t(*(size_t *)buf); break; case Ctypes_Int8_t: b = Val_int(*(int8_t *)buf); break; case Ctypes_Int16_t: b = Val_int(*(int16_t *)buf); break; case Ctypes_Int32_t: b = caml_copy_int32(*(int32_t *)buf); break; case Ctypes_Int64_t: b = caml_copy_int64(*(int64_t *)buf); break; case Ctypes_Uint8_t: b = ctypes_copy_uint8(*(uint8_t *)buf); break; case Ctypes_Uint16_t: b = ctypes_copy_uint16(*(uint16_t *)buf); break; case Ctypes_Uint32_t: b = ctypes_copy_uint32(*(uint32_t *)buf); break; case Ctypes_Uint64_t: b = ctypes_copy_uint64(*(uint64_t *)buf); break; case Ctypes_Camlint: b = Val_int(*(intnat *)buf); break; case Ctypes_Nativeint: b = caml_copy_nativeint(*(intnat *)buf); break; case Ctypes_Float: b = caml_copy_double(*(float *)buf); break; case Ctypes_Double: b = caml_copy_double(*(double *)buf); break; case Ctypes_Complex32: b = ctypes_copy_float_complex(*(float complex *)buf); break; case Ctypes_Complex64: b = ctypes_copy_double_complex(*(double complex *)buf); break; default: assert(0); } CAMLreturn(b); } /* Read a C value from a block of memory */ /* write : 'a prim -> 'a -> fat_pointer -> unit */ value ctypes_write(value prim_, value v, value buffer_) { CAMLparam3(prim_, v, buffer_); void *buf = CTYPES_ADDR_OF_FATPTR(buffer_); switch (Int_val(prim_)) { case Ctypes_Char: *(unsigned char *)buf = Int_val(v); break; case Ctypes_Schar: *(signed char *)buf = Int_val(v); break; case Ctypes_Uchar: *(unsigned char *)buf = Uint8_val(v); break; case Ctypes_Bool: *(bool *)buf = Bool_val(v); break; case Ctypes_Short: *(short *)buf = Int_val(v); break; case Ctypes_Int: *(int *)buf = Int_val(v); break; case Ctypes_Long: *(long *)buf = ctypes_long_val(v); break; case Ctypes_Llong: *(long long *)buf = ctypes_llong_val(v); break; case Ctypes_Ushort: *(unsigned short *)buf = ctypes_ushort_val(v); break; case Ctypes_Sint: *(int *)buf = ctypes_sint_val(v); break; case Ctypes_Uint: *(unsigned int *)buf = ctypes_uint_val(v); break; case Ctypes_Ulong: *(unsigned long *)buf = ctypes_ulong_val(v); break; case Ctypes_Ullong: *(unsigned long long *)buf = ctypes_ullong_val(v); break; case Ctypes_Size_t: *(size_t *)buf = ctypes_size_t_val(v); break; case Ctypes_Int8_t: *(int8_t *)buf = Int_val(v); break; case Ctypes_Int16_t: *(int16_t *)buf = Int_val(v); break; case Ctypes_Int32_t: *(int32_t *)buf = Int32_val(v); break; case Ctypes_Int64_t: *(int64_t *)buf = Int64_val(v); break; case Ctypes_Uint8_t: *(uint8_t *)buf = Uint8_val(v); break; case Ctypes_Uint16_t: *(uint16_t *)buf = Uint16_val(v); break; case Ctypes_Uint32_t: *(uint32_t *)buf = Uint32_val(v); break; case Ctypes_Uint64_t: *(uint64_t *)buf = Uint64_val(v); break; case Ctypes_Camlint: *(intnat *)buf = Int_val(v); break; case Ctypes_Nativeint: *(intnat *)buf = Nativeint_val(v); break; case Ctypes_Float: *(float *)buf = Double_val(v); break; case Ctypes_Double: *(double *)buf = Double_val(v); break; case Ctypes_Complex32: *(float complex *)buf = ctypes_float_complex_val(v); break; case Ctypes_Complex64: *(double complex *)buf = ctypes_double_complex_val(v); break; default: assert(0); } CAMLreturn(Val_unit); } /* Format a C value */ /* string_of_prim : 'a prim -> 'a -> string */ value ctypes_string_of_prim(value prim_, value v) { CAMLparam2(prim_, v); CAMLlocal1(s); char buf[64]; int len = 0; switch (Int_val(prim_)) { case Ctypes_Char: len = snprintf(buf, sizeof buf, "'%c'", Int_val(v)); break; case Ctypes_Schar: len = snprintf(buf, sizeof buf, "%d", Int_val(v)); break; case Ctypes_Uchar: len = snprintf(buf, sizeof buf, "%d", (unsigned char)Uint8_val(v)); break; case Ctypes_Bool: len = snprintf(buf, sizeof buf, "%s", Bool_val(v) ? "true" : "false"); break; case Ctypes_Short: len = snprintf(buf, sizeof buf, "%hd", (short)Int_val(v)); break; case Ctypes_Int: len = snprintf(buf, sizeof buf, "%d", Int_val(v)); break; case Ctypes_Long: len = snprintf(buf, sizeof buf, "%ld", (long)ctypes_long_val(v)); break; case Ctypes_Llong: len = snprintf(buf, sizeof buf, "%lld", (long long)ctypes_llong_val(v)); break; case Ctypes_Ushort: len = snprintf(buf, sizeof buf, "%hu", (unsigned short)ctypes_ushort_val(v)); break; case Ctypes_Sint: len = snprintf(buf, sizeof buf, "%d", ctypes_sint_val(v)); break; case Ctypes_Uint: len = snprintf(buf, sizeof buf, "%u", (unsigned)ctypes_uint_val(v)); break; case Ctypes_Ulong: len = snprintf(buf, sizeof buf, "%lu", (unsigned long)ctypes_ulong_val(v)); break; case Ctypes_Ullong: len = snprintf(buf, sizeof buf, "%llu", (unsigned long long)ctypes_ullong_val(v)); break; case Ctypes_Size_t: len = snprintf(buf, sizeof buf, "%zu", (size_t)ctypes_size_t_val(v)); break; case Ctypes_Int8_t: len = snprintf(buf, sizeof buf, "%" PRId8, (int8_t)Int_val(v)); break; case Ctypes_Int16_t: len = snprintf(buf, sizeof buf, "%" PRId16, (int16_t)Int_val(v)); break; case Ctypes_Int32_t: len = snprintf(buf, sizeof buf, "%" PRId32, Int32_val(v)); break; case Ctypes_Int64_t: len = snprintf(buf, sizeof buf, "%" PRId64, (int64_t)Int64_val(v)); break; case Ctypes_Uint8_t: len = snprintf(buf, sizeof buf, "%" PRIu8, Uint8_val(v)); break; case Ctypes_Uint16_t: len = snprintf(buf, sizeof buf, "%" PRIu16, Uint16_val(v)); break; case Ctypes_Uint32_t: len = snprintf(buf, sizeof buf, "%" PRIu32, Uint32_val(v)); break; case Ctypes_Uint64_t: len = snprintf(buf, sizeof buf, "%" PRIu64, Uint64_val(v)); break; case Ctypes_Camlint: len = snprintf(buf, sizeof buf, "%" REAL_ARCH_INTNAT_PRINTF_FORMAT "d", (intnat)Int_val(v)); break; case Ctypes_Nativeint: len = snprintf(buf, sizeof buf, "%" REAL_ARCH_INTNAT_PRINTF_FORMAT "d", (intnat)Nativeint_val(v)); break; case Ctypes_Float: len = snprintf(buf, sizeof buf, "%.12g", Double_val(v)); break; case Ctypes_Double: len = snprintf(buf, sizeof buf, "%.12g", Double_val(v)); break; case Ctypes_Complex32: { float complex c = ctypes_float_complex_val(v); len = snprintf(buf, sizeof buf, "%.12g+%.12gi", crealf(c), cimagf(c)); break; } case Ctypes_Complex64: { double complex c = ctypes_double_complex_val(v); len = snprintf(buf, sizeof buf, "%.12g+%.12gi", creal(c), cimag(c)); break; } default: assert(0); } s = caml_alloc_string(len); memcpy(String_val(s), buf, len); CAMLreturn (s); } /* read_pointer : fat_pointer -> raw_pointer */ value ctypes_read_pointer(value src_) { CAMLparam1(src_); void *src = CTYPES_ADDR_OF_FATPTR(src_); CAMLreturn(CTYPES_FROM_PTR(*(void **)src)); } /* write_pointer : fat_pointer -> dst:fat_pointer -> unit */ value ctypes_write_pointer(value p_, value dst_) { CAMLparam2(p_, dst_); void *dst = CTYPES_ADDR_OF_FATPTR(dst_); *(void **)dst = CTYPES_ADDR_OF_FATPTR(p_); CAMLreturn(Val_unit); } /* string_of_pointer : fat_pointer -> string */ value ctypes_string_of_pointer(value p_) { char buf[32]; CAMLparam1(p_); snprintf(buf, sizeof buf, "%p", CTYPES_ADDR_OF_FATPTR(p_)); CAMLreturn (caml_copy_string(buf)); } ocaml-ctypes-0.7.0/src/ctypes/unsigned.ml000066400000000000000000000172231274143137600203770ustar00rootroot00000000000000(* * 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_int64 : int64 -> t val to_int64 : t -> int64 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_int64 : int64 -> t = "ctypes_uint8_of_int64" external to_int64 : t -> int64 = "ctypes_uint8_to_int64" 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_int64 : int64 -> t = "ctypes_uint16_of_int64" external to_int64 : t -> int64 = "ctypes_uint16_to_int64" 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_int64 : int64 -> t = "ctypes_uint32_of_int64" external to_int64 : t -> int64 = "ctypes_uint32_to_int64" 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_uint64_to_int64" 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_int64 : int64 -> t = "ctypes_uint64_of_int64" external to_int64 : t -> int64 = "ctypes_uint64_to_int64" 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) 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-0.7.0/src/ctypes/unsigned.mli000066400000000000000000000105231274143137600205440ustar00rootroot00000000000000(* * 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_int64 : int64 -> t (** Convert the given int64 value to an unsigned integer. *) val to_int64 : t -> int64 (** Convert the given unsigned integer value to an int64. *) 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-0.7.0/src/ctypes/unsigned_stubs.c000066400000000000000000000303611274143137600214270ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #if !__USE_MINGW_ANSI_STDIO && (defined(__MINGW32__) || defined(__MINGW64__)) #define __USE_MINGW_ANSI_STDIO 1 #endif #include #include #include #include #include #include #include #include #include #include "ctypes_unsigned_stubs.h" #define Uint_custom_val(TYPE, V) (*((TYPE *) Data_custom_val(V))) #define TYPE(SIZE) uint ## SIZE ## _t #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(TYPE(SIZE), a) \ OP Uint_custom_val(TYPE(SIZE), 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 intnat uint ## BITS ## _hash(value v) \ { \ return Uint_custom_val(TYPE(BITS), v); \ } \ \ static void uint ## BITS ## _serialize(value v, \ uintnat *wsize_32, \ uintnat *wsize_64) \ { \ caml_serialize_int_ ## BYTES(Uint_custom_val(TYPE(BITS), v)); \ *wsize_32 = *wsize_64 = BYTES; \ } \ \ static uintnat 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(TYPE(BITS), 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(TYPE(BITS), 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_int64 : int64 -> t */ \ value ctypes_uint ## BITS ## _of_int64(value a) \ { \ return ctypes_copy_uint ## BITS(Int64_val(a)); \ } \ \ /* to_int64 : t -> int64 */ \ value ctypes_uint ## BITS ## _to_int64(value a) \ { \ return caml_copy_int64(Uint_custom_val(TYPE(BITS), a)); \ } \ \ /* of_string : string -> t */ \ value ctypes_uint ## BITS ## _of_string(value a) \ { \ 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_uintptr_t_size (value _) { return Val_int(sizeof (uintptr_t)); } value ctypes_intptr_t_size (value _) { return Val_int(sizeof (intptr_t)); } value ctypes_ptrdiff_t_size (value _) { return Val_int(sizeof (ptrdiff_t)); } ocaml-ctypes-0.7.0/src/discover/000077500000000000000000000000001274143137600165335ustar00rootroot00000000000000ocaml-ctypes-0.7.0/src/discover/commands.ml000066400000000000000000000041231274143137600206660ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) let unwind_protect ~cleanup f x = let rv = try f x with exn -> begin cleanup x; raise exn end in begin cleanup x; rv end let with_open_output_file ~filename f = unwind_protect ~cleanup:close_out f (open_out filename) let with_open_input_file ~filename f = unwind_protect ~cleanup:close_in f (open_in filename) let file_contents ~filename : string = with_open_input_file ~filename (fun file -> let () = set_binary_mode_in file true in let size = in_channel_length file in let buf = Bytes.create size in let () = really_input file buf 0 size in buf) type command_output = { status: int; stdout: string; stderr: string; } let temp_dir = "." (* The use of [unixify] below is not ideal: it's a workaround for the Windows build, which uses a mixture of Windows- and Unix-style paths due to using MinGW to compile OCaml and Bash for the shell. *) let unixify = Str.(global_replace (regexp "\\\\") "/") let shell_command_results command = let stdout_filename = Filename.temp_file ~temp_dir "ctypes_config" ".stdout" in let stderr_filename = Filename.temp_file ~temp_dir "ctypes_config" ".stderr" in unwind_protect (fun () -> let full_command = Printf.sprintf "(%s) > %s 2> %s" command (unixify stdout_filename) (unixify stderr_filename) in let status = Sys.command full_command in let stdout = file_contents stdout_filename in let stderr = file_contents stderr_filename in { status; stdout; stderr } ) () ~cleanup:begin fun () -> Sys.remove stdout_filename; Sys.remove stderr_filename; end let command fmt = Printf.ksprintf shell_command_results fmt let command_output' command = (shell_command_results command).stdout let command_succeeds' command = (shell_command_results command).status = 0 let command_succeeds fmt = Printf.ksprintf command_succeeds' fmt ocaml-ctypes-0.7.0/src/discover/commands.mli000066400000000000000000000010341274143137600210350ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) val unwind_protect : cleanup:('a -> 'c) -> ('a -> 'b) -> 'a -> 'b val with_open_output_file : filename:string -> (out_channel -> 'a) -> 'a val file_contents : filename:string -> string type command_output = { status: int; stdout: string; stderr: string; } val command : ('a, unit, string, command_output) format4 -> 'a val command_succeeds : ('a, unit, string, bool) format4 -> 'a ocaml-ctypes-0.7.0/src/discover/determine_as_needed_flags.sh000077500000000000000000000003611274143137600242110ustar00rootroot00000000000000#!/bin/sh touch as_needed_test.ml if ocamlopt -shared -cclib -Wl,--no-as-needed as_needed_test.ml -o as_needed_test.cmxs 2>/dev/null then echo 'as_needed_flags=-Wl,--no-as-needed' else echo 'as_needed_flags=' fi rm as_needed_test.* ocaml-ctypes-0.7.0/src/discover/discover.ml000066400000000000000000000226401274143137600207070ustar00rootroot00000000000000(* Copyright (C) 2015 Jeremy Yallop * 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 search_paths = List.map (fun dir -> (dir ^ "/include", dir ^ "/lib")) [ "/usr"; "/usr/local"; "/opt"; "/opt/local"; "/sw"; "/mingw"; ] let is_win = Sys.os_type = "Win32" let path_sep = if is_win then ";" else ":" let split_path = Str.(split (regexp (path_sep ^ "+"))) let ( // ) = Filename.concat (** See the comment in commands.ml *) let unixify = Str.(global_replace (regexp "\\") "/") (* +-----------------------------------------------------------------+ | Test codes | +-----------------------------------------------------------------+ *) let libffi_caml_code = " external test : unit -> unit = \"ffi_test\" let () = test () " let libffi_stub_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 is_macports = ref false let homebrew_prefix = ref "/usr/local" let macports_prefix = ref "/opt/local" (* 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 silent_remove filename = try Sys.remove filename with exn -> () let test_code opt lib stub_code caml_code = let open Commands in let stem f = Filename.(chop_extension (basename f)) in let stub_filename = unixify (Filename.temp_file "ctypes_libffi" ".c") in let caml_filename = unixify (Filename.temp_file "ctypes_libffi" ".ml") in with_open_output_file ~filename:stub_filename begin fun stubfd -> with_open_output_file ~filename:caml_filename begin fun camlfd -> unwind_protect (fun () -> output_string stubfd stub_code; output_string camlfd caml_code; Commands.command_succeeds "%s -custom %s %s %s %s 1>&2" !ocamlc (String.concat " " (List.map (sprintf "-ccopt %s") opt)) (unixify (Filename.quote stub_filename)) (unixify (Filename.quote caml_filename)) (String.concat " " (List.map (sprintf "-cclib %s") lib))) () ~cleanup:begin fun () -> let caml_stem = unixify (stem caml_filename) in silent_remove (unixify (stem stub_filename ^ !ext_obj)); silent_remove !exec_name; silent_remove (caml_stem ^ ".cmi"); silent_remove (caml_stem ^ ".cmo"); end end end let test_feature name test = begin fprintf stderr "testing for %s:%!" name; if test () then begin fprintf stderr " %s available\n%!" (String.make (34 - String.length name) '.'); true end else begin fprintf stderr " %s unavailable\n%!" (String.make (34 - String.length name) '.'); false end end (* +-----------------------------------------------------------------+ | pkg-config | +-----------------------------------------------------------------+ *) let split = Str.(split (regexp " +")) let brew_libffi_version flags = match Commands.command "brew ls libffi --versions | awk '{print $NF}'" with { Commands.status; stderr } when status <> 0 -> ksprintf failwith "brew ls libffi failed: %s" stderr | { Commands.stdout = "" } -> failwith "You need to 'brew install libffi' to get a suitably up-to-date version" | { Commands.stdout } -> String.trim stdout let pkg_config flags = let output = if !is_homebrew then Commands.command "env PKG_CONFIG_PATH=%s/Cellar/libffi/%s/lib/pkgconfig %s/bin/pkg-config %s" !homebrew_prefix (brew_libffi_version ()) !homebrew_prefix flags else Commands.command "pkg-config %s" flags in match output with { Commands.status } when status <> 0 -> None | { Commands.stdout } -> Some (split (String.trim stdout)) let pkg_config_flags name = match (ksprintf pkg_config "--cflags %s" name, ksprintf pkg_config "--libs %s" name) with Some opt, Some lib -> Some (opt, lib) | _ -> None let get_homebrew_prefix () = match Commands.command "brew --prefix" with { Commands.status } when status <> 0 -> raise Exit | { Commands.stdout } -> String.trim stdout let search_libffi_header () = match search_header "ffi.h" with | Some (dir_i, dir_l) -> (["-I" ^ dir_i], ["-L" ^ dir_l; "-lffi"]) | None -> ([], ["-lffi"]) let test_libffi setup_data have_pkg_config = let get var = try Some (split (Sys.getenv var)) with Not_found -> None in let opt, lib = match get "LIBFFI_CFLAGS", get "LIBFFI_LIBS" with | Some opt, Some lib -> (opt, lib) | envopt, envlib -> let opt, lib = if not have_pkg_config then search_libffi_header () else match pkg_config_flags "libffi" with | Some (pkgopt, pkglib) -> (pkgopt, pkglib) | None -> search_libffi_header () in match envopt, envlib, opt, lib with | Some opt, Some lib, _ , _ | Some opt, None , _ , lib | None , Some lib, opt, _ | None , None , opt, lib -> opt, lib in setup_data := ("libffi_opt", opt) :: ("libffi_lib", lib) :: !setup_data; let libffi_available = test_code opt lib libffi_stub_code libffi_caml_code in setup_data := ("libffi_available", [string_of_bool libffi_available]) :: !setup_data; libffi_available (* Test for pkg-config. If we are on MacOS X, we need the latest pkg-config * from either Homebrew or MacPorts *) let have_pkg_config is_homebrew is_macports homebrew_prefix macports_prefix = if is_homebrew then begin (* Look in `brew for the right pkg-config *) homebrew_prefix := get_homebrew_prefix (); test_feature "pkg-config" (fun () -> Commands.command_succeeds "%s/bin/pkg-config --version" !homebrew_prefix) end else if is_macports then begin (* Look in macports for the right pkg-config *) test_feature "macports" (fun () -> Commands.command_succeeds "%s/bin/port version" !macports_prefix) end else begin test_feature "pkg-config" (fun () -> Commands.command_succeeds "pkg-config --version") end 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"; ] (* +-----------------------------------------------------------------+ | Entry point | +-----------------------------------------------------------------+ *) let () = Arg.parse args ignore "check for external C libraries and available features\noptions are:"; (* Test for MacOS X Homebrew. *) is_homebrew := test_feature "brew" (fun () -> (Commands.command "brew ls --versions").Commands.stdout <> ""); (* Test for MacOS X MacPorts. *) is_macports := test_feature "MacPorts" (fun () -> Commands.command_succeeds "port info libffi"); let have_pkg_config = have_pkg_config !is_homebrew !is_macports homebrew_prefix macports_prefix in let setup_data = ref [] in let have_libffi = test_feature "libffi" (fun () -> test_libffi setup_data have_pkg_config) in if not have_pkg_config then fprintf stderr "Warning: the 'pkg-config' command is not available.\n"; if not have_libffi then fprintf stderr "Warning: libffi is not available.\n"; ListLabels.iter !setup_data ~f:(fun (name, args) -> Printf.printf "%s=%s\n" name (String.concat " " args)) ocaml-ctypes-0.7.0/tests/000077500000000000000000000000001274143137600152705ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/bench-micro/000077500000000000000000000000001274143137600174565ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/bench-micro/.merlin000066400000000000000000000000541274143137600207440ustar00rootroot00000000000000PKG ctypes PKG core PKG core_bench S . B . ocaml-ctypes-0.7.0/tests/bench-micro/Makefile000066400000000000000000000031761274143137600211250ustar00rootroot00000000000000.PHONY: build bench clean CFLAGS=-Wall -O2 CTYPES_INCLUDE=`ocamlfind query ctypes`/.. BENCH_MICRO_STUBS=bench_micro_stubs.h bench_micro_lib.c bench_micro_stubs.c BENCH_MICRO_GENERATED=bench_micro_generated_stubs.c bench_micro_generated.ml build: bench_micro bench: build LD_LIBRARY_PATH=. ./bench_micro -ascii -q 10 +time +cycles \ -clear-columns -no-compactions -v -ci-absolute -all-values \ -overheads -save > summary.txt ocaml process_summary.ml summary.txt gnuplot bench_micro.gnuplot gnuplot bench_micro_interpreted.gnuplot libbench_micro.so: $(BENCH_MICRO_STUBS) gcc -o libbench_micro.so -shared -fPIC $(CFLAGS) bench_micro_stubs.c bench_micro_gen: $(BENCH_MICRO_STUBS) bench_micro_bindings.ml bench_micro_gen.ml ocamlfind opt -o bench_micro_gen \ -linkpkg -package ctypes.foreign,ctypes.stubs \ bench_micro_lib.c bench_micro_stubs.c \ bench_micro_bindings.ml bench_micro_gen.ml bench_micro_generated.ml bench_micro_generated_stubs.c: bench_micro_gen ./bench_micro_gen bench_micro: $(BENCH_MICRO_STUBS) $(BENCH_MICRO_GENERATED) libbench_micro.so bench_micro_bindings.ml bench_micro.ml ocamlfind opt -o bench_micro $(patsubst %,-ccopt %,$(CFLAGS)) \ -cclib -lbench_micro -cclib -L. \ -thread -linkpkg -I $(CTYPES_INCLUDE) \ -package ctypes.foreign,ctypes.stubs,core,core_bench \ bench_micro_lib.c bench_micro_stubs.c \ bench_micro_generated_stubs.c \ bench_micro_bindings.ml bench_micro_generated.ml bench_micro.ml clean: rm -f bench_micro bench_micro_gen libbench_micro.so rm -f bench_micro_generated.ml bench_micro_generated_stubs.c rm -f bench_micro.eps bench_micro_interpreted.eps rm -f *.o *.cmo *.cmx *.cmi ocaml-ctypes-0.7.0/tests/bench-micro/bench_micro.gnuplot000066400000000000000000000006241274143137600233420ustar00rootroot00000000000000set terminal eps set output 'bench_micro.eps' set key left top set xlabel "Arity" set autoscale set yrange [0:] set ylabel "Time (ns)" #set title "Mean FFI Call Latency by Arity" set style data linespoints plot "staged_functor.txt" using 1:2 title "Cmeleon Staged", \ "traditional.txt" using 1:2 title "OCaml Manual", \ "cowboy.txt" using 1:2 title "OCaml Expert" ocaml-ctypes-0.7.0/tests/bench-micro/bench_micro.ml000066400000000000000000000073721274143137600222710ustar00rootroot00000000000000open Core.Std open Core_bench.Std module Bindings = Bench_micro_bindings module Make(Bench : Bindings.API with type 'a fn = 'a) = struct let call = function | 0 -> Staged.stage (fun () -> ignore (Bench.f_i0 ())) | 1 -> Staged.stage (fun () -> ignore (Bench.f_i1 1)) | 2 -> Staged.stage (fun () -> ignore (Bench.f_i2 1 2)) | 3 -> Staged.stage (fun () -> ignore (Bench.f_i3 1 2 3)) | 4 -> Staged.stage (fun () -> ignore (Bench.f_i4 1 2 3 4)) | 5 -> Staged.stage (fun () -> ignore (Bench.f_i5 1 2 3 4 5)) | 6 -> Staged.stage (fun () -> ignore (Bench.f_i6 1 2 3 4 5 6)) | 7 -> Staged.stage (fun () -> ignore (Bench.f_i7 1 2 3 4 5 6 7)) | 8 -> Staged.stage (fun () -> ignore (Bench.f_i8 1 2 3 4 5 6 7 8)) | 9 -> Staged.stage (fun () -> ignore (Bench.f_i9 1 2 3 4 5 6 7 8 9)) | 10-> Staged.stage (fun () -> ignore (Bench.f_i10 1 2 3 4 5 6 7 8 9 10)) | 11-> Staged.stage (fun () -> ignore (Bench.f_i11 1 2 3 4 5 6 7 8 9 10 11)) | 12-> Staged.stage (fun () -> ignore (Bench.f_i12 1 2 3 4 5 6 7 8 9 10 11 12)) | 13-> Staged.stage (fun () -> ignore (Bench.f_i13 1 2 3 4 5 6 7 8 9 10 11 12 13)) | 14-> Staged.stage (fun () -> ignore (Bench.f_i14 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) | 15-> Staged.stage (fun () -> ignore (Bench.f_i15 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) | _ -> assert false end module Interpreted_local = Make(Bindings.Make(Bindings.Interpreter_local)) module Interpreted_shared = Make(Bindings.Make(Bindings.Interpreter_shared)) module Staged_bench = Bindings.Make(Bench_micro_generated) module Staged_functor = Make(Staged_bench) module Staged_no_functor = struct let call = function | 0 -> Staged.stage (fun () -> ignore (Staged_bench.f_i0 ())) | 1 -> Staged.stage (fun () -> ignore (Staged_bench.f_i1 1)) | 2 -> Staged.stage (fun () -> ignore (Staged_bench.f_i2 1 2)) | 3 -> Staged.stage (fun () -> ignore (Staged_bench.f_i3 1 2 3)) | 4 -> Staged.stage (fun () -> ignore (Staged_bench.f_i4 1 2 3 4)) | 5 -> Staged.stage (fun () -> ignore (Staged_bench.f_i5 1 2 3 4 5)) | 6 -> Staged.stage (fun () -> ignore (Staged_bench.f_i6 1 2 3 4 5 6)) | 7 -> Staged.stage (fun () -> ignore (Staged_bench.f_i7 1 2 3 4 5 6 7)) | 8 -> Staged.stage (fun () -> ignore (Staged_bench.f_i8 1 2 3 4 5 6 7 8)) | 9 -> Staged.stage (fun () -> ignore (Staged_bench.f_i9 1 2 3 4 5 6 7 8 9)) | 10-> Staged.stage (fun () -> ignore (Staged_bench.f_i10 1 2 3 4 5 6 7 8 9 10)) | 11-> Staged.stage (fun () -> ignore (Staged_bench.f_i11 1 2 3 4 5 6 7 8 9 10 11)) | 12-> Staged.stage (fun () -> ignore (Staged_bench.f_i12 1 2 3 4 5 6 7 8 9 10 11 12)) | 13-> Staged.stage (fun () -> ignore (Staged_bench.f_i13 1 2 3 4 5 6 7 8 9 10 11 12 13)) | 14-> Staged.stage (fun () -> ignore (Staged_bench.f_i14 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) | 15-> Staged.stage (fun () -> ignore (Staged_bench.f_i15 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) | _ -> assert false end module Traditional = Make(Bindings.Traditional) module Cowboy = Make(Bindings.Cowboy) let zero_to_nine = [0;1;2;3;4;5;6;7;8;9;10;11;12;13;14;15] let () = Command.run (Bench.make_command [ Bench.Test.create_indexed ~name:"interpreted_local" ~args:zero_to_nine Interpreted_local.call; Bench.Test.create_indexed ~name:"interpreted_shared" ~args:zero_to_nine Interpreted_local.call; Bench.Test.create_indexed ~name:"staged_functor" ~args:zero_to_nine Staged_functor.call; Bench.Test.create_indexed ~name:"staged_no_functor" ~args:zero_to_nine Staged_no_functor.call; Bench.Test.create_indexed ~name:"traditional" ~args:zero_to_nine Traditional.call; Bench.Test.create_indexed ~name:"cowboy" ~args:zero_to_nine Cowboy.call; ]) ocaml-ctypes-0.7.0/tests/bench-micro/bench_micro_bindings.ml000066400000000000000000000164151274143137600241440ustar00rootroot00000000000000module type FOREIGN = sig type 'a fn val foreign : string -> ('a -> 'b) Ctypes.fn -> ('a -> 'b) fn end type int5 = int -> int -> int -> int -> int -> int type int10 = int -> int -> int -> int -> int -> int5 module type API = sig type 'a fn val f_i0 : (unit -> int) fn val f_i1 : (int -> int) fn val f_i2 : (int -> int -> int) fn val f_i3 : (int -> int -> int -> int) fn val f_i4 : (int -> int -> int -> int -> int) fn val f_i5 : int5 fn val f_i6 : (int -> int5) fn val f_i7 : (int -> int -> int5) fn val f_i8 : (int -> int -> int -> int5) fn val f_i9 : (int -> int -> int -> int -> int5) fn val f_i10: int10 fn val f_i11: (int -> int10) fn val f_i12: (int -> int -> int10) fn val f_i13: (int -> int -> int -> int10) fn val f_i14: (int -> int -> int -> int -> int10) fn val f_i15: (int -> int -> int -> int -> int -> int10) fn end module Interpreter_local : FOREIGN with type 'a fn = 'a = struct type 'a fn = 'a external f_i0_ptr : unit -> nativeint = "f_i0_ptr" external f_i1_ptr : unit -> nativeint = "f_i1_ptr" external f_i2_ptr : unit -> nativeint = "f_i2_ptr" external f_i3_ptr : unit -> nativeint = "f_i3_ptr" external f_i4_ptr : unit -> nativeint = "f_i4_ptr" external f_i5_ptr : unit -> nativeint = "f_i5_ptr" external f_i6_ptr : unit -> nativeint = "f_i6_ptr" external f_i7_ptr : unit -> nativeint = "f_i7_ptr" external f_i8_ptr : unit -> nativeint = "f_i8_ptr" external f_i9_ptr : unit -> nativeint = "f_i9_ptr" external f_i10_ptr: unit -> nativeint = "f_i10_ptr" external f_i11_ptr: unit -> nativeint = "f_i11_ptr" external f_i12_ptr: unit -> nativeint = "f_i12_ptr" external f_i13_ptr: unit -> nativeint = "f_i13_ptr" external f_i14_ptr: unit -> nativeint = "f_i14_ptr" external f_i15_ptr: unit -> nativeint = "f_i15_ptr" let foreign name fn = let f_addr = match name with | "f_i0" -> f_i0_ptr () | "f_i1" -> f_i1_ptr () | "f_i2" -> f_i2_ptr () | "f_i3" -> f_i3_ptr () | "f_i4" -> f_i4_ptr () | "f_i5" -> f_i5_ptr () | "f_i6" -> f_i6_ptr () | "f_i7" -> f_i7_ptr () | "f_i8" -> f_i8_ptr () | "f_i9" -> f_i9_ptr () | "f_i10"-> f_i10_ptr () | "f_i11"-> f_i11_ptr () | "f_i12"-> f_i12_ptr () | "f_i13"-> f_i13_ptr () | "f_i14"-> f_i14_ptr () | "f_i15"-> f_i15_ptr () | _ -> assert false in Ctypes.(coerce (ptr void) (Foreign.funptr fn) (ptr_of_raw_address f_addr)) end module Interpreter_shared : FOREIGN with type 'a fn = 'a = struct type 'a fn = 'a let foreign name fn = Foreign.foreign name fn end module Make (F : FOREIGN) : API with type 'a fn = 'a F.fn = struct open Ctypes type 'a fn = 'a F.fn let plus_int5 r = int @-> int @-> int @-> int @-> int @-> r let int5 = plus_int5 (returning int) let int10= plus_int5 int5 let f_i0 = F.foreign "f_i0" @@ void @-> returning int let f_i1 = F.foreign "f_i1" @@ int @-> returning int let f_i2 = F.foreign "f_i2" @@ int @-> int @-> returning int let f_i3 = F.foreign "f_i3" @@ int @-> int @-> int @-> returning int let f_i4 = F.foreign "f_i4" @@ int @-> int @-> int @-> int @-> returning int let f_i5 = F.foreign "f_i5" @@ int5 let f_i6 = F.foreign "f_i6" @@ int @-> int5 let f_i7 = F.foreign "f_i7" @@ int @-> int @-> int5 let f_i8 = F.foreign "f_i8" @@ int @-> int @-> int @-> int5 let f_i9 = F.foreign "f_i9" @@ int @-> int @-> int @-> int @-> int5 let f_i10= F.foreign "f_i10"@@ int10 let f_i11= F.foreign "f_i11"@@ int @-> int10 let f_i12= F.foreign "f_i12"@@ int @-> int @-> int10 let f_i13= F.foreign "f_i13"@@ int @-> int @-> int @-> int10 let f_i14= F.foreign "f_i14"@@ int @-> int @-> int @-> int @-> int10 let f_i15= F.foreign "f_i15"@@ int @-> int @-> int @-> int @-> int @-> int10 end module Traditional : API with type 'a fn = 'a = struct type 'a fn = 'a external f_i0 : unit -> int = "f_i0_caml" external f_i1 : int -> int = "f_i1_caml" external f_i2 : int -> int -> int = "f_i2_caml" external f_i3 : int -> int -> int -> int = "f_i3_caml" external f_i4 : int -> int -> int -> int -> int = "f_i4_caml" external f_i5 : int -> int -> int -> int -> int -> int = "f_i5_caml" external f_i6 : int -> int -> int -> int -> int -> int -> int = "f_i6_caml_byte" "f_i6_caml" external f_i7 : int -> int -> int -> int -> int -> int -> int -> int = "f_i7_caml_byte" "f_i7_caml" external f_i8 : int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i8_caml_byte" "f_i8_caml" external f_i9 : int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i9_caml_byte" "f_i9_caml" external f_i10: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i10_caml_byte" "f_i10_caml" external f_i11: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i11_caml_byte" "f_i11_caml" external f_i12: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i12_caml_byte" "f_i12_caml" external f_i13: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i13_caml_byte" "f_i13_caml" external f_i14: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i14_caml_byte" "f_i14_caml" external f_i15: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i15_caml_byte" "f_i15_caml" end module Cowboy : API with type 'a fn = 'a = struct type 'a fn = 'a external f_i0 : unit -> int = "f_i0_cowboy" "noalloc" external f_i1 : int -> int = "f_i1_cowboy" "noalloc" external f_i2 : int -> int -> int = "f_i2_cowboy" "noalloc" external f_i3 : int -> int -> int -> int = "f_i3_cowboy" "noalloc" external f_i4 : int -> int -> int -> int -> int = "f_i4_cowboy" "noalloc" external f_i5 : int -> int -> int -> int -> int -> int = "f_i5_cowboy" "noalloc" external f_i6 : int -> int -> int -> int -> int -> int -> int = "f_i6_cowboy_byte" "f_i6_cowboy" "noalloc" external f_i7 : int -> int -> int -> int -> int -> int -> int -> int = "f_i7_cowboy_byte" "f_i7_cowboy" "noalloc" external f_i8 : int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i8_cowboy_byte" "f_i8_cowboy" "noalloc" external f_i9 : int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i9_cowboy_byte" "f_i9_cowboy" "noalloc" external f_i10: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i10_cowboy_byte" "f_i10_cowboy" "noalloc" external f_i11: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i11_cowboy_byte" "f_i11_cowboy" "noalloc" external f_i12: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i12_cowboy_byte" "f_i12_cowboy" "noalloc" external f_i13: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i13_cowboy_byte" "f_i13_cowboy" "noalloc" external f_i14: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i14_cowboy_byte" "f_i14_cowboy" "noalloc" external f_i15: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "f_i15_cowboy_byte" "f_i15_cowboy" "noalloc" end ocaml-ctypes-0.7.0/tests/bench-micro/bench_micro_gen.ml000066400000000000000000000007451274143137600231170ustar00rootroot00000000000000let with_formatter ~path f = let chan = open_out path in f Format.(formatter_of_out_channel chan); close_out chan ;; with_formatter ~path:"bench_micro_generated_stubs.c" (fun fmt -> Format.fprintf fmt "#include \"bench_micro_stubs.h\"\n\n"; Cstubs.write_c fmt ~prefix:"bench_micro" (module Bench_micro_bindings.Make)); with_formatter ~path:"bench_micro_generated.ml" (fun fmt -> Cstubs.write_ml fmt ~prefix:"bench_micro" (module Bench_micro_bindings.Make)) ocaml-ctypes-0.7.0/tests/bench-micro/bench_micro_interpreted.gnuplot000066400000000000000000000005551274143137600257520ustar00rootroot00000000000000set terminal eps set output 'bench_micro_interpreted.eps' set key left top set xlabel "Arity" set autoscale set yrange [0:] set ylabel "Time (ns)" # set title "Mean FFI Call Latency by Arity" set style data linespoints plot "interpreted_shared.txt" using 1:2 title "Cmeleon libffi Interpreted", \ "traditional.txt" using 1:2 title "OCaml Manual" ocaml-ctypes-0.7.0/tests/bench-micro/bench_micro_lib.c000066400000000000000000000026131274143137600227220ustar00rootroot00000000000000#include "bench_micro_stubs.h" int f_i0() { return 0; } int f_i1(int i0) { return i0; } int f_i2(int i0, int i1) { return i1; } int f_i3(int i0, int i1, int i2) { return i2; } int f_i4(int i0, int i1, int i2, int i3) { return i3; } int f_i5(int i0, int i1, int i2, int i3, int i4) { return i4; } int f_i6(int i0, int i1, int i2, int i3, int i4, int i5) { return i5; } int f_i7(int i0, int i1, int i2, int i3, int i4, int i5, int i6) { return i6; } int f_i8(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7) { return i7; } int f_i9(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8) { return i8; } int f_i10(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9) { return i9; } int f_i11(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10) { return i10; } int f_i12(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10, int i11) { return i11; } int f_i13(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10, int i11, int i12) { return i12; } int f_i14(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10, int i11, int i12, int i13) { return i13; } int f_i15(int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10, int i11, int i12, int i13, int i14) { return i14; } ocaml-ctypes-0.7.0/tests/bench-micro/bench_micro_stubs.c000066400000000000000000000321451274143137600233170ustar00rootroot00000000000000#include #include #include #include #include "bench_micro_stubs.h" value f_i0_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i0); } value f_i1_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i1); } value f_i2_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i2); } value f_i3_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i3); } value f_i4_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i4); } value f_i5_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i5); } value f_i6_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i6); } value f_i7_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i7); } value f_i8_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i8); } value f_i9_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i9); } value f_i10_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i10); } value f_i11_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i11); } value f_i12_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i12); } value f_i13_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i13); } value f_i14_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i14); } value f_i15_ptr(value _) { return caml_copy_nativeint((intptr_t)(void *)f_i15); } value f_i0_caml(value unit) { CAMLparam1(unit); CAMLreturn(Val_int(f_i0())); } value f_i1_caml(value i0) { CAMLparam1(i0); int ii0 = Int_val(i0); CAMLreturn(Val_int(f_i1(ii0))); } value f_i2_caml(value i0, value i1) { CAMLparam2(i0,i1); int ii0 = Int_val(i0); int ii1 = Int_val(i1); CAMLreturn(Val_int(f_i2(ii0,ii1))); } value f_i3_caml(value i0, value i1, value i2) { CAMLparam3(i0,i1,i2); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); CAMLreturn(Val_int(f_i3(ii0,ii1,ii2))); } value f_i4_caml(value i0, value i1, value i2, value i3) { CAMLparam4(i0,i1,i2,i3); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); CAMLreturn(Val_int(f_i4(ii0,ii1,ii2,ii3))); } value f_i5_caml(value i0, value i1, value i2, value i3, value i4) { CAMLparam5(i0,i1,i2,i3,i4); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); CAMLreturn(Val_int(f_i5(ii0,ii1,ii2,ii3,ii4))); } value f_i6_caml(value i0, value i1, value i2, value i3, value i4, value i5) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam1(i5); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); CAMLreturn(Val_int(f_i6(ii0,ii1,ii2,ii3,ii4,ii5))); } value f_i7_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam2(i5,i6); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); CAMLreturn(Val_int(f_i7(ii0,ii1,ii2,ii3,ii4,ii5,ii6))); } value f_i8_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam3(i5,i6,i7); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); CAMLreturn(Val_int(f_i8(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7))); } value f_i9_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam4(i5,i6,i7,i8); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); CAMLreturn(Val_int(f_i9(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8))); } value f_i10_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam5(i5,i6,i7,i8,i9); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); CAMLreturn(Val_int(f_i10(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9))); } value f_i11_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam5(i5,i6,i7,i8,i9); CAMLxparam1(i10); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); CAMLreturn(Val_int(f_i11(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10))); } value f_i12_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10, value i11) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam5(i5,i6,i7,i8,i9); CAMLxparam2(i10,i11); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); int ii11= Int_val(i11); CAMLreturn(Val_int(f_i12(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10,ii11))); } value f_i13_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10, value i11, value i12) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam5(i5,i6,i7,i8,i9); CAMLxparam3(i10,i11,i12); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); int ii11= Int_val(i11); int ii12= Int_val(i12); CAMLreturn(Val_int(f_i13(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10,ii11,ii12))); } value f_i14_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10, value i11, value i12, value i13) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam5(i5,i6,i7,i8,i9); CAMLxparam4(i10,i11,i12,i13); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); int ii11= Int_val(i11); int ii12= Int_val(i12); int ii13= Int_val(i13); CAMLreturn(Val_int(f_i14(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10,ii11,ii12,ii13))); } value f_i15_caml(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10, value i11, value i12, value i13, value i14) { CAMLparam5(i0,i1,i2,i3,i4); CAMLxparam5(i5,i6,i7,i8,i9); CAMLxparam5(i10,i11,i12,i13,i14); int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); int ii11= Int_val(i11); int ii12= Int_val(i12); int ii13= Int_val(i13); int ii14= Int_val(i14); CAMLreturn(Val_int(f_i15(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10,ii11,ii12,ii13,ii14))); } value f_i0_cowboy(value unit) { return Val_int(f_i0()); } value f_i1_cowboy(value i0) { int ii0 = Int_val(i0); return Val_int(f_i1(ii0)); } value f_i2_cowboy(value i0, value i1) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); return Val_int(f_i2(ii0,ii1)); } value f_i3_cowboy(value i0, value i1, value i2) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); return Val_int(f_i3(ii0,ii1,ii2)); } value f_i4_cowboy(value i0, value i1, value i2, value i3) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); return Val_int(f_i4(ii0,ii1,ii2,ii3)); } value f_i5_cowboy(value i0, value i1, value i2, value i3, value i4) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); return Val_int(f_i5(ii0,ii1,ii2,ii3,ii4)); } value f_i6_cowboy(value i0, value i1, value i2, value i3, value i4, value i5) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); return Val_int(f_i6(ii0,ii1,ii2,ii3,ii4,ii5)); } value f_i7_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); return Val_int(f_i7(ii0,ii1,ii2,ii3,ii4,ii5,ii6)); } value f_i8_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); return Val_int(f_i8(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7)); } value f_i9_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); return Val_int(f_i9(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8)); } value f_i10_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); return Val_int(f_i10(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9)); } value f_i11_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); return Val_int(f_i11(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10)); } value f_i12_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10, value i11) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); int ii11= Int_val(i11); return Val_int(f_i12(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10,ii11)); } value f_i13_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10, value i11, value i12) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); int ii11= Int_val(i11); int ii12= Int_val(i12); return Val_int(f_i13(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10,ii11,ii12)); } value f_i14_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10, value i11, value i12, value i13) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); int ii11= Int_val(i11); int ii12= Int_val(i12); int ii13= Int_val(i13); return Val_int(f_i14(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10,ii11,ii12,ii13)); } value f_i15_cowboy(value i0, value i1, value i2, value i3, value i4, value i5, value i6, value i7, value i8, value i9, value i10, value i11, value i12, value i13, value i14) { int ii0 = Int_val(i0); int ii1 = Int_val(i1); int ii2 = Int_val(i2); int ii3 = Int_val(i3); int ii4 = Int_val(i4); int ii5 = Int_val(i5); int ii6 = Int_val(i6); int ii7 = Int_val(i7); int ii8 = Int_val(i8); int ii9 = Int_val(i9); int ii10= Int_val(i10); int ii11= Int_val(i11); int ii12= Int_val(i12); int ii13= Int_val(i13); int ii14= Int_val(i14); return Val_int(f_i15(ii0,ii1,ii2,ii3,ii4,ii5,ii6,ii7,ii8,ii9,ii10,ii11,ii12,ii13,ii14)); } ocaml-ctypes-0.7.0/tests/bench-micro/bench_micro_stubs.h000066400000000000000000000022111274143137600233130ustar00rootroot00000000000000 int f_i0 (); int f_i1 (int i0); int f_i2 (int i0, int i1); int f_i3 (int i0, int i1, int i2); int f_i4 (int i0, int i1, int i2, int i3); int f_i5 (int i0, int i1, int i2, int i3, int i4); int f_i6 (int i0, int i1, int i2, int i3, int i4, int i5); int f_i7 (int i0, int i1, int i2, int i3, int i4, int i5, int i6); int f_i8 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7); int f_i9 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8); int f_i10 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9); int f_i11 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10); int f_i12 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10, int i11); int f_i13 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10, int i11, int i12); int f_i14 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10, int i11, int i12, int i13); int f_i15 (int i0, int i1, int i2, int i3, int i4, int i5, int i6, int i7, int i8, int i9, int i10, int i11, int i12, int i13, int i14); ocaml-ctypes-0.7.0/tests/bench-micro/process_summary.ml000066400000000000000000000047551274143137600232560ustar00rootroot00000000000000type point = { configuration : string; parameter : int; time : float; time_err : float * float; cycles : float; cycles_err : float * float; } let split_on_colon s = let i = String.index s ':' in String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1) let early_float s = Scanf.sscanf s "%f" (fun x -> x) let point_of_row row = let configuration, parameter = split_on_colon row.(0) in let parameter = int_of_string parameter in { configuration; parameter; time=early_float row.(2); time_err=early_float row.(3), early_float row.(4); cycles=early_float row.(6); cycles_err=early_float row.(7), early_float row.(8); } let split_on_spaces s = let rec acc lst s = let t = String.trim s in match String.index t ' ' with | si -> let f = String.sub t 0 si in let r = String.sub t si (String.length t - si) in acc (f::lst) r | exception Not_found -> List.rev (t::lst) in acc [] s let print_pretty_point ({ configuration; parameter; time; time_err; cycles; cycles_err }) = Printf.printf "Configuration: %s\nParameter: %d\n" configuration parameter; Printf.printf "Time: %f %f %+f\nCycles: %f %f %+f\n\n" time (fst time_err) (snd time_err) cycles (fst cycles_err) (snd cycles_err) ;; let benchmark_names = [ "interpreted_local"; "interpreted_shared"; "staged_functor"; "staged_no_functor"; "traditional"; "cowboy"; ] in let columns = 9 in if Array.length Sys.argv < 2 then failwith "must provide benchmark summary file" else let data = ref [] in let path = Sys.argv.(1) in let ic = open_in path in try while true do let line = input_line ic in let prefix = String.sub line 0 6 in if prefix = " -----" then while true do let line = input_line ic in data := line :: !data done done with End_of_file -> close_in ic; let table = List.rev_map split_on_spaces !data in let table = List.filter (fun row -> List.length row = columns) table in let points = List.map (fun row -> point_of_row (Array.of_list row)) table in List.iter (fun c -> let points = List.filter (function | { configuration } when configuration = c -> true | _ -> false ) points in let data_file = c ^ ".txt" in let oc = open_out data_file in List.iter (fun { parameter; time; cycles } -> Printf.fprintf oc "%d\t%f\t%f\n" parameter time cycles ) points; close_out oc ) benchmark_names ocaml-ctypes-0.7.0/tests/clib/000077500000000000000000000000001274143137600162015ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/clib/test_functions.c000066400000000000000000000341601274143137600214200ustar00rootroot00000000000000/* * 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 #if defined _WIN32 && !defined __CYGWIN__ #include #else #include #endif #include "test_functions.h" static int add(int x, int y) { return x + y; } static int times(int x, int y) { return x * y; } int higher_order_1(intfun *callback, int x, int y) { return callback(x, y) == x + y; } int higher_order_3(acceptor *callback, intfun *fn, int x, int y) { return callback(fn, x, y); } 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; 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; } int accept_struct(struct simple simple) { return simple.i + (int)simple.f + (simple.self == NULL ? 1 : 0); } struct simple return_struct(void) { struct simple *t = malloc(sizeof *t); t->i = 10; t->f = 12.5; t->self = t; struct simple s = { 20, 35.0, t }; return s; } int64_t sum_union_components(union padded *padded, size_t len) { size_t i; int64_t acc = 0; for (i = 0; i < len; i++) { acc += padded[i].i; } return acc; } union padded add_unions(union padded l, union padded r) { union padded result, args[] = { l, r }; result.i = sum_union_components(args, sizeof args / sizeof *args); return result; } void concat_strings(const char **sv, int sc, char *buffer) { int i = 0; for (; i < sc; i++) { const char *s = sv[i]; while (*s) { *buffer++ = *s++; } } *buffer = '\0'; } struct tagged add_tagged_numbers(struct tagged l, struct tagged r) { union number n; struct tagged result = { 'd', n }; switch (l.tag) { case 'i': switch (r.tag) { case 'i': result.num.d = l.num.i + r.num.i; return result; case 'd': result.num.d = l.num.i + r.num.d; return result; default: assert(0); } case 'd': switch (r.tag) { case 'i': result.num.d = l.num.d + r.num.i; return result; case 'd': result.num.d = l.num.d + r.num.d; return result; default: assert(0); } default: assert(0); } } double accepts_pointer_to_array_of_structs(struct tagged(*arr)[5]) { double sum = 0.0; int i = 0; struct tagged *s = &(*arr[0]); for (; i < 5; i++) { switch (s[i].tag) { case 'i': { sum += s[i].num.i; break; } case 'd': { sum += s[i].num.d; break; } default: assert(0); } } return sum; } struct global_struct global_struct = { sizeof GLOBAL_STRING - 1, GLOBAL_STRING }; struct triple add_triples(struct triple l, struct triple r) { int i = 0; struct triple result; for (; i < 3; i++) { result.elements[i] = l.elements[i] + r.elements[i]; } return result; } /* OO-style example */ struct animal_methods; struct animal { struct animal_methods *vtable; }; struct animal_methods { char *(*say)(struct animal *); char *(*identify)(struct animal *); }; int check_name(struct animal *a, char *name) { return strcmp(a->vtable->identify(a), name) == 0; } enum colour { white, red, black, pale }; struct chorse_methods; struct chorse { struct chorse_methods *vtable; enum colour colour; }; struct chorse_methods { struct animal_methods base; char *(*colour)(struct chorse *); }; char *chorse_colour(struct chorse *chorse) { switch (chorse->colour) { case white : return "white"; case red : return "red"; case black : return "black"; case pale : return "pale"; default: assert(0); } } char *chorse_say(struct animal *c) { return "neigh"; } char *chorse_identify(struct animal *a) { static char buffer[30]; /* static allocation is adequate for the test */ sprintf(buffer, "%s horse", chorse_colour((struct chorse *)a)); return buffer; } static struct chorse_methods chorse_vtable = { { chorse_say, chorse_identify, }, chorse_colour, }; struct chorse *new_chorse(int colour) { struct chorse *h = malloc(sizeof *h); h->vtable = &chorse_vtable; h->colour = (enum colour)colour; return h; } /* (End of OO-style example) */ int accept_pointers(float *float_p, double *double_p, short *short_p, int *int_p, long *long_p, long long *llong_p, intnat *nativeint_p, int8_t *int8_t_p, int16_t *int16_t_p, int32_t *int32_t_p, int64_t *int64_t_p, uint8_t *uint8_t_p, uint16_t *uint16_t_p, uint32_t *uint32_t_p, uint64_t *uint64_t_p, size_t *size_t_p, unsigned short *ushort_p, unsigned *uint_p, unsigned long *ulong_p, unsigned long long *ullong_p) { return (*float_p + *double_p + *short_p + *int_p + *long_p + *llong_p + *nativeint_p + *int8_t_p + *int16_t_p + *int32_t_p + *int64_t_p + *uint8_t_p + *uint16_t_p + *uint32_t_p + *uint64_t_p + *size_t_p + *ushort_p + *uint_p + *ulong_p + *ullong_p); } int accept_pointers_to_pointers(int *p, int **pp, int ***ppp, int ****pppp) { return *p + **pp + ***ppp + ****pppp; } intfun **returning_pointer_to_function_pointer(void) { static intfun *f = times; return &f; } int accepting_pointer_to_function_pointer(intfun **pfp) { return (*pfp)(20, 4); } int passing_pointers_to_callback(pintfun1 *f) { int x = 3, y = 4; return f(&x, &y); } int accepting_pointer_from_callback(pintfun2 *f) { int *p = f(7, 8); int q = *p; *p = 12; return q; } signed char retrieve_SCHAR_MIN(void) { return SCHAR_MIN; } signed char retrieve_SCHAR_MAX(void) { return SCHAR_MAX; } unsigned char retrieve_UCHAR_MAX(void) { return UCHAR_MAX; } char retrieve_CHAR_MIN(void) { return CHAR_MIN; } char retrieve_CHAR_MAX(void) { return CHAR_MAX; } short retrieve_SHRT_MIN(void) { return SHRT_MIN; } short retrieve_SHRT_MAX(void) { return SHRT_MAX; } unsigned short retrieve_USHRT_MAX(void) { return USHRT_MAX; } int retrieve_INT_MIN(void) { return INT_MIN; } int retrieve_INT_MAX(void) { return INT_MAX; } unsigned int retrieve_UINT_MAX(void) { return UINT_MAX; } long retrieve_LONG_MAX(void) { return LONG_MAX; } long retrieve_LONG_MIN(void) { return LONG_MIN; } unsigned long retrieve_ULONG_MAX(void) { return ULONG_MAX; } long long retrieve_LLONG_MAX(void) { return LLONG_MAX; } long long retrieve_LLONG_MIN(void) { return LLONG_MIN; } unsigned long long retrieve_ULLONG_MAX(void) { return ULLONG_MAX; } int8_t retrieve_INT8_MIN(void) { return INT8_MIN; } int16_t retrieve_INT16_MIN(void) { return INT16_MIN; } int32_t retrieve_INT32_MIN(void) { return INT32_MIN; } int64_t retrieve_INT64_MIN(void) { return INT64_MIN; } int8_t retrieve_INT8_MAX(void) { return INT8_MAX; } int16_t retrieve_INT16_MAX(void) { return INT16_MAX; } int32_t retrieve_INT32_MAX(void) { return INT32_MAX; } int64_t retrieve_INT64_MAX(void) { return INT64_MAX; } uint8_t retrieve_UINT8_MAX(void) { return UINT8_MAX; } uint16_t retrieve_UINT16_MAX(void) { return UINT16_MAX; } uint32_t retrieve_UINT32_MAX(void) { return UINT32_MAX; } uint64_t retrieve_UINT64_MAX(void) { return UINT64_MAX; } size_t retrieve_SIZE_MAX(void) { return SIZE_MAX; } float retrieve_FLT_MIN(void) { return FLT_MIN; } float retrieve_FLT_MAX(void) { return FLT_MAX; } double retrieve_DBL_MIN(void) { return DBL_MIN; } double retrieve_DBL_MAX(void) { return DBL_MAX; } void add_complexd(double complex *l, double complex *r, double complex *out) { *out = *l + *r; } void mul_complexd(double complex *l, double complex *r, double complex *out) { *out = *l * *r; } void 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; } double complex add_complexd_val(double complex l, double complex r) { return l + r; } double complex mul_complexd_val(double complex l, double complex r) { return l * r; } float complex add_complexf_val(float complex l, float complex r) { return l + r; } float complex mul_complexf_val(float complex l, float complex r) { return l * r; } 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 return_struct_by_value(void) { struct one_int v = { 3 }; return v; } /* naive matrix operations */ void matrix_mul(int lrows, int lcols, int rcols, double *l, double *r, double *prod) { int i, j, k; for (i = 0; i < lrows; i++) { for (j = 0; j < rcols; j++) { prod[i * rcols + j] = 0.0; for (k = 0; k < lcols; k++) { prod[i * rcols + j] += l[i * lcols + k] * r[k * rcols + j]; } } } } double *matrix_transpose(int rows, int cols, double *matrix) { int i, j; double *rv = malloc(rows * cols * sizeof *rv); for (i = 0; i < rows; i++) for (j = 0; j < cols; j++) rv[j * rows + i] = matrix[i * cols + j]; return rv; } int (*plus_callback)(int) = NULL; /* Sum the range [a, b] */ int sum_range_with_plus_callback(int a, int b) { int sum = 0, i = 0; for (i = a; i <= b; i++) { sum += i; } return sum; } static callback_t *registered_callback = NULL; void register_callback(callback_t *callback) { registered_callback = callback; } void call_registered_callback(int times, int starting_value) { int i; for (i = 0; i < times; i++) { int result = registered_callback(); assert (result == starting_value++); } } #if defined _WIN32 && !defined __CYGWIN__ #define sem_t HANDLE #define sem_init(sem, sem_attr1, sem_init_value) \ (void)((*sem = CreateSemaphore(NULL,0,32768,NULL))==NULL) #define sem_wait(sem) \ (void)(WAIT_OBJECT_0 != WaitForSingleObject(*sem,INFINITE)) #define sem_post(sem) (void)ReleaseSemaphore(*sem,1,NULL) #endif static sem_t semaphore1; static sem_t semaphore2; void initialize_waiters(void) { sem_init(&semaphore1, 0, -1); sem_init(&semaphore2, 0, -1); } void post1_wait2(void) { sem_post(&semaphore1); sem_wait(&semaphore2); } void post2_wait1(void) { sem_post(&semaphore2); sem_wait(&semaphore1); } size_t sizeof_s1(void) { return sizeof(struct s1); } size_t alignmentof_s1(void) { return offsetof(struct { char c; struct s1 x; }, x); } size_t offsetof_x1(void) { return offsetof(struct s1, x1); } size_t offsetof_x2(void) { return offsetof(struct s1, x2); } size_t offsetof_x3(void) { return offsetof(struct s1, x3); } size_t offsetof_x4(void) { return offsetof(struct s1, x4); } size_t sizeof_s2(void) { return sizeof(struct s2); } size_t alignmentof_s2(void) { return offsetof(struct { char c; struct s2 x; }, x); } size_t offsetof_y1(void) { return offsetof(struct s2, y1); } size_t offsetof_y2(void) { return offsetof(struct s2, y2); } size_t offsetof_y3(void) { return offsetof(struct s2, y3); } size_t offsetof_y4(void) { return offsetof(struct s2, y4); } size_t sizeof_s3(void) { return sizeof(struct s3); } size_t alignmentof_s3(void) { return offsetof(struct { char c; struct s3 x; }, x); } size_t offsetof_z1(void) { return offsetof(struct s3, z1); } size_t offsetof_z2(void) { return offsetof(struct s3, z2); } size_t sizeof_s4(void) { return sizeof(struct s4); } size_t alignmentof_s4(void) { return offsetof(struct { char c; struct s4 x; }, x); } size_t offsetof_z3(void) { return offsetof(struct s4, z3); } size_t offsetof_z4(void) { return offsetof(struct s4, z4); } size_t sizeof_s6(void) { return sizeof(s6); } size_t alignmentof_s6(void) { return offsetof(struct { char c; s6 x; }, x); } size_t offsetof_v1(void) { return offsetof(s6, v1); } size_t offsetof_v2(void) { return offsetof(s6, v2); } size_t sizeof_u1(void) { return sizeof(union u1); } size_t alignmentof_u1(void) { return offsetof (struct { char c; union u1 x; }, x); } size_t sizeof_u2(void) { return sizeof(u2); } size_t alignmentof_u2(void) { return offsetof (struct { char c; u2 x; }, x); } bool bool_and(bool l, bool r) { return l && r; } int call_s5(struct s1 *s1, struct s5 *s5) { return s5->w1(s1); } enum signed_enum classify_integer(int x) { return (x < 0) ? minus_one : plus_one; } enum signed_enum out_of_range(void) { return (enum signed_enum)2; } enum fruit next_fruit(enum fruit f) { switch (f) { case Orange: return Apple; case Apple: return Banana; case Banana: return Pear; case Pear: return Orange; default: assert(0); } } int32_t sum_int_array(int32_t *arr, size_t len) { int32_t sum = 0; size_t i = 0; for (; i < len; i++) { sum += arr[i]; } return sum; } void *global_ocaml_value = NULL; void save_ocaml_value(void *p) { global_ocaml_value = p; } void *retrieve_ocaml_value(void) { return global_ocaml_value; } int sixargs(int x1, int x2, int x3, int x4, int x5, int x6) { return x1 + x2 + x3 + x4 + x5 + x6; } int return_10(void) { return 10; } int callback_returns_char_a(char (*f)(void)) { return f() == 'a' ? 1 : 0; } ocaml-ctypes-0.7.0/tests/clib/test_functions.h000066400000000000000000000162131274143137600214240ustar00rootroot00000000000000/* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. */ #ifndef TEST_FUNCTIONS_H #define TEST_FUNCTIONS_H #include #include #include #include #include typedef int intfun(int, int); extern int higher_order_1(intfun *, int, int); typedef int acceptor(intfun *, int, int); extern int higher_order_3(acceptor *, intfun *, int, int); typedef int vintfun(int); extern int higher_order_simplest(vintfun *); extern intfun *returning_funptr(int); extern int accepting_possibly_null_funptr(intfun *, int, int); extern int global; extern int *return_global_address(void); extern double float_pointer_callback(void (*)(double *), double); extern int write_through_callback(int (*)(int *)); extern int write_through_callback_pointer_pointer(int (*)(int **, int *)); extern int is_null(void *); extern int callback_returns_funptr(vintfun *(*)(int), int); extern int *pass_pointer_through(int *, int *, int); struct simple { int i; double f; struct simple *self; }; extern int accept_struct(struct simple); extern struct simple return_struct(void); union padded { int64_t i; char a[sizeof(int64_t) + 1]; }; extern int64_t sum_union_components(union padded *, size_t); extern union padded add_unions(union padded, union padded); extern void concat_strings(const char **, int, char *); union number { int i; double d; }; struct tagged { char tag; union number num; }; extern struct tagged add_tagged_numbers(struct tagged, struct tagged); extern double accepts_pointer_to_array_of_structs(struct tagged(*)[5]); #define GLOBAL_STRING "global string" struct global_struct { size_t len; const char str[sizeof GLOBAL_STRING]; }; extern struct global_struct global_struct; struct triple { double elements[3]; }; extern struct triple add_triples(struct triple, struct triple); struct animal; struct chorse; extern int check_name(struct animal *, char *); extern char *chorse_colour(struct chorse *); extern char *chorse_say(struct animal *); extern char *chorse_identify(struct animal *); extern struct chorse *new_chorse(int); extern int accept_pointers(float *, double *, short *, int *, long *, long long *, intnat *, int8_t *, int16_t *, int32_t *, int64_t *, uint8_t *, uint16_t *, uint32_t *, uint64_t *, size_t *, unsigned short *, unsigned *, unsigned long *, unsigned long long *); int accept_pointers_to_pointers(int *, int **, int ***, int ****); intfun **returning_pointer_to_function_pointer(void); int accepting_pointer_to_function_pointer(intfun **); typedef int pintfun1(int *, int *); int passing_pointers_to_callback(pintfun1 *); typedef int *pintfun2(int, int); int accepting_pointer_from_callback(pintfun2 *); signed char retrieve_SCHAR_MIN(void); signed char retrieve_SCHAR_MAX(void); unsigned char retrieve_UCHAR_MAX(void); char retrieve_CHAR_MIN(void); char retrieve_CHAR_MAX(void); short retrieve_SHRT_MIN(void); short retrieve_SHRT_MAX(void); unsigned short retrieve_USHRT_MAX(void); int retrieve_INT_MIN(void); int retrieve_INT_MAX(void); unsigned int retrieve_UINT_MAX(void); long retrieve_LONG_MAX(void); long retrieve_LONG_MIN(void); unsigned long retrieve_ULONG_MAX(void); long long retrieve_LLONG_MAX(void); long long retrieve_LLONG_MIN(void); unsigned long long retrieve_ULLONG_MAX(void); int8_t retrieve_INT8_MIN(void); int16_t retrieve_INT16_MIN(void); int32_t retrieve_INT32_MIN(void); int64_t retrieve_INT64_MIN(void); int8_t retrieve_INT8_MAX(void); int16_t retrieve_INT16_MAX(void); int32_t retrieve_INT32_MAX(void); int64_t retrieve_INT64_MAX(void); uint8_t retrieve_UINT8_MAX(void); uint16_t retrieve_UINT16_MAX(void); uint32_t retrieve_UINT32_MAX(void); uint64_t retrieve_UINT64_MAX(void); size_t retrieve_SIZE_MAX(void); float retrieve_FLT_MIN(void); float retrieve_FLT_MAX(void); double retrieve_DBL_MIN(void); double retrieve_DBL_MAX(void); void add_complexd(double complex *, double complex *, double complex *); void mul_complexd(double complex *, double complex *, double complex *); void add_complexf(float complex *, float complex *, float complex *); void mul_complexf(float complex *, float complex *, float complex *); double complex add_complexd_val(double complex, double complex); double complex mul_complexd_val(double complex, double complex); float complex add_complexf_val(float complex, float complex); float complex mul_complexf_val(float complex, float complex); void store_callback(int (*callback)(int)); int invoke_stored_callback(int); vintfun *return_callback(vintfun *); struct one_int { int i; }; struct one_int return_struct_by_value(void); void matrix_mul(int, int, int, double *, double *, double *); double *matrix_transpose(int, int, double *); int (*plus_callback)(int); int sum_range_with_plus_callback(int, int); typedef int callback_t(void); void register_callback(callback_t *); void call_registered_callback(int, int); void initialize_waiters(void); void post1_wait2(void); void post2_wait1(void); struct s1 { int x1, x2, x3, x4; }; struct s2 { int y1, y2, y3, y4; }; struct s3 { int z1; struct s3 *z2; }; struct s4 { struct s3 z3; struct s3 *z4; }; struct s5 { int (*w1)(struct s1 *); }; typedef struct { int v1; float v2; } s6; size_t sizeof_s1(void); size_t alignmentof_s1(void); size_t offsetof_x1(void); size_t offsetof_x2(void); size_t offsetof_x3(void); size_t offsetof_x4(void); size_t sizeof_s2(void); size_t alignmentof_s2(void); size_t offsetof_y1(void); size_t offsetof_y2(void); size_t offsetof_y3(void); size_t offsetof_y4(void); size_t sizeof_s3(void); size_t alignmentof_s3(void); size_t offsetof_z1(void); size_t offsetof_z2(void); size_t sizeof_s4(void); size_t alignmentof_s4(void); size_t offsetof_z3(void); size_t offsetof_z4(void); size_t sizeof_s6(void); size_t alignmentof_s6(void); size_t offsetof_v1(void); size_t offsetof_v2(void); union u1 { char x1; float x2; double x3; char x4[13]; }; typedef union { int t1; float t2; } u2; size_t sizeof_u1(void); size_t alignmentof_u1(void); size_t sizeof_u2(void); size_t alignmentof_u2(void); bool bool_and(bool, bool); int call_s5(struct s1 *, struct s5 *); enum letter { A, B, C = 10, D }; enum fruit { Orange, Apple, Banana, Pear }; enum bears { Edward, Winnie, Paddington }; enum signed_enum { minus_one = -1, plus_one = 1 }; enum fruit next_fruit(enum fruit); enum signed_enum classify_integer(int); enum signed_enum out_of_range(void); struct fruit_cell { enum fruit frt; struct fruit_cell *next; }; int32_t sum_int_array(int32_t *, size_t); void save_ocaml_value(void *); void *retrieve_ocaml_value(void); int sixargs(int, int, int, int, int, int); int return_10(void); int callback_returns_char_a(char (*)(void)); #endif /* TEST_FUNCTIONS_H */ ocaml-ctypes-0.7.0/tests/test-alignment/000077500000000000000000000000001274143137600202235ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-alignment/test_alignment.ml000066400000000000000000000202541274143137600235750ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes (* Test 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 [alignment] treats OCaml types as incomplete. *) let test_alignment_ocaml_string _ = assert_raises IncompleteType (fun () -> alignment ocaml_string) (* Test that the alignment of a struct is equal to the maximum alignment of its members. *) let test_struct_alignment _ = let module M = struct type a and b and u let maximum = List.fold_left max 0 let struct_a = structure "A" let (-:) ty label = field struct_a label ty let _ = char -: "_" let _ = int -: "_" let _ = double -: "_" let () = seal struct_a let () = assert_equal (maximum [alignment char; alignment int; alignment double]) (alignment struct_a) let abs = abstract ~name:"abs" ~size:33 ~alignment:33 let charish = view ~read:(fun _ -> ()) ~write:(fun () -> 'c') char let struct_b = structure "A" let (-:) ty label = field struct_b label ty let _ = charish -: "_" let _ = Foreign.funptr (int @-> returning int) -: "_" let _ = abs -: "_" let _ = double -: "_" let () = seal struct_b let () = assert_equal (maximum [alignment charish; alignment (Foreign.funptr (int @-> returning int)); alignment abs; alignment double]) (alignment struct_b) end in () (* Test that structs are properly tail-padded. For example, suppose a 32-bit architecture with 8-bit bytes and word-aligned ints and the following definitions: struct A { char a; int b; char c; }; struct B { struct A d; char e; } Then we should have the following layouts: A: a---bbbbc--- B: A-----------e--- and the following sizes: sizeof (struct A) == 12 sizeof (struct B) == 16 *) let test_struct_tail_padding _ = let module M = struct type a and b and u let struct_a = structure "A" let (-:) ty label = field struct_a label ty let a = char -: "a" let b = int -: "b" let c = char -: "c" let () = seal (struct_a : a structure typ) let u = union "U" let (-:) ty label = field u label ty let x = char -: "x" let () = seal (u : u union typ) let struct_b = structure "B" let (-:) ty label = field struct_b label ty let d = struct_a -: "d" let e = u -: "e" let () = seal (struct_b : b structure typ) let char_ptr p = from_voidp char (to_voidp p) let va = make struct_a and vb = make struct_b let pa = addr va and pb = addr vb let () = begin assert_equal ~msg:"offsetof (A, a) == 0" (offsetof a) 0 ~printer:string_of_int; assert_equal ~msg:"offsetof(A, b) == alignmentof(int)" (offsetof b) (alignment int) ~printer:string_of_int; assert_equal ~msg:"((char *)&pa->b - (char *)&pa->a) == alignmentof(int)" (ptr_diff (char_ptr (pa |-> a)) (char_ptr (pa |-> b))) (alignment int) ~printer:string_of_int; assert_equal ~msg:"offsetof(A, c) == 2 * alignmentof(int)" (offsetof c) (2 * alignment int) ~printer:string_of_int; assert_equal ~msg:"sizeof(struct A) == 3 * alignmentof(int)" (sizeof struct_a) (3 * alignment int) ~printer:string_of_int; assert_equal ~msg:"offsetof(B, e) == 3 * alignmentof(int)" (offsetof e) (3 * alignment int) ~printer:string_of_int; assert_equal ~msg:"((char *)&pb->e - (char *)&pb->d) == 3 * alignmentof(int)" (ptr_diff (char_ptr (pb |-> d)) (char_ptr (pb |-> e))) (3 * alignment int) ~printer:string_of_int; assert_equal ~msg:"sizeof(struct B) == 4 * alignmentof(int)" (sizeof struct_b) (4 * alignment int) ~printer:string_of_int; end end in () (* Test that the alignment of a bigarray is the same as the alignment of its element type. *) let test_bigarray_alignment _ = let module M = struct module B = Bigarray 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 considers ocaml_string incomplete" >:: test_alignment_ocaml_string; "alignment of bigarray types" >:: test_bigarray_alignment; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-arrays/000077500000000000000000000000001274143137600175465ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-arrays/stub-generator/000077500000000000000000000000001274143137600225075ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-arrays/stub-generator/driver.ml000066400000000000000000000004051274143137600243330ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the arrays tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-arrays/stubs/000077500000000000000000000000001274143137600207065ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-arrays/stubs/functions.ml000066400000000000000000000015621274143137600232540ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the arrays tests. *) open Ctypes module Stubs (F: Cstubs.FOREIGN) = struct open F (* union u { int i; double d; } *) type number let u : number union typ = union "number" let (-:) ty label = field u label ty let i = int -: "i" let d = double -: "d" let () = seal u (* struct s { char tag; union u data; } *) type tagged let s : tagged structure typ = structure "tagged" let (-:) ty label = field s label ty let tag = char -: "tag" let data = u -: "num" let () = seal s let accepts_pointer_to_array_of_structs = foreign "accepts_pointer_to_array_of_structs" (ptr (array 5 s) @-> returning double) end ocaml-ctypes-0.7.0/tests/test-arrays/test_array.ml000066400000000000000000000126471274143137600222670ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes let testlib = Dl.(dlopen ~filename:"clib/libtest_functions.so" ~flags:[RTLD_NOW]) (* Creating multidimensional arrays, and reading and writing elements. *) let test_multidimensional_arrays _ = let module Array = CArray in (* one dimension *) let one = Array.make int 10 in for i = 0 to Array.length one - 1 do one.(i) <- i done; for i = 0 to Array.length one - 1 do assert_equal i one.(i) done; (* two dimensions *) let two = Array.make (array 5 char) 10 in let s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" in for i = 0 to 9 do for j = 0 to 4 do two.(i).(j) <- s.[i + j] done done; for i = 0 to 9 do for j = 0 to 4 do assert_equal two.(i).(j) s.[i + j] ~printer:(String.make 1) done done; (* three dimensions *) let three = Array.make (array 2 (array 5 float)) 10 in let float = 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 module Array = CArray in let int_array = Array.make int ~initial:33 10 in for i = 0 to Array.length int_array - 1 do assert_equal 33 int_array.(i) done; let int_array_array = Array.make (array 10 int) ~initial:int_array 5 in for i = 0 to Array.length int_array_array - 1 do for j = 0 to Array.length int_array_array.(i) - 1 do assert_equal 33 int_array_array.(i).(j) done done (* Test that creating arrays of elements of incomplete type fails. *) let test_arrays_of_incomplete_type _ = let module M = struct let () = assert_raises IncompleteType (fun () -> CArray.make void 10) let s = structure "s" let () = assert_raises IncompleteType (fun () -> CArray.make s 10) end in () (* Test that OCaml types cannot be used to build arrays. *) let test_ocaml_types_rejected_as_array_elements _ = assert_raises IncompleteType (fun () -> CArray.make ocaml_string 10) (* Test that creating an array initializes all elements appropriately. *) let test_pointer_to_array_arithmetic _ = let module Array = CArray in (* int ( * )[3] *) let p = allocate_n (array 3 int) ~count:4 in p <-@ Array.of_list int [1; 2; 3]; (p +@ 1) <-@ Array.of_list int [4; 5; 6]; (p +@ 2) <-@ Array.of_list int [7; 8; 9]; (p +@ 3) <-@ Array.of_list int [10; 11; 12]; let q = p in assert_equal 8 (!@(q +@ 2)).(1); assert_equal 12 (!@(q +@ 3)).(2); assert_equal 1 (!@(q +@ 0)).(0); let a = Array.from_ptr p 4 in assert_equal 8 a.(2).(1); assert_equal 12 a.(3).(2); assert_equal 1 a.(0).(0) module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Test passing pointer to array of structs. *) let test_passing_pointer_to_array_of_structs _ = let box_int x = let v = make s in setf v tag 'i'; let pd = v @. data in (pd |-> i) <-@ x; v in let box_double x = let v = make s in setf v tag 'd'; let pd = v @. data in (pd |-> d) <-@ x; v in let sum = accepts_pointer_to_array_of_structs (from_voidp (array 5 s) (to_voidp (CArray.start (CArray.of_list s [box_int 10; box_double 3.5; box_int 12; box_double (-14.1); box_double (103.25)])))) in assert_equal (103.25 +. (-14.1) +. 12.0 +. 3.5 +. 10.0) sum end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Array tests" >::: ["multidimensional arrays" >:: test_multidimensional_arrays; "array initialization" >:: test_array_initialiation; "arrays of incomplete type" >:: test_arrays_of_incomplete_type; "ocaml_string cannot be used to build arrays" >:: test_ocaml_types_rejected_as_array_elements; "pointer to array arithmetic" >:: test_pointer_to_array_arithmetic; "passing pointer to array of structs (foreign)" >:: Foreign_tests.test_passing_pointer_to_array_of_structs; "passing pointer to array of structs (stubs)" >:: Stub_tests.test_passing_pointer_to_array_of_structs; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-bigarrays/000077500000000000000000000000001274143137600202305ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-bigarrays/stub-generator/000077500000000000000000000000001274143137600231715ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-bigarrays/stub-generator/driver.ml000066400000000000000000000004101274143137600250110ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the bigarrays tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-bigarrays/stubs/000077500000000000000000000000001274143137600213705ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-bigarrays/stubs/functions.ml000066400000000000000000000010431274143137600237300ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the bigarrays tests. *) open Ctypes open Tests_common module Stubs (F: Cstubs.FOREIGN) = struct open F let matrix_mul = foreign "matrix_mul" (int @-> int @-> int @-> ptr double @-> ptr double @-> ptr double @-> returning void) let matrix_transpose = foreign "matrix_transpose" (int @-> int @-> ptr double @-> returning (ptr double)) end ocaml-ctypes-0.7.0/tests/test-bigarrays/test_bigarrays.ml000066400000000000000000000352011274143137600236050ustar00rootroot00000000000000(* * 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 OUnit2 open Ctypes module BA = Bigarray let array_of_list2 typ list2 = let dim2 = List.length (List.hd list2) in let atyp = array dim2 typ in CArray.of_list atyp (List.map (CArray.of_list typ) list2) let array_of_list3 typ list3 = let dim2 = List.length (List.hd list3) and dim3 = List.length (List.hd (List.hd list3)) in let atyp = array dim2 (array dim3 typ) in CArray.of_list atyp (List.map (array_of_list2 typ) list3) let list2_of_array array = List.map CArray.to_list (CArray.to_list array) let matrix l = bigarray_of_array array2 BA.float64 (array_of_list2 double l) let unmatrix m = list2_of_array (array_of_bigarray array2 m) let castp typ p = from_voidp typ (to_voidp p) (* View ctypes-managed memory through a bigarray lens. *) let test_bigarray_of_ctypes_array _ = (* One-dimensional Genarrays *) let module Array = CArray in let a1 = Array.of_list int8_t [10; 20; 30; 40] in let b1 = bigarray_of_array genarray BA.int8_signed a1 in let () = begin assert_equal (Array.length a1) (BA.Genarray.nth_dim b1 0); for i = 0 to Array.length a1 - 1 do assert_equal a1.(i) (BA.Genarray.get b1 [|i|]) done end in (* Array1 *) let eps32 = 1e-6 in let complex32_eq = let open Complex in fun { re = lre; im = lim } { re = rre; im = rim } -> abs_float (lre -. rre) < eps32 && abs_float (lim -. rim) < eps32 in let a2 = Array.of_list complex32 Complex.([{re = 0.1; im = 1.0}; {re = 0.2; im = 2.0}; {re = 0.3; im = 3.0}; {re = 0.4; im = 4.0}]) in let b2 = bigarray_of_array array1 BA.complex32 a2 in let () = begin assert_equal (Array.length a2) (BA.Array1.dim b2); for i = 0 to Array.length a2 - 1 do assert_equal a2.(i) b2.{i} ~cmp:complex32_eq done end in (* Two-dimensional Genarrays *) let uint16 = view uint16_t ~read:Unsigned.UInt16.to_int ~write:Unsigned.UInt16.of_int in let a3 = array_of_list2 uint16 [[5; 10; 15]; [3; 6; 9]; [2; 4; 6]; [1; 2; 3]] in let b3 = BA.reshape (bigarray_of_array genarray BA.int16_unsigned (Array.from_ptr (castp uint16 (Array.start a3)) 12)) [| 4; 3 |] in let () = begin assert_equal (Array.length a3) (BA.Genarray.nth_dim b3 0); assert_equal (Array.length a3.(0)) (BA.Genarray.nth_dim b3 1); for i = 0 to Array.length a3 - 1 do for j = 0 to Array.length a3.(0) - 1 do assert_equal a3.(i).(j) (BA.Genarray.get b3 [|i; j|]) done done end in (* Array2 *) let a4 = array_of_list2 nativeint [[5n; 10n]; [3n; 6n]; [1n; 2n]] in let b4 = bigarray_of_array array2 BA.nativeint a4 in let () = begin assert_equal (Array.length a4) (BA.Array2.dim1 b4); assert_equal (Array.length a4.(0)) (BA.Array2.dim2 b4); for i = 0 to Array.length a4 - 1 do for j = 0 to Array.length a4.(0) - 1 do assert_equal a4.(i).(j) b4.{i, j} done done end in (* Three-dimensional Genarrays *) let a5 = array_of_list3 int64_t [[[1L; 2L; 3L; 4L; 5L]; [2L; 4L; 6L; 8L; 10L]]; [[10L; 20L; 30L; 40L; 50L]; [20L; 40L; 60L; 80L; 100L]]; [[100L; 200L; 300L; 400L; 500L]; [200L; 400L; 600L; 800L; 1000L]]] in let b5 = BA.reshape (bigarray_of_array genarray BA.int64 (Array.from_ptr (castp int64_t (Array.start a5)) 30)) [| 3; 2; 5 |] in let () = begin assert_equal (Array.length a5) (BA.Genarray.nth_dim b5 0); assert_equal (Array.length a5.(0)) (BA.Genarray.nth_dim b5 1); assert_equal (Array.length a5.(0).(0)) (BA.Genarray.nth_dim b5 2); for i = 0 to Array.length a5 - 1 do for j = 0 to Array.length a5.(0) - 1 do for k = 0 to Array.length a5.(0).(0) - 1 do assert_equal a5.(i).(j).(k) (BA.Genarray.get b5 [|i; j; k|]) done done done end in (* Array3 *) let a6 = array_of_list3 double [[[1.; 2.; 3.; 4.]; [2.; 4.; 6.; 8.]]; [[10.; 20.; 30.; 40.]; [20.; 40.; 60.; 80.]]; [[100.; 200.; 300.; 400.]; [200.; 400.; 600.; 800.]]] in let b6 = bigarray_of_array array3 BA.float64 a6 in let () = begin assert_equal (Array.length a6) (BA.Array3.dim1 b6); assert_equal (Array.length a6.(0)) (BA.Array3.dim2 b6); assert_equal (Array.length a6.(0).(0)) (BA.Array3.dim3 b6); for i = 0 to Array.length a6 - 1 do for j = 0 to Array.length a6.(0) - 1 do for k = 0 to Array.length a6.(0).(0) - 1 do assert_equal a6.(i).(j).(k) b6.{i, j, k} done done done end in () (* View bigarray-managed memory through a ctypes lens *) let test_ctypes_array_of_bigarray _ = let module Array = CArray in (* One-dimensional Genarrays *) let b1_dim = 6 in let b1 = BA.(Genarray.create float32 c_layout) [| b1_dim |] in let a1 = array_of_bigarray genarray b1 in begin assert_equal (BA.Genarray.nth_dim b1 0) (Array.length a1); List.iteri (fun i -> BA.Genarray.set b1 [| i |]) [ 6.; 5.; 4.; 3.; 2.; 1. ]; for i = 0 to b1_dim - 1 do assert_equal (BA.Genarray.get b1 [| i |]) a1.(i) done end; (* Array1 *) let b2_dim = 7 in let b2 = BA.(Array1.create int8_unsigned c_layout) b2_dim in let a2 = array_of_bigarray array1 b2 in begin assert_equal (BA.Array1.dim b2) (Array.length a2); List.iteri (fun i -> fun v -> b2.{i} <- v) [ 2; 4; 6; 8; 10; 12; 14 ]; for i = 0 to b2_dim - 1 do assert_equal b2.{i} a2.(i) done end; (* Two-dimensional Genarrays *) let b3_dim1 = 4 and b3_dim2 = 2 in let b3 = BA.(Genarray.create int16_signed c_layout) [| b3_dim1; b3_dim2 |] in let a3 = Array.from_ptr (castp (array b3_dim2 int16_t) (bigarray_start genarray b3)) b3_dim1 in begin assert_equal (BA.Genarray.nth_dim b3 0) (Array.length a3); assert_equal (BA.Genarray.nth_dim b3 1) (Array.length a3.(0)); List.iteri (fun i -> List.iteri (fun j -> BA.Genarray.set b3 [| i; j |])) [[-1; -2]; [-3; -4]; [-5; -6]; [-7; -8]]; for i = 0 to b3_dim1 - 1 do for j = 0 to b3_dim2 - 1 do assert_equal (BA.Genarray.get b3 [| i; j |]) a3.(i).(j) done done end; (* Array2 *) let b4_dim1 = 3 and b4_dim2 = 4 in let b4 = BA.(Array2.create int32 c_layout) b4_dim1 b4_dim2 in let a4 = array_of_bigarray array2 b4 in begin assert_equal (BA.Array2.dim1 b4) (Array.length a4); assert_equal (BA.Array2.dim2 b4) (Array.length a4.(0)); List.iteri (fun i -> List.iteri (fun j -> fun v -> b4.{i, j} <- v)) [[17l; 15l; 13l; 11l]; [9l; 7l; 5l; 3l]; [1l; -1l; -3l; -5l]]; for i = 0 to b4_dim1 - 1 do for j = 0 to b4_dim2 - 1 do assert_equal b4.{i, j} a4.(i).(j) done done end; (* Three-dimensional Genarrays *) let b5_dim1 = 4 and b5_dim2 = 2 and b5_dim3 = 5 in let b5 = BA.(Genarray.create int c_layout) [| b5_dim1; b5_dim2; b5_dim3 |] in let a5 = Array.from_ptr (castp (array b5_dim2 (array b5_dim3 camlint)) (bigarray_start genarray b5)) b5_dim1 in begin assert_equal (BA.Genarray.nth_dim b5 0) (Array.length a5); assert_equal (BA.Genarray.nth_dim b5 1) (Array.length a5.(0)); assert_equal (BA.Genarray.nth_dim b5 2) (Array.length a5.(0).(0)); List.iteri (fun i -> List.iteri (fun j -> List.iteri (fun k -> BA.Genarray.set b5 [| i; j; k |]))) [[[1; 2; 3; 4; 5]; [6; 7; 8; 9; 10]]; [[11; 12; 13; 14; 15]; [16; 17; 18; 19; 20]]; [[21; 22; 23; 24; 25]; [26; 27; 28; 29; 30]]; [[31; 32; 33; 34; 35]; [36; 37; 38; 39; 40]]]; for i = 0 to b5_dim1 - 1 do for j = 0 to b5_dim2 - 1 do for k = 0 to b5_dim3 - 1 do assert_equal (BA.Genarray.get b5 [| i; j; k |]) a5.(i).(j).(k) done done done end; (* Array3 *) let eps64 = 1e-12 in let complex64_eq = let open Complex in fun { re = lre; im = lim } { re = rre; im = rim } -> abs_float (lre -. rre) < eps64 && abs_float (lim -. rim) < eps64 in let b6_dim1 = 3 and b6_dim2 = 4 and b6_dim3 = 2 in let b6 = BA.(Array3.create complex64 c_layout) b6_dim1 b6_dim2 b6_dim3 in let a6 = array_of_bigarray array3 b6 in begin assert_equal (BA.Array3.dim1 b6) (Array.length a6); assert_equal (BA.Array3.dim2 b6) (Array.length a6.(0)); assert_equal (BA.Array3.dim3 b6) (Array.length a6.(0).(0)); let open Complex in List.iteri (fun i -> List.iteri (fun j -> List.iteri (fun k -> fun v -> b6.{i, j, k} <- v))) [[[{re = 1.; im = 10.}; {re = 1e2; im = 0.0}]; [{re = 2.; im = 20.}; {re = 2e2; im = 0.0}]; [{re = 3.; im = 30.}; {re = 3e2; im = 0.0}]; [{re = 4.; im = 40.}; {re = 4e2; im = 0.0}]]; [[{re = 5.; im = 50.}; {re = 5e2; im = 0.1}]; [{re = 6.; im = 60.}; {re = 6e2; im = 0.1}]; [{re = 7.; im = 70.}; {re = 7e2; im = 0.1}]; [{re = 8.; im = 80.}; {re = 8e2; im = 0.1}]]; [[{re = 9.; im = 90.}; {re = 9e2; im = 0.2}]; [{re = 10.; im = 100.}; {re = 1e3; im = 0.2}]; [{re = 11.; im = 110.}; {re = 1.1e3; im = 0.2}]; [{re = 12.; im = 120.}; {re = 1.2e3; im = 0.2}]]]; for i = 0 to b6_dim1 - 1 do for j = 0 to b6_dim2 - 1 do for k = 0 to b6_dim3 - 1 do assert_equal b6.{i, j, k} a6.(i).(j).(k) ~cmp:complex64_eq done done done end module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Test passing bigarrays to c functions. *) let test_passing_bigarrays _ = let mul l r = let m = BA.Array2.dim1 l and n = BA.Array2.dim2 l in let o = BA.Array2.dim1 r and p = BA.Array2.dim2 r in assert (n = o); let product = BA.(Array2.(create (kind l)) c_layout) m p in let addr = bigarray_start array2 in matrix_mul m n p (addr l) (addr r) (addr product); product in assert_equal [[-6.; 11.]; [-3.; -3.]] (unmatrix (mul (matrix [[1.; 6.]; [9.; 3.]]) (matrix [[ 0.; -1.]; [-1.; 2.]]))); assert_equal [[460.; 520.; 580.; 640.; 700.]; [1000.; 1150.; 1300.; 1450.; 1600.]] (unmatrix (mul (matrix [[10.; 20.; 30.]; [40.; 50.; 60.]]) (matrix [[ 1.; 2.; 3.; 4.; 5.]; [ 6.; 7.; 8.; 9.; 10.]; [11.; 12.; 13.; 14.; 15.]]))) (* Test returning bigarrays from c functions. *) let test_returning_bigarrays _ = let transpose m = (* For the purposes of the test we'll just leak the allocated memory. *) let rows = BA.Array2.dim1 m and cols = BA.Array2.dim2 m in bigarray_of_ptr array2 (cols, rows) BA.float64 (matrix_transpose rows cols (bigarray_start array2 m)) in assert_equal [[25.; 1.]; [15.; 2.]; [10.; 3.]; [ 5.; 4.]; [ 0.; 5.]] (unmatrix (transpose (matrix [[25.; 15.; 10.; 5.; 0.]; [ 1.; 2.; 3.; 4.; 5.]]))) end (* Test that bigarrays are not collected while there's a ctypes pointer pointing into them. *) let test_bigarray_lifetime_with_ctypes_reference _ = let state = ref `Not_safe_to_collect in let finalise ba = begin assert_equal `Safe_to_collect !state; assert_equal 1 ba.{0, 0}; state := `Collected; end in let () = let pointer = (* Allocate a bigarray and attach a ctypes pointer *) let ba = Bigarray.(Array2.create int c_layout) 1024 1024 in begin ba.{0,0} <- 1; Gc.finalise finalise ba; bigarray_start array2 ba end in (* The bigarray is out of scope, but the ctypes object is still live, so the memory shouldn't be reclaimed. *) begin Gc.full_major (); Gc.full_major (); assert_equal !state `Not_safe_to_collect; assert_equal 1 !@pointer; end in (* Both the bigarray and the ctypes object are unreachable, so the finaliser should (or, at least, could) run. *) begin state := `Safe_to_collect; Gc.full_major (); Gc.full_major (); assert_equal !state `Collected end (* Test that ctypes-allocated memory is not collected while there's a bigarray associated with it. *) let test_ctypes_memory_lifetime_with_bigarray_reference _ = let module Array = CArray in let state = ref `Not_safe_to_collect in let finalise a = begin assert_equal `Safe_to_collect !state; assert_equal [1L; 2L; 3L; 4L; 5L] (Array.to_list a); state := `Collected end in let () = (* Allocate a chunk of ctypes-managed memory, and view it as a bigarray *) let ba = let a = Array.make ~finalise int64_t 5 in begin for i = 0 to 4 do a.(i) <- Int64.(add (of_int i) one) done; bigarray_of_array array1 BA.int64 a end in (* The ctypes object is out of scope, but the bigarray is still live, so the memory shouldn't be reclaimed. *) begin Gc.full_major (); Gc.full_major (); assert_equal !state `Not_safe_to_collect; assert_equal ba.{0} 1L; assert_equal ba.{3} 4L; end in (* Both the ctypes object and the bigarray are unreachable, so the finaliser should (or, at least, could) run. *) begin state := `Safe_to_collect; Gc.full_major (); Gc.full_major (); assert_equal !state `Collected end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Bigarray tests" >::: ["View ctypes-managed memory using bigarrays" >:: test_bigarray_of_ctypes_array; "View bigarray-managed memory using ctypes" >:: test_ctypes_array_of_bigarray; "Bigarrays live at least as long as ctypes references to them" >:: test_bigarray_lifetime_with_ctypes_reference; "Ctypes-allocated memory lives while there's a bigarray reference to it" >:: test_ctypes_memory_lifetime_with_bigarray_reference; "Passing bigarrays to C (foreign)" >:: Foreign_tests.test_passing_bigarrays; "Passing bigarrays to C (stubs)" >:: Stub_tests.test_passing_bigarrays; "Returning bigarrays from C (foreign)" >:: Foreign_tests.test_returning_bigarrays; "Returning bigarrays from C (stubs)" >:: Stub_tests.test_returning_bigarrays; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-bools/000077500000000000000000000000001274143137600173635ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-bools/stub-generator/000077500000000000000000000000001274143137600223245ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-bools/stub-generator/driver.ml000066400000000000000000000004131274143137600241470ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the bool number tests. *) let () = Tests_common.run Sys.argv (module Functions.Common) ocaml-ctypes-0.7.0/tests/test-bools/stubs/000077500000000000000000000000001274143137600205235ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-bools/stubs/functions.ml000066400000000000000000000006751274143137600230750ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the bool tests. *) open Ctypes (* These functions can be bound either dynamically using Foreign or statically using stub generation. *) module Common(F : Cstubs.FOREIGN) = struct let bool_and = F.(foreign "bool_and" (bool @-> bool @-> returning bool)) end ocaml-ctypes-0.7.0/tests/test-bools/test_bools.ml000066400000000000000000000017151274143137600220760ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Common(S) open M (* Test passing bool values. *) let test_passing_bools _ = begin assert_equal false (M.bool_and false false); assert_equal false (M.bool_and false true); assert_equal false (M.bool_and true false); assert_equal true (M.bool_and true true); end end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Bool tests" >::: ["passing bools (foreign)" >:: Foreign_tests.test_passing_bools; "passing bools (stubs)" >:: Stub_tests.test_passing_bools; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-builtins/000077500000000000000000000000001274143137600200765ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-builtins/stub-generator/000077500000000000000000000000001274143137600230375ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-builtins/stub-generator/driver.ml000066400000000000000000000004071274143137600246650ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the builtins tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-builtins/stubs/000077500000000000000000000000001274143137600212365ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-builtins/stubs/functions.ml000066400000000000000000000011051274143137600235750ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the builtins tests. *) open Ctypes module Stubs (F: Cstubs.FOREIGN) = struct open F (* *ptr |= value; return *ptr; *) let __sync_or_and_fetch = foreign "__sync_or_and_fetch" (ptr uint8_t @-> uint8_t @-> returning uint8_t) (* tmp = *ptr; *ptr &= value; return tmp; *) let __sync_fetch_and_and = foreign "__sync_fetch_and_and" (ptr uint8_t @-> uint8_t @-> returning uint8_t) end ocaml-ctypes-0.7.0/tests/test-builtins/test_builtins.ml000066400000000000000000000013641274143137600233240ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes module Bindings = Functions.Stubs(Generated_bindings) (* Test calling builtins. *) let test_calling_builtins _ = let open Unsigned.UInt8 in let open Bindings in let u1 = of_int 0x77 and u2 = of_int 0x8 in let expected = Infix.(u1 lor u2) in let p = allocate uint8_t u1 in assert (__sync_or_and_fetch p u2 = expected); assert (!@p = expected); p <-@ u1; assert (__sync_fetch_and_and p u2 = u1); assert (!@p = Infix.(u1 land u2)) let suite = "Builtin tests" >::: ["calling builtins" >:: test_calling_builtins; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-callback_lifetime/000077500000000000000000000000001274143137600216575ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-callback_lifetime/stub-generator/000077500000000000000000000000001274143137600246205ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-callback_lifetime/stub-generator/driver.ml000066400000000000000000000004201274143137600264410ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the callback lifetime tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-callback_lifetime/stubs/000077500000000000000000000000001274143137600230175ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-callback_lifetime/stubs/functions.ml000066400000000000000000000012151274143137600253600ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the callback lifetime tests. *) open Ctypes open Foreign module Stubs (F: Cstubs.FOREIGN) = struct open F let callback_type_ptr = funptr Ctypes.(int @-> returning int) let store_callback = foreign "store_callback" (callback_type_ptr @-> returning void) let invoke_stored_callback = foreign "invoke_stored_callback" (int @-> returning int) let return_callback = foreign "return_callback" (callback_type_ptr @-> returning callback_type_ptr) end ocaml-ctypes-0.7.0/tests/test-callback_lifetime/test_callback_lifetime.ml000066400000000000000000000120151274143137600266610ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes open Foreign module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Check that we can store a reference to an OCaml function in a C global and invoke it later. *) let test_storing_function_reference _ = (* This shouldn't be collected in the code that follows. *) let double x = x * 2 in begin store_callback double; Gc.full_major (); assert_equal 10 (invoke_stored_callback 5) end (* Check that if a closure passed to C is collected before it's called then CallToExpiredClosure is raised. The value of this test is questionable: calling an expired closure does not have defined behaviour, since the structures needed to make the call may have been garbage collected. *) let test_calling_collected_closure_raises_exception _ = let closure x y = x * y in begin (* The closure should be collected in the next GC *) store_callback (closure (int_of_string "2")); (* The first GC collects the closure itself, which frees the associated object to be collected on the next GC. *) Gc.full_major (); Gc.full_major (); assert_raises CallToExpiredClosure (fun () -> invoke_stored_callback 5) end (* Check that we have fairly fine-grained control over the lifetime of closures passed to C. *) let test_controlling_closure_lifetime _ = (* The return_callback function simply returns its argument. However, since that involves converting an OCaml function ("arg") to a C function pointer and back to an OCaml function ("ret"), there are potential problems with memory management. More precisely, ret holds a reference to a C/libffi closure, which in turn holds a reference to arg that is not visible to the GC. We'd like to ensure that arg is not collected before ret is called, which requires that we store ret and arg together. This test demonstrate the behaviour of naive and more careful implementations. *) let module Sig = struct module type S = sig type t val make : arg:(int -> int) -> t val get : t -> (int -> int) end end in let module Naive : Sig.S = struct type t = { ret : int -> int ; } let make ~arg = { ret = return_callback arg } let get { ret } = ret end in let module Better : Sig.S = struct type t = { ret : int -> int ; arg : int -> int ; } let make ~arg = { arg ; ret = return_callback arg } let get { ret } = ret end in let module Careful : Sig.S = struct type t = { ret : int -> int ; arg : int -> int ; } let make ~arg = { arg ; ret = return_callback arg } let get { ret } c = ret c end in let closure x y = x * y in (* First, the naive implementation. This should fail, because arg is collected before ret is called. *) let ret = Naive.make ~arg:(closure (int_of_string "3")) in Gc.full_major (); assert_raises CallToExpiredClosure (fun () -> Naive.get ret 5); (* Now a more careful implementation. This succeeds, because we keep a reference to arg around with the reference to ret *) let ret = Better.make ~arg:(closure (int_of_string "3")) in Gc.full_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 (int_of_string "3"))) in Gc.full_major (); assert_raises CallToExpiredClosure (fun () -> ret 5); (* The most careful implementation calls ret rather than returning it, so arg cannot be collected prematurely. *) let ret = Careful.get (Careful.make ~arg:(closure (int_of_string "3"))) in Gc.full_major (); assert_equal 15 (ret 5) end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Callback lifetime tests" >::: ["storing references to OCaml functions (foreign)" >:: Foreign_tests.test_storing_function_reference; "storing references to OCaml functions (stubs)" >:: Stub_tests.test_storing_function_reference; "calling expired closures (foreign)" >:: Foreign_tests.test_calling_collected_closure_raises_exception; "calling expired closures (stubs)" >:: Stub_tests.test_calling_collected_closure_raises_exception; "controlling the lifetime of closures passed to C (foreign)" >:: Foreign_tests.test_controlling_closure_lifetime; "controlling the lifetime of closures passed to C (stubs)" >:: Stub_tests.test_controlling_closure_lifetime; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-coercions/000077500000000000000000000000001274143137600202315ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-coercions/stub-generator/000077500000000000000000000000001274143137600231725ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-coercions/stub-generator/driver.ml000066400000000000000000000004661274143137600250250ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the coercions tests. *) let cheader = "#include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-coercions/stubs/000077500000000000000000000000001274143137600213715ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-coercions/stubs/functions.ml000066400000000000000000000005561274143137600237410ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the coercion tests. *) open Ctypes module Stubs (F: Cstubs.FOREIGN) = struct open F let memchr = foreign "memchr" (ptr void @-> int @-> size_t @-> returning (ptr void)) end ocaml-ctypes-0.7.0/tests/test-coercions/test_coercions.ml000066400000000000000000000176641274143137600236240ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes (* Check coercions between pointers. *) let test_pointer_coercions _ = let module M = struct type boxed_type = T : 'a typ -> boxed_type let types = [ T void; T int8_t; T uint16_t; T int; T float; T short; T complex64; T (ptr double); T string; T (bigarray array1 10 Bigarray.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4); ] (* Check that we can construct a coercion between any two pointer types *) let () = ListLabels.iter types ~f:(fun (T t1) -> ListLabels.iter types ~f:(fun (T t2) -> let _ = coerce (ptr t1) (ptr t2) in ())) (* Check that pointer coercions are value-preserving. *) let v = 10 let p = allocate int v let p' = coerce (ptr float) (ptr int) (coerce (ptr int) (ptr float) p) let () = assert_equal p p' end in () (* Check that coercions between a pointer to a struct and a pointer to its first member succeed. *) let test_struct_first_member_coercions _ = let module M = struct let s = structure "s" let f = field s "f" double let i = field s "i" int let () = seal s let () = begin let v = make s in let p = coerce (ptr s) (ptr double) (addr v) in setf v f 5.5; assert_equal !@p 5.5; p <-@ 6.6; assert_equal (getf v f) 6.6 end end in () (* Check that coercions between a pointer to a union and a pointer to a member succeed. *) let test_union_coercions _ = let module M = struct let u = union "u" let f = field u "f" double let i = field u "i" int let () = seal u let () = begin let v = make u in let pf = coerce (ptr u) (ptr double) (addr v) in let pi = coerce (ptr u) (ptr int) (addr v) in setf v f 5.5; assert_equal !@pf 5.5; pi <-@ 12; assert_equal (getf v i) 12; setf v i 14; assert_equal !@pi 14; pf <-@ 6.6; assert_equal (getf v f) 6.6; end end in () (* Check coercions between views. *) let test_view_coercions _ = let module M = struct type 'a variant = V of 'a let unV (V v) = v and inV v = V v let variant_view v = view v ~read:inV ~write:unV type 'a record = { r : 'a } let record_view v = view v ~read:(fun r -> {r}) ~write:(fun {r} -> r) let pintvv = variant_view (variant_view (ptr int)) let pintr = record_view (ptr int) let () = begin let pi = allocate int 100 in let v = allocate pintvv (V (V pi)) in assert_equal !@((coerce pintvv pintr !@v).r) 100 end end in () module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Check coercions between functions. *) let test_function_coercions _ = let isize_t = view size_t ~read:Unsigned.Size_t.to_int ~write:Unsigned.Size_t.of_int in let memchr' = coerce_fn (ptr void @-> int @-> size_t @-> returning (ptr void)) (string @-> int8_t @-> isize_t @-> returning string_opt) memchr in begin assert_equal (memchr' "foobar" (Char.code 'b') 4) (Some "bar") ; assert_equal (memchr' "foobar" (Char.code 'b') 2) None ; end end (* Check that identity coercions are cost-free. *) let test_identity_coercions _ = let f = fun x y -> x in let fn = int @-> float @-> returning int in let f' = coerce_fn fn fn f in assert_bool "identity coercions are free" (f' == f) (* Check that coercions between unsupported types raise an exception *) let test_unsupported_coercions _ = let module M = struct type boxed_type = T : 'a typ -> boxed_type let types = [ T int8_t, [T uint16_t; T float; T complex64; T (bigarray array1 10 Bigarray.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T uint16_t, [T int8_t; T int; T float; T short; T complex64; T (bigarray array1 10 Bigarray.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T int, [T uint16_t; T float; T complex64; T (bigarray array1 10 Bigarray.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T float, [T int8_t; T uint16_t; T int; T short; T complex64; T (bigarray array1 10 Bigarray.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T short, [T uint16_t; T float; T complex64; T (bigarray array1 10 Bigarray.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T complex64, [T int8_t; T uint16_t; T int; T float; T short; T (bigarray array1 10 Bigarray.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T (bigarray array1 10 Bigarray.int32), [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)]; T (array 5 int32_t), [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)]; T (structure "s"), [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)]; T (union "u"), [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)]; T (abstract ~name:"a" ~size:12 ~alignment:4), [T int8_t; T uint16_t; T int; T float; T short; T complex64; T (bigarray array1 10 Bigarray.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; T ocaml_string, [T int8_t; T uint16_t; T int; T float; T short; T complex64; T (bigarray array1 10 Bigarray.int32); T (array 5 int32_t); T (structure "s"); T (union "u"); T (abstract ~name:"a" ~size:12 ~alignment:4)]; ] (* None of the types in the list are currently intercoercible. *) let () = ListLabels.iter types ~f:(fun (T t1, ts) -> ListLabels.iter ts ~f:(fun (T t2) -> try coerce t1 t2; assert_failure "coercion unexpectedly succeeded" with Uncoercible _ -> ())) end in () module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Coercsion tests" >::: ["test pointer coercions" >:: test_pointer_coercions; "test struct first member coercions" >:: test_struct_first_member_coercions; "test union coercions" >:: test_union_coercions; "test view coercions" >:: test_view_coercions; "test function coercions (foreign)" >:: Foreign_tests.test_function_coercions; "test function coercions (stubs)" >:: Stub_tests.test_function_coercions; "test identity coercions" >:: test_identity_coercions; "test unsupported coercions" >:: test_unsupported_coercions; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-complex/000077500000000000000000000000001274143137600177145ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-complex/stub-generator/000077500000000000000000000000001274143137600226555ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-complex/stub-generator/driver.ml000066400000000000000000000004151274143137600245020ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the complex number tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-complex/stubs/000077500000000000000000000000001274143137600210545ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-complex/stubs/functions.ml000066400000000000000000000023731274143137600234230ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the complex number tests. *) open Ctypes (* These functions can be bound either dynamically using Foreign or statically using stub generation. *) module Common(F : Cstubs.FOREIGN) = struct let bind typ name = F.(foreign name (ptr typ @-> ptr typ @-> ptr typ @-> returning void)) let add_complexd = bind complex64 "add_complexd" let mul_complexd = bind complex64 "mul_complexd" let add_complexf = bind complex32 "add_complexf" let mul_complexf = bind complex32 "mul_complexf" end (* These functions can only be bound using stub generation, since Foreign doesn't support passing complex numbers by value. *) module Stubs_only(F : Cstubs.FOREIGN) = struct let bind typ name = F.(foreign name (typ @-> typ @-> returning typ)) let add_complexd_val = bind complex64 "add_complexd_val" let mul_complexd_val = bind complex64 "mul_complexd_val" let add_complexf_val = bind complex32 "add_complexf_val" let mul_complexf_val = bind complex32 "mul_complexf_val" end module Stubs (F: Cstubs.FOREIGN) = struct include Common(F) include Stubs_only(F) end ocaml-ctypes-0.7.0/tests/test-complex/test_complex.ml000066400000000000000000000065261274143137600227650ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes let testlib = Dl.(dlopen ~filename:"clib/libtest_functions.so" ~flags:[RTLD_NOW]) module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Common(S) open M (* Test primitive operations on complex numbers. Arguments and return values are currently mediated through pointers, since libffi doesn't support passing complex numbers. *) let test_complex_primitive_operations _ = let wrap typ f 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 end module Build_stub_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module N = Functions.Stubs(S) open N include Common_tests(S) (* Test primitive operations on complex numbers passed by value. *) let test_complex_primitive_value_operations _ = begin let open Complex in let eps64 = 1e-12 in let complex64_eq { re = lre; im = lim } { re = rre; im = rim } = abs_float (lre -. rre) < eps64 && abs_float (lim -. rim) < eps64 in let eps32 = 1e-6 in let complex32_eq { re = lre; im = lim } { re = rre; im = rim } = abs_float (lre -. rre) < eps32 && abs_float (lim -. rim) < eps32 in let l = { re = 3.5; im = -1.0 } and r = { re = 2.0; im = 2.7 } in assert_equal ~cmp:complex64_eq (Complex.add l r) (add_complexd_val l r); assert_equal ~cmp:complex64_eq (Complex.mul l r) (mul_complexd_val l r); assert_equal ~cmp:complex32_eq (Complex.add l r) (add_complexf_val l r); assert_equal ~cmp:complex32_eq (Complex.mul l r) (mul_complexf_val l r); end end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Build_stub_tests(Generated_bindings) let suite = "Complex number tests" >::: ["basic operations on complex numbers (foreign)" >:: Foreign_tests.test_complex_primitive_operations; "basic operations on complex numbers (stubs)" >:: Stub_tests.test_complex_primitive_operations; "basic operations on complex numbers passed by value(stubs)" >:: Stub_tests.test_complex_primitive_value_operations; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-constants/000077500000000000000000000000001274143137600202615ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-constants/stub-generator/000077500000000000000000000000001274143137600232225ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-constants/stub-generator/driver.ml000066400000000000000000000006241274143137600250510ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the constants tests. *) let cheader = "#include \n#include " let () = Tests_common.run Sys.argv ~cheader ~structs:(module Types.Struct_stubs) (module functor (S: Cstubs.FOREIGN) -> struct end) ocaml-ctypes-0.7.0/tests/test-constants/stubs/000077500000000000000000000000001274143137600214215ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-constants/stubs/types.ml000066400000000000000000000036741274143137600231310ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes module Struct_stubs(S : Cstubs.Types.TYPE) = struct open S let _SCHAR_MIN = constant "SCHAR_MIN" schar let _SCHAR_MAX = constant "SCHAR_MAX" schar let _UCHAR_MAX = constant "UCHAR_MAX" uchar let _CHAR_MIN = constant "CHAR_MIN" char let _CHAR_MAX = constant "CHAR_MAX" char let _SHRT_MIN = constant "SHRT_MIN" short let _SHRT_MAX = constant "SHRT_MAX" short let _USHRT_MAX = constant "USHRT_MAX" ushort let _INT_MIN = constant "INT_MIN" sint let _INT_MAX = constant "INT_MAX" sint let _UINT_MAX = constant "UINT_MAX" uint let _LONG_MAX = constant "LONG_MAX" long let _LONG_MIN = constant "LONG_MIN" long let _ULONG_MAX = constant "ULONG_MAX" ulong let _LLONG_MAX = constant "LLONG_MAX" llong let _LLONG_MIN = constant "LLONG_MIN" llong let _ULLONG_MAX = constant "ULLONG_MAX" ullong let _INT8_MIN = constant "INT8_MIN" int8_t let _INT16_MIN = constant "INT16_MIN" int16_t let _INT32_MIN = constant "INT32_MIN" int32_t let _INT64_MIN = constant "INT64_MIN" int64_t let _INT8_MAX = constant "INT8_MAX" int8_t let _INT16_MAX = constant "INT16_MAX" int16_t let _INT32_MAX = constant "INT32_MAX" int32_t let _INT64_MAX = constant "INT64_MAX" int64_t let _UINT8_MAX = constant "UINT8_MAX" uint8_t let _UINT16_MAX = constant "UINT16_MAX" uint16_t let _UINT32_MAX = constant "UINT32_MAX" uint32_t let _UINT64_MAX = constant "UINT64_MAX" uint64_t let _SIZE_MAX = constant "SIZE_MAX" size_t let _true = constant "true" bool let _false = constant "false" bool let i32_inverted = view int32_t ~read:Int32.neg ~write:Int32.neg let neg_INT16_MAX = constant "INT16_MAX" i32_inverted let neg_INT16_MIN = constant "INT16_MIN" i32_inverted let _A = constant "A" int let _B = constant "B" int let _C = constant "C" int let _D = constant "D" int end ocaml-ctypes-0.7.0/tests/test-constants/test_constants.ml000066400000000000000000000067611274143137600237000ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes let testlib = Dl.(dlopen ~filename:"clib/libtest_functions.so" ~flags:[RTLD_NOW]) module Constants = Types.Struct_stubs(Generated_struct_bindings) let constant name typ = Foreign.foreign ~from:testlib ("retrieve_"^ name) (void @-> returning typ) () let test_retrieve_constants _ = begin assert_equal Constants._LONG_MIN (constant "LONG_MIN" long); assert_equal Constants._SCHAR_MIN (constant "SCHAR_MIN" Ctypes.schar); assert_equal Constants._SCHAR_MAX (constant "SCHAR_MAX" Ctypes.schar); assert_equal Constants._UCHAR_MAX (constant "UCHAR_MAX" Ctypes.uchar); assert_equal Constants._CHAR_MIN (constant "CHAR_MIN" Ctypes.char); assert_equal Constants._CHAR_MAX (constant "CHAR_MAX" Ctypes.char); assert_equal Constants._SHRT_MIN (constant "SHRT_MIN" Ctypes.short); assert_equal Constants._SHRT_MAX (constant "SHRT_MAX" Ctypes.short); assert_equal Constants._USHRT_MAX (constant "USHRT_MAX" Ctypes.ushort); assert_equal Constants._INT_MIN (constant "INT_MIN" Ctypes.sint); assert_equal Constants._INT_MAX (constant "INT_MAX" Ctypes.sint); assert_equal Constants._UINT_MAX (constant "UINT_MAX" Ctypes.uint); assert_equal Constants._LONG_MAX (constant "LONG_MAX" Ctypes.long); assert_equal Constants._LONG_MIN (constant "LONG_MIN" Ctypes.long); assert_equal Constants._ULONG_MAX (constant "ULONG_MAX" Ctypes.ulong); assert_equal Constants._LLONG_MAX (constant "LLONG_MAX" Ctypes.llong); assert_equal Constants._LLONG_MIN (constant "LLONG_MIN" Ctypes.llong); assert_equal Constants._ULLONG_MAX (constant "ULLONG_MAX" Ctypes.ullong); assert_equal Constants._INT8_MIN (constant "INT8_MIN" Ctypes.int8_t); assert_equal Constants._INT16_MIN (constant "INT16_MIN" Ctypes.int16_t); assert_equal Constants._INT32_MIN (constant "INT32_MIN" Ctypes.int32_t); assert_equal Constants._INT64_MIN (constant "INT64_MIN" Ctypes.int64_t); assert_equal Constants._INT8_MAX (constant "INT8_MAX" Ctypes.int8_t); assert_equal Constants._INT16_MAX (constant "INT16_MAX" Ctypes.int16_t); assert_equal Constants._INT32_MAX (constant "INT32_MAX" Ctypes.int32_t); assert_equal Constants._INT64_MAX (constant "INT64_MAX" Ctypes.int64_t); assert_equal Constants._UINT8_MAX (constant "UINT8_MAX" Ctypes.uint8_t); assert_equal Constants._UINT16_MAX (constant "UINT16_MAX" Ctypes.uint16_t); assert_equal Constants._UINT32_MAX (constant "UINT32_MAX" Ctypes.uint32_t); assert_equal Constants._UINT64_MAX (constant "UINT64_MAX" Ctypes.uint64_t); assert_equal Constants._SIZE_MAX (constant "SIZE_MAX" Ctypes.size_t); assert_equal Constants._true true; assert_equal Constants._false false; end let test_retrieve_views _ = begin assert_equal Constants.neg_INT16_MAX (Int32.(neg (of_int (constant "INT16_MAX" Ctypes.int16_t)))) ; assert_equal Constants.neg_INT16_MIN (Int32.(neg (of_int (constant "INT16_MIN" Ctypes.int16_t)))) ; end let test_retrieve_enums _ = begin assert_equal [0; 1; 10; 11] Constants.([_A; _B; _C; _D]) end let suite = "Constant tests" >::: ["retrieving values of various integer types" >:: test_retrieve_constants; "retrieving values of view type" >:: test_retrieve_views; "retrieving enumeration constants" >:: test_retrieve_enums; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-cstdlib/000077500000000000000000000000001274143137600176715ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-cstdlib/stub-generator/000077500000000000000000000000001274143137600226325ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-cstdlib/stub-generator/driver.ml000066400000000000000000000005501274143137600244570ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the C standard library tests. *) let cheader = " #include #include #include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-cstdlib/stubs/000077500000000000000000000000001274143137600210315ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-cstdlib/stubs/functions.ml000066400000000000000000000035331274143137600233770ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the C standard library tests. *) open Ctypes open Foreign module Stubs (F: Cstubs.FOREIGN) = struct open F let cchar = view ~read:Char.chr ~write:Char.code int let bool = view ~read:((<>)0) ~write:(fun b -> if b then 1 else 0) int let t = (cchar @-> returning bool) let isalnum = foreign "isalnum" t and isalpha = foreign "isalpha" t and iscntrl = foreign "iscntrl" t and isdigit = foreign "isdigit" t and isgraph = foreign "isgraph" t and islower = foreign "islower" t and isprint = foreign "isprint" t and ispunct = foreign "ispunct" t and isspace = foreign "isspace" t and isupper = foreign "isupper" t and isxdigit = foreign "isxdigit" t (* char *strchr(const char *str, int c); *) let strchr = foreign "strchr" (string @-> int @-> returning string) (* int strcmp(const char *str1, const char *str2); *) let strcmp = foreign "strcmp" (string @-> string @-> returning int) (* int memcmp(const void *ptr1, const void *ptr2, size_t num) *) let memcmp = foreign "memcmp" (ptr void @-> ptr void @-> size_t @-> returning int) (* void *memset(void *ptr, int value, size_t num) *) let memset = foreign "memset" (ptr void @-> int @-> size_t @-> returning (ptr void)) (* let div = foreign "div" (int @-> int @-> returning div_t) *) let qsort = foreign "qsort" (ptr void @-> size_t @-> size_t @-> funptr Ctypes.(ptr void @-> ptr void @-> returning int) @-> returning void) let bsearch = foreign "bsearch" (ptr void @-> ptr void @-> size_t @-> size_t @-> funptr Ctypes.(ptr void @-> ptr void @-> returning int) @-> returning (ptr void)) let strlen = foreign "strlen" (ptr char @-> returning size_t) end ocaml-ctypes-0.7.0/tests/test-cstdlib/test_cstdlib.ml000066400000000000000000000204151274143137600227100ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes open Unsigned open Foreign module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Call the functions int isisalnum(int) int isisalpha(int) int isiscntrl(int) int isisdigit(int) int isisgraph(int) int isislower(int) int isisprint(int) int isispunct(int) int isisspace(int) int isisupper(int) int isisxdigit(int) *) let test_isX_functions _ = begin assert_bool "" (isalnum 'a'); assert_bool "" (not (isalnum ' ')); assert_bool "" (isalpha 'x'); assert_bool "" (not (isalpha ';')); assert_bool "" (iscntrl '\r'); assert_bool "" (not (iscntrl 'a')); assert_bool "" (isdigit '2'); assert_bool "" (not (isdigit 'a')); assert_bool "" (isgraph '?'); assert_bool "" (not (isgraph ' ')); assert_bool "" (islower 's'); assert_bool "" (not (islower 'S')); assert_bool "" (isprint ' '); assert_bool "" (not (isprint '\b')); assert_bool "" (ispunct '.'); assert_bool "" (not (ispunct 'a')); assert_bool "" (isspace '\t'); assert_bool "" (not (isspace '~')); assert_bool "" (isupper 'X'); assert_bool "" (not (isupper 'x')); assert_bool "" (isxdigit 'f'); assert_bool "" (not (isxdigit 'g')); end (* Call the functions char *strchr(const char *str, int c); int strcmp(const char *str1, const char *str2); *) let test_string_functions _ = assert_equal "efg" (strchr "abcdefg" (Char.code 'e')) ~printer:(fun x -> x); (* non-word-aligned pointers do not trigger exceptions *) assert_equal "defg" (strchr "abcdefg" (Char.code 'd')); assert_bool "strcmp('abc', 'def') < 0" (strcmp "abc" "def" < 0); assert_bool "strcmp('def', 'abc') > 0" (strcmp "def" "abc" > 0); assert_bool "strcmp('abc', 'abc') == 0" (strcmp "abc" "abc" = 0); let p1 = allocate int 10 and p2 = allocate int 20 in assert_bool "memcmp(&10, &20) < 0" (memcmp (to_voidp p1) (to_voidp p2) (Size_t.of_int (sizeof int)) < 0); let p = allocate_n uchar 12 in let i = 44 in let u = UChar.of_int i in begin ignore (memset (to_voidp p) i (Size_t.of_int 12)); for i = 0 to 11 do assert_equal u !@(p +@ i) done end (* Call the function void qsort(void *base, size_t nmemb, size_t size, int(*compar)(const void *, const void *)); *) let test_qsort _ = let sortby (type a) (typ : a typ) (f : a -> a -> int) (l : a list) = let open CArray in let open Size_t in let 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 (* struct mi { int nr; char *name; } months[] = { { 1, "jan" }, { 2, "feb" }, { 3, "mar" }, { 4, "apr" }, { 5, "may" }, { 6, "jun" }, { 7, "jul" }, { 8, "aug" }, { 9, "sep" }, {10, "oct" }, {11, "nov" }, {12, "dec" } }; *) type mi let mi = structure "mi" let (-:) ty label = field mi label ty let mr = int -: "mr" let name = ptr char -: "name" let () = seal (mi : mi structure typ) let of_string : string -> char carray = fun s -> CArray.from_ptr (coerce string (ptr char) s) (String.length s) let as_string : char ptr -> string = coerce (ptr char) string let mkmi n s = let m = make mi in setf m mr n; setf m name (CArray.start s); m let cmpi m1 m2 = let mi1 = from_voidp mi m1 in let mi2 = from_voidp mi m2 in 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 = CArray.of_list mi [ mkmi 1 jan; mkmi 2 feb; mkmi 3 mar; mkmi 4 apr; mkmi 5 may; mkmi 6 jun; mkmi 7 jul; mkmi 8 aug; mkmi 9 sep; mkmi 10 oct; mkmi 11 nov; mkmi 12 dec; ] let () = qsort (to_voidp (CArray.start months)) (Size_t.of_int (CArray.length months)) (Size_t.of_int (sizeof mi)) cmpi let search : mi structure -> mi structure carray -> mi structure option = fun key array -> let len = Size_t.of_int (CArray.length array) in let size = Size_t.of_int (sizeof mi) in let r : unit ptr = bsearch (to_voidp (addr key)) (to_voidp (CArray.start array)) len size cmpi in if r = null then None else Some (!@(from_voidp mi r)) let find_month_by_name : char carray -> mi structure option = fun s -> search (mkmi 0 s) months let () = match find_month_by_name dec with Some m -> assert_equal 12 (getf m mr) | _ -> assert false let () = match find_month_by_name feb with Some m -> assert_equal 2 (getf m mr) | _ -> assert false let () = match find_month_by_name jan with Some m -> assert_equal 1 (getf m mr) | _ -> assert false let () = match find_month_by_name may with Some m -> assert_equal 5 (getf m mr) | _ -> assert false let missing = of_string "missing" let () = assert_equal None (find_month_by_name missing) let empty = of_string "" let () = assert_equal None (find_month_by_name empty) end in () end (* Call the functions div_t div(int numerator, int denominator) where div_t is defined as follows: typedef struct { int quot; /* Quotient. */ int rem; /* Remainder. */ } div_t; *) let test_div _ = let module M = struct type div_t let div_t : div_t structure typ = structure "div_t" let (-:) ty label = field div_t label ty let quot = int -: "quot" let rem = int -: "rem" let () = seal div_t let div = foreign "div" (int @-> int @-> returning div_t) let test ~num ~dem ~quotient ~remainder = let v = div num dem in let () = assert_equal quotient (getf v quot) in let () = assert_equal remainder (getf v rem) in () let () = test ~num:10 ~dem:2 ~quotient:5 ~remainder:0 let () = test ~num:11 ~dem:2 ~quotient:5 ~remainder:1 end in () module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "C standard library tests" >::: ["test isX functions (foreign)" >:: Foreign_tests.test_isX_functions; "test isX functions (stubs)" >:: Stub_tests.test_isX_functions; "test string function (foreign)" >:: Foreign_tests.test_string_functions; "test string function (stubs)" >:: Stub_tests.test_string_functions; "test div function" >:: test_div; "test qsort function (foreign)" >:: Foreign_tests.test_qsort; "test qsort function (stubs)" >:: Stub_tests.test_qsort; "test bsearch function (foreign)" >:: Foreign_tests.test_bsearch; "test bsearch function (stubs)" >:: Stub_tests.test_bsearch; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-custom_ops/000077500000000000000000000000001274143137600204405ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-custom_ops/test_custom_ops.ml000066400000000000000000000051131274143137600242240ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes let hash = Hashtbl.hash (* Test hashing and equality for managed buffers. Hashing and equality are based on the addresses of malloc-allocated objects, so even structurally-equal values should have different hashes and compare unequal. *) let test_managed_buffer_hashing_and_equality _ = let i1 = allocate int 20 in let i2 = allocate int 20 in assert_equal !@i1 !@i2; assert_equal (hash i1) (hash i1); assert_bool "equal-but-not-identical objects have distinct hashes" (hash i1 <> hash i2); assert_bool "equal-but-not-identical objects do not compare equal" (i1 <> i2) (* Test type info hashing and equality. Equality is structural, so distinct but structurally-equal values should have equal hashes and compare equal. *) let test_type_info_hashing_and_equality _ = let module M = struct type s let s : s structure typ = structure "s" let _ = begin ignore (field s "d" double); ignore (field s "p" (ptr void)); seal s end type t let t : t structure typ = structure "s" let _ = begin ignore (field t "d" double); ignore (field t "p" (ptr void)); seal t end let () = begin (* Pointer equality is structural. *) assert_equal ~msg:"Equal pointer types have equal hashes" (hash (ptr double)) (hash (ptr double)); assert_equal ~msg:"Equal pointer types compare equal" (ptr double) (ptr double); (* Array equality is structural. *) assert_equal ~msg:"Equal array types have equal hashes" (hash (array 3 (array 4 int))) (hash (array 3 (array 4 int))); assert_equal ~msg:"Equal array types compare equal" (array 3 (array 4 int)) (array 3 (array 4 int)); assert_bool "Distinct array types do not compare equal" (array 3 (array 4 int) <> array 3 (array 5 int)); (* Structure equality is structural *) assert_equal (hash s) (hash s); assert_bool "equal-but-not-identical structure types have equal hashes" (hash s = hash t); assert_bool "equal-but-not-identical structure types compare equal" (Obj.repr s = Obj.repr t); end end in () let suite = "Custom ops tests" >::: ["managed buffer hashing and equality" >:: test_managed_buffer_hashing_and_equality; "type info hashing and equality" >:: test_type_info_hashing_and_equality; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-enums/000077500000000000000000000000001274143137600173745ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-enums/struct-stub-generator/000077500000000000000000000000001274143137600236575ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-enums/struct-stub-generator/driver.ml000066400000000000000000000005171274143137600255070ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Struct stub generation driver for the enum tests. *) let () = Tests_common.run Sys.argv ~structs:(module Types.Struct_stubs) (module functor (X: Cstubs.FOREIGN) -> struct end) ocaml-ctypes-0.7.0/tests/test-enums/struct-stubs/000077500000000000000000000000001274143137600220565ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-enums/struct-stubs/types.ml000066400000000000000000000024231274143137600235550ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes type fruit = Orange | Apple | Banana | Pear module Struct_stubs(S : Cstubs.Types.TYPE) = struct open S let orange = constant "Orange" int64_t let apple = constant "Apple" int64_t let pear = constant "Pear" int64_t let banana = constant "Banana" int64_t let fruit = enum "fruit" [ Orange , orange ; Apple , apple ; Pear , pear ; Banana , banana ; ] let minus_one = constant "minus_one" int64_t let plus_one = constant "plus_one" int64_t let signed = enum "signed_enum" ~unexpected:(fun _ -> 0) [ -1, minus_one ; 1 , plus_one ; ] let fruit_cell : [`fruit_cell] structure typ = structure "fruit_cell" let frt = field fruit_cell "frt" fruit let next = field fruit_cell "next" (ptr_opt fruit_cell) let () = seal fruit_cell let edward = constant "Edward" int64_t let winnie = constant "Winnie" int64_t let paddington = constant "Paddington" int64_t let bears : [`Edward|`Winnie|`Paddington] typ = enum "bears" [ `Edward , edward ; `Winnie , winnie ; `Paddington , paddington ; ] end ocaml-ctypes-0.7.0/tests/test-enums/stub-generator/000077500000000000000000000000001274143137600223355ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-enums/stub-generator/driver.ml000066400000000000000000000004031274143137600241570ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the enum tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-enums/stubs/000077500000000000000000000000001274143137600205345ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-enums/stubs/functions.ml000066400000000000000000000012611274143137600230760ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the enum tests. *) open Ctypes (* These functions can only be bound using stub generation, since Foreign doesn't support passing enums. *) module Stubs(F : Cstubs.FOREIGN) = struct open F module T = Types.Struct_stubs(Generated_struct_bindings) let classify_integer = foreign "classify_integer" (int @-> returning T.signed) let out_of_range = foreign "out_of_range" (void @-> returning T.signed) let next_fruit = foreign "next_fruit" (T.fruit @-> returning T.fruit) end ocaml-ctypes-0.7.0/tests/test-enums/test_enums.ml000066400000000000000000000057351274143137600221260ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes module Build_enum_stub_tests (S : Cstubs.Types.TYPE with type 'a typ = 'a Ctypes.typ and type ('a, 's) field = ('a, 's) Ctypes.field) = struct module M = Types.Struct_stubs(S) open M let test_enum_struct_members _ = let reverse cell = let rec loop prev cell = match cell with None -> prev | Some c -> let n = getf !@c next in let () = setf !@c next prev in loop cell n in loop None cell in let as_list cell = let rec loop l = function None -> List.rev l | Some c -> loop (getf !@c frt :: l) (getf !@c next) in loop [] cell in let rec of_list l = match l with [] -> None | f :: fs -> let c = make fruit_cell in let n = of_list fs in let () = setf c frt f in let () = setf c next n in Some (addr c) in begin let open Types in let l = of_list [Apple; Apple; Pear; Banana] in assert_equal [Apple; Apple; Pear; Banana] (as_list l); assert_equal [Banana; Pear; Apple; Apple] (as_list (reverse l)); assert_equal [] (as_list None); end let test_enum_arrays _ = let module Array = CArray in let a = Array.make bears 4 in begin a.(0) <- `Edward; a.(1) <- `Winnie; a.(2) <- `Paddington; a.(3) <- `Edward; assert_equal [`Edward; `Winnie; `Paddington; `Edward] (Array.to_list a) end module Build_call_tests (F : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module F = Functions.Stubs(F) open F open M let test_passing_returning_enums _ = let open Types in begin assert_equal Apple (next_fruit Orange); assert_equal Banana (next_fruit Apple); assert_equal Pear (next_fruit Banana); assert_equal Orange (next_fruit Pear); end let test_signed_enums _ = begin assert_equal (-1) (classify_integer (-3)); assert_equal 1 (classify_integer 4); end let test_default_enums _ = begin assert_equal 0 (out_of_range ()) end end end module Enum_stubs_tests = Build_enum_stub_tests(Generated_struct_bindings) module Combined_stub_tests = Enum_stubs_tests.Build_call_tests(Generated_bindings) let suite = "Enum tests" >::: [ "passing and returning enums" >:: Combined_stub_tests.test_passing_returning_enums; "enums with signed values" >:: Combined_stub_tests.test_signed_enums; "enums with default values" >:: Combined_stub_tests.test_default_enums; "enums as struct members" >:: Enum_stubs_tests.test_enum_struct_members; "arrays of enums" >:: Enum_stubs_tests.test_enum_arrays; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-finalisers/000077500000000000000000000000001274143137600204045ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-finalisers/test_finalisers.ml000066400000000000000000000040171274143137600241360ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes (* Simple finalisation test for arrays. *) let test_array_finaliser _ = let module Array = CArray in let finaliser_completed = ref false in let finalise a = begin assert_equal 10 (Array.length a); assert_equal [1;2;3;4;5;6;7;8;9;10] (Array.to_list a); finaliser_completed := true; end in let () = let p = let a = Array.make ~finalise int 10 in begin for i = 0 to 9 do a.(i) <- i + 1 done; Array.start a end in begin Gc.full_major (); assert_equal ~msg:"The finaliser was not run" false !finaliser_completed; assert_equal 1 !@p; end in begin Gc.full_major (); assert_equal ~msg:"The finaliser was run" true !finaliser_completed; end (* Simple finalisation test for structs. *) let test_struct_finaliser _ = let module M = struct type s let s : s structure typ = structure "s" let i = field s "i" int32_t let c = field s "c" char let () = seal s let finaliser_completed = ref false let finalise s = begin assert_equal 10l (getf s i); assert_equal 'e' (getf s c); finaliser_completed := true; end let () = let p = let s = make ~finalise s in begin setf s i 10l; setf s c 'e'; addr s end in begin Gc.full_major (); assert_equal ~msg:"The finaliser was not run" false !finaliser_completed; assert_equal 10l !@(from_voidp int32_t (to_voidp p)); end let () = begin Gc.full_major (); assert_equal ~msg:"The finaliser was run" true !finaliser_completed; end end in () let suite = "Finaliser tests" >::: ["array finalisation" >:: test_array_finaliser; "struct finalisation" >:: test_struct_finaliser; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-foreign-errno/000077500000000000000000000000001274143137600210215ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-foreign-errno/test_errno.ml000066400000000000000000000030361274143137600235410ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes let us x = if Sys.os_type <> "Win32" then x else "_" ^ x (* Call close() with a bogus file descriptor and check that an exception is raised. *) let test_errno_exception_raised _ = let close = Foreign.foreign (us "close") ~check_errno:true (int @-> returning int) in assert_raises (Unix.Unix_error(Unix.EBADF, us "close", "")) (fun () -> close (-300)) (* Call chdir() with a valid directory path and check that zero is returned. *) let test_int_return_errno_exception_raised _ = let unlikely_to_exist = if Sys.os_type <> "Win32" then "/unlikely_to_exist" else "C:\\unlikely_to_exist" in let chdir = Foreign.foreign (us "chdir") ~check_errno:true (string @-> returning int) in assert_raises (Unix.Unix_error(Unix.ENOENT, us "chdir", "")) (fun () -> chdir unlikely_to_exist) (* Call chdir() with a valid directory path and check that zero is returned. *) let test_errno_no_exception_raised _ = let chdir = Foreign.foreign (us "chdir") ~check_errno:true (string @-> returning int) in assert_equal 0 (chdir (Sys.getcwd ())) let suite = "foreign+errno tests" >::: ["Exception from close" >:: test_errno_exception_raised; "Exception from chdir" >:: test_int_return_errno_exception_raised; "No exception from chdir" >:: test_errno_no_exception_raised; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-foreign_values/000077500000000000000000000000001274143137600212555ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-foreign_values/stub-generator/000077500000000000000000000000001274143137600242165ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-foreign_values/stub-generator/driver.ml000066400000000000000000000004751274143137600260510ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the foreign value tests. *) let cheader = "extern char **environ;" let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-foreign_values/stubs/000077500000000000000000000000001274143137600224155ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-foreign_values/stubs/functions.ml000066400000000000000000000015341274143137600247620ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Bindings for the foreign value tests. *) open Ctypes module Common (F: Cstubs.FOREIGN) = struct let s : [`global_struct] structure typ = structure "global_struct" let (-:) ty label = field s label ty let len = size_t -: "len" let str = array 1 char -: "str" let () = seal s let global_struct = F.foreign_value "global_struct" s let plus = F.(foreign_value "plus_callback" (Foreign.funptr_opt Ctypes.(int @-> int @-> returning int))) let sum = F.(foreign "sum_range_with_plus_callback" (int @-> int @-> returning int)) end module Stubs (F: Cstubs.FOREIGN) = struct include Common(F) let environ = F.(foreign_value "environ" (ptr string_opt)) end ocaml-ctypes-0.7.0/tests/test-foreign_values/test_foreign_values.ml000066400000000000000000000047441274143137600256670ustar00rootroot00000000000000(* * Copyright (c) 2013-2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Common(S) open M (* Retrieve a struct exposed as a global value. *) let test_retrieving_struct _ = let p = CArray.start (getf !@global_struct str) in let stringp = from_voidp string (to_voidp (allocate (ptr char) p)) in begin let expected = "global string" in assert_equal expected !@stringp; assert_equal (Unsigned.Size_t.of_int (String.length expected)) (getf !@global_struct len) end (* Store a reference to an OCaml function as a global function pointer. *) let test_global_callback _ = begin assert_equal !@plus None; plus <-@ Some (+); assert_equal (sum 1 10) 55; plus <-@ None; end end module Make_stub_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module N = Functions.Stubs(S) open N (* Read environment variables from the 'environ' global. *) let test_environ _ = let parse_entry s = match Str.(bounded_split (regexp "=") s 2), "" with [k; v], _ | [k], v -> (String.uppercase k, v) | _ -> Printf.ksprintf failwith "Parsing %S failed" s in let rec copy_environ acc env = match !@env with None -> acc | Some s -> copy_environ (parse_entry s :: acc) (env +@ 1) in begin let environment = copy_environ [] !@environ in assert_equal ~printer:(fun x -> x) (List.assoc "HOME" environment) (Sys.getenv "HOME") end end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = struct include Common_tests(Generated_bindings) include Make_stub_tests(Generated_bindings) end let suite = "Foreign value tests" >::: ["retrieving global struct (foreign)" >:: Foreign_tests.test_retrieving_struct; "global callback function (foreign)" >:: Foreign_tests.test_global_callback; "retrieving global struct (stubs)" >:: Stub_tests.test_retrieving_struct; "global callback function (stubs)" >:: Stub_tests.test_global_callback; "reading from 'environ' (stubs)" >:: Stub_tests.test_environ; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-higher_order/000077500000000000000000000000001274143137600207065ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-higher_order/stub-generator/000077500000000000000000000000001274143137600236475ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-higher_order/stub-generator/driver.ml000066400000000000000000000004131274143137600254720ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the higher order tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-higher_order/stubs/000077500000000000000000000000001274143137600220465ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-higher_order/stubs/functions.ml000066400000000000000000000031361274143137600244130ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the higher order tests. *) open Ctypes open Foreign module Stubs (F: Cstubs.FOREIGN) = struct open F let higher_order_1 = foreign "higher_order_1" (funptr Ctypes.(int @-> int @-> returning int) @-> int @-> int @-> returning int) let higher_order_1_static = foreign "higher_order_1" (static_funptr Ctypes.(int @-> int @-> returning int) @-> int @-> int @-> returning int) let higher_order_3 = foreign "higher_order_3" (funptr Ctypes.(funptr (int @-> int @-> returning int) @-> int @-> int @-> returning int) @-> funptr Ctypes.(int @-> int @-> returning int) @-> int @-> int @-> returning int) let callback_returns_char_a = foreign "callback_returns_char_a" (funptr Ctypes.(void @-> returning char) @-> returning int) let returning_funptr = foreign "returning_funptr" (int @-> returning (funptr Ctypes.(int @-> int @-> returning int))) let returning_funptr_static = foreign "returning_funptr" (int @-> returning (static_funptr Ctypes.(int @-> int @-> returning int))) let callback_returns_funptr = foreign "callback_returns_funptr" (funptr Ctypes.(int @-> returning (funptr (int @-> returning int))) @-> int @-> returning int) let register_callback = foreign "register_callback" (funptr Ctypes.(void @-> returning int) @-> returning void) let call_registered_callback = foreign "call_registered_callback" (int @-> int @-> returning void) end ocaml-ctypes-0.7.0/tests/test-higher_order/test_higher_order.ml000066400000000000000000000113341274143137600247420ustar00rootroot00000000000000(* * 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 OUnit2 open Foreign module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Call a C function of type int (int ( * )(int, int), int, int) passing various OCaml functions of type int -> int -> int as the first argument. *) let test_higher_order_basic _ = (* higher_order_1 f x y returns true iff f x y == x + y *) assert_equal 1 (higher_order_1 ( + ) 2 3); assert_equal 0 (higher_order_1 ( * ) 2 3); assert_equal 0 (higher_order_1 min 2 3); assert_equal 1 (higher_order_1 min (-3) 0) (* Call a C function of type int (int ( * )(int ( * )(int, int), int, int), int ( * )(int, int), int, int) passing OCaml functions of type (int -> int -> int) -> int -> int -> int int -> int -> int as the first and second arguments. *) let test_higher_higher_order _ = let acceptor op x y = op x (op x y) in assert_equal 10 (higher_order_3 acceptor ( + ) 3 4); assert_equal 36 (higher_order_3 acceptor ( * ) 3 4) (* Call a C function of type int (char( * )(void)) and check that the char returned by the function pointer is handled correctly *) let test_function_pointer_returning_char _ = assert_equal 1 (callback_returns_char_a (fun () -> 'a')) (* Call a C function of type int ( *(int))(int) (i.e. a function that returns a pointer-to-function) and ensure that we can call the returned function from OCaml. *) let test_returning_pointer_to_function _ = let add = returning_funptr 0 in let times = returning_funptr 1 in assert_equal 22 (add 10 12); assert_equal 15 (times 3 5); assert_equal 101 (add 100 1); assert_equal 0 (times 0 12) (* Call a C function of type int (int ( * ( * )(int))(int), int) (i.e. a function whose first argument is a pointer-to-function returning a pointer-to-function.) *) let test_callback_returns_pointer_to_function _ = let callback = function | 0 -> ( + ) 10 | 1 -> ( * ) 13 | _ -> invalid_arg "callback" in assert_equal 280 (callback_returns_funptr callback 0) (* Call an OCaml function through a C function pointer of type void ( * )(void) *) let test_zero_argument_callbacks _ = let counter = ref 0 in let callback () = let c = !counter in incr counter; c in let () = register_callback callback in begin assert_equal !counter 0; call_registered_callback 5 !counter; assert_equal !counter 5; call_registered_callback 3 !counter; assert_equal !counter 8; end (* Retrieve a function pointer from C and pass it back to C using static_funptr. *) let test_static_funptr _ = let add = returning_funptr_static 0 and mul = returning_funptr_static 1 in begin assert_equal 1 (higher_order_1_static add 2 3); assert_equal 0 (higher_order_1_static mul 2 3); end end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Higher-order tests" >::: ["test_higher_order_basic (foreign)" >:: Foreign_tests.test_higher_order_basic; "test_higher_order_basic (stubs)" >:: Stub_tests.test_higher_order_basic; "test_higher_higher_order (foreign)" >:: Foreign_tests.test_higher_higher_order; "test_higher_higher_order (stubs)" >:: Stub_tests.test_higher_higher_order; "test_function_pointer_returning_char (stubs)" >:: Stub_tests.test_function_pointer_returning_char; "test_function_pointer_returning_char (foreign)" >:: Foreign_tests.test_function_pointer_returning_char; "test_returning_pointer_to_function (foreign)" >:: Foreign_tests.test_returning_pointer_to_function; "test_returning_pointer_to_function (stubs)" >:: Stub_tests.test_returning_pointer_to_function; "test_callback_returns_pointer_to_function (foreign)" >:: Foreign_tests.test_callback_returns_pointer_to_function; "test_callback_returns_pointer_to_function (stubs)" >:: Stub_tests.test_callback_returns_pointer_to_function; "test_zero_argument_callbacks (foreign)" >:: Foreign_tests.test_zero_argument_callbacks; "test_zero_argument_callbacks (stubs)" >:: Stub_tests.test_zero_argument_callbacks; "test_static_funptr (foreign)" >:: Foreign_tests.test_static_funptr; "test_static_funptr (stubs)" >:: Stub_tests.test_static_funptr; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-lwt-jobs/000077500000000000000000000000001274143137600200065ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-lwt-jobs/stub-generator/000077500000000000000000000000001274143137600227475ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-lwt-jobs/stub-generator/driver.ml000066400000000000000000000006771274143137600246060ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the Lwt jobs tests. *) let cheader = "#include #include #include #include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) ~structs:(module Types.Struct_stubs) ~concurrency:Cstubs.lwt_jobs ocaml-ctypes-0.7.0/tests/test-lwt-jobs/stubs/000077500000000000000000000000001274143137600211465ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-lwt-jobs/stubs/functions.ml000066400000000000000000000013571274143137600235160ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the Lwt jobs tests. *) open Ctypes module Stubs (F: Cstubs.FOREIGN) = struct open F let sqrt = foreign "sqrt" (double @-> returning double) let sum_int_array = foreign "sum_int_array" (ptr int32_t @-> size_t @-> returning int32_t) let struct_stat : [`stat] structure typ = structure "stat" let stat = foreign "stat" (string @-> ptr struct_stat @-> returning int) let sixargs = foreign "sixargs" (int @-> int @-> int @-> int @-> int @-> int @-> returning int) let return_10 = foreign "return_10" (void @-> returning int) end ocaml-ctypes-0.7.0/tests/test-lwt-jobs/stubs/types.ml000066400000000000000000000007341274143137600226500ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open PosixTypes module Struct_stubs(S : Cstubs.Types.TYPE) = struct open S let ifdir = constant "S_IFDIR" (lift_typ mode_t) let ifmt = constant "S_IFMT" (lift_typ mode_t) let stat : [`stat] structure typ = structure "stat" let st_mode = field stat "st_mode" (lift_typ mode_t) let () = seal stat end ocaml-ctypes-0.7.0/tests/test-lwt-jobs/test_lwt_jobs.ml000066400000000000000000000044731274143137600232320ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes module Structures = Types.Struct_stubs(Generated_struct_bindings) module Bindings = Functions.Stubs(Generated_bindings) (* Test the Lwt binding to "sqrt". *) let test_sqrt _ = Lwt_unix.run Lwt.((Bindings.sqrt 9.0).Generated_bindings.lwt >>= fun x -> return (assert (x = 3.0))) (* Test that objects remain alive during the Lwt job call. *) let test_object_lifetime _ = let call = let open Bigarray in let b = Array1.create int32 c_layout 3 in begin b.{0} <- 1l; b.{1} <- 2l; b.{2} <- 3l; end; (Bindings.sum_int_array (bigarray_start array1 b) (Unsigned.Size_t.of_int 3)).Generated_bindings.lwt in begin Gc.compact (); Gc.compact (); Lwt_unix.run (Lwt.(call >>= fun n -> assert_equal 6l n ~printer:Int32.to_string; return ())) end (* Test that strings remain alive during the Lwt job call. *) let test_string_lifetime _ = let s = make Structures.stat in let call = (Bindings.stat (Bytes.copy ".") (addr s)).Generated_bindings.lwt in begin Gc.compact (); Gc.compact (); Lwt_unix.run (Lwt.(call >>= fun i -> assert_equal 0 i; assert_equal Structures.ifdir (PosixTypes.Mode.logand Structures.ifmt (getf s Structures.st_mode)); return ())) end (* Test calling functions with many arguments. *) let test_six_args _ = let open Lwt.Infix in Lwt_unix.run ((Bindings.sixargs 1 2 3 4 5 6).Generated_bindings.lwt >>= fun i -> assert_equal (1 + 2 + 3 + 4 + 5 + 6) i; Lwt.return ()) (* Test calling functions with no arguments. *) let test_no_args _ = let open Lwt.Infix in Lwt_unix.run ((Bindings.return_10 ()).Generated_bindings.lwt >>= fun i -> assert_equal 10 i; Lwt.return ()) let suite = "Lwt job tests" >::: ["calling sqrt" >:: test_sqrt; "object lifetime" >:: test_object_lifetime; "string lifetime" >:: test_string_lifetime; "functions with many arguments" >:: test_six_args; "functions with no arguments" >:: test_no_args; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-macros/000077500000000000000000000000001274143137600175315ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-macros/stub-generator/000077500000000000000000000000001274143137600224725ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-macros/stub-generator/driver.ml000066400000000000000000000004641274143137600243230ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the macro tests. *) let cheader = " #include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-macros/stubs/000077500000000000000000000000001274143137600206715ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-macros/stubs/functions.ml000066400000000000000000000006141274143137600232340ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the macro tests. *) open Ctypes module Stubs (F: Cstubs.FOREIGN) = struct open F let exp_double = foreign "exp" (double @-> returning double) let exp_float = foreign "exp" (float @-> returning float) end ocaml-ctypes-0.7.0/tests/test-macros/test_macros.ml000066400000000000000000000012071274143137600224060ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes module Bindings = Functions.Stubs(Generated_bindings) (* Test calling type-generic macros. *) let test_tg_macros _ = let open Bindings in assert_bool "calling double version of type-generic exp" (exp_double 1.0 = exp 1.0); assert_bool "calling float version of type-generic exp" (abs_float (exp_float 1.0 -. exp 1.0) <= 0.001) let suite = "Macro tests" >::: ["Calling type-generic macros" >:: test_tg_macros; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-oo_style/000077500000000000000000000000001274143137600201025ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-oo_style/stub-generator/000077500000000000000000000000001274143137600230435ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-oo_style/stub-generator/driver.ml000066400000000000000000000004071274143137600246710ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the OO-style tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-oo_style/stubs/000077500000000000000000000000001274143137600212425ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-oo_style/stubs/functions.ml000066400000000000000000000052021274143137600236030ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the OO-style tests. *) open Ctypes open Foreign module Stubs (F: Cstubs.FOREIGN) = struct open F let cast base p = from_voidp base (to_voidp p) (* We'll build part of the hierarchy in C and part in OCaml. animal ^ ^ | | chorse camel *) (** Create the base class and its method table **) type animal and animal_methods let animal_methods : animal_methods structure typ = structure "animal methods" and animal : animal structure typ = structure "animal" (* class layout (vtable pointer, no instance variables) *) let animal_vtable = field animal "animal_vtable" (ptr animal_methods) let () = seal animal (* method table layout (two virtual methods) *) let (-:) ty label = field animal_methods label ty let say = Foreign.funptr Ctypes.(ptr animal @-> returning string) -: "say" let identify = Foreign.funptr Ctypes.(ptr animal @-> returning string) -: "identify" let () = seal animal_methods let call_say cinstance = !@((getf (!@cinstance) animal_vtable) |-> say) cinstance let call_identify cinstance = !@((getf (!@cinstance) animal_vtable) |-> identify) cinstance (* constructor *) class animalc ~cinstance = object method say : string = call_say cinstance method identify : string = call_identify cinstance method cinstance = cinstance end (** Create a sub class and its method table **) type camel and camel_methods let camel_methods : camel_methods structure typ = structure "camel methods" and camel : camel structure typ = structure "camel" (* class layout (vtable pointer, one instance variable) *) let (-:) ty label = field camel label ty let camel_vtable = ptr camel_methods -: "camel_vtable" let nhumps = int -: "nhumps" let () = seal camel (* method table layout (one additional virtual method) *) let (-:) ty label = field camel_methods label ty let _ = animal_methods -: "_" let humps = Foreign.funptr Ctypes.(ptr camel @-> returning int) -: "humps" let () = seal camel_methods let call_humps cinstance = !@((getf (!@cinstance) camel_vtable) |-> humps) cinstance (* constructor *) class camelc ~cinstance = object inherit animalc ~cinstance:(cast animal cinstance) method humps : int = call_humps cinstance end let check_name = foreign "check_name" (ptr animal @-> string @-> returning int) let new_chorse = foreign "new_chorse" (int @-> returning (ptr animal)) end ocaml-ctypes-0.7.0/tests/test-oo_style/test_oo_style.ml000066400000000000000000000051651274143137600233370ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Establish a hierarchy of "classes", create some "objects" and call some "methods". *) let test_oo_hierarchy _ = let module M = struct let camel_vtable_singleton = make camel_methods let () = 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 () = 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 class chorse ~colour = object inherit animalc (new_chorse (colour_num colour)) end let () = let red_horse = new chorse ~colour:Red and pale_horse = new chorse ~colour:Pale in begin assert_equal "red horse" red_horse#identify; assert_equal "pale horse" pale_horse#identify; assert_equal "neigh" pale_horse#say; end end in () end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "OO-style tests" >::: ["OO style (foreign)" >:: Foreign_tests.test_oo_hierarchy; "OO style (stubs)" >:: Stub_tests.test_oo_hierarchy; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-passable/000077500000000000000000000000001274143137600200375ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-passable/test_passable.ml000066400000000000000000000273571274143137600232400ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes (* Test that primitives are passable. *) let test_primitives_are_passable _ = let _ = void @-> returning void and _ = char @-> returning char and _ = schar @-> returning schar and _ = float @-> returning float and _ = double @-> returning double and _ = int @-> returning int and _ = nativeint @-> returning nativeint and _ = int8_t @-> returning int8_t and _ = short @-> returning short and _ = int16_t @-> returning int16_t and _ = int32_t @-> returning int32_t and _ = int64_t @-> returning int64_t and _ = uchar @-> returning uchar and _ = uint8_t @-> returning uint8_t and _ = uint16_t @-> returning uint16_t and _ = uint32_t @-> returning uint32_t and _ = uint64_t @-> returning uint64_t and _ = size_t @-> returning size_t and _ = ushort @-> returning ushort and _ = uint @-> returning uint and _ = ulong @-> returning ulong and _ = ullong @-> returning ullong in () (* Test that unions are not passable *) let test_unions_are_not_passable _ = let module M = struct type u let u : u union typ = union "u" let (-:) ty label = field u label ty let c = int -: "c" let f = double -: "f" let p = ptr u -: "p" let () = seal u let _ = begin (* union types can be used as argument types *) ignore (u @-> returning void); assert_raises ~msg:"Foreign rejects union types as argument types" (Unsupported "libffi does not support passing unions") (fun () -> Foreign.funptr (u @-> returning void)); (* union types can be used as return types *) ignore (u @-> returning void); assert_raises ~msg:"Foreign rejects union types as return types" (Unsupported "libffi does not support passing unions") (fun () -> Foreign.funptr (void @-> returning u)); end end in () (* Test the passability of 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-0.7.0/tests/test-passing-ocaml-values/000077500000000000000000000000001274143137600222775ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-passing-ocaml-values/stub-generator/000077500000000000000000000000001274143137600252405ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-passing-ocaml-values/stub-generator/driver.ml000066400000000000000000000005001274143137600270600ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the OCaml-value-passing tests. *) let cheader = "#include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-passing-ocaml-values/stubs/000077500000000000000000000000001274143137600234375ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-passing-ocaml-values/stubs/functions.ml000066400000000000000000000014361274143137600260050ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the OCaml-value-passing tests. *) open Ctypes let name_strdup = match Sys.os_type with | "Win32" -> "_strdup" | _ -> "strdup" module Stubs (F: Cstubs.FOREIGN) = struct open F let memcpy_string_string = foreign "memcpy" (ocaml_string @-> ocaml_string @-> size_t @-> returning (ptr void)) let memcpy_bytes_bytes = foreign "memcpy" (ocaml_bytes @-> ocaml_bytes @-> size_t @-> returning (ptr void)) let memcpy_string_ptr = foreign "memcpy" (ocaml_string @-> ptr void @-> size_t @-> returning (ptr void)) let strdup = foreign name_strdup (ocaml_string @-> returning string) end ocaml-ctypes-0.7.0/tests/test-passing-ocaml-values/test_passing_ocaml_values.ml000066400000000000000000000075321274143137600300750ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes open Foreign let testlib = Dl.(dlopen ~filename:"clib/libtest_functions.so" ~flags:[RTLD_NOW]) module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Test passing OCaml strings directly to C. *) let test_passing_strings _ = let input = "abcdefghijklmnopqrstuvwxyz" in let len = String.length input in let buf = String.make len 'Z' in let _ = memcpy_string_string (ocaml_string_start buf) (ocaml_string_start input) (Unsigned.Size_t.of_int len) in begin assert_equal buf input end; let bbuf = Bytes.create len in let binput = Bytes.of_string input in let _ = memcpy_bytes_bytes (ocaml_bytes_start bbuf) (ocaml_bytes_start binput) (Unsigned.Size_t.of_int len) in begin assert_equal bbuf binput end; let arr = CArray.make char len in let () = String.iteri (CArray.set arr) input in let buf = String.make len 'Z' in let _ = memcpy_string_ptr (ocaml_string_start buf) (coerce (ptr char) (ptr void) (CArray.start arr)) (Unsigned.Size_t.of_int len) in begin assert_equal buf input end (* Test pointer arithmetic on OCaml values. *) let test_pointer_arithmetic _ = let s = ocaml_string_start "abcdefghijklmnopqrstuvwxyz" in begin assert_equal s (s +@ 0); assert_equal (ptr_diff s (s +@ 10)) 10; assert_equal s ((s +@ 10) -@ 10); assert_equal (strdup (ocaml_string_start "klmnopqrstuvwxyz")) (strdup (s +@ 10)) end end (* Test that OCaml values do not reside in addressable memory. *) let test_ocaml_types_rejected_as_pointer_reference_types _ = assert_raises IncompleteType (fun () -> allocate ocaml_string (ocaml_string_start "")) (* Test that OCaml values cannot be used as return types. *) let strdup = if Sys.os_type = "Win32" then "_strdup" else "strdup" let test_ocaml_types_rejected_as_return_types _ = assert_raises IncompleteType (fun () -> Foreign.foreign strdup (string @-> returning ocaml_string)) (* Test that pointers to OCaml values cannot be dereferenced. *) let test_pointers_to_ocaml_types_cannot_be_dereferenced _ = let p = allocate_n char 10 in let po = coerce (ptr char) (ptr ocaml_string) p in begin assert_raises IncompleteType (fun () -> !@po); assert_raises IncompleteType (fun () -> po <-@ ocaml_string_start ""); end (* Test that [funptr] does not support ocaml_string return values. *) let test_no_higher_order_ocaml_string_support _ = begin assert_raises IncompleteType (fun () -> funptr (void @-> returning ocaml_string)) end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Tests passing OCaml values" >::: ["passing strings (foreign)" >:: Foreign_tests.test_passing_strings; "passing strings (stubs)" >:: Stub_tests.test_passing_strings; "pointer arithmetic on OCaml values (foreign)" >:: Foreign_tests.test_pointer_arithmetic; "pointer arithmetic on OCaml values (stubs)" >:: Stub_tests.test_pointer_arithmetic; "ocaml_string values aren't addressable" >:: test_ocaml_types_rejected_as_pointer_reference_types; "ocaml_string can't be used as a return type" >:: test_ocaml_types_rejected_as_return_types; "pointers to ocaml_string values cannot be dereferenced" >:: test_pointers_to_ocaml_types_cannot_be_dereferenced; "no higher-order ocaml_string support" >:: test_no_higher_order_ocaml_string_support; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-pointers/000077500000000000000000000000001274143137600201105ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-pointers/stub-generator/000077500000000000000000000000001274143137600230515ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-pointers/stub-generator/driver.ml000066400000000000000000000004061274143137600246760ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the pointer tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-pointers/stubs/000077500000000000000000000000001274143137600212505ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-pointers/stubs/functions.ml000066400000000000000000000041111274143137600236070ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the pointer tests. *) open Ctypes module Stubs (F: Cstubs.FOREIGN) = struct open F let accept_pointers = foreign "accept_pointers" (ptr float @-> ptr double @-> ptr short @-> ptr int @-> ptr long @-> ptr llong @-> ptr nativeint @-> ptr int8_t @-> ptr int16_t @-> ptr int32_t @-> ptr int64_t @-> ptr uint8_t @-> ptr uint16_t @-> ptr uint32_t @-> ptr uint64_t @-> ptr size_t @-> ptr ushort @-> ptr uint @-> ptr ulong @-> ptr ullong @-> returning int) let accept_pointers_to_pointers = foreign "accept_pointers_to_pointers" (ptr int @-> ptr (ptr int) @-> ptr (ptr (ptr int)) @-> ptr (ptr (ptr (ptr int))) @-> returning int) let malloc = foreign "malloc" (size_t @-> returning (ptr void)) let realloc = foreign "realloc" (ptr void @-> size_t @-> returning (ptr void)) let free = foreign "free" (ptr void @-> returning void) let return_global_address = foreign "return_global_address" (void @-> returning (ptr int)) let pass_pointer_through = foreign "pass_pointer_through" (ptr int @-> ptr int @-> int @-> returning (ptr int)) let passing_pointers_to_callback = foreign "passing_pointers_to_callback" (Foreign.funptr Ctypes.(ptr int @-> ptr int @-> returning int) @-> returning int) let accepting_pointer_from_callback = foreign "accepting_pointer_from_callback" (Foreign.funptr Ctypes.(int @-> int @-> returning (ptr int)) @-> returning int) let accepting_pointer_to_function_pointer = foreign "accepting_pointer_to_function_pointer" (ptr (Foreign.funptr Ctypes.(int @-> int @-> returning int)) @-> returning int) let returning_pointer_to_function_pointer = foreign "returning_pointer_to_function_pointer" (void @-> returning (ptr (Foreign.funptr Ctypes.(int @-> int @-> returning int)))) end ocaml-ctypes-0.7.0/tests/test-pointers/test_pointers.ml000066400000000000000000000471721274143137600233570ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes open Foreign let testlib = Dl.(dlopen ~filename:"clib/libtest_functions.so" ~flags:[RTLD_NOW]) module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Test passing various types of pointers to a function. *) let test_passing_pointers _ = assert_equal ~msg:"Passing pointers to various numeric types" ~printer:string_of_int (1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 11 + 12 + 13 + 14 + 15 + 16 + 17 + 18 + 19 + 20) (let open Signed in let open Unsigned in accept_pointers (allocate float 1.0) (allocate double 2.0) (allocate short 3) (allocate int 4) (allocate long (Long.of_int 5)) (allocate llong (LLong.of_int 6)) (allocate nativeint 7n) (allocate int8_t 8) (allocate int16_t 9) (allocate int32_t 10l) (allocate int64_t 11L) (allocate uint8_t (UInt8.of_int 12)) (allocate uint16_t (UInt16.of_int 13)) (allocate uint32_t (UInt32.of_int 14)) (allocate uint64_t (UInt64.of_int 15)) (allocate size_t (Size_t.of_int 16)) (allocate ushort (UShort.of_int 17)) (allocate uint (UInt.of_int 18)) (allocate ulong (ULong.of_int 19)) (allocate ullong (ULLong.of_int 20))) (* Test passing pointers to pointers. *) let test_passing_pointers_to_pointers _ = let p = allocate int 1 and pp = allocate (ptr int) (allocate int 2) and ppp = allocate (ptr (ptr int)) (allocate (ptr int) (allocate int 3)) and pppp = allocate (ptr (ptr (ptr int))) (allocate (ptr (ptr int)) (allocate (ptr int) (allocate int 4))) in assert_equal ~msg:"Passing pointers to pointers" 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 _ = assert_equal 7 (passing_pointers_to_callback (fun lp rp -> !@lp + !@rp)) (* Passing a callback that returns a pointer. *) let test_callback_returning_pointers _ = let p = allocate int 17 in begin assert_equal 17 !@p; assert_equal 56 (accepting_pointer_from_callback (fun x y -> p <-@ (x * y); p)); assert_equal 12 !@p end (* Test passing a pointer-to-a-function-pointer as an argument. *) let test_passing_pointer_to_function_pointer _ = assert_equal ~printer:string_of_int 5 (accepting_pointer_to_function_pointer (allocate (funptr (int @-> int @-> returning int)) ( / ))) (* Test returning a pointer to a function pointer *) let test_callback_returning_pointer_to_function_pointer _ = assert_equal 10 (!@(returning_pointer_to_function_pointer ()) 2 5) (* Test bindings for malloc, realloc and free. *) let test_allocation _ = let open Unsigned in let pointer = malloc (Size_t.of_int (sizeof int)) in let int_pointer = from_voidp int pointer in int_pointer <-@ 17; assert_equal !@int_pointer 17; int_pointer <-@ -3; assert_equal !@int_pointer (-3); let pointer' = realloc pointer (Size_t.of_int (20 * sizeof int)) in assert_bool "realloc succeeded" (pointer' <> null); let int_pointer = from_voidp int pointer' in assert_equal ~msg:"realloc copied the existing data over" !@int_pointer (-3); for i = 0 to 19 do (int_pointer +@ i) <-@ i done; for i = 0 to 19 do assert_equal i !@(int_pointer +@ i) done; free pointer' (* Test a function that returns the address of a global variable. *) let test_reading_returned_global _ = assert_equal (!@(return_global_address ())) 100 (* Test a function that returns a pointer passed as argument. *) let test_passing_pointer_through _ = let p1 = allocate int 25 in let p2 = allocate int 32 in let rv = pass_pointer_through p1 p2 10 in assert_equal !@rv !@p1; assert_equal 25 !@rv; let rv = pass_pointer_through p1 p2 (-10) in assert_equal !@rv !@p2; assert_equal 32 !@rv; let p3 = p1 +@ 1 in let rv = pass_pointer_through p3 p1 1 in assert_bool "pointer with (positive) offset successfully passed through" (ptr_compare rv p3 = 0); assert_bool "pointer with positive computed offset compares greater than original" (ptr_compare p1 p3 < 0); assert_bool "pointer with positive computed offset compares greater than original" (ptr_compare p3 p1 > 0); assert_bool "returned pointer with positive computed offset compares greater than original" (ptr_compare p1 rv < 0); assert_bool "returned pointer with positive computed offset compares greater than original" (ptr_compare rv p1 > 0); assert_equal !@(rv -@ 1) !@(p3 -@ 1); let p4 = p1 -@ 1 in let rv = pass_pointer_through p1 p4 (-1) in assert_bool "pointer with (negative) offset successfully passed through" (ptr_compare rv p4 = 0); assert_bool "pointer with negative computed offset compares less than original" (ptr_compare p1 p4 > 0); assert_bool "pointer with negative computed offset compares less than original" (ptr_compare p4 p1 < 0); assert_bool "returned pointer with negative computed offset compares greater than original" (ptr_compare p1 rv > 0); assert_bool "returned pointer with negative computed offset compares greater than original" (ptr_compare rv p1 < 0) end (* Tests for reading and writing primitive values through pointers. *) let test_pointer_assignment_with_primitives _ = let open Signed in let open Unsigned in let p_char = allocate char '1' and p_uchar = allocate uchar (UChar.of_int 2) and p_bool = allocate bool false and p_schar = allocate schar 3 and p_float = allocate float 4.0 and p_double = allocate double 5.0 and p_short = allocate short 6 and p_int = allocate int 7 and p_long = allocate long (Long.of_int 8) and p_llong = allocate llong (LLong.of_int 9) and p_nativeint = allocate nativeint 10n and p_int8_t = allocate int8_t 11 and p_int16_t = allocate int16_t 12 and p_int32_t = allocate int32_t 13l and p_int64_t = allocate int64_t 14L and p_uint8_t = allocate uint8_t (UInt8.of_int 15) and p_uint16_t = allocate uint16_t (UInt16.of_int 16) and p_uint32_t = allocate uint32_t (UInt32.of_int 17) and p_uint64_t = allocate uint64_t (UInt64.of_int 18) and p_size_t = allocate size_t (Size_t.of_int 19) and p_ushort = allocate ushort (UShort.of_int 20) and p_uint = allocate uint (UInt.of_int 21) and p_ulong = allocate ulong (ULong.of_int 22) and p_ullong = allocate ullong (ULLong.of_int 23) in begin assert_equal '1' (!@p_char); assert_equal (UChar.of_int 2) (!@p_uchar); assert_equal false (!@p_bool); assert_equal 3 (!@p_schar); assert_equal 4.0 (!@p_float); assert_equal 5.0 (!@p_double); assert_equal 6 (!@p_short); assert_equal 7 (!@p_int); assert_equal (Long.of_int 8) (!@p_long); assert_equal (LLong.of_int 9) (!@p_llong); assert_equal 10n (!@p_nativeint); assert_equal 11 (!@p_int8_t); assert_equal 12 (!@p_int16_t); assert_equal 13l (!@p_int32_t); assert_equal 14L (!@p_int64_t); assert_equal (UInt8.of_int 15) (!@p_uint8_t); assert_equal (UInt16.of_int 16) (!@p_uint16_t); assert_equal (UInt32.of_int 17) (!@p_uint32_t); assert_equal (UInt64.of_int 18) (!@p_uint64_t); assert_equal (Size_t.of_int 19) (!@p_size_t); assert_equal (UShort.of_int 20) (!@p_ushort); assert_equal (UInt.of_int 21) (!@p_uint); assert_equal (ULong.of_int 22) (!@p_ulong); assert_equal (ULLong.of_int 23) (!@p_ullong); p_char <-@ '2'; p_uchar <-@ (UChar.of_int 102); p_bool <-@ true; p_schar <-@ 103; p_float <-@ 104.0; p_double <-@ 105.0; p_short <-@ 106; p_int <-@ 107; p_long <-@ (Long.of_int 108); p_llong <-@ (LLong.of_int 109); p_nativeint <-@ 110n; p_int8_t <-@ 111; p_int16_t <-@ 112; p_int32_t <-@ 113l; p_int64_t <-@ 114L; p_uint8_t <-@ (UInt8.of_int 115); p_uint16_t <-@ (UInt16.of_int 116); p_uint32_t <-@ (UInt32.of_int 117); p_uint64_t <-@ (UInt64.of_int 118); p_size_t <-@ (Size_t.of_int 119); p_ushort <-@ (UShort.of_int 120); p_uint <-@ (UInt.of_int 121); p_ulong <-@ (ULong.of_int 122); p_ullong <-@ (ULLong.of_int 123); assert_equal '2' (!@p_char); assert_equal (UChar.of_int 102) (!@p_uchar); assert_equal true (!@p_bool); assert_equal 103 (!@p_schar); assert_equal 104.0 (!@p_float); assert_equal 105.0 (!@p_double); assert_equal 106 (!@p_short); assert_equal 107 (!@p_int); assert_equal (Long.of_int 108) (!@p_long); assert_equal (LLong.of_int 109) (!@p_llong); assert_equal 110n (!@p_nativeint); assert_equal 111 (!@p_int8_t); assert_equal 112 (!@p_int16_t); assert_equal 113l (!@p_int32_t); assert_equal 114L (!@p_int64_t); assert_equal (UInt8.of_int 115) (!@p_uint8_t); assert_equal (UInt16.of_int 116) (!@p_uint16_t); assert_equal (UInt32.of_int 117) (!@p_uint32_t); assert_equal (UInt64.of_int 118) (!@p_uint64_t); assert_equal (Size_t.of_int 119) (!@p_size_t); assert_equal (UShort.of_int 120) (!@p_ushort); assert_equal (UInt.of_int 121) (!@p_uint); assert_equal (ULong.of_int 122) (!@p_ulong); assert_equal (ULLong.of_int 123) (!@p_ullong); end (* Dereferencing pointers to incomplete types *) let test_dereferencing_pointers_to_incomplete_types _ = begin assert_raises IncompleteType (fun () -> !@null); assert_raises IncompleteType (fun () -> !@(from_voidp (structure "incomplete") null)); assert_raises IncompleteType (fun () -> !@(from_voidp (union "incomplete") null)); end (* Writing through a pointer to an abstract type *) let test_writing_through_pointer_to_abstract_type _ = let module Array = CArray in let arra = Array.make int 2 in let arrb = Array.make int 2 in let absptr a = from_voidp (abstract ~name:"absptr" ~size:(2 * sizeof int) ~alignment:(alignment (array 2 int))) (to_voidp (Array.start a)) in let () = begin arra.(0) <- 10; arra.(1) <- 20; arrb.(0) <- 30; arrb.(1) <- 40; end in let dest = absptr arra in let src = absptr arrb in begin assert_equal 10 arra.(0); assert_equal 20 arra.(1); assert_equal 30 arrb.(0); assert_equal 40 arrb.(1); dest <-@ !@src; assert_equal 30 arra.(0); assert_equal 40 arra.(1); assert_equal 30 arrb.(0); assert_equal 40 arrb.(1); assert_bool "pointers distinct" (dest <> src); assert_bool "arrays distinct" (arra <> arrb); end (* Test for reading and writing global values using the "foreign_value" function. *) let test_reading_and_writing_global_value _ = let ptr = foreign_value "global" int ~from:testlib in let ptr' = foreign_value "global" int ~from:testlib in assert_equal (!@ptr) 100; ptr <-@ 200; assert_equal (!@ptr) 200; assert_equal (!@ptr') 200; ptr' <-@ 100; assert_equal (!@ptr) 100; assert_equal (!@ptr') 100 (* Tests for reading a string from an address. *) let test_reading_strings _ = let p = allocate_n char 26 in begin StringLabels.iteri "abcdefghijklmnoprwstuvwxyz" ~f:(fun i c -> (p +@ i) <-@ c); assert_equal (string_from_ptr p 5) "abcde"; assert_equal (string_from_ptr p 26) "abcdefghijklmnoprwstuvwxyz"; assert_equal (string_from_ptr p 0) ""; assert_raises (Invalid_argument "Ctypes.string_from_ptr") (fun () -> string_from_ptr p (-1)); end (* Tests for various aspects of pointer arithmetic. *) let test_pointer_arithmetic _ = let module Array = CArray in let arr = Array.of_list int [1;2;3;4;5;6;7;8] in (* Traverse the array using an int pointer *) let p = Array.start arr in for i = 0 to 7 do assert_equal !@(p +@ i) (succ i) done; let twoints = structure "s" in let i1 = field twoints "i" int in let i2 = field twoints "j" int in let () = seal twoints in (* Traverse the array using a 'struct twoints' pointer *) let ps = from_voidp twoints (to_voidp p) in for i = 0 to 3 do assert_equal !@((ps +@ i) |-> i1) (2 * i + 1); assert_equal !@((ps +@ i) |-> i2) (2 * i + 2); done; (* Traverse the array using a char pointer *) let pc = from_voidp char (to_voidp p) in for i = 0 to 7 do let p' = pc +@ i * sizeof int in assert_equal !@(from_voidp int (to_voidp p')) (succ i) done; (* Reverse traversal *) let pend = p +@ 7 in for i = 0 to 7 do assert_equal !@(pend -@ i) (8 - i) done (* Test pointer comparisons. *) let test_pointer_comparison _ = let canonicalize p = (* Ensure that the 'pbyte_offset' component of the pointer is zero by writing the pointer to memory and then reading it back. *) let buf = allocate_n ~count:1 (ptr void) in buf <-@ (to_voidp p); !@buf in let (<) l r = ptr_compare l r < 0 and (>) l r = ptr_compare l r > 0 and (=) l r = ptr_compare l r = 0 in (* equal but not identical pointers compare equal *) let p = allocate int 10 in let p' = from_voidp int (to_voidp p) in assert_bool "equal but not identical poitners compare equal" (p = p'); (* Canonicalization preserves ordering *) assert_bool "p < p+n" (p < (p +@ 10)); assert_bool "canonicalize(p) < canonicalize(p+n)" (canonicalize p < canonicalize (p +@ 10)); assert_bool "p > p-1" (p > (p -@ 1)); assert_bool "canonicalize(p) > canonicalize(p-1)" (canonicalize p > canonicalize (p -@ 1)); let s3 = structure "s3" in let i = field s3 "i" int in let j = field s3 "j" int in let k = field s3 "k" int in let () = seal s3 in let sp = addr (make s3) in let p1 = to_voidp (sp |-> i) and p2 = to_voidp (sp |-> j) and p3 = to_voidp (sp |-> k) in assert_bool "sp |-> i < sp |-> j" (p1 < p2); assert_bool "sp |-> i < canonicalize (sp |-> j)" (p1 < canonicalize p2); assert_bool "canonicalize (sp |-> i) < sp |-> j" (canonicalize p1 < p2); assert_bool "canonicalize (sp |-> i) < canonicalize (sp |-> j)" (canonicalize p1 < canonicalize p2); assert_bool "sp |-> i < sp |-> k" (p1 < p3); assert_bool "sp |-> i < canonicalize (sp |-> k)" (p1 < canonicalize p3); assert_bool "canonicalize (sp |-> i) < sp |-> k" (canonicalize p1 < p3); assert_bool "canonicalize (sp |-> i) < canonicalize (sp |-> k)" (canonicalize p1 < canonicalize p3); assert_bool "sp |-> j < sp |-> k" (p2 < p3); assert_bool "sp |-> j < canonicalize (sp |-> k)" (p2 < canonicalize p3); assert_bool "canonicalize (sp |-> j) < sp |-> k" (canonicalize p2 < p3); assert_bool "canonicalize (sp |-> j) < canonicalize (sp |-> k)" (canonicalize p2 < canonicalize p3); (* Canonicalization preserves equality *) assert_bool "canonicalization preserves equality" (to_voidp p = canonicalize p) (* Test pointer differences. *) let test_pointer_differences _ = let canonicalize p = (* Ensure that the 'pbyte_offset' component of the pointer is zero by writing the pointer to memory and then reading it back. *) let buf = allocate_n ~count:1 (ptr void) in buf <-@ (to_voidp p); !@buf in let s = structure "s" in let (-:) ty label = field s label ty in let i = int -: "i" in let j = array 17 char -: "j" in let k = double -: "k" in let l = char -: "l" in let () = seal s in let v = make s in let p = addr v in let to_charp p = from_voidp char (to_voidp p) in let cp = to_charp p in assert_equal (offsetof i) (ptr_diff cp (to_charp (p |-> i))); assert_equal (offsetof j) (ptr_diff cp (to_charp (p |-> j))); assert_equal (offsetof k) (ptr_diff cp (to_charp (p |-> k))); assert_equal (offsetof l) (ptr_diff cp (to_charp (p |-> l))); assert_equal (-offsetof i) (ptr_diff (to_charp (p |-> i)) cp); assert_equal (-offsetof j) (ptr_diff (to_charp (p |-> j)) cp); assert_equal (-offsetof k) (ptr_diff (to_charp (p |-> k)) cp); assert_equal (-offsetof l) (ptr_diff (to_charp (p |-> l)) cp); assert_equal (offsetof i) (ptr_diff cp (to_charp (canonicalize (p |-> i)))); assert_equal (offsetof j) (ptr_diff cp (to_charp (canonicalize (p |-> j)))); assert_equal (offsetof k) (ptr_diff cp (to_charp (canonicalize (p |-> k)))); assert_equal (offsetof l) (ptr_diff cp (to_charp (canonicalize (p |-> l)))); assert_equal (-offsetof i) (ptr_diff (to_charp (canonicalize (p |-> i))) cp); assert_equal (-offsetof j) (ptr_diff (to_charp (canonicalize (p |-> j))) cp); assert_equal (-offsetof k) (ptr_diff (to_charp (canonicalize (p |-> k))) cp); assert_equal (-offsetof l) (ptr_diff (to_charp (canonicalize (p |-> l))) cp) (* Test raw pointers. *) let test_raw_pointers _ = (* Check that conversions to the raw form commute with arithmetic. *) let p : float ptr = allocate double 1.0 in let p' = p +@ 3 in let praw = raw_address_of_ptr (to_voidp p) in let praw' = raw_address_of_ptr (to_voidp p') in assert_equal praw' Nativeint.(add praw (of_int (3 * sizeof double))) module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Pointer tests" >::: ["passing pointers (foreign)" >:: Foreign_tests.test_passing_pointers; "passing pointers (stubs)" >:: Stub_tests.test_passing_pointers; "passing pointers to pointers (foreign)" >:: Foreign_tests.test_passing_pointers_to_pointers; "passing pointers to pointers (stubs)" >:: Stub_tests.test_passing_pointers_to_pointers; "callback receiving pointers (foreign)" >:: Foreign_tests.test_callback_receiving_pointers; "callback receiving pointers (stubs)" >:: Stub_tests.test_callback_receiving_pointers; "callback returning pointers (foreign)" >:: Foreign_tests.test_callback_returning_pointers; "callback returning pointers (stubs)" >:: Stub_tests.test_callback_returning_pointers; "pointer assignment with primitives" >:: test_pointer_assignment_with_primitives; "passing pointer to function pointer (foreign)" >:: Foreign_tests.test_passing_pointer_to_function_pointer; "passing pointer to function pointer (stubs)" >:: Stub_tests.test_passing_pointer_to_function_pointer; "callback returning pointer to function pointer (foreign)" >:: Foreign_tests.test_callback_returning_pointer_to_function_pointer; "callback returning pointer to function pointer (stubs)" >:: Stub_tests.test_callback_returning_pointer_to_function_pointer; "incomplete types" >:: test_dereferencing_pointers_to_incomplete_types; "abstract types" >:: test_writing_through_pointer_to_abstract_type; "global value" >:: test_reading_and_writing_global_value; "allocation (foreign)" >:: Foreign_tests.test_allocation; "allocation (stubs)" >:: Stub_tests.test_allocation; "passing pointers through functions (foreign)" >:: Foreign_tests.test_passing_pointer_through; "passing pointers through functions (stubs)" >:: Stub_tests.test_passing_pointer_through; "returned globals (foreign)" >:: Foreign_tests.test_reading_returned_global; "returned globals (stubs)" >:: Stub_tests.test_reading_returned_global; "reading strings" >:: test_reading_strings; "arithmetic" >:: test_pointer_arithmetic; "comparisons" >:: test_pointer_comparison; "differences" >:: test_pointer_differences; "raw" >:: test_raw_pointers; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-raw/000077500000000000000000000000001274143137600170365ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-raw/test_raw.ml000066400000000000000000000053221274143137600212220ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes_memory_stubs open Ctypes_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 _ = Ctypes_ffi_stubs.( let double_ffitype = primitive_ffitype Ctypes_primitive_types.Double in let callspec = allocate_callspec ~check_errno:false ~runtime_lock:false in let arg_1_offset = add_argument callspec double_ffitype in let () = prep_callspec callspec Libffi_abi.(abi_code default_abi) double_ffitype in let dlfabs = Dl.dlsym "fabs" in let dlfabs_fat = Ctypes_ptr.Fat.make dlfabs ~reftyp:Ctypes.(double @-> returning double) in let fabs x = call "fabs" dlfabs_fat callspec (fun p _values -> write Ctypes_primitive_types.Double x Ctypes_ptr.(Fat.make ~reftyp:Ctypes_static.Void (Raw.(add p (of_int arg_1_offset))))) (fun p -> read Ctypes_primitive_types.Double (Ctypes_ptr.Fat.make ~reftyp:Ctypes_static.Void p)) in assert_equal 2.0 (fabs (-2.0)) ~printer:string_of_float; assert_equal 12.0 (fabs (12.0)) ~printer:string_of_float; assert_equal 0.0 (fabs 0.0) ~printer:string_of_float; ) (* Call the C function double pow(double, double) *) let test_pow _ = Ctypes_ffi_stubs.( let double_ffitype = primitive_ffitype Ctypes_primitive_types.Double in let callspec = allocate_callspec ~check_errno:false ~runtime_lock:false in let arg_1_offset = add_argument callspec double_ffitype in let arg_2_offset = add_argument callspec double_ffitype in let () = prep_callspec callspec Libffi_abi.(abi_code default_abi) double_ffitype in let dlpow = Dl.dlsym "pow" in let dlpow_fat = Ctypes_ptr.Fat.make dlpow ~reftyp:Ctypes.(double @-> double @-> returning double) in let pow x y = call "pow" dlpow_fat callspec (fun buffer _values -> write Ctypes_primitive_types.Double x Ctypes_ptr.(Fat.make ~reftyp:Ctypes_static.Void (Raw.(add buffer (of_int arg_1_offset)))); write Ctypes_primitive_types.Double y Ctypes_ptr.(Fat.make ~reftyp:Ctypes_static.Void (Raw.(add buffer (of_int arg_2_offset))))) (fun p -> read Ctypes_primitive_types.Double (Ctypes_ptr.Fat.make ~reftyp:Ctypes_static.Void p)) in assert_equal 8.0 (pow 2.0 3.0); assert_equal 1.0 (pow 10.0 0.0); ) let suite = "Raw interface tests" >::: ["test_abs" >:: test_fabs; "test_pow" >:: test_pow ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-returning-errno-lwt/000077500000000000000000000000001274143137600222115ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-returning-errno-lwt/stub-generator/000077500000000000000000000000001274143137600251525ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-returning-errno-lwt/stub-generator/driver.ml000066400000000000000000000007601274143137600270020ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the errno tests. *) let cheader = "#include #include #include #include #include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) ~structs:(module Types.Struct_stubs) ~concurrency:Cstubs.lwt_jobs ~errno:Cstubs.return_errno ocaml-ctypes-0.7.0/tests/test-returning-errno-lwt/stubs/000077500000000000000000000000001274143137600233515ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-returning-errno-lwt/stubs/functions.ml000066400000000000000000000011151274143137600257110ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the Errno tests. *) open Ctypes module Stubs (F: Cstubs.FOREIGN) = struct open F let struct_stat : [`stat] structure typ = structure "stat" let stat = foreign "stat" (string @-> ptr struct_stat @-> returning int) let sixargs = foreign "sixargs" (int @-> int @-> int @-> int @-> int @-> int @-> returning int) let return_10 = foreign "return_10" (void @-> returning int) end ocaml-ctypes-0.7.0/tests/test-returning-errno-lwt/stubs/types.ml000066400000000000000000000010031274143137600250410ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open PosixTypes module Struct_stubs(S : Cstubs.Types.TYPE) = struct open S let _ENOENT = constant "ENOENT" sint let ifdir = constant "S_IFDIR" (lift_typ mode_t) let ifmt = constant "S_IFMT" (lift_typ mode_t) let stat : [`stat] structure typ = structure "stat" let st_mode = field stat "st_mode" (lift_typ mode_t) let () = seal stat end ocaml-ctypes-0.7.0/tests/test-returning-errno-lwt/test_returning_errno.ml000066400000000000000000000027321274143137600270300ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes module Bindings = Functions.Stubs(Generated_bindings) module Constants = Types.Struct_stubs(Generated_struct_bindings) (* Test the binding to "stat". *) let test_stat _ = let s = make Constants.stat in begin Lwt_unix.run Lwt.((Bindings.stat "." (addr s)).lwt >>= fun (x, errno) -> assert_equal 0 x; assert_equal Signed.SInt.zero errno; return ()); Lwt_unix.run Lwt.((Bindings.stat "/does-not-exist" (addr s)).lwt >>= fun (x, errno) -> assert_equal (-1) x; assert_equal Constants._ENOENT errno; return ()) end (* Test calling functions with many arguments. *) let test_six_args _ = let open Lwt.Infix in Lwt_unix.run ((Bindings.sixargs 1 2 3 4 5 6).Generated_bindings.lwt >>= fun (i, errno) -> assert_equal (1 + 2 + 3 + 4 + 5 + 6) i; Lwt.return ()) (* Test calling functions with no arguments. *) let test_no_args _ = let open Lwt.Infix in Lwt_unix.run ((Bindings.return_10 ()).Generated_bindings.lwt >>= fun (i, errno) -> assert_equal 10 i; Lwt.return ()) let suite = "Errno tests" >::: ["calling stat" >:: test_stat; "functions with many arguments" >:: test_six_args; "functions with no arguments" >:: test_no_args; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-returning-errno/000077500000000000000000000000001274143137600214055ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-returning-errno/stub-generator/000077500000000000000000000000001274143137600243465ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-returning-errno/stub-generator/driver.ml000066400000000000000000000007171274143137600262000ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the errno tests. *) let cheader = "#include #include #include #include #include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) ~structs:(module Types.Struct_stubs) ~errno:Cstubs.return_errno ocaml-ctypes-0.7.0/tests/test-returning-errno/stubs/000077500000000000000000000000001274143137600225455ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-returning-errno/stubs/functions.ml000066400000000000000000000006361274143137600251140ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the Errno tests. *) open Ctypes module Stubs (F: Cstubs.FOREIGN) = struct open F let struct_stat : [`stat] structure typ = structure "stat" let stat = foreign "stat" (string @-> ptr struct_stat @-> returning int) end ocaml-ctypes-0.7.0/tests/test-returning-errno/stubs/types.ml000066400000000000000000000010031274143137600242350ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes open PosixTypes module Struct_stubs(S : Cstubs.Types.TYPE) = struct open S let _ENOENT = constant "ENOENT" sint let ifdir = constant "S_IFDIR" (lift_typ mode_t) let ifmt = constant "S_IFMT" (lift_typ mode_t) let stat : [`stat] structure typ = structure "stat" let st_mode = field stat "st_mode" (lift_typ mode_t) let () = seal stat end ocaml-ctypes-0.7.0/tests/test-returning-errno/test_returning_errno.ml000066400000000000000000000013611274143137600262210ustar00rootroot00000000000000(* * Copyright (c) 2016 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes module Bindings = Functions.Stubs(Generated_bindings) module Constants = Types.Struct_stubs(Generated_struct_bindings) (* Test the binding to "stat". *) let test_stat _ = let st = make Constants.stat in begin let x, errno = Bindings.stat "." (addr st) in assert_equal 0 x; assert_equal Signed.SInt.zero errno; let x, errno = Bindings.stat "/does-not-exist" (addr st) in assert_equal (-1) x; assert_equal Constants._ENOENT errno; end let suite = "Errno tests" >::: ["calling stat" >:: test_stat; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-roots/000077500000000000000000000000001274143137600174135ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-roots/test_roots.ml000066400000000000000000000047261274143137600221630ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes open Foreign let testlib = Dl.(dlopen ~filename:"clib/libtest_functions.so" ~flags:[RTLD_NOW]) (* Test root lifetime. *) let test_root_lifetime _ = (* Check that values not registered as roots are collected. *) let alive = ref true in let () = let v = [| 1; 2; 3 |] in Gc.finalise (fun _ -> alive := false) v; in Gc.compact (); assert_equal false !alive ~msg:"values not registered as roots are collected"; (* Check that values registered as roots are not collected. *) let alive = ref true in let _r = let v = [| 1; 2; 3 |] in Gc.finalise (fun _ -> alive := false) v; Root.create v in Gc.compact (); assert_equal true !alive ~msg:"registered roots are not collected"; (* Check that values unregistered as roots are collected. *) let alive = ref true in let r = let v = [| 1; 2; 3 |] in Gc.finalise (fun _ -> alive := false) v; Root.create v in Root.release r; Gc.compact (); assert_equal false !alive ~msg:"released roots are collected"; (* Check that values assigned to roots are not collected. *) let alive = ref true in let () = let v = [| 1; 2; 3 |] in Gc.finalise (fun _ -> alive := false) v; let r = Root.create () in Root.set r v; in Gc.compact (); assert_equal true !alive ~msg:"values assigned to roots are not collected"; (* Check that values registered as roots and then overwritten are collected. *) let alive = ref true in let r = let v = [| 1; 2; 3 |] in Gc.finalise (fun _ -> alive := false) v; Root.create v in Root.set r (); Gc.compact (); assert_equal false !alive ~msg:"overwritten roots are collected"; () (* Test passing roots to C functions. *) let test_passing_roots _ = let save = foreign ~from:testlib "save_ocaml_value" (ptr void @-> returning void) and retrieve = foreign ~from:testlib "retrieve_ocaml_value" (void @-> returning (ptr void)) in let r = Root.create [| ( + ) 1; ( * ) 2 |] in begin save r; Gc.compact (); let fs : (int -> int) array = Root.get (retrieve ()) in assert_equal 11 (fs.(0) 10); assert_equal 20 (fs.(1) 10) end let suite = "Root tests" >::: ["root lifetime" >:: test_root_lifetime; "passing roots" >:: test_passing_roots; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-sizeof/000077500000000000000000000000001274143137600175445ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-sizeof/test_sizeof.ml000066400000000000000000000154631274143137600224450ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes (* Test 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 that [sizeof] treats OCaml types as incomplete. *) let test_sizeof_ocaml_string _ = assert_raises IncompleteType (fun () -> sizeof ocaml_string) (* Test the behaviour of sizeof on array types. *) let test_sizeof_arrays _ = begin assert_equal ~msg:"The size of an array is the sum of the size of its members" (12 * (sizeof int8_t)) (sizeof (array 12 int8_t)); assert_equal ~msg:"Arrays of arrays are correctly sized" (5 * 7 * (sizeof nativeint)) (sizeof (array 7 (array 5 nativeint))) end (* Test the behaviour of sizeof on bigarray types. *) let test_sizeof_bigarrays _ = let module M = struct module B = Bigarray 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 considers ocaml_string incomplete" >:: test_sizeof_ocaml_string; "sizeof arrays" >:: test_sizeof_arrays; "sizeof bigarrays" >:: test_sizeof_bigarrays; "sizeof pointers" >:: test_sizeof_pointers; "sizeof views" >:: test_sizeof_views; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-structs/000077500000000000000000000000001274143137600177545ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-structs/stub-generator/000077500000000000000000000000001274143137600227155ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-structs/stub-generator/driver.ml000066400000000000000000000004601274143137600245420ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the struct tests. *) let () = Tests_common.run Sys.argv ~structs:(module Types.Struct_stubs) (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-structs/stubs/000077500000000000000000000000001274143137600211145ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-structs/stubs/functions.ml000066400000000000000000000035631274143137600234650ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the struct tests. *) open Ctypes (* These functions can be bound either dynamically using Foreign or statically using stub generation. *) module Common (F: Cstubs.FOREIGN) = struct open F type simple let simple : simple structure typ = structure "simple" let i = field simple "i" int let f = field simple "f" double let self = field simple "self" (ptr simple) let () = seal simple let accept_struct = foreign "accept_struct" (simple @-> returning int) let return_struct = foreign "return_struct" (void @-> returning simple) (* Forward declarations *) let s1 : [`s1] structure typ = structure "s1" and s5 : [`s5] structure typ = structure "s5" let call_s5 = foreign "call_s5" (ptr s1 @-> ptr s5 @-> returning int); end (* These functions can only be bound using stub generation, since Foreign doesn't support passing structs with union or array members. *) module Stubs_only(F : Cstubs.FOREIGN) = struct open F type number let number : number union typ = union "number" let i = field number "i" int let d = field number "d" double let () = seal number type tagged let tagged : tagged structure typ = structure "tagged" let tag = field tagged "tag" char let num = field tagged "num" number let () = seal tagged type triple let triple : triple structure typ = structure "triple" let elements = field triple "elements" (array 3 double) let () = seal triple let add_tagged_numbers = foreign "add_tagged_numbers" (tagged @-> tagged @-> returning tagged) let add_triples = foreign "add_triples" (triple @-> triple @-> returning triple) end module Stubs (F: Cstubs.FOREIGN) = struct include Common(F) include Stubs_only(F) end ocaml-ctypes-0.7.0/tests/test-structs/stubs/types.ml000066400000000000000000000025451274143137600226200ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes module Struct_stubs(S : Ctypes_types.TYPE) = struct open S (* missing fields *) let s1 : [`s1] structure typ = structure "s1" let x1 = field s1 "x1" int let x4 = field s1 "x4" int let () = seal s1 (* fields reordered *) let s2 : [`s2] structure typ = structure "s2" let y2 = field s2 "y2" int let y1 = field s2 "y1" int let () = seal s2 (* one struct depending on another *) let s3 : [`s3] structure typ = structure "s3" let z1 = field s3 "z1" int let z2 = field s3 "z2" (ptr s3) let () = seal s3 let s4 : [`s4] structure typ = structure "s4" let z3 = field s4 "z3" s3 let z4 = field s4 "z4" (ptr s3) let () = seal s4 (* dependencies involving function pointers *) (* (incomplete types are available in the present) *) let s1_fwd : [`s1] Ctypes.structure Ctypes.typ = Ctypes.structure "s1" let s5 : [`s5] structure typ = structure "s5" let w1 = field s5 "w1" (lift_typ (Foreign.funptr Ctypes.(ptr s1_fwd @-> returning int))) let () = seal s5 (* adding fields through views (typedefs) *) let struct_s6 : [`s6] structure typ = structure "" let s6 = typedef struct_s6 "s6" let v1 = field s6 "v1" int let v2 = field s6 "v2" float let () = seal s6 end ocaml-ctypes-0.7.0/tests/test-structs/test_structs.ml000066400000000000000000000407141274143137600230620ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes let testlib = Dl.(dlopen ~filename:"clib/libtest_functions.so" ~flags:[RTLD_NOW]) module Build_foreign_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Common(S) open M (* Call a function of type void (struct simple) where struct simple { int i; double f; struct simple *self; }; *) let test_passing_struct _ = let module M = struct let s = make simple let () = begin setf s i 10; setf s f 14.5; setf s self (from_voidp simple null) end let v = accept_struct s let () = assert_equal 25 v ~printer:string_of_int end in () (* Call a function of type struct simple(void) where struct simple { int i; double f; struct simple *self; }; *) let test_returning_struct _ = let module M = struct let s = return_struct () let () = assert_equal 20 (getf s i) let () = assert_equal 35.0 (getf s f) let t = getf s self let () = assert_equal 10 !@(t |-> i) ~printer:string_of_int let () = assert_equal 12.5 !@(t |-> f) ~printer:string_of_float let () = assert_equal (to_voidp !@(t |-> self)) (to_voidp t) end in () end (* Check that attempts to use incomplete types for struct members are rejected. *) let test_incomplete_struct_members _ = let s = structure "s" in begin assert_raises IncompleteType (fun () -> field s "_" void); assert_raises IncompleteType (fun () -> field s "_" (structure "incomplete")); assert_raises IncompleteType (fun () -> field s "_" (union "incomplete")); end (* Test that fields can be added to views over structs. *) let test_adding_fields_through_views _ = let module M = struct let struct_s = structure "struct_s" let s = typedef struct_s "s" let i = field s "i" int let j = field s "j" float let () = seal s end in () (* Test that OCaml types cannot be used as struct or union fields. *) let test_ocaml_types_rejected_as_fields _ = let module M = struct let s = structure "s" let () = assert_raises IncompleteType (fun () -> field s "o" ocaml_string) let u = union "u" let () = assert_raises IncompleteType (fun () -> let _ = field u "o" ocaml_string in (* The error is currently only caught on sealing the union *) seal u) end in () (* Test reading and writing pointers to struct members. *) let test_pointers_to_struct_members _ = let module M = struct type s let styp : s structure typ = structure "s" let (-:) ty label = field styp label ty let i = int -: "i" let j = int -: "j" let k = ptr int -: "k" let () = seal styp let s = make styp let () = begin let sp = addr s in sp |-> i <-@ 10; sp |-> j <-@ 20; (sp |-> k) <-@ (sp |-> i); assert_equal ~msg:"sp->i = 10" ~printer:string_of_int 10 (!@(sp |-> i)); assert_equal ~msg:"sp->j = 20" ~printer:string_of_int 20 (!@(sp |-> j)); assert_equal ~msg:"*sp->k = 10" ~printer:string_of_int 10 (!@(!@(sp |-> k))); (sp |-> k) <-@ (sp |-> j); assert_equal ~msg:"*sp->k = 20" ~printer:string_of_int 20 (!@(!@(sp |-> k))); sp |-> i <-@ 15; sp |-> j <-@ 25; assert_equal ~msg:"*sp->k = 25" ~printer:string_of_int 25 (!@(!@(sp |-> k))); (sp |-> k) <-@ (sp |-> i); assert_equal ~msg:"*sp->k = 15" ~printer:string_of_int 15 (!@(!@(sp |-> k))); end end in () (* Test structs with union members. *) let test_structs_with_union_members _ = let module M = struct type u and s let complex64_eq = let open Complex in let eps = 1e-12 in fun { re = lre; im = lim } { re = rre; im = rim } -> abs_float (lre -. rre) < eps && abs_float (lim -. rim) < eps let utyp : u union typ = union "u" let (-:) ty label = field utyp label ty let uc = char -: "uc" let ui = int -: "ui" let uz = complex64 -: "uz" let () = seal utyp let u = make utyp let () = begin setf u ui 14; assert_equal ~msg:"u.ui = 14" ~printer:string_of_int 14 (getf u ui); setf u uc 'x'; assert_equal ~msg:"u.uc = 'x'" ~printer:(String.make 1) 'x' (getf u uc); setf u uz { Complex.re = 5.55; im = -3.3 }; assert_equal ~msg:"u.uz = 5.55 - 3.3i" ~cmp:complex64_eq { Complex.re = 5.55; im = -3.3 } (getf u uz); end let styp : s structure typ = structure "s" let (-:) ty label = field styp label ty let si = int -: "si" let su = utyp -: "su" let sc = char -: "sc" let () = seal styp let s = make styp let () = begin setf s si 22; setf s su u; setf s sc 'z'; assert_equal ~msg:"s.si = 22" ~printer:string_of_int 22 (getf s si); assert_equal ~msg:"s.su.uc = 0.0 - 3.3i" ~cmp:complex64_eq { Complex.re = 5.55; im = -3.3 } (getf (getf s su) uz); assert_equal ~msg:"s.sc = 'z'" ~printer:(String.make 1) 'z' (getf s sc); end end in () (* Test structs with array members. *) let test_structs_with_array_members _ = let module M = struct type u and s let styp : s structure typ = structure "s" let (-:) ty label = field styp label ty let i = int -: "i" let a = array 3 double -: "a" let c = char -: "c" let () = seal styp let s = make styp module Array = CArray let arr = Array.of_list double [3.3; 4.4; 5.5] let () = begin setf s i 22; setf s a arr; setf s c 'z'; assert_equal ~msg:"s.i = 22" ~printer:string_of_int 22 (getf s i); assert_equal ~msg:"s.a[0] = 3.3" ~printer:string_of_float 3.3 (getf s a).(0); assert_equal ~msg:"s.a[0] = 3.3" ~printer:string_of_float 3.3 (getf s a).(0); assert_equal ~msg:"s.a[1] = 4.4" ~printer:string_of_float 4.4 (getf s a).(1); assert_equal ~msg:"s.a[2] = 5.5" ~printer:string_of_float 5.5 (getf s a).(2); assert_raises (Invalid_argument "index out of bounds") (fun () -> (getf s a).(3)); assert_equal ~msg:"s.c = 'z'" ~printer:(String.make 1) 'z' (getf s c); (* References to the array member should alias the original *) let arr' = getf s a in arr'.(0) <- 13.3; arr'.(1) <- 24.4; arr'.(2) <- 35.5; assert_equal ~msg:"s.a[0] = 13.3" ~printer:string_of_float 13.3 (getf s a).(0); assert_equal ~msg:"s.a[1] = 24.4" ~printer:string_of_float 24.4 (getf s a).(1); assert_equal ~msg:"s.a[2] = 35.5" ~printer:string_of_float 35.5 (getf s a).(2); end end in () (* Test that attempting to update a sealed struct is treated as an error. *) let test_updating_sealed_struct _ = let styp = structure "sealed" in let _ = field styp "_" int in let () = seal styp in assert_raises (ModifyingSealedType "sealed") (fun () -> field styp "_" char) (* Test that attempting to seal an empty struct is treated as an error. *) let test_sealing_empty_struct _ = let empty = structure "empty" in assert_raises (Unsupported "struct with no fields") (fun () -> seal empty) (* Check that references to fields aren't garbage collected while they're still needed. *) let test_field_references_not_invalidated _ = let module M = struct type s1 and s2 (* struct s1 { struct s2 { int i; } s2; }; *) let s1 : s1 structure typ = structure "s1" let () = (fun () -> let s2 : s2 structure typ = structure "s2" in let _ = field s2 "i" int in let () = seal s2 in let _ = field s1 "_" s2 in () ) () let () = begin Gc.full_major (); seal s1; assert_equal ~printer:string_of_int (sizeof int) (sizeof s1) end end in () (* Check that references to ffi_type values for structs aren't collected while they're still needed *) let test_struct_ffi_type_lifetime _ = let module M = struct let f = let t = void @-> returning (begin let s = structure "one_int" in let _ = field s "i" int in let () = seal s in s end) in Foreign.foreign ~from:testlib "return_struct_by_value" t let () = Gc.full_major() let x = f () end in () module Build_stub_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct open Functions include Build_foreign_tests(S) module N = Functions.Stubs(S) open N (* Test passing structs with union members. *) let test_passing_structs_with_union_members _ = let mkInt v = let t = make tagged in t @. tag <-@ 'i'; (t @. num |-> i) <-@ v; t and mkDbl v = let t = make tagged in t @. tag <-@ 'd'; (t @. num |-> d) <-@ v; t and readDbl t = assert_equal 'd' !@(t @. tag); !@(t @. num |-> d) in begin assert_equal 10.0 (readDbl (add_tagged_numbers (mkInt 3) (mkInt 7))); assert_equal 10.0 (readDbl (add_tagged_numbers (mkInt 3) (mkDbl 7.0))); assert_equal 10.0 (readDbl (add_tagged_numbers (mkDbl 3.0) (mkInt 7))); assert_equal 10.0 (readDbl (add_tagged_numbers (mkDbl 3.0) (mkDbl 7.0))); end (* Test passing structs with array members. *) let test_passing_structs_with_array_members _ = let mkTriple (x, y, z) = let t = make triple in t @. elements <-@ CArray.of_list double [x; y; z]; t and readTriple t = match CArray.to_list (getf t elements) with | [x; y; z] -> (x, y, z) | _ -> assert false in begin assert_equal (10.0, 20.0, 30.0) (readTriple (add_triples (mkTriple (5.0, 12.0, 17.0)) (mkTriple (5.0, 8.0, 13.0)))) end end module Foreign_tests = Build_foreign_tests(Tests_common.Foreign_binder) module Stub_tests = Build_stub_tests(Generated_bindings) module Build_struct_stub_tests (S : Ctypes_types.TYPE with type 'a typ = 'a Ctypes.typ and type ('a, 's) field = ('a, 's) Ctypes.field) = struct module M = Types.Struct_stubs(S) let retrieve_size name = let f = Foreign.foreign ~from:testlib name (void @-> returning size_t) in Unsigned.Size_t.to_int (f ()) let sizeof_s1 = retrieve_size "sizeof_s1" let alignmentof_s1 = retrieve_size "alignmentof_s1" let offsetof_x1 = retrieve_size "offsetof_x1" let offsetof_x2 = retrieve_size "offsetof_x2" let offsetof_x3 = retrieve_size "offsetof_x3" let offsetof_x4 = retrieve_size "offsetof_x4" let sizeof_s2 = retrieve_size "sizeof_s2" let alignmentof_s2 = retrieve_size "alignmentof_s2" let offsetof_y1 = retrieve_size "offsetof_y1" let offsetof_y2 = retrieve_size "offsetof_y2" let offsetof_y3 = retrieve_size "offsetof_y3" let offsetof_y4 = retrieve_size "offsetof_y4" let sizeof_s3 = retrieve_size "sizeof_s3" let alignmentof_s3 = retrieve_size "alignmentof_s3" let offsetof_z1 = retrieve_size "offsetof_z1" let offsetof_z2 = retrieve_size "offsetof_z2" let sizeof_s4 = retrieve_size "sizeof_s4" let alignmentof_s4 = retrieve_size "alignmentof_s4" let offsetof_z3 = retrieve_size "offsetof_z3" let offsetof_z4 = retrieve_size "offsetof_z4" let sizeof_s6 = retrieve_size "sizeof_s6" let alignmentof_s6 = retrieve_size "alignmentof_s6" let offsetof_v1 = retrieve_size "offsetof_v1" let offsetof_v2 = retrieve_size "offsetof_v2" (* Test that struct layout retrieved from C correctly accounts for missing fields. *) let test_missing_fields _ = begin assert_equal sizeof_s1 (sizeof M.s1); assert_equal alignmentof_s1 (alignment M.s1); assert_equal offsetof_x1 (offsetof M.x1); assert_equal offsetof_x4 (offsetof M.x4); end (* Test that struct layout retrieved from C correctly accounts for reordered fields. *) let test_reordered_fields _ = begin assert_equal sizeof_s2 (sizeof M.s2); assert_equal alignmentof_s2 (alignment M.s2); assert_equal offsetof_y1 (offsetof M.y1); assert_equal offsetof_y2 (offsetof M.y2); end (* Test that we can retrieve information about multiple structs with dependencies between them. *) let test_struct_dependencies _ = begin assert_equal sizeof_s3 (sizeof M.s3); assert_equal alignmentof_s3 (alignment M.s3); assert_equal offsetof_z1 (offsetof M.z1); assert_equal offsetof_z2 (offsetof M.z2); assert_equal sizeof_s4 (sizeof M.s4); assert_equal alignmentof_s4 (alignment M.s4); assert_equal offsetof_z3 (offsetof M.z3); assert_equal offsetof_z4 (offsetof M.z4); end (* Test that we can retrieve information for structs without tags that are identified through typedefs, e.g. typedef struct { int x; float y; } t; *) let test_tagless_structs _ = begin assert_equal sizeof_s6 (sizeof M.s6); assert_equal alignmentof_s6 (alignment M.s6); assert_equal offsetof_v1 (offsetof M.v1); assert_equal offsetof_v2 (offsetof M.v2); end module Build_call_tests (F : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module F = Functions.Common(F) open F open M let callback p = !@(p |-> x1) + !@(p |-> x4) (* Call a function passing two structs, one of which contains a function pointer which accepts an argument to the other. This is mostly testing that we can support complex dependencies together with retrieved layout. *) let test_struct_dependencies _ = let v5 = make s5 in let v1 = make s1 in begin setf v1 x1 10; setf v1 x4 20; setf v5 w1 callback; assert_equal 30 (call_s5 (addr v1) (addr v5)) ~printer:string_of_int; end end end module Struct_stubs_tests = Build_struct_stub_tests(Generated_struct_bindings) module Combined_foreign_tests = Struct_stubs_tests.Build_call_tests(Tests_common.Foreign_binder) module Combined_stub_tests = Struct_stubs_tests.Build_call_tests(Generated_bindings) let suite = "Struct tests" >::: ["passing struct (foreign)" >:: Foreign_tests.test_passing_struct; "passing struct (stubs)" >:: Stub_tests.test_passing_struct; "returning struct (foreign)" >:: Foreign_tests.test_returning_struct; "returning struct (stubs)" >:: Stub_tests.test_returning_struct; "struct dependencies (foreign)" >:: Combined_foreign_tests.test_struct_dependencies; "struct dependencies (stubs)" >:: Combined_stub_tests.test_struct_dependencies; "incomplete struct members rejected" >:: test_incomplete_struct_members; "fields can be added to views over structs" >:: test_adding_fields_through_views; "ocaml_string cannot be used as a structure field" >:: test_ocaml_types_rejected_as_fields; "pointers to struct members" >:: test_pointers_to_struct_members; "structs with union members" >:: test_structs_with_union_members; "passing structs with union members (stubs)" >:: Stub_tests.test_passing_structs_with_union_members; "passing structs with array members (stubs)" >:: Stub_tests.test_passing_structs_with_array_members; "structs with array members" >:: test_structs_with_array_members; "updating sealed struct" >:: test_updating_sealed_struct; "sealing empty struct" >:: test_sealing_empty_struct; "field references not invalidated" >:: test_field_references_not_invalidated; "test struct ffi_type lifetime" >:: test_struct_ffi_type_lifetime; "test layout of structs with missing fields" >:: Struct_stubs_tests.test_missing_fields; "test layout of structs with reordered fields" >:: Struct_stubs_tests.test_reordered_fields; "test retrieving information about structs with dependencies" >:: Struct_stubs_tests.test_struct_dependencies; "test adding fields to tagless structs" >:: Struct_stubs_tests.test_tagless_structs; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-stubs/000077500000000000000000000000001274143137600174055ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-stubs/test_stubs.ml000066400000000000000000000012571274143137600221430ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes open Foreign let missing = "_60d2dd04_1b66_4b79_a2ea_8375157da563" let test_missing _ = let miss = foreign missing ~stub:true (int @-> int @-> (returning int)) in begin try ignore (miss 2 3); assert_failure "should raise" with exn -> () end; try let _ = 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-0.7.0/tests/test-threads/000077500000000000000000000000001274143137600176775ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-threads/stubs/000077500000000000000000000000001274143137600210375ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-threads/stubs/functions.ml000066400000000000000000000015601274143137600234030ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the threads tests. *) open Ctypes open Foreign let () = (* temporary workaround due to flexlink limitations *) if Sys.os_type = "Win32" then ignore (Dl.(dlopen ~filename:"clib/libtest_functions.so" ~flags:[RTLD_NOW])) let initialize_waiters = foreign "initialize_waiters" (void @-> returning void) let post1_wait2 = foreign "post1_wait2" ~release_runtime_lock:true (void @-> returning void) let post2_wait1 = foreign "post2_wait1" ~release_runtime_lock:true (void @-> returning void) let callback_with_pointers = foreign "passing_pointers_to_callback" ~release_runtime_lock:true (funptr ~runtime_lock:true (ptr int @-> ptr int @-> returning int) @-> returning int) ocaml-ctypes-0.7.0/tests/test-threads/test_threads.ml000066400000000000000000000033251274143137600227250ustar00rootroot00000000000000(* * 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 OUnit2 open Foreign open Functions (* Ensure that passing ~release_runtime_lock releases the runtime lock. *) let test_release_runtime_lock _ = begin initialize_waiters (); let t1 = Thread.create post1_wait2 () in let t2 = Thread.create post2_wait1 () in Thread.join t1; Thread.join t2; end (* Ensure that passing ~runtime_lock to funptr causes a callback to acquire the runtime lock. *) let test_acquire_runtime_lock _ = begin let f x y = let _ = Gc.full_major () in !@x + !@y in let t1 = Thread.create Gc.full_major () in assert (callback_with_pointers f = 7); Thread.join t1 end (* Acquire the runtime lock in a callback while other threads execute OCaml code. *) let test_acquire_runtime_lock_parallel _ = begin let r = ref None in let g size n = for i = 0 to n do r := Some (CArray.make float size ~initial:0.0); Thread.yield (); done in let f x y = let _ = Gc.compact () in !@x + !@y in let threads = ref [] in for i = 0 to 10 do threads := Thread.create (g 100) 10000 :: !threads; done; for i = 0 to 10 do assert (callback_with_pointers f = 7); Thread.yield (); done; List.iter Thread.join !threads; end let suite = "Thread tests" >::: ["test_release_runtime_lock (foreign)" >:: test_release_runtime_lock; "test_acquire_runtime_lock (foreign)" >:: test_acquire_runtime_lock; "test_acquire_runtime_lock_parallel (foreign)" >:: test_acquire_runtime_lock_parallel; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-type_printing/000077500000000000000000000000001274143137600211405ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-type_printing/test_type_printing.ml000066400000000000000000000354721274143137600254370ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes let 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 "_Bool" bool; assert_typ_printed_as ~name:"g" "uint8_t g" uint8_t; assert_typ_printed_as "uint16_t" uint16_t; assert_typ_printed_as ~name:"h" "uint32_t h" uint32_t; assert_typ_printed_as "uint64_t" uint64_t; assert_typ_printed_as ~name:"i" "size_t i" size_t; assert_typ_printed_as "unsigned short" ushort; assert_typ_printed_as ~name:"j" "unsigned int j" uint; assert_typ_printed_as "unsigned long" ulong; assert_typ_printed_as ~name:"k" "unsigned long long k" ullong; assert_typ_printed_as "float" float; assert_typ_printed_as ~name:"l" "double l" double; let abs_t = abstract ~name:"abs_t" ~size:1 ~alignment:1 in assert_typ_printed_as "abs_t" abs_t; end (* Test the printing of pointers to object and function types. *) let test_pointer_printing _ = begin (* Pointers to atomic types *) assert_typ_printed_as ~name:"a" "void *a" (ptr void); assert_typ_printed_as "unsigned long long **" (ptr (ptr ullong)); assert_typ_printed_as ~name:"b" "char *****b" (ptr (ptr (ptr (ptr (ptr char))))); let abs_t = abstract ~name:"abs_t" ~size:1 ~alignment:1 in assert_typ_printed_as "abs_t *" (ptr abs_t); (* Pointers to incomplete structs and unions *) let s_incomplete = structure "s_incomplete" in let u_incomplete = union "u_incomplete" in assert_typ_printed_as ~name:"c" "struct s_incomplete *c" (ptr s_incomplete); assert_typ_printed_as "union u_incomplete **" (ptr (ptr u_incomplete)); (* Pointers to complete structs and unions *) let s_complete = structure "s_complete" in let _ = field s_complete "i" int in seal s_complete; let u_complete = union "u_complete" in let _ = field u_complete "i" int in seal u_complete; assert_typ_printed_as ~name:"d" "struct s_complete *d" (ptr s_complete); assert_typ_printed_as "union u_complete **" (ptr (ptr u_complete)); (* Pointers to arrays *) assert_typ_printed_as ~name:"e" "int (*e)[4]" (ptr (array 4 int)); assert_typ_printed_as "struct s_complete (*)[3]" (ptr (array 3 s_complete)); assert_typ_printed_as ~name:"f" "union u_complete (*f)[3][4][5]" (ptr (array 3 (array 4 (array 5 u_complete)))); (* Pointers to functions *) assert_typ_printed_as "void (*)(void)" (Foreign.funptr (void @-> returning void)); assert_typ_printed_as ~name:"g" "float (*g)(int, long)" (Foreign.funptr (int @-> long @-> returning float)); assert_typ_printed_as "void (*)(int (*)[4])" (Foreign.funptr (ptr (array 4 int) @-> returning void)); assert_typ_printed_as ~name:"h" "int32_t (*(*h)(void ))(int)" (Foreign.funptr (void @-> returning (Foreign.funptr (int @-> returning int32_t)))); assert_typ_printed_as "unsigned long (*(*)(int, void (*)(float, float)))(long)" (Foreign.funptr (int @-> Foreign.funptr (float @-> float @-> returning void) @-> returning (Foreign.funptr (long @-> returning ulong)))); (* Pointers to pointers to functions *) assert_typ_printed_as ~name:"i" "double (**i)(int)" (ptr (Foreign.funptr (int @-> returning double))); assert_typ_printed_as "double (**)(int)" (ptr (Foreign.funptr (int @-> returning double))); assert_typ_printed_as ~name:"j" "void (*(*(*(**j)(int))(void))[8])(long, long)" (ptr (Foreign.funptr (int @-> returning (Foreign.funptr (void @-> returning (ptr (array 8 (Foreign.funptr (long @-> long @-> returning void))))))))); end (* Test the printing of pointers to object and function types. *) let test_struct_and_union_printing _ = begin (* Incomplete structs and unions *) let s_incomplete = structure "s_incomplete" in let u_incomplete = union "u_incomplete" in assert_typ_printed_as ~name:"a" "struct s_incomplete a" s_incomplete; assert_typ_printed_as "union u_incomplete" u_incomplete; (* Structs and unions containing primitives *) let s_prims = structure "s_prims" in let (-:) ty label = field s_prims label ty in let _ = int -: "i" in let _ = ulong -: "l" in let _ = float -: "z" in seal s_prims; assert_typ_printed_as ~name:"b" "struct s_prims { int i; unsigned long l; float z; } b" s_prims; let u_prims = union "u_prims" in let (-:) ty label = field u_prims label ty in let _ = int32_t -: "i32" in let _ = int64_t -: "i64" in let _ = double -: "d" in seal u_prims; assert_typ_printed_as "union u_prims { int32_t i32; int64_t i64; double d; }" u_prims; (* Structs and unions containing pointers to themselves *) let selfish = structure "selfish" in let (-:) ty label = field selfish label ty in let _ = ptr selfish -: "s" in let _ = ptr int -: "i" in let _ = ptr (ptr selfish) -: "p" in seal selfish; assert_typ_printed_as ~name:"c" "struct selfish { struct selfish *s; int *i; struct selfish **p; } c" selfish; let u_selfish = union "u_selfish" in let (-:) ty label = field u_selfish label ty in let _ = ptr u_selfish -: "self" in let _ = ptr (union "other") -: "other" in seal u_selfish; assert_typ_printed_as "union u_selfish { union u_selfish *self; union other *other; }" u_selfish; (* Structs and unions containing arrays and pointers to functions *) let mixture = structure "mixture" in let (-:) ty label = field mixture label ty in let _ = array 10 (array 12 (ptr mixture)) -: "parr" in let _ = Foreign.funptr (ptr mixture @-> returning void) -: "fn" in let _ = int -: "i" in seal mixture; assert_typ_printed_as ~name:"d" "struct mixture { struct mixture *parr[10][12]; void (*fn)(struct mixture *); int i; } d" mixture; let u_mixture = union "u_mixture" in let (-:) ty label = field u_mixture label ty in let _ = float -: "fl" in let _ = ptr (array 3 (Foreign.funptr (float @-> returning float))) -: "p" in seal u_mixture; assert_typ_printed_as ~name:"e" "union u_mixture { float fl; float (*(*p)[3])(float); } e" u_mixture; (* Structs and unions containing struct and union members *) let inner_s = structure "inner_s" in let _ = field inner_s "_" int in seal inner_s; let inner_u = union "inner_u" in let _ = field inner_u "_" int in seal inner_u; let 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 OCaml string types. *) let test_ocaml_string_printing _ = begin assert_typ_printed_as ~name:"p" "char *p" ocaml_string; assert_typ_printed_as "char *" ocaml_string; end (* Test the printing of bigarray types with signed elements. *) let test_bigarray_signed_printing _ = begin assert_typ_printed_as "int8_t[1][3]" (bigarray genarray [|1; 3|] Bigarray.int8_signed); assert_typ_printed_as "int16_t[3]" (bigarray array1 3 Bigarray.int16_signed); assert_typ_printed_as "int32_t[5][6]" (bigarray array2 (5, 6) Bigarray.int32); assert_typ_printed_as "int64_t[7][8]" (bigarray array2 (7, 8) Bigarray.int64); assert_typ_printed_as "camlint[9][10]" (bigarray array2 (9, 10) Bigarray.int); assert_typ_printed_as "intnat[13][14][15]" (bigarray array3 (13, 14, 15) Bigarray.nativeint); end (* Test the printing of bigarray types with unsigned elements. *) let test_bigarray_unsigned_printing _ = skip_if true "Unsigned bigarray elements currently indistinguishable from signed elements"; begin assert_typ_printed_as "uint8_t[2]" (bigarray array1 2 Bigarray.int8_unsigned); assert_typ_printed_as "uint16_t[4]" (bigarray array1 4 Bigarray.int16_unsigned); end (* Test the printing of bigarray types with floating elements. *) let test_bigarray_float_printing _ = begin assert_typ_printed_as "float[10][100]" (bigarray genarray [|10; 100|] Bigarray.float32); assert_typ_printed_as "double[20][30][40]" (bigarray genarray [|20; 30; 40|] Bigarray.float64); assert_typ_printed_as "float _Complex[16][17][18]" (bigarray array3 (16, 17, 18) Bigarray.complex32); assert_typ_printed_as "double _Complex[19][20][21]" (bigarray array3 (19, 20, 21) Bigarray.complex64); end (* Test the printing of function types. *) let test_function_printing _ = begin assert_fn_printed_as ~name:"a" "void a(void)" (void @-> returning void); assert_fn_printed_as "float(int, char, double)" (int @-> char @-> double @-> returning float); assert_fn_printed_as ~name:"c" "int (*c(void (*)(void)))(int)" (Foreign.funptr (void @-> returning void) @-> returning (Foreign.funptr (int @-> returning int))); let s = structure "s" in let _ = field s "_" int in seal s; assert_fn_printed_as "struct s(struct s)" (s @-> returning s); end (* Test the printing of view types. *) let test_view_printing _ = begin (* By default, views are printed as the underlying type *) assert_typ_printed_as ~name:"a" "char *a" string; let v : unit typ = view ~read:(fun _ -> ()) ~write:(fun () () -> ()) (Foreign.funptr (void @-> returning void)) in assert_typ_printed_as "void (*)(void)" v; (* The format_typ optional argument can be used to provide custom printing for views. *) let w : unit typ = view (Foreign.funptr (int @-> returning float)) ~format_typ:(fun k fmt -> Format.fprintf fmt "unit%t" k) ~read:(fun _ -> ()) ~write:(fun () _ -> 0.0) in assert_typ_printed_as "unit" w; assert_fn_printed_as ~name:"g" "unit g(unit)" (w @-> returning w) end let suite = "Type printing tests" >::: ["printing atomic types" >:: test_atomic_printing; "printing pointers" >:: test_pointer_printing; "printing structs and unions" >:: test_struct_and_union_printing; "printing arrays" >:: test_array_printing; "printing OCaml string types" >:: test_ocaml_string_printing; "printing bigarrays with signed elements" >:: test_bigarray_signed_printing; "printing bigarrays with unsigned elements" >:: test_bigarray_unsigned_printing; "printing bigarrays with floating elements" >:: test_bigarray_float_printing; "printing functions" >:: test_function_printing; "printing views" >:: test_view_printing; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-unions/000077500000000000000000000000001274143137600175605ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-unions/stub-generator/000077500000000000000000000000001274143137600225215ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-unions/stub-generator/driver.ml000066400000000000000000000004571274143137600243540ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the union tests. *) let () = Tests_common.run Sys.argv ~structs:(module Types.Struct_stubs) (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-unions/stubs/000077500000000000000000000000001274143137600207205ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-unions/stubs/functions.ml000066400000000000000000000020611274143137600232610ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the union tests. *) open Ctypes type padded let padded : padded union typ = union "padded" let (-:) ty label = field padded label ty let i = int64_t -: "i" let a = array (sizeof int64_t + 1) char -: "a" let () = seal padded (* These functions can be bound either dynamically using Foreign or statically using stub generation. *) module Common (F: Cstubs.FOREIGN) = struct let sum_union_components = F.(foreign "sum_union_components" (ptr padded @-> size_t @-> returning int64_t)) end (* These functions can only be bound using stub generation, since Foreign doesn't support passing unions by value. *) module Stubs_only(F : Cstubs.FOREIGN) = struct let add_unions = F.(foreign "add_unions" (padded @-> padded @-> returning padded)) end module Stubs (F: Cstubs.FOREIGN) = struct include Common(F) include Stubs_only(F) end ocaml-ctypes-0.7.0/tests/test-unions/stubs/types.ml000066400000000000000000000010401274143137600224110ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open Ctypes module Struct_stubs(S : Ctypes_types.TYPE) = struct open S (* missing fields *) let u1 : [`u1] union typ = union "u1" let x1 = field u1 "x1" char let () = seal u1 (* adding fields through views (typedefs) *) let union_u2 : [`s7] union typ = union "" let u2 = typedef union_u2 "u2" let t1 = field u2 "t1" int let t2 = field u2 "t2" float let () = seal u2 end ocaml-ctypes-0.7.0/tests/test-unions/test_unions.ml000066400000000000000000000163761274143137600225010ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes open Unsigned let testlib = Dl.(dlopen ~filename:"clib/libtest_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 module Array = CArray let () = assert_equal ~msg:"the byte that we expected to change was changed" arr.(updated_char_index) UChar.one let () = for i = 1 to sizeof int64_t - 1 do if i <> updated_char_index then assert_equal ~msg:"only the top or the bottom byte was changed" UChar.zero arr.(i) done end in () module Build_foreign_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct open Functions module M = Common(S) open M (* Check that unions are tail-padded sufficiently to satisfy the alignment requirements of all their members. *) let test_union_padding _ = let module M = struct let mkPadded : int64 -> padded union = fun x -> let u = make padded in setf u i x; u let arr = CArray.of_list padded [ mkPadded 1L; mkPadded 2L; mkPadded 3L; mkPadded 4L; mkPadded 5L; ] let sum = sum_union_components (CArray.start arr) (Unsigned.Size_t.of_int (CArray.length arr)) let () = assert_equal ~msg:"padded union members accessed correctly" 15L sum ~printer:Int64.to_string end in () end module Build_stub_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct open Functions include Build_foreign_tests(S) module N = Functions.Stubs(S) open N (* Check that unions can be passed and returned by value. *) let test_passing_unions_by_value _ = let module M = struct let mkPadded : int64 -> padded union = fun x -> let u = make padded in setf u i x; u let u = add_unions (mkPadded 20L) (mkPadded 30L) let () = assert_equal ~msg:"unions passed by value" 50L (getf u i) ~printer:Int64.to_string end in () end module Build_struct_stub_tests (S : Ctypes_types.TYPE with type 'a typ = 'a Ctypes.typ and type ('a, 's) field = ('a, 's) Ctypes.field) = struct module M = Types.Struct_stubs(S) let retrieve_size name = let f = Foreign.foreign ~from:testlib name (void @-> returning size_t) in Unsigned.Size_t.to_int (f ()) let sizeof_u1 = retrieve_size "sizeof_u1" let alignmentof_u1 = retrieve_size "alignmentof_u1" let sizeof_u2 = retrieve_size "sizeof_u2" let alignmentof_u2 = retrieve_size "alignmentof_u2" (* Test that union layout retrieved from C correctly accounts for missing fields. *) let test_missing_fields _ = begin assert_equal sizeof_u1 (sizeof M.u1); assert_equal alignmentof_u1 (alignment M.u1); end (* Test that we can retrieve information for unions without tags that are identified through typedefs, e.g. typedef union { int x; float y; } u; *) let test_tagless_unions _ = begin assert_equal sizeof_u2 (sizeof M.u2); assert_equal alignmentof_u2 (alignment M.u2); end end module Struct_stubs_tests = Build_struct_stub_tests(Generated_struct_bindings) (* Check that the address of a union is equal to the addresses of each of its members. *) let test_union_address _ = let module M = struct type u let u : u union typ = union "u" let (-:) ty label = field u label ty let i = int64_t -: "i" let c = char -: "c" let s = ptr (structure "incomplete") -: "s" let () = seal u let up = addr (make u) let () = begin assert_equal (to_voidp up) (to_voidp (up |-> i)); assert_equal (to_voidp up) (to_voidp (up |-> c)); assert_equal (to_voidp up) (to_voidp (up |-> s)); end end in () (* Test that attempting to update a sealed union is treated as an error. *) let test_updating_sealed_union _ = let utyp = union "sealed" in let _ = field utyp "_" int in let () = seal utyp in assert_raises (ModifyingSealedType "sealed") (fun () -> field utyp "_" char) (* Test that fields can be added to views over unions. *) let test_adding_fields_through_views _ = let module M = struct let union_u = union "union_u" let u = typedef union_u "u" let x = field u "x" int let y = field u "y" float let () = seal u end in () (* Test that attempting to seal an empty union is treated as an error. *) let test_sealing_empty_union _ = let empty = union "empty" in assert_raises (Unsupported "union with no fields") (fun () -> seal empty) module Foreign_tests = Build_foreign_tests(Tests_common.Foreign_binder) module Stub_tests = Build_stub_tests(Generated_bindings) let suite = "Union tests" >::: ["inspecting float representation" >:: test_inspecting_float; "detecting endianness" >:: test_endian_detection; "union padding (foreign)" >:: Foreign_tests.test_union_padding; "union padding (stubs)" >:: Stub_tests.test_union_padding; "passing unions by value (stubs)" >:: Stub_tests.test_passing_unions_by_value; "union address" >:: test_union_address; "updating sealed union" >:: test_updating_sealed_union; "sealing empty union" >:: test_sealing_empty_union; "fields can be added to views over unions" >:: test_adding_fields_through_views; "sealing empty union" >:: test_sealing_empty_union; "test adding fields to tagless unions" >:: Struct_stubs_tests.test_tagless_unions; (* "test layout of unions with missing fields" *) (* >:: Struct_stubs_tests.test_missing_fields; *) ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-value_printing/000077500000000000000000000000001274143137600212735ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-value_printing/stub-generator/000077500000000000000000000000001274143137600242345ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-value_printing/stub-generator/driver.ml000066400000000000000000000004151274143137600260610ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the value printing tests. *) let () = Tests_common.run Sys.argv (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-value_printing/stubs/000077500000000000000000000000001274143137600224335ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-value_printing/stubs/functions.ml000066400000000000000000000063051274143137600250010ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the value printing tests. *) open Ctypes module Stubs (F: Cstubs.FOREIGN) = struct open F let retrieve_CHAR_MIN = foreign "retrieve_CHAR_MIN" (void @-> returning char) let retrieve_CHAR_MAX = foreign "retrieve_CHAR_MAX" (void @-> returning char) let retrieve_SCHAR_MIN = foreign "retrieve_SCHAR_MIN" (void @-> returning schar) let retrieve_SCHAR_MAX = foreign "retrieve_SCHAR_MAX" (void @-> returning schar) let retrieve_SHRT_MIN = foreign "retrieve_SHRT_MIN" (void @-> returning short) let retrieve_SHRT_MAX = foreign "retrieve_SHRT_MAX" (void @-> returning short) let retrieve_INT_MIN = foreign "retrieve_INT_MIN" (void @-> returning int) let retrieve_INT_MAX = foreign "retrieve_INT_MAX" (void @-> returning int) let retrieve_LONG_MAX = foreign "retrieve_LONG_MAX" (void @-> returning long) let retrieve_LONG_MIN = foreign "retrieve_LONG_MIN" (void @-> returning long) let retrieve_LLONG_MAX = foreign "retrieve_LLONG_MAX" (void @-> returning llong) let retrieve_LLONG_MIN = foreign "retrieve_LLONG_MIN" (void @-> returning llong) let retrieve_UCHAR_MAX = foreign "retrieve_UCHAR_MAX" (void @-> returning uchar) let retrieve_USHRT_MAX = foreign "retrieve_USHRT_MAX" (void @-> returning ushort) let retrieve_UINT_MAX = foreign "retrieve_UINT_MAX" (void @-> returning uint) let retrieve_ULONG_MAX = foreign "retrieve_ULONG_MAX" (void @-> returning ulong) let retrieve_ULLONG_MAX = foreign "retrieve_ULLONG_MAX" (void @-> returning ullong) let retrieve_INT8_MIN = foreign "retrieve_INT8_MIN" (void @-> returning int8_t) let retrieve_INT8_MAX = foreign "retrieve_INT8_MAX" (void @-> returning int8_t) let retrieve_INT16_MIN = foreign "retrieve_INT16_MIN" (void @-> returning int16_t) let retrieve_INT16_MAX = foreign "retrieve_INT16_MAX" (void @-> returning int16_t) let retrieve_INT32_MIN = foreign "retrieve_INT32_MIN" (void @-> returning int32_t) let retrieve_INT32_MAX = foreign "retrieve_INT32_MAX" (void @-> returning int32_t) let retrieve_INT64_MIN = foreign "retrieve_INT64_MIN" (void @-> returning int64_t) let retrieve_INT64_MAX = foreign "retrieve_INT64_MAX" (void @-> returning int64_t) let retrieve_UINT8_MAX = foreign "retrieve_UINT8_MAX" (void @-> returning uint8_t) let retrieve_UINT16_MAX = foreign "retrieve_UINT16_MAX" (void @-> returning uint16_t) let retrieve_UINT32_MAX = foreign "retrieve_UINT32_MAX" (void @-> returning uint32_t) let retrieve_UINT64_MAX = foreign "retrieve_UINT64_MAX" (void @-> returning uint64_t) let retrieve_SIZE_MAX = foreign "retrieve_SIZE_MAX" (void @-> returning size_t) (* float *) let retrieve_FLT_MIN = foreign "retrieve_FLT_MIN" (void @-> returning float) let retrieve_FLT_MAX = foreign "retrieve_FLT_MAX" (void @-> returning float) let retrieve_DBL_MIN = foreign "retrieve_DBL_MIN" (void @-> returning double) let retrieve_DBL_MAX = foreign "retrieve_DBL_MAX" (void @-> returning double) end ocaml-ctypes-0.7.0/tests/test-value_printing/test_value_printing.ml000066400000000000000000000310441274143137600257140ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes let strip_whitespace = Str.(global_replace (regexp "[\n ]+") "") let equal_ignoring_whitespace l r = strip_whitespace l = strip_whitespace r module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Test the printing of atomic values: arithmetic types and values of abstract types. *) let test_atomic_printing _ = let open Signed in let open Unsigned in (* char *) let _CHAR_MIN = retrieve_CHAR_MIN () in let _CHAR_MAX = retrieve_CHAR_MAX () in assert_equal (string_of char _CHAR_MIN) (Printf.sprintf "'%c'" _CHAR_MIN); assert_equal (string_of char 'a') "'a'"; assert_equal (string_of char 'A') "'A'"; assert_equal (string_of char '3') "'3'"; assert_equal (string_of char '\n') "'\n'"; assert_equal (string_of char ' ') "' '"; assert_equal (string_of char _CHAR_MAX) (Printf.sprintf "'%c'" _CHAR_MAX); (* signed char *) let _SCHAR_MIN = retrieve_SCHAR_MIN () in let _SCHAR_MAX = retrieve_SCHAR_MAX () in assert_equal (string_of schar _SCHAR_MIN) (string_of_int _SCHAR_MIN); assert_equal (string_of schar 0) (string_of_int 0); assert_equal (string_of schar (-5)) (string_of_int (-5)); assert_equal (string_of schar 5) (string_of_int 5); assert_equal (string_of schar _SCHAR_MAX) (string_of_int _SCHAR_MAX); (* short *) let _SHRT_MIN = retrieve_SHRT_MIN () in let _SHRT_MAX = retrieve_SHRT_MAX () in assert_equal (string_of short _SHRT_MIN) (string_of_int _SHRT_MIN); assert_equal (string_of short 0) (string_of_int 0); assert_equal (string_of short (-5)) (string_of_int (-5)); assert_equal (string_of short 14) (string_of_int 14); assert_equal (string_of short _SHRT_MAX) (string_of_int _SHRT_MAX); (* int *) let _INT_MIN = retrieve_INT_MIN () in let _INT_MAX = retrieve_INT_MAX () in assert_equal (string_of int _INT_MIN) (string_of_int _INT_MIN); assert_equal (string_of int 0) (string_of_int 0); assert_equal (string_of int (-5)) (string_of_int (-5)); assert_equal (string_of int 14) (string_of_int 14); assert_equal (string_of int _INT_MAX) (string_of_int _INT_MAX); (* long *) let _LONG_MAX = retrieve_LONG_MAX () in let _LONG_MIN = retrieve_LONG_MIN () in assert_equal (string_of long _LONG_MIN) Long.(to_string _LONG_MIN); assert_equal (string_of long Long.(of_int 0)) Long.(to_string (of_int 0)); assert_equal (string_of long (Long.of_int (-5))) Long.(to_string (of_int (-5))); assert_equal (string_of long (Long.of_int 14)) Long.(to_string (of_int 14)); assert_equal (string_of long _LONG_MAX) Long.(to_string _LONG_MAX); (* long long *) let _LLONG_MAX = retrieve_LLONG_MAX () in let _LLONG_MIN = retrieve_LLONG_MIN () in assert_equal (string_of llong _LLONG_MIN) LLong.(to_string _LLONG_MIN); assert_equal (string_of llong LLong.(of_int 0)) LLong.(to_string (of_int 0)); assert_equal (string_of llong (LLong.of_int (-5))) LLong.(to_string (of_int (-5))); assert_equal (string_of llong (LLong.of_int 14)) LLong.(to_string (of_int 14)); assert_equal (string_of llong _LLONG_MAX) LLong.(to_string _LLONG_MAX); (* unsigned char *) let _UCHAR_MAX = retrieve_UCHAR_MAX () in UChar.(assert_equal (string_of uchar (of_int 0)) (to_string (of_int 0))); UChar.(assert_equal (string_of uchar (of_int 5)) (to_string (of_int 5))); UChar.(assert_equal (string_of uchar _UCHAR_MAX) (to_string _UCHAR_MAX)); (* bool *) assert_equal (string_of bool true) "true"; assert_equal (string_of bool false) "false"; (* unsigned short *) let _USHRT_MAX = retrieve_USHRT_MAX () in UShort.(assert_equal (string_of ushort (of_int 0)) (to_string (of_int 0))); UShort.(assert_equal (string_of ushort (of_int 5)) (to_string (of_int 5))); UShort.(assert_equal (string_of ushort _USHRT_MAX) (to_string _USHRT_MAX)); (* unsigned int *) let _UINT_MAX = retrieve_UINT_MAX () in UInt.(assert_equal (string_of uint (of_int 0)) (to_string (of_int 0))); UInt.(assert_equal (string_of uint (of_int 5)) (to_string (of_int 5))); UInt.(assert_equal (string_of uint _UINT_MAX) (to_string _UINT_MAX)); (* unsigned long *) let _ULONG_MAX = retrieve_ULONG_MAX () in ULong.(assert_equal (string_of ulong (of_int 0)) (to_string (of_int 0))); ULong.(assert_equal (string_of ulong (of_int 5)) (to_string (of_int 5))); ULong.(assert_equal (string_of ulong _ULONG_MAX) (to_string _ULONG_MAX)); (* unsigned long long *) let _ULLONG_MAX = retrieve_ULLONG_MAX () in ULLong.(assert_equal (string_of ullong (of_int 0)) (to_string (of_int 0))); ULLong.(assert_equal (string_of ullong (of_int 5)) (to_string (of_int 5))); ULLong.(assert_equal (string_of ullong _ULLONG_MAX) (to_string _ULLONG_MAX)); (* int8_t *) let _INT8_MIN = retrieve_INT8_MIN () in let _INT8_MAX = retrieve_INT8_MAX () in assert_equal (string_of int8_t _INT8_MIN) (string_of_int _INT8_MIN); assert_equal (string_of int8_t 0) (string_of_int 0); assert_equal (string_of int8_t (-5)) (string_of_int (-5)); assert_equal (string_of int8_t 14) (string_of_int 14); assert_equal (string_of int8_t _INT8_MAX) (string_of_int _INT8_MAX); (* int16_t *) let _INT16_MIN = retrieve_INT16_MIN () in let _INT16_MAX = retrieve_INT16_MAX () in assert_equal (string_of int16_t _INT16_MIN) (string_of_int _INT16_MIN); assert_equal (string_of int16_t 0) (string_of_int 0); assert_equal (string_of int16_t (-5)) (string_of_int (-5)); assert_equal (string_of int16_t 14) (string_of_int 14); assert_equal (string_of int16_t _INT16_MAX) (string_of_int _INT16_MAX); (* int32_t *) let _INT32_MIN = retrieve_INT32_MIN () in let _INT32_MAX = retrieve_INT32_MAX () in assert_equal (string_of int32_t _INT32_MIN) (Int32.to_string _INT32_MIN); assert_equal (string_of int32_t 0l) (Int32.to_string 0l); assert_equal (string_of int32_t (-5l)) (Int32.to_string (-5l)); assert_equal (string_of int32_t 14l) (Int32.to_string 14l); assert_equal (string_of int32_t _INT32_MAX) (Int32.to_string _INT32_MAX); (* int64_t *) let _INT64_MIN = retrieve_INT64_MIN () in let _INT64_MAX = retrieve_INT64_MAX () in assert_equal (string_of int64_t _INT64_MIN) (Int64.to_string _INT64_MIN); assert_equal (string_of int64_t 0L) (Int64.to_string 0L); assert_equal (string_of int64_t (-5L)) (Int64.to_string (-5L)); assert_equal (string_of int64_t 14L) (Int64.to_string 14L); assert_equal (string_of int64_t _INT64_MAX) (Int64.to_string _INT64_MAX); (* uint8_t *) let _UINT8_MAX = retrieve_UINT8_MAX () in UInt8.(assert_equal (string_of uint8_t (of_int 0)) (to_string (of_int 0))); UInt8.(assert_equal (string_of uint8_t (of_int 5)) (to_string (of_int 5))); UInt8.(assert_equal (string_of uint8_t _UINT8_MAX) (to_string _UINT8_MAX)); (* uint16_t *) let _UINT16_MAX = retrieve_UINT16_MAX () in UInt16.(assert_equal (string_of uint16_t (of_int 0)) (to_string (of_int 0))); UInt16.(assert_equal (string_of uint16_t (of_int 5)) (to_string (of_int 5))); UInt16.(assert_equal (string_of uint16_t _UINT16_MAX) (to_string _UINT16_MAX)); (* uint32_t *) let _UINT32_MAX = retrieve_UINT32_MAX () in UInt32.(assert_equal (string_of uint32_t (of_int 0)) (to_string (of_int 0))); UInt32.(assert_equal (string_of uint32_t (of_int 5)) (to_string (of_int 5))); UInt32.(assert_equal (string_of uint32_t _UINT32_MAX) (to_string _UINT32_MAX)); (* uint64_t *) let _UINT64_MAX = retrieve_UINT64_MAX () in UInt64.(assert_equal (string_of uint64_t (of_int 0)) (to_string (of_int 0))); UInt64.(assert_equal (string_of uint64_t (of_int 5)) (to_string (of_int 5))); UInt64.(assert_equal (string_of uint64_t _UINT64_MAX) (to_string _UINT64_MAX)); (* size_t *) let _SIZE_MAX = retrieve_SIZE_MAX () in Size_t.(assert_equal (string_of size_t (of_int 0)) (to_string (of_int 0))); Size_t.(assert_equal (string_of size_t (of_int 5)) (to_string (of_int 5))); Size_t.(assert_equal (string_of size_t _SIZE_MAX) (to_string _SIZE_MAX)); (* float *) let _FLT_MIN = retrieve_FLT_MIN () in let _FLT_MAX = retrieve_FLT_MAX () in 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 _DBL_MIN = retrieve_DBL_MIN () in let _DBL_MAX = retrieve_DBL_MAX () in assert_equal (string_of double _DBL_MIN) (string_of_float _DBL_MIN); assert_equal (valid_float_lexem (string_of double 0.0)) (string_of_float 0.0); assert_equal (string_of double (-1.03)) (string_of_float (-1.03)); assert_equal (string_of double (34.22)) (string_of_float (34.22)); 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); () end (* Test the printing of pointers. *) let test_pointer_printing _ = (* There's not much we can test here, since pointer formatting is implementation-dependent. We can at least run the pointer-formatting code, and test that pointers of different types are printed equivalently. *) let arr = CArray.make int 10 in let p = CArray.start arr in assert_equal (string_of (ptr (reference_type p)) p) (string_of (ptr void) (to_voidp p)) (* Test the printing of structs. *) let test_struct_printing _ = let s = structure "s" in let (-:) ty label = field s label ty in let a = array 3 int -: "arr" in let d = double -: "dbl" in let c = char -: "chr" in let () = seal s in let t = structure "t" in let (-:) ty label = field t label ty in let ts = s -: "ts" in let ti = int -: "ti" in let () = seal t in let vt = make t in let vs = make s in begin setf vs a (CArray.of_list int [4; 5; 6]); setf vs d nan; setf vs c 'a'; setf vt ts vs; setf vt ti 14; assert_bool "struct printing" (equal_ignoring_whitespace "{ts = { arr = {4, 5, 6}, dbl = nan, chr = 'a' }, ti = 14}" (string_of t vt)) end (* Test the printing of unions. *) let test_union_printing _ = let s = structure "s" in let (-:) ty label = field s label ty in let i = uint16_t -: "i" in let j = uint16_t -: "j" in let () = seal s in let u = union "u" in let (-:) ty label = field u label ty in let us = s -: "us" in let ua = array 4 uint8_t -: "ua" in let () = seal u in let v = make u in ignore (i, j, us); setf v ua (CArray.make ~initial:(Unsigned.UInt8.of_int 0) uint8_t 4); assert_bool "union printing" (equal_ignoring_whitespace "{ us = {i = 0, j = 0} | ua = {0, 0, 0, 0}}" (string_of u v)) (* Test the printing of array types. *) let test_array_printing _ = let arr = CArray.of_list int [-1; 0; 1] in let arrarr = CArray.of_list (array 3 int) [arr; arr] in assert_bool "array printing" (equal_ignoring_whitespace "{{-1, 0, 1}, {-1, 0, 1}}" (string_of (array 2 (array 3 int)) arrarr)) (* Test the printing of ocaml_string values. *) let test_ocaml_string_printing _ = let s = "abc@%^&*[\"" in begin assert_equal (string_of ocaml_string (ocaml_string_start s)) (Printf.sprintf "%S" s); assert_bool "ocaml_string printing with offsets" (equal_ignoring_whitespace (string_of ocaml_string ((ocaml_string_start s) +@ 3)) (Printf.sprintf "%S [offset:3]" s)); end module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "Value printing tests" >::: ["printing atomic values (foreign)" >:: Foreign_tests.test_atomic_printing; "printing atomic values (stubs)" >:: Stub_tests.test_atomic_printing; "printing pointers" >:: test_pointer_printing; "printing structs" >:: test_struct_printing; "printing unions" >:: test_union_printing; "printing arrays" >:: test_array_printing; "printing ocaml strings" >:: test_ocaml_string_printing; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-variadic/000077500000000000000000000000001274143137600200275ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-variadic/stub-generator/000077500000000000000000000000001274143137600227705ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-variadic/stub-generator/driver.ml000066400000000000000000000004771274143137600246250ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the variadic function tests. *) let cheader = " #include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-variadic/stubs/000077500000000000000000000000001274143137600211675ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-variadic/stubs/functions.ml000066400000000000000000000014561274143137600235370ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the variadic function tests. *) open Ctypes module Stubs (F: Cstubs.FOREIGN) = struct open F let size_t_as_int : int typ = view size_t ~read:Unsigned.Size_t.to_int ~write:Unsigned.Size_t.of_int let bind_snprintf tail = foreign "snprintf" (ptr char @-> size_t_as_int @-> string @-> tail) let snprintf_int = bind_snprintf (int @-> returning int) let snprintf_char_unsigned = bind_snprintf (char @-> uint @-> returning int) let snprintf_longlong_int = bind_snprintf (llong @-> int @-> returning int) let snprintf_string_ushort = bind_snprintf (string @-> ushort @-> returning int) end ocaml-ctypes-0.7.0/tests/test-variadic/test_variadic.ml000066400000000000000000000036541274143137600232120ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Tests for binding variadic functions. *) open OUnit2 open Ctypes module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open Signed open Unsigned open M (* Test calling snprintf. *) let test_snprintf _ = let bufsz = 128 in let write snprintf apply = let buf = allocate_n char bufsz in apply (snprintf buf bufsz); coerce (ptr char) string buf in begin assert_equal "an int: 100." (write snprintf_int (fun k -> k "an int: %d." 100)); assert_equal "a char A and a uint 33." (write snprintf_char_unsigned (fun k -> k "a char %c and a uint %u." 'A' (UInt.of_int 33))); let ref_string = match Sys.word_size with | 32 -> "a long long 2147483647 and an int -4." | 64 -> "a long long 9223372036854775807 and an int -4." | n -> failwith (Printf.sprintf "This test doesn't yet support word size %d" n) in let format_string = match Sys.os_type with | "Win32" -> "a long long %I64d and an int %d." | _ -> "a long long %lld and an int %d." in assert_equal ref_string (write snprintf_longlong_int (fun k -> k format_string (LLong.of_nativeint Nativeint.max_int) (-4))); assert_equal "a string abcde and an unsigned short ffd." (write snprintf_string_ushort (fun k -> k "a string %s and an unsigned short %hx." "abcde" (UShort.of_int 0xffd))); end end module Stub_tests = Common_tests(Generated_bindings) let suite = "Variadic tests" >::: ["snprintf" >:: Stub_tests.test_snprintf; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/test-views/000077500000000000000000000000001274143137600174025ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-views/stub-generator/000077500000000000000000000000001274143137600223435ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-views/stub-generator/driver.ml000066400000000000000000000004631274143137600241730ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Stub generation driver for the views tests. *) let cheader = " #include " let () = Tests_common.run ~cheader Sys.argv (module Functions.Stubs) ocaml-ctypes-0.7.0/tests/test-views/stubs/000077500000000000000000000000001274143137600205425ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/test-views/stubs/functions.ml000066400000000000000000000015451274143137600231110ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Foreign function bindings for the views tests. *) open Ctypes module Stubs (F: Cstubs.FOREIGN) = struct open F let charish = view ~read:Char.chr ~write:Char.code int let nullable_intptr = Foreign.funptr_opt Ctypes.(int @-> int @-> returning int) let concat_strings = foreign "concat_strings" (ptr string @-> int @-> ptr char @-> returning void) let toupper = foreign "toupper" (charish @-> returning charish) let returning_funptr = foreign "returning_funptr" (int @-> returning nullable_intptr) let accepting_possibly_null_funptr = foreign "accepting_possibly_null_funptr" (nullable_intptr @-> int @-> int @-> returning int) end ocaml-ctypes-0.7.0/tests/test-views/test_views.ml000066400000000000000000000117731274143137600221410ustar00rootroot00000000000000(* * Copyright (c) 2013 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) open OUnit2 open Ctypes module Common_tests(S : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a) = struct module M = Functions.Stubs(S) open M (* Call a function of type void (char **sv, int sc, char *buffer) using strings for input parameters and a char array for an output parameter. Examine the output buffer using a cast to a string view. *) let test_passing_string_array _ = let l = ["the "; "quick "; "brown "; "fox "; "etc. "; "etc. "; ] in let arr = CArray.of_list string l in let outlen = List.fold_left (fun a s -> String.length s + a) 1 l in let buf = CArray.make char outlen in let () = CArray.(concat_strings (start arr) (length arr) (start buf)) in let buf_addr = allocate (ptr char) (CArray.start buf) in let s = from_voidp string (to_voidp buf_addr) in assert_equal ~msg:"Check output" "the quick brown fox etc. etc. " !@s (* Call a function of type int (int) using a custom view that treats chars as ints. *) let test_passing_chars_as_ints _ = assert_equal ~msg:"toupper('x') = 'X'" 'X' (toupper 'x'); assert_equal ~msg:"toupper('3') = '3'" '3' (toupper '3'); assert_equal ~msg:"toupper('X') = 'X'" 'X' (toupper 'X') (* Use views to create a nullable function pointer. *) let test_nullable_function_pointer_view _ = begin let fromSome = function None -> assert false | Some x -> x in let add = fromSome (returning_funptr 0) and times = fromSome (returning_funptr 1) in assert_equal ~msg:"reading non-null function pointer return value" 9 (add 5 4); assert_equal ~msg:"reading non-null function pointer return value" 20 (times 5 4); assert_equal ~msg:"reading null function pointer return value" None (returning_funptr 2); assert_equal ~msg:"passing null function pointer" (-1) (accepting_possibly_null_funptr None 2 3); assert_equal ~msg:"passing non-null function pointer" 5 (accepting_possibly_null_funptr (Some 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 end (* Use the nullable pointer view to view nulls as Nones. *) let test_nullable_pointer_view _ = let p = allocate int 10 in let pp = allocate (ptr int) p in let npp = from_voidp (ptr_opt int) (to_voidp pp) in begin assert_equal 10 !@ !@pp; begin match !@npp with | Some x -> assert_equal 10 !@x | None -> assert false end; pp <-@ from_voidp int null; assert_equal null (to_voidp !@pp); assert_equal None !@npp; end (* Use a polar form view of complex numbers. *) let test_polar_form_view _ = let module M = struct open Complex type polar = {norm: float; arg: float} let pi = 4.0 *. atan 1.0 let polar_of_cartesian c = { norm = norm c; arg = arg c} let cartesian_of_polar { norm; arg } = polar norm arg let polar64 = view complex64 ~read:polar_of_cartesian ~write:cartesian_of_polar let eps = 1e-9 let complex64_eq { re = lre; im = lim } { re = rre; im = rim } = abs_float (lre -. rre) < eps && abs_float (lim -. rim) < eps let polar64_eq { norm = lnorm; arg = larg } { norm = rnorm; arg = rarg } = abs_float (lnorm -. rnorm) < eps && abs_float (larg -. rarg) < eps let polp = allocate polar64 { norm = 0.0; arg = 0.0 } let carp = from_voidp complex64 (to_voidp polp) let () = begin assert_equal !@polp { norm = 0.0; arg = 0.0 } ~cmp:polar64_eq; assert_equal !@carp { re = 0.0; im = 0.0 } ~cmp:complex64_eq; carp <-@ { re = 1.0; im = 0.0 }; assert_equal !@polp { norm = 1.0; arg = 0.0 } ~cmp:polar64_eq; carp <-@ { re = 0.0; im = 2.5 }; assert_equal !@polp { norm = 2.5; arg = pi /. 2. } ~cmp:polar64_eq; polp <-@ { norm = 4.1e5; arg = pi *. 1.5 }; assert_equal !@carp { re = 0.0; im = -4.1e5 } ~cmp:complex64_eq; end end in () module Foreign_tests = Common_tests(Tests_common.Foreign_binder) module Stub_tests = Common_tests(Generated_bindings) let suite = "View tests" >::: ["passing array of strings (foreign)" >:: Foreign_tests.test_passing_string_array; "passing array of strings (stubs)" >:: Stub_tests.test_passing_string_array; "custom views (foreign)" >:: Foreign_tests.test_passing_chars_as_ints; "custom views (stubs)" >:: Stub_tests.test_passing_chars_as_ints; "nullable function pointers (foreign)" >:: Foreign_tests.test_nullable_function_pointer_view; "nullable function pointers (stubs)" >:: Stub_tests.test_nullable_function_pointer_view; "nullable pointers" >:: test_nullable_pointer_view; "polar form view" >:: test_polar_form_view; ] let _ = run_test_tt_main suite ocaml-ctypes-0.7.0/tests/tests-common/000077500000000000000000000000001274143137600177205ustar00rootroot00000000000000ocaml-ctypes-0.7.0/tests/tests-common/tests_common.ml000066400000000000000000000045451274143137600227740ustar00rootroot00000000000000(* * Copyright (c) 2014 Jeremy Yallop. * * This file is distributed under the terms of the MIT License. * See the file LICENSE for details. *) (* Functions for test stub generation. *) open Ctypes let filenames argv = let usage = "arguments: [--ml-file $filename] [--c-file $filename]" in let ml_filename = ref "" and c_filename = ref "" and c_struct_filename = ref "" in let spec = Arg.([("--ml-file", Set_string ml_filename, "ML filename"); ("--c-file", Set_string c_filename, "C filename"); ("--c-struct-file", Set_string c_struct_filename, "C struct filename");]) in let no_positional_args _ = prerr_endline "No positional arguments" in begin Arg.parse spec no_positional_args usage; (!ml_filename, !c_filename, !c_struct_filename) end module Foreign_binder : Cstubs.FOREIGN with type 'a result = 'a and type 'a return = 'a = struct type 'a fn = 'a Ctypes.fn type 'a return = 'a let (@->) = Ctypes.(@->) let returning = Ctypes.returning type 'a result = 'a let foreign name fn = Foreign.foreign name fn let foreign_value name fn = Foreign.foreign_value name fn end module type STUBS = functor (F : Cstubs.FOREIGN) -> sig end let with_open_formatter filename f = let out = open_out filename in let fmt = Format.formatter_of_out_channel out in let close_channel () = close_out out in try let rv = f fmt in close_channel (); rv with e -> close_channel (); raise e let header = "#include \"clib/test_functions.h\"" let run ?concurrency ?errno ?(cheader="") argv ?structs specs = let ml_filename, c_filename, c_struct_filename = filenames argv in if ml_filename <> "" then with_open_formatter ml_filename (fun fmt -> Cstubs.write_ml ?concurrency ?errno fmt ~prefix:"cstubs_tests" specs); if c_filename <> "" then with_open_formatter c_filename (fun fmt -> Format.fprintf fmt "%s@\n%s@\n" header cheader; Cstubs.write_c ?concurrency ?errno fmt ~prefix:"cstubs_tests" specs); begin match structs, c_struct_filename with | None, _ -> () | Some _, "" -> () | Some specs, c_filename -> with_open_formatter c_filename (fun fmt -> Format.fprintf fmt "%s@\n%s@\n" header cheader; Cstubs_structs.write_c fmt specs) end