From ce1be8f82442c0a1ca96a626102c3a71e31862c0 Mon Sep 17 00:00:00 2001 From: Jeremy Yallop Date: Fri, 10 Jul 2020 19:53:54 +0100 Subject: [PATCH] Add support for unknown integer types. --- Makefile.tests | 1 + src/cstubs/cstubs_structs.ml | 60 +++++++++++++++++++++++++++++++-- src/cstubs/cstubs_structs.mli | 6 ++++ src/ctypes/cstubs_internals.ml | 31 +++++++++++++++++ src/ctypes/cstubs_internals.mli | 8 +++++ src/ctypes/ctypes.ml | 8 +++++ src/ctypes/ctypes.mli | 6 ++++ 7 files changed, 117 insertions(+), 3 deletions(-) diff --git a/Makefile.tests b/Makefile.tests index eb7e45a6..7102c6dd 100644 --- a/Makefile.tests +++ b/Makefile.tests @@ -246,6 +246,7 @@ 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.deps = integers test-enums-stubs.subproject_deps = ctypes \ test-enums-struct-stubs \ test-enums-struct-stubs-generator \ diff --git a/src/cstubs/cstubs_structs.ml b/src/cstubs/cstubs_structs.ml index 517a7138..46a3b4bf 100644 --- a/src/cstubs/cstubs_structs.ml +++ b/src/cstubs/cstubs_structs.ml @@ -14,6 +14,12 @@ sig type 'a const val constant : string -> 'a typ -> 'a const + module type signed = sig include Signed.S val t : t typ end + val signed : string -> (module signed) + + module type unsigned = sig include Unsigned.S val t : t typ end + val unsigned : string -> (module unsigned) + val enum : string -> ?typedef:bool -> ?unexpected:(int64 -> 'a) -> ('a * int64 const) list -> 'a typ end @@ -233,22 +239,59 @@ let write_enums fmt enums = [" | s ->"; " failwith (\"unmatched enum: \"^ s)"] +let write_signeds fmt signeds = + let case name = + printf1 fmt + (Format.sprintf + " | %S -> \n Cstubs_internals.build_signed_type %S Ctypes_static.%%s\n" name name) + (fun fmt -> + Format.fprintf fmt + "ctypes_arithmetic_type_name(CTYPES_CLASSIFY_ARITHMETIC_TYPE(%s))" name) + in + cases fmt signeds + [""; + "module type signed = sig include Signed.S val t : t typ end"; + "let signed (type a) name = match name with"] + ~case + [" | s -> failwith (\"unmatched signed type: \"^ s)"] + +let write_unsigneds fmt unsigneds = + let case name = + printf1 fmt + (Format.sprintf + " | %S -> \n Cstubs_internals.build_unsigned_type %S Ctypes_static.%%s\n" name name) + (fun fmt -> + Format.fprintf fmt + "ctypes_arithmetic_type_name(CTYPES_CLASSIFY_ARITHMETIC_TYPE(%s))" name) + in + cases fmt unsigneds + [""; + "module type unsigned = sig include Unsigned.S val t : t typ end"; + "let unsigned (type a) name = match name with"] + ~case + [" | s -> failwith (\"unmatched unsigned type: \"^ s)"] + -let write_ml fmt fields structures consts enums = +let write_ml fmt fields structures consts enums signeds unsigneds = List.iter (puts fmt) mlprologue; write_field fmt fields; write_seal fmt structures; write_consts fmt consts; - write_enums fmt enums + write_enums fmt enums; + write_signeds fmt signeds; + write_unsigneds fmt unsigneds + let gen_c () = let fields = ref [] and structures = ref [] and consts = ref [] and enums = ref [] + and signeds = ref [] + and unsigneds = ref [] in let finally fmt = write_c fmt (fun fmt -> - write_ml fmt !fields !structures !consts !enums) in + write_ml fmt !fields !structures !consts !enums !signeds !unsigneds) in let m = (module struct include Ctypes @@ -281,6 +324,17 @@ let gen_c () = type _ const = unit let constant name ty = consts := (name, Ctypes_static.BoxedType ty) :: !consts + + module type signed = sig include Signed.S val t : t typ end + let signed name : (module signed) = + let () = signeds := name :: !signeds in + (module struct include Signed.Int32 let t = int32_t end) (* arbitrary *) + + module type unsigned = sig include Unsigned.S val t : t typ end + let unsigned name : (module unsigned) = + let () = unsigneds := name :: !unsigneds in + (module struct include Unsigned.UInt32 let t = uint32_t end) (* arbitrary *) + let enum name ?(typedef=false) ?unexpected alist = let () = enums := (name, typedef) :: !enums in let format_typ k fmt = Format.fprintf fmt "%s%s%t" diff --git a/src/cstubs/cstubs_structs.mli b/src/cstubs/cstubs_structs.mli index adf5e6dd..0d27e55c 100644 --- a/src/cstubs/cstubs_structs.mli +++ b/src/cstubs/cstubs_structs.mli @@ -12,6 +12,12 @@ sig type 'a const val constant : string -> 'a typ -> 'a const + module type signed = sig include Signed.S val t : t typ end + val signed : string -> (module signed) + + module type unsigned = sig include Unsigned.S val t : t typ end + val unsigned : string -> (module unsigned) + val enum : string -> ?typedef:bool -> ?unexpected:(int64 -> 'a) -> ('a * int64 const) list -> 'a typ end diff --git a/src/ctypes/cstubs_internals.ml b/src/ctypes/cstubs_internals.ml index 12749183..4085b169 100644 --- a/src/ctypes/cstubs_internals.ml +++ b/src/ctypes/cstubs_internals.ml @@ -63,6 +63,37 @@ 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 +module type signed = sig include Signed.S val t : t typ end +let build_signed_type name underlying : (module signed) = + let wrong kind = + Printf.ksprintf failwith "Signed type detected as %s type: %s" kind name + in + match underlying with + Ctypes_static.Uint8 -> wrong "unsigned" + | Ctypes_static.Uint16 -> wrong "unsigned" + | Ctypes_static.Uint32 -> wrong "unsigned" + | Ctypes_static.Uint64 -> wrong "unsigned" + | Ctypes_static.Int8 -> (module struct include Signed.Int let t = Ctypes.int8_t end) + | Ctypes_static.Int16 -> (module struct include Signed.Int let t = Ctypes.int16_t end) + | Ctypes_static.Int32 -> (module struct include Signed.Int32 let t = Ctypes.int32_t end) + | Ctypes_static.Int64 -> (module struct include Signed.Int64 let t = Ctypes.int64_t end) + | Ctypes_static.Float | Ctypes_static.Double -> wrong "floating" + + +module type unsigned = sig include Unsigned.S val t : t typ end +let build_unsigned_type name underlying : (module unsigned) = + match underlying with + Ctypes_static.Int8 -> (module struct include Signed.Int let t = Ctypes.int8_t end) + | Ctypes_static.Int16 -> (module struct include Signed.Int let t = Ctypes.int16_t end) + | Ctypes_static.Int32 -> (module struct include Signed.Int32 let t = Ctypes.int32_t end) + | Ctypes_static.Int64 -> (module struct include Signed.Int64 let t = Ctypes.int64_t end) + | Ctypes_static.Uint8 -> (module struct include Unsigned.UInt8 let t = Ctypes.uint8_t end) + | Ctypes_static.Uint16 -> (module struct include Unsigned.UInt16 let t = Ctypes.uint16_t end) + | Ctypes_static.Uint32 -> (module struct include Unsigned.UInt32 let t = Ctypes.uint32_t end) + | Ctypes_static.Uint64 -> (module struct include Unsigned.UInt64 let t = Ctypes.uint64_t end) + | Ctypes_static.Float | Ctypes_static.Double -> + Printf.ksprintf failwith "Unsigned type detected as floating type: %s" name + let build_enum_type name underlying ?(typedef=false) ?unexpected alist = let build_view t coerce uncoerce = let unexpected = match unexpected with diff --git a/src/ctypes/cstubs_internals.mli b/src/ctypes/cstubs_internals.mli index cddf688b..2b7d0c9f 100644 --- a/src/ctypes/cstubs_internals.mli +++ b/src/ctypes/cstubs_internals.mli @@ -91,6 +91,14 @@ type 'a prim = 'a Ctypes_primitive_types.prim = | Complex64 : Complex.t prim | Complexld : ComplexL.t prim +module type signed = sig include Signed.S val t : t typ end +val build_signed_type : + string -> Ctypes_static.arithmetic -> (module signed) + +module type unsigned = sig include Unsigned.S val t : t typ end +val build_unsigned_type : + string -> Ctypes_static.arithmetic -> (module unsigned) + val build_enum_type : string -> Ctypes_static.arithmetic -> ?typedef:bool -> ?unexpected:(int64 -> 'a) -> ('a * int64) list -> 'a typ diff --git a/src/ctypes/ctypes.ml b/src/ctypes/ctypes.ml index 72e48a91..a6ff5cb5 100644 --- a/src/ctypes/ctypes.ml +++ b/src/ctypes/ctypes.ml @@ -39,6 +39,14 @@ sig type 'a const val constant : string -> 'a typ -> 'a const + + module type signed = sig include Signed.S val t : t typ end + val signed : string -> (module signed) + + module type unsigned = sig include Unsigned.S val t : t typ end + val unsigned : string -> (module unsigned) + val enum : string -> ?typedef:bool -> ?unexpected:(int64 -> 'a) -> ('a * int64 const) list -> 'a typ end + diff --git a/src/ctypes/ctypes.mli b/src/ctypes/ctypes.mli index 94a8a15f..3b1932e1 100644 --- a/src/ctypes/ctypes.mli +++ b/src/ctypes/ctypes.mli @@ -517,6 +517,12 @@ sig warning: overflow in implicit constant conversion *) + module type signed = sig include Signed.S val t : t typ end + val signed : string -> (module signed) + + module type unsigned = sig include Unsigned.S val t : t typ end + val unsigned : string -> (module unsigned) + val enum : string -> ?typedef:bool -> ?unexpected:(int64 -> 'a) -> ('a * int64 const) list -> 'a typ (** [enum name ?unexpected alist] builds a type representation for the