From 40c4984e9020a6b5ee837b16e85ceb4df2a96f3c Mon Sep 17 00:00:00 2001 From: Pierre Boutillier Date: Thu, 10 Oct 2024 10:19:30 +0200 Subject: [PATCH 1/8] Separate error gathering from pure bindings --- src/tsdl.ml | 710 +++++++++++++++++++++++++++++----------------------- 1 file changed, 400 insertions(+), 310 deletions(-) diff --git a/src/tsdl.ml b/src/tsdl.ml index 1e28541..a93d835 100644 --- a/src/tsdl.ml +++ b/src/tsdl.ml @@ -38,8 +38,6 @@ let err_array_to_short ~exp ~fnd = (* ctypes views *) -let write_never _ = assert false - let bool = view ~read:((<>)0) ~write:(fun b -> compare b false) int;; @@ -88,25 +86,15 @@ type nonrec 'a result = ( 'a, [ `Msg of string ] ) result let error () = Error (`Msg (get_error ())) -let zero_to_ok = - let read = function 0 -> Ok () | err -> error () in - view ~read ~write:write_never int +let zero_to_ok = function 0 -> Ok () | _ -> error () -let one_to_ok = - let read = function 1 -> Ok () | err -> error () in - view ~read ~write:write_never int +let one_to_ok = function 1 -> Ok () | _ -> error () -let bool_to_ok = - let read = function 0 -> Ok false | 1 -> Ok true | _ -> error () in - view ~read ~write:write_never int +let bool_to_ok = function 0 -> Ok false | 1 -> Ok true | _ -> error () -let nat_to_ok = - let read = function n when n < 0 -> error () | n -> Ok n in - view ~read ~write:write_never int +let nat_to_ok = function n when n < 0 -> error () | n -> Ok n -let some_to_ok t = - let read = function Some v -> Ok v | None -> error () in - view ~read ~write:write_never t +let some_to_ok = function Some v -> Ok v | None -> error () let sdl_free = foreign "SDL_free" (ptr void @-> returning void) @@ -191,10 +179,12 @@ module Init = struct end let init = - foreign "SDL_Init" (uint32_t @-> returning zero_to_ok) + foreign "SDL_Init" (uint32_t @-> returning int) +let init n = init n |> zero_to_ok let init_sub_system = - foreign "SDL_InitSubSystem" (uint32_t @-> returning zero_to_ok) + foreign "SDL_InitSubSystem" (uint32_t @-> returning int) +let init_sub_system n = init_sub_system n |> zero_to_ok let quit = foreign "SDL_Quit" (void @-> returning void) @@ -359,27 +349,29 @@ type rw_ops = _rw_ops structure ptr let load_file_rw = foreign "SDL_LoadFile_RW" - (rw_ops @-> ptr int @-> bool @-> returning (some_to_ok string_opt)) + (rw_ops @-> ptr int @-> bool @-> returning string_opt) let load_file_rw rw_ops close = - load_file_rw rw_ops (coerce (ptr void) (ptr int) null) close + load_file_rw rw_ops (coerce (ptr void) (ptr int) null) close |> some_to_ok let rw_from_file = foreign "SDL_RWFromFile" - (string @-> string @-> returning (some_to_ok rw_ops_opt)) + (string @-> string @-> returning rw_ops_opt) + let rw_from_file x y = rw_from_file x y |> some_to_ok let rw_from_const_mem = foreign "SDL_RWFromConstMem" - (ocaml_string @-> int @-> returning (some_to_ok rw_ops_opt)) + (ocaml_string @-> int @-> returning rw_ops_opt) let rw_from_const_mem str = rw_from_const_mem - (ocaml_string_start str) (String.length str) + (ocaml_string_start str) (String.length str) |> some_to_ok let rw_from_mem = foreign "SDL_RWFromMem" - (ocaml_bytes @-> int @-> returning (some_to_ok rw_ops_opt)) + (ocaml_bytes @-> int @-> returning rw_ops_opt) -let rw_from_mem b = rw_from_mem (ocaml_bytes_start b) (Bytes.length b) +let rw_from_mem b = + rw_from_mem (ocaml_bytes_start b) (Bytes.length b) |> some_to_ok let load_file filename = (* defined as a macro in SDL_rwops.h *) match rw_from_file filename "rb" with @@ -404,18 +396,18 @@ let get_base_path = let get_base_path () = let p = get_base_path () in - let path = coerce (ptr char) (some_to_ok string_opt) p in + let path = coerce (ptr char) string_opt p in sdl_free (coerce (ptr char) (ptr void) p); - path + path |> some_to_ok let get_pref_path = foreign "SDL_GetPrefPath" (string @-> string @-> returning (ptr char)) let get_pref_path ~org ~app = let p = get_pref_path org app in - let path = coerce (ptr char) (some_to_ok string_opt) p in + let path = coerce (ptr char) string_opt p in sdl_free (coerce (ptr char) (ptr void) p); - path + path |> some_to_ok (* Video *) @@ -534,10 +526,6 @@ module Vertex = struct let set_position v position = setf v vertex_position position let set_color v color = setf v vertex_color color let set_tex_coord v tex_coord = setf v vertex_tex_coord tex_coord - - let opt_addr = function - | None -> coerce (ptr void) (ptr vertex) null - | Some v -> addr v end (* Rectangle *) @@ -706,7 +694,8 @@ let unsafe_ptr_of_palette palette = let alloc_palette = foreign "SDL_AllocPalette" - (int @-> returning (some_to_ok palette_opt)) + (int @-> returning palette_opt) +let alloc_palette x = alloc_palette x |> some_to_ok let free_palette = foreign "SDL_FreePalette" (palette @-> returning void) @@ -733,7 +722,8 @@ let get_palette_colors_ba p = let set_palette_colors = foreign "SDL_SetPaletteColors" - (palette @-> ptr void @-> int @-> int @-> returning zero_to_ok) + (palette @-> ptr void @-> int @-> int @-> returning int) + let set_palette_colors x y z t = set_palette_colors x y z t |> zero_to_ok let set_palette_colors_ba p cs ~fst = let len = Bigarray.Array1.dim cs in @@ -873,7 +863,8 @@ let unsafe_ptr_of_pixel_format pixel_format = let alloc_format = foreign "SDL_AllocFormat" - (uint32_t @-> returning (some_to_ok pixel_format_opt)) + (uint32_t @-> returning pixel_format_opt) + let alloc_format x = alloc_format x |> some_to_ok let free_format = foreign "SDL_FreeFormat" (pixel_format @-> returning void) @@ -945,7 +936,8 @@ let pixel_format_enum_to_masks pf = let set_pixel_format_palette = foreign "SDL_SetPixelFormatPalette" - (pixel_format @-> palette @-> returning zero_to_ok) + (pixel_format @-> palette @-> returning int) +let set_pixel_format_palette x y = set_pixel_format_palette x y |> zero_to_ok (* Surface *) @@ -978,23 +970,23 @@ let unsafe_ptr_of_surface surface = let blit_scaled = (* SDL_BlitScaled is #ifdef'd to SDL_UpperBlitScaled *) foreign "SDL_UpperBlitScaled" - (surface @-> ptr rect @-> surface @-> ptr rect @-> returning zero_to_ok) + (surface @-> ptr rect @-> surface @-> ptr rect @-> returning int) let blit_scaled ~src sr ~dst dr = - blit_scaled src (Rect.opt_addr sr) dst (Rect.opt_addr dr) + blit_scaled src (Rect.opt_addr sr) dst (Rect.opt_addr dr) |> zero_to_ok let blit_surface = (* SDL_BlitSurface is #ifdef'd to SDL_UpperBlit *) foreign "SDL_UpperBlit" - (surface @-> ptr rect @-> surface @-> ptr rect @-> returning zero_to_ok) + (surface @-> ptr rect @-> surface @-> ptr rect @-> returning int) let blit_surface ~src sr ~dst dr = - blit_surface src (Rect.opt_addr sr) dst (Rect.opt_addr dr) + blit_surface src (Rect.opt_addr sr) dst (Rect.opt_addr dr) |> zero_to_ok let convert_pixels = foreign "SDL_ConvertPixels" (int @-> int @-> uint32_t @-> ptr void @-> int @-> uint32_t @-> - ptr void @-> int @-> returning zero_to_ok) + ptr void @-> int @-> returning int) let convert_pixels ~w ~h ~src sp spitch ~dst dp dpitch = (* FIXME: we could try check bounds. *) @@ -1002,88 +994,88 @@ let convert_pixels ~w ~h ~src sp spitch ~dst dp dpitch = let dpitch = ba_kind_byte_size (Bigarray.Array1.kind dp) * dpitch in let sp = to_voidp (bigarray_start array1 sp) in let dp = to_voidp (bigarray_start array1 dp) in - convert_pixels w h src sp spitch dst dp dpitch + convert_pixels w h src sp spitch dst dp dpitch |> zero_to_ok let convert_surface = foreign "SDL_ConvertSurface" (surface @-> pixel_format @-> uint32_t @-> - returning (some_to_ok surface_opt)) + returning surface_opt) let convert_surface s pf = - convert_surface s pf Unsigned.UInt32.zero + convert_surface s pf Unsigned.UInt32.zero |> some_to_ok let convert_surface_format = foreign "SDL_ConvertSurfaceFormat" - (surface @-> uint32_t @-> uint32_t @-> returning (some_to_ok surface_opt)) + (surface @-> uint32_t @-> uint32_t @-> returning surface_opt) let convert_surface_format s pf = - convert_surface_format s pf Unsigned.UInt32.zero + convert_surface_format s pf Unsigned.UInt32.zero |> some_to_ok let create_rgb_surface = foreign "SDL_CreateRGBSurface" (uint32_t @-> int @-> int @-> int @-> int32_as_uint32_t @-> int32_as_uint32_t @-> int32_as_uint32_t @-> int32_as_uint32_t @-> - returning (some_to_ok surface_opt)) + returning surface_opt) let create_rgb_surface ~w ~h ~depth rmask gmask bmask amask = - create_rgb_surface Unsigned.UInt32.zero w h depth rmask gmask bmask amask + create_rgb_surface Unsigned.UInt32.zero w h depth rmask gmask bmask amask |> some_to_ok let create_rgb_surface_from = foreign "SDL_CreateRGBSurfaceFrom" (ptr void @-> int @-> int @-> int @-> int @-> int32_as_uint32_t @-> int32_as_uint32_t @-> int32_as_uint32_t @-> int32_as_uint32_t @-> - returning (some_to_ok surface_opt)) + returning surface_opt) let create_rgb_surface_from p ~w ~h ~depth ~pitch rmask gmask bmask amask = (* FIXME: we could try check bounds. *) let pitch = ba_kind_byte_size (Bigarray.Array1.kind p) * pitch in let p = to_voidp (bigarray_start array1 p) in - create_rgb_surface_from p w h depth pitch rmask gmask bmask amask + create_rgb_surface_from p w h depth pitch rmask gmask bmask amask |> some_to_ok let create_rgb_surface_with_format = foreign "SDL_CreateRGBSurfaceWithFormat" (uint32_t @-> int @-> int @-> int @-> uint32_t @-> - returning (some_to_ok surface_opt)) + returning surface_opt) let create_rgb_surface_with_format ~w ~h ~depth format = - create_rgb_surface_with_format Unsigned.UInt32.zero w h depth format + create_rgb_surface_with_format Unsigned.UInt32.zero w h depth format |> some_to_ok let create_rgb_surface_with_format_from = foreign "SDL_CreateRGBSurfaceWithFormatFrom" (ptr void @-> int @-> int @-> int @-> int @-> uint32_t @-> - returning (some_to_ok surface_opt)) + returning surface_opt) let create_rgb_surface_with_format_from p ~w ~h ~depth ~pitch format = (* FIXME: check bounds? *) let pitch = ba_kind_byte_size (Bigarray.Array1.kind p) * pitch in let p = to_voidp (bigarray_start array1 p) in - create_rgb_surface_with_format_from p w h depth pitch format + create_rgb_surface_with_format_from p w h depth pitch format |> some_to_ok let duplicate_surface = foreign "SDL_DuplicateSurface" (surface @-> returning surface) let fill_rect = foreign "SDL_FillRect" - (surface @-> ptr rect @-> int32_as_uint32_t @-> returning zero_to_ok) + (surface @-> ptr rect @-> int32_as_uint32_t @-> returning int) let fill_rect s r c = - fill_rect s (Rect.opt_addr r) c + fill_rect s (Rect.opt_addr r) c |> zero_to_ok let fill_rects = foreign "SDL_FillRects" (surface @-> ptr void @-> int @-> int32_as_uint32_t @-> - returning zero_to_ok) + returning int) let fill_rects_ba s rs col = let len = Bigarray.Array1.dim rs in if len mod 4 <> 0 then invalid_arg (err_length_mul len 4) else let count = len / 4 in let rs = to_voidp (bigarray_start array1 rs) in - fill_rects s rs count col + fill_rects s rs count col |> zero_to_ok let fill_rects s rs col = let a = CArray.of_list rect rs in - fill_rects s (to_voidp (CArray.start a)) (CArray.length a) col + fill_rects s (to_voidp (CArray.start a)) (CArray.length a) col |> zero_to_ok let free_surface = foreign "SDL_FreeSurface" (surface @-> returning void) @@ -1097,42 +1089,42 @@ let get_clip_rect s = let get_color_key = foreign "SDL_GetColorKey" - (surface @-> ptr uint32_t @-> returning zero_to_ok) + (surface @-> ptr uint32_t @-> returning int) let get_color_key s = let key = allocate uint32_t Unsigned.UInt32.zero in match get_color_key s key with - | Ok () -> Ok (Unsigned.UInt32.to_int32 (!@ key)) | Error _ as e -> e + | 0 -> Ok (Unsigned.UInt32.to_int32 (!@ key)) | _ -> error () let get_surface_alpha_mod = foreign "SDL_GetSurfaceAlphaMod" - (surface @-> ptr uint8_t @-> returning zero_to_ok) + (surface @-> ptr uint8_t @-> returning int) let get_surface_alpha_mod s = let alpha = allocate uint8_t Unsigned.UInt8.zero in match get_surface_alpha_mod s alpha with - | Ok () -> Ok (Unsigned.UInt8.to_int (!@ alpha)) | Error _ as e -> e + | 0 -> Ok (Unsigned.UInt8.to_int (!@ alpha)) | _ -> error () let get_surface_blend_mode = foreign "SDL_GetSurfaceBlendMode" - (surface @-> ptr uint @-> returning zero_to_ok) + (surface @-> ptr uint @-> returning int) let get_surface_blend_mode s = let mode = allocate uint Unsigned.UInt.zero in match get_surface_blend_mode s mode with - Ok () -> Ok (!@ mode) | Error _ as e -> e + 0 -> Ok (!@ mode) | _ -> error () let get_surface_color_mod = foreign "SDL_GetSurfaceColorMod" (surface @-> ptr uint8_t @-> ptr uint8_t @-> ptr uint8_t @-> - returning zero_to_ok) + returning int) let get_surface_color_mod s = let alloc () = allocate uint8_t Unsigned.UInt8.zero in let get v = Unsigned.UInt8.to_int (!@ v) in let r, g, b = alloc (), alloc (), alloc () in match get_surface_color_mod s r g b with - | Ok () -> Ok (get r, get g, get b) | Error _ as e -> e + | 0 -> Ok (get r, get g, get b) | _ -> error () let get_surface_format_enum s = (* We don't give direct access to the format field. This prevents @@ -1159,10 +1151,10 @@ let get_surface_size s = let load_bmp_rw = foreign "SDL_LoadBMP_RW" - (rw_ops @-> bool @-> returning (some_to_ok surface_opt)) + (rw_ops @-> bool @-> returning surface_opt) let load_bmp_rw rw ~close = - load_bmp_rw rw close + load_bmp_rw rw close |> some_to_ok let load_bmp file = (* SDL_LoadBMP is cpp based *) @@ -1171,28 +1163,29 @@ let load_bmp file = | Ok rw -> load_bmp_rw rw ~close:true let lock_surface = - foreign "SDL_LockSurface" (surface @-> returning zero_to_ok) + foreign "SDL_LockSurface" (surface @-> returning int) +let lock_surface x = lock_surface x |> zero_to_ok let lower_blit = foreign "SDL_LowerBlit" - (surface @-> ptr rect @-> surface @-> ptr rect @-> returning zero_to_ok) + (surface @-> ptr rect @-> surface @-> ptr rect @-> returning int) let lower_blit ~src sr ~dst dr = - lower_blit src (addr sr) dst (addr dr) + lower_blit src (addr sr) dst (addr dr) |> zero_to_ok let lower_blit_scaled = foreign "SDL_LowerBlitScaled" - (surface @-> ptr rect @-> surface @-> ptr rect @-> returning zero_to_ok) + (surface @-> ptr rect @-> surface @-> ptr rect @-> returning int) let lower_blit_scaled ~src sr ~dst dr = - lower_blit_scaled src (addr sr) dst (addr dr) + lower_blit_scaled src (addr sr) dst (addr dr) |> zero_to_ok let save_bmp_rw = foreign "SDL_SaveBMP_RW" - (surface @-> rw_ops @-> bool @-> returning zero_to_ok) + (surface @-> rw_ops @-> bool @-> returning int) let save_bmp_rw s rw ~close = - save_bmp_rw s rw close + save_bmp_rw s rw close |> zero_to_ok let save_bmp s file = (* SDL_SaveBMP is cpp based *) @@ -1208,27 +1201,33 @@ let set_clip_rect s r = let set_color_key = foreign "SDL_SetColorKey" - (surface @-> bool @-> int32_as_uint32_t @-> returning zero_to_ok) + (surface @-> bool @-> int32_as_uint32_t @-> returning int) +let set_color_key s b x = set_color_key s b x |> zero_to_ok let set_surface_alpha_mod = foreign "SDL_SetSurfaceAlphaMod" - (surface @-> int_as_uint8_t @-> returning zero_to_ok) + (surface @-> int_as_uint8_t @-> returning int) +let set_surface_alpha_mod s x = set_surface_alpha_mod s x |> zero_to_ok let set_surface_blend_mode = foreign "SDL_SetSurfaceBlendMode" - (surface @-> uint @-> returning zero_to_ok) + (surface @-> uint @-> returning int) +let set_surface_blend_mode s x = set_surface_blend_mode s x |> zero_to_ok let set_surface_color_mod = foreign "SDL_SetSurfaceColorMod" (surface @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> - returning zero_to_ok) + returning int) +let set_surface_color_mod s x y z = set_surface_color_mod s x y z |> zero_to_ok let set_surface_palette = foreign "SDL_SetSurfacePalette" - (surface @-> palette @-> returning zero_to_ok) + (surface @-> palette @-> returning int) +let set_surface_palette s p = set_surface_palette s p |> zero_to_ok let set_surface_rle = - foreign "SDL_SetSurfaceRLE" (surface @-> bool @-> returning zero_to_ok) + foreign "SDL_SetSurfaceRLE" (surface @-> bool @-> returning int) +let set_surface_rle s b = set_surface_rle s b |> zero_to_ok let unlock_surface = foreign "SDL_UnlockSurface" (surface @-> returning void) @@ -1307,206 +1306,214 @@ let renderer_info_of_c c = let create_renderer = foreign "SDL_CreateRenderer" - (window @-> int @-> uint32_t @-> returning (some_to_ok renderer_opt)) + (window @-> int @-> uint32_t @-> returning renderer_opt) let create_renderer ?(index = -1) ?(flags = Unsigned.UInt32.zero) w = - create_renderer w index flags + create_renderer w index flags |> some_to_ok let create_software_renderer = foreign "SDL_CreateSoftwareRenderer" - (surface @-> returning (some_to_ok renderer_opt)) + (surface @-> returning renderer_opt) +let create_software_renderer s = create_software_renderer s |> some_to_ok let destroy_renderer = foreign "SDL_DestroyRenderer" (renderer @-> returning void) let get_num_render_drivers = - foreign "SDL_GetNumRenderDrivers" (void @-> returning nat_to_ok) + foreign "SDL_GetNumRenderDrivers" (void @-> returning int) +let get_num_render_drivers () = get_num_render_drivers () |> nat_to_ok let get_render_draw_blend_mode = foreign "SDL_GetRenderDrawBlendMode" - (renderer @-> ptr uint @-> returning zero_to_ok) + (renderer @-> ptr uint @-> returning int) let get_render_draw_blend_mode r = let m = allocate uint Unsigned.UInt.zero in match get_render_draw_blend_mode r m with - | Ok () -> Ok !@m | Error _ as e -> e + | 0 -> Ok !@m | _ -> error () let get_render_draw_color = foreign "SDL_GetRenderDrawColor" (renderer @-> ptr uint8_t @-> ptr uint8_t @-> ptr uint8_t @-> - ptr uint8_t @-> returning zero_to_ok) + ptr uint8_t @-> returning int) let get_render_draw_color rend = let alloc () = allocate uint8_t Unsigned.UInt8.zero in let get v = Unsigned.UInt8.to_int (!@ v) in let r, g, b, a = alloc (), alloc (), alloc (), alloc () in match get_render_draw_color rend r g b a with - | Ok () -> Ok (get r, get g, get b, get a) | Error _ as e -> e + | 0 -> Ok (get r, get g, get b, get a) | _ -> error () let get_render_driver_info = foreign "SDL_GetRenderDriverInfo" - (int @-> ptr renderer_info @-> returning zero_to_ok) + (int @-> ptr renderer_info @-> returning int) let get_render_driver_info i = let info = make renderer_info in match get_render_driver_info i (addr info) with - | Ok () -> Ok (renderer_info_of_c info) | Error _ as e -> e + | 0 -> Ok (renderer_info_of_c info) | _ -> error () let get_render_target = foreign "SDL_GetRenderTarget" (renderer @-> returning texture_opt) let get_renderer = foreign "SDL_GetRenderer" - (window @-> returning (some_to_ok renderer_opt)) + (window @-> returning renderer_opt) +let get_renderer w = get_renderer w |> some_to_ok let get_renderer_info = foreign "SDL_GetRendererInfo" - (renderer @-> ptr renderer_info @-> returning zero_to_ok) + (renderer @-> ptr renderer_info @-> returning int) let get_renderer_info r = let info = make renderer_info in match get_renderer_info r (addr info) with - | Ok () -> Ok (renderer_info_of_c info) | Error _ as e -> e + | 0 -> Ok (renderer_info_of_c info) | _ -> error () let get_renderer_output_size = foreign "SDL_GetRendererOutputSize" - (renderer @-> ptr int @-> ptr int @-> returning zero_to_ok) + (renderer @-> ptr int @-> ptr int @-> returning int) let get_renderer_output_size r = let w = allocate int 0 in let h = allocate int 0 in match get_renderer_output_size r w h with - | Ok () -> Ok (!@ w, !@ h) | Error _ as e -> e + | 0 -> Ok (!@ w, !@ h) | _ -> error () let render_clear = - foreign "SDL_RenderClear" (renderer @-> returning zero_to_ok) + foreign "SDL_RenderClear" (renderer @-> returning int) +let render_clear r = render_clear r |> zero_to_ok let render_copy = foreign "SDL_RenderCopy" (renderer @-> texture @-> ptr rect @-> ptr rect @-> - returning zero_to_ok) + returning int) let render_copy ?src ?dst r t = - render_copy r t (Rect.opt_addr src) (Rect.opt_addr dst) + render_copy r t (Rect.opt_addr src) (Rect.opt_addr dst) |> zero_to_ok let render_copy_ex = foreign "SDL_RenderCopyEx" (renderer @-> texture @-> ptr rect @-> ptr rect @-> double @-> - ptr point @-> int @-> returning zero_to_ok) + ptr point @-> int @-> returning int) let render_copy_ex ?src ?dst r t angle c flip = render_copy_ex r t (Rect.opt_addr src) (Rect.opt_addr dst) angle - (Point.opt_addr c) flip + (Point.opt_addr c) flip |> zero_to_ok let render_draw_line = foreign "SDL_RenderDrawLine" - (renderer @-> int @-> int @-> int @-> int @-> returning zero_to_ok) + (renderer @-> int @-> int @-> int @-> int @-> returning int) +let render_draw_line r a b c d = render_draw_line r a b c d |> zero_to_ok let render_draw_line_f = foreign "SDL_RenderDrawLineF" - (renderer @-> float @-> float @-> float @-> float @-> returning zero_to_ok) + (renderer @-> float @-> float @-> float @-> float @-> returning int) +let render_draw_line_f r a b c d = render_draw_line_f r a b c d |> zero_to_ok let render_draw_lines = foreign "SDL_RenderDrawLines" - (renderer @-> ptr void @-> int @-> returning zero_to_ok) + (renderer @-> ptr void @-> int @-> returning int) let render_draw_lines_ba r ps = let len = Bigarray.Array1.dim ps in if len mod 2 <> 0 then invalid_arg (err_length_mul len 2) else let count = len / 2 in let ps = to_voidp (bigarray_start array1 ps) in - render_draw_lines r ps count + render_draw_lines r ps count |> zero_to_ok let render_draw_lines r ps = let a = CArray.of_list point ps in - render_draw_lines r (to_voidp (CArray.start a)) (CArray.length a) + render_draw_lines r (to_voidp (CArray.start a)) (CArray.length a) |> zero_to_ok let render_draw_point = foreign "SDL_RenderDrawPoint" - (renderer @-> int @-> int @-> returning zero_to_ok) + (renderer @-> int @-> int @-> returning int) +let render_draw_point r a b = render_draw_point r a b |> zero_to_ok let render_draw_points = foreign "SDL_RenderDrawPoints" - (renderer @-> ptr void @-> int @-> returning zero_to_ok) + (renderer @-> ptr void @-> int @-> returning int) let render_draw_points_ba r ps = let len = Bigarray.Array1.dim ps in if len mod 2 <> 0 then invalid_arg (err_length_mul len 2) else let count = len / 2 in let ps = to_voidp (bigarray_start array1 ps) in - render_draw_points r ps count + render_draw_points r ps count |> zero_to_ok let render_draw_points r ps = let a = CArray.of_list point ps in - render_draw_points r (to_voidp (CArray.start a)) (CArray.length a) + render_draw_points r (to_voidp (CArray.start a)) (CArray.length a) |> zero_to_ok let render_draw_point_f = foreign "SDL_RenderDrawPointF" - (renderer @-> float @-> float @-> returning zero_to_ok) + (renderer @-> float @-> float @-> returning int) +let render_draw_point_f r a b = render_draw_point_f r a b |> zero_to_ok let render_draw_points_f = foreign "SDL_RenderDrawPointsF" - (renderer @-> ptr void @-> int @-> returning zero_to_ok) + (renderer @-> ptr void @-> int @-> returning int) let render_draw_points_f_ba r ps = let len = Bigarray.Array1.dim ps in if len mod 2 <> 0 then invalid_arg (err_length_mul len 2) else let count = len / 2 in let ps = to_voidp (bigarray_start array1 ps) in - render_draw_points_f r ps count + render_draw_points_f r ps count |> zero_to_ok let render_draw_points_f r ps = let a = CArray.of_list fpoint ps in - render_draw_points_f r (to_voidp (CArray.start a)) (CArray.length a) + render_draw_points_f r (to_voidp (CArray.start a)) (CArray.length a) |> zero_to_ok let render_draw_rect = foreign "SDL_RenderDrawRect" - (renderer @-> ptr rect @-> returning zero_to_ok) + (renderer @-> ptr rect @-> returning int) let render_draw_rect rend r = - render_draw_rect rend (Rect.opt_addr r) + render_draw_rect rend (Rect.opt_addr r) |> zero_to_ok let render_draw_rects = foreign "SDL_RenderDrawRects" - (renderer @-> ptr void @-> int @-> returning zero_to_ok) + (renderer @-> ptr void @-> int @-> returning int) let render_draw_rects_ba r rs = let len = Bigarray.Array1.dim rs in if len mod 4 <> 0 then invalid_arg (err_length_mul len 4) else let count = len / 4 in let rs = to_voidp (bigarray_start array1 rs) in - render_draw_rects r rs count + render_draw_rects r rs count |> zero_to_ok let render_draw_rects r rs = let a = CArray.of_list rect rs in - render_draw_rects r (to_voidp (CArray.start a)) (CArray.length a) + render_draw_rects r (to_voidp (CArray.start a)) (CArray.length a) |> zero_to_ok let render_fill_rect = foreign "SDL_RenderFillRect" - (renderer @-> ptr rect @-> returning zero_to_ok) + (renderer @-> ptr rect @-> returning int) let render_fill_rect rend r = - render_fill_rect rend (Rect.opt_addr r) + render_fill_rect rend (Rect.opt_addr r) |> zero_to_ok let render_fill_rects = foreign "SDL_RenderFillRects" - (renderer @-> ptr void @-> int @-> returning zero_to_ok) + (renderer @-> ptr void @-> int @-> returning int) let render_fill_rects_ba r rs = let len = Bigarray.Array1.dim rs in if len mod 4 <> 0 then invalid_arg (err_length_mul len 4) else let count = len / 4 in let rs = to_voidp (bigarray_start array1 rs) in - render_fill_rects r rs count + render_fill_rects r rs count |> zero_to_ok let render_fill_rects r rs = let a = CArray.of_list rect rs in - render_fill_rects r (to_voidp (CArray.start a)) (CArray.length a) + render_fill_rects r (to_voidp (CArray.start a)) (CArray.length a) |> zero_to_ok let render_geometry = foreign "SDL_RenderGeometry" (renderer @-> texture @-> ptr void @-> int @-> ptr void @-> int @-> - returning zero_to_ok) + returning int) let render_geometry ?indices ?texture r vertices = let a1 = CArray.of_list vertex vertices in @@ -1520,7 +1527,7 @@ let render_geometry ?indices ?texture r vertices = (to_voidp (CArray.start a2), CArray.length a2) in render_geometry - r t (to_voidp (CArray.start a1)) (CArray.length a1) a2_ptr a2_len + r t (to_voidp (CArray.start a1)) (CArray.length a1) a2_ptr a2_len |> zero_to_ok let render_geometry_raw = foreign "SDL_RenderGeometryRaw" @@ -1528,7 +1535,7 @@ let render_geometry_raw = ptr void @-> int @-> ptr void @-> int @-> ptr void @-> int @-> - int @-> ptr void @-> int @-> int @-> returning zero_to_ok) + int @-> ptr void @-> int @-> int @-> returning int) let render_geometry_raw ?indices ?texture r ~xy ?(xy_stride = 8) ~color ?(color_stride = 4) @@ -1569,7 +1576,7 @@ let render_geometry_raw end; render_geometry_raw r t xy_ptr xy_stride color_ptr color_stride uv_ptr uv_stride num_vertices - i_ptr i_len i_stride + i_ptr i_len i_stride |> zero_to_ok let render_get_clip_rect = foreign "SDL_RenderGetClipRect" @@ -1623,58 +1630,63 @@ let render_present = let render_read_pixels = foreign "SDL_RenderReadPixels" (renderer @-> ptr rect @-> uint32_t @-> ptr void @-> int @-> - returning zero_to_ok) + returning int) let render_read_pixels r rect format pixels pitch = let format = match format with None -> Unsigned.UInt32.zero | Some f -> f in let pixels = to_voidp (bigarray_start array1 pixels) in - render_read_pixels r (Rect.opt_addr rect) format pixels pitch + render_read_pixels r (Rect.opt_addr rect) format pixels pitch |> zero_to_ok let render_set_clip_rect = foreign "SDL_RenderSetClipRect" - (renderer @-> ptr rect @-> returning zero_to_ok) + (renderer @-> ptr rect @-> returning int) let render_set_clip_rect rend r = - render_set_clip_rect rend (Rect.opt_addr r) + render_set_clip_rect rend (Rect.opt_addr r) |> zero_to_ok let render_set_integer_scale = foreign "SDL_RenderSetIntegerScale" - (renderer @-> bool @-> returning zero_to_ok) + (renderer @-> bool @-> returning int) +let render_set_integer_scale r b = render_set_integer_scale r b |> zero_to_ok let render_set_logical_size = foreign "SDL_RenderSetLogicalSize" - (renderer @-> int @-> int @-> returning zero_to_ok) + (renderer @-> int @-> int @-> returning int) +let render_set_logical_size r x y = render_set_logical_size r x y |> zero_to_ok let render_set_scale = foreign "SDL_RenderSetScale" - (renderer @-> float @-> float @-> returning zero_to_ok) + (renderer @-> float @-> float @-> returning int) +let render_set_scale r x y = render_set_scale r x y |> zero_to_ok let render_set_viewport = foreign "SDL_RenderSetViewport" - (renderer @-> ptr rect @-> returning zero_to_ok) + (renderer @-> ptr rect @-> returning int) let render_set_viewport rend r = - render_set_viewport rend (Rect.opt_addr r) + render_set_viewport rend (Rect.opt_addr r) |> zero_to_ok let render_target_supported = foreign "SDL_RenderTargetSupported" (renderer @-> returning bool) let set_render_draw_blend_mode = foreign "SDL_SetRenderDrawBlendMode" - (renderer @-> uint @-> returning zero_to_ok) + (renderer @-> uint @-> returning int) +let set_render_draw_blend_mode r x = set_render_draw_blend_mode r x |> zero_to_ok let set_render_draw_color = foreign "SDL_SetRenderDrawColor" (renderer @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> - int_as_uint8_t @-> returning zero_to_ok) + int_as_uint8_t @-> returning int) +let set_render_draw_color r a b c d = set_render_draw_color r a b c d |> zero_to_ok let set_render_target = foreign "SDL_SetRenderTarget" - (renderer @-> texture @-> returning zero_to_ok) + (renderer @-> texture @-> returning int) let set_render_target r t = let t = match t with None -> null | Some t -> t in - set_render_target r t + set_render_target r t |> zero_to_ok (* Textures *) @@ -1694,64 +1706,65 @@ end let create_texture = foreign "SDL_CreateTexture" (renderer @-> uint32_t @-> int @-> int @-> int @-> - returning (some_to_ok texture_opt)) + returning texture_opt) let create_texture r pf access ~w ~h = - create_texture r pf access w h + create_texture r pf access w h |> some_to_ok let create_texture_from_surface = foreign "SDL_CreateTextureFromSurface" - (renderer @-> surface @-> returning (some_to_ok texture_opt)) + (renderer @-> surface @-> returning texture_opt) +let create_texture_from_surface r s = create_texture_from_surface r s |> some_to_ok let destroy_texture = foreign "SDL_DestroyTexture" (texture @-> returning void) let get_texture_alpha_mod = foreign "SDL_GetTextureAlphaMod" - (texture @-> ptr uint8_t @-> returning zero_to_ok) + (texture @-> ptr uint8_t @-> returning int) let get_texture_alpha_mod t = let alpha = allocate uint8_t Unsigned.UInt8.zero in match get_texture_alpha_mod t alpha with - | Ok () -> Ok (Unsigned.UInt8.to_int (!@ alpha)) | Error _ as e -> e + | 0 -> Ok (Unsigned.UInt8.to_int (!@ alpha)) | _ -> error () let get_texture_blend_mode = foreign "SDL_GetTextureBlendMode" - (texture @-> ptr uint @-> returning zero_to_ok) + (texture @-> ptr uint @-> returning int) let get_texture_blend_mode t = let m = allocate uint Unsigned.UInt.zero in match get_texture_blend_mode t m with - | Ok () -> Ok (!@ m) | Error _ as e -> e + | 0 -> Ok (!@ m) | _ -> error () let get_texture_color_mod = foreign "SDL_GetTextureColorMod" (texture @-> ptr uint8_t @-> ptr uint8_t @-> ptr uint8_t @-> - returning zero_to_ok) + returning int) let get_texture_color_mod t = let alloc () = allocate uint8_t Unsigned.UInt8.zero in let get v = Unsigned.UInt8.to_int (!@ v) in let r, g, b = alloc (), alloc (), alloc () in match get_texture_color_mod t r g b with - | Ok () -> Ok (get r, get g, get b) | Error _ as e -> e + | 0 -> Ok (get r, get g, get b) | _ -> error () let query_texture = foreign "SDL_QueryTexture" (texture @-> ptr uint32_t @-> ptr int @-> ptr int @-> ptr int @-> - returning zero_to_ok) + returning int) let _texture_height t = let h = allocate int 0 in let unull = coerce (ptr void) (ptr uint32_t) null in let inull = coerce (ptr void) (ptr int) null in match query_texture t unull inull inull h with - | Ok () -> Ok (!@ h) | Error _ as e -> e + | 0 -> Ok (!@ h) | _ -> error () let lock_texture = foreign "SDL_LockTexture" (texture @-> ptr rect @-> ptr (ptr void) @-> ptr int @-> - returning zero_to_ok) + returning int) let lock_texture t r kind = match (match r with None -> _texture_height t | Some r -> Ok (Rect.h r)) with @@ -1760,8 +1773,7 @@ let lock_texture t r kind = let pitch = allocate int 0 in let p = allocate (ptr void) null in match lock_texture t (Rect.opt_addr r) p pitch with - | Error _ as e -> e - | Ok () -> + | 0 -> let p = !@ p in let pitch = !@ pitch in let kind_size = ba_kind_byte_size kind in @@ -1771,6 +1783,7 @@ let lock_texture t r kind = let ba_size = (pitch * h) / kind_size in let pixels = coerce (ptr void) (access_ptr_typ_of_ba_kind kind) p in Ok (bigarray_of_ptr array1 ba_size kind pixels, pitch / kind_size) + | _ -> error () let query_texture t = let pf = allocate uint32_t Unsigned.UInt32.zero in @@ -1778,44 +1791,47 @@ let query_texture t = let w = allocate int 0 in let h = allocate int 0 in match query_texture t pf access w h with - | Ok () -> Ok (!@ pf, !@ access, (!@ w, !@ h)) | Error _ as e -> e + | 0 -> Ok (!@ pf, !@ access, (!@ w, !@ h)) | _ -> error () let set_texture_alpha_mod = foreign "SDL_SetTextureAlphaMod" - (texture @-> int_as_uint8_t @-> returning zero_to_ok) + (texture @-> int_as_uint8_t @-> returning int) +let set_texture_alpha_mod t a = set_texture_alpha_mod t a |> zero_to_ok let set_texture_blend_mode = foreign "SDL_SetTextureBlendMode" - (texture @-> uint @-> returning zero_to_ok) + (texture @-> uint @-> returning int) +let set_texture_blend_mode t b = set_texture_blend_mode t b |> zero_to_ok let set_texture_color_mod = foreign "SDL_SetTextureColorMod" (texture @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> - returning zero_to_ok) + returning int) +let set_texture_color_mod t a b c = set_texture_color_mod t a b c |> zero_to_ok let unlock_texture = foreign "SDL_UnlockTexture" (texture @-> returning void) let update_texture = foreign "SDL_UpdateTexture" - (texture @-> ptr rect @-> ptr void @-> int @-> returning zero_to_ok) + (texture @-> ptr rect @-> ptr void @-> int @-> returning int) let update_texture t rect pixels pitch = let pitch = pitch * (ba_kind_byte_size (Bigarray.Array1.kind pixels)) in let pixels = to_voidp (bigarray_start array1 pixels) in - update_texture t (Rect.opt_addr rect) pixels pitch + update_texture t (Rect.opt_addr rect) pixels pitch |> zero_to_ok let update_yuv_texture = foreign "SDL_UpdateYUVTexture" (texture @-> ptr rect @-> ptr void @-> int @-> ptr void @-> int @-> ptr void @-> int @-> - returning zero_to_ok) + returning int) let update_yuv_texture r rect ~y ypitch ~u upitch ~v vpitch = let yp = to_voidp (bigarray_start array1 y) in let up = to_voidp (bigarray_start array1 u) in let vp = to_voidp (bigarray_start array1 v) in - update_yuv_texture r (Rect.opt_addr rect) yp ypitch up upitch vp vpitch + update_yuv_texture r (Rect.opt_addr rect) yp ypitch up upitch vp vpitch |> zero_to_ok (* Video drivers *) @@ -1823,13 +1839,16 @@ let get_current_video_driver = foreign "SDL_GetCurrentVideoDriver" (void @-> returning string_opt) let get_num_video_drivers = - foreign "SDL_GetNumVideoDrivers" (void @-> returning nat_to_ok) + foreign "SDL_GetNumVideoDrivers" (void @-> returning int) +let get_num_video_drivers () = get_num_video_drivers () |> nat_to_ok let get_video_driver = - foreign "SDL_GetVideoDriver" (int @-> returning (some_to_ok string_opt)) + foreign "SDL_GetVideoDriver" (int @-> returning string_opt) +let get_video_driver x = get_video_driver x |> some_to_ok let video_init = - foreign "SDL_VideoInit" (string_opt @-> returning zero_to_ok) + foreign "SDL_VideoInit" (string_opt @-> returning int) +let video_init s = video_init s |> zero_to_ok let video_quit = foreign "SDL_VideoQuit" (void @-> returning void) @@ -1889,69 +1908,72 @@ let get_closest_display_mode i m = let get_current_display_mode = foreign "SDL_GetCurrentDisplayMode" - (int @-> ptr display_mode @-> returning zero_to_ok) + (int @-> ptr display_mode @-> returning int) let get_current_display_mode i = let mode = make display_mode in match get_current_display_mode i (addr mode) with - | Ok () -> Ok (display_mode_of_c mode) | Error _ as e -> e + | 0 -> Ok (display_mode_of_c mode) | _ -> error () let get_desktop_display_mode = foreign "SDL_GetDesktopDisplayMode" - (int @-> ptr display_mode @-> returning zero_to_ok) + (int @-> ptr display_mode @-> returning int) let get_desktop_display_mode i = let mode = make display_mode in match get_desktop_display_mode i (addr mode) with - | Ok () -> Ok (display_mode_of_c mode) | Error _ as e -> e + | 0 -> Ok (display_mode_of_c mode) | _ -> error () let get_display_bounds = foreign "SDL_GetDisplayBounds" - (int @-> ptr rect @-> returning zero_to_ok) + (int @-> ptr rect @-> returning int) let get_display_bounds i = let r = make rect in match get_display_bounds i (addr r) with - | Ok () -> Ok r | Error _ as e -> e + | 0 -> Ok r | _ -> error () let get_display_dpi = foreign "SDL_GetDisplayDPI" - (int @-> ptr float @-> ptr float @-> ptr float @-> returning zero_to_ok) + (int @-> ptr float @-> ptr float @-> ptr float @-> returning int) let get_display_dpi display = let diagonal = allocate float 0. in let horizontal = allocate float 0. in let vertical = allocate float 0. in match get_display_dpi display diagonal horizontal vertical with - | Ok () -> Ok (!@diagonal,!@horizontal,!@vertical) - | Error _ as err -> err + | 0 -> Ok (!@diagonal,!@horizontal,!@vertical) + | _ -> error () let get_display_mode = foreign "SDL_GetDisplayMode" - (int @-> int @-> ptr display_mode @-> returning zero_to_ok) + (int @-> int @-> ptr display_mode @-> returning int) let get_display_mode d i = let mode = make display_mode in match get_display_mode d i (addr mode) with - | Ok () -> Ok (display_mode_of_c mode) | Error _ as e -> e + | 0 -> Ok (display_mode_of_c mode) | _ -> error () let get_display_usable_bounds = foreign "SDL_GetDisplayUsableBounds" - (int @-> ptr rect @-> returning zero_to_ok) + (int @-> ptr rect @-> returning int) let get_display_usable_bounds i = let r = make rect in match get_display_usable_bounds i (addr r) with - | Ok () -> Ok r | Error _ as e -> e + | 0 -> Ok r | _ -> error () let get_num_display_modes = - foreign "SDL_GetNumDisplayModes" (int @-> returning nat_to_ok) + foreign "SDL_GetNumDisplayModes" (int @-> returning int) +let get_num_display_modes x = get_num_display_modes x |> nat_to_ok let get_display_name = - foreign "SDL_GetDisplayName" (int @-> returning (some_to_ok string_opt)) + foreign "SDL_GetDisplayName" (int @-> returning string_opt) +let get_display_name x = get_display_name x |> some_to_ok let get_num_video_displays = - foreign "SDL_GetNumVideoDisplays" (void @-> returning nat_to_ok) + foreign "SDL_GetNumVideoDisplays" (void @-> returning int) +let get_num_video_displays () = get_num_video_displays () |> nat_to_ok (* Windows *) @@ -1991,21 +2013,21 @@ end let create_window = foreign "SDL_CreateWindow" (string @-> int @-> int @-> int @-> int @-> uint32_t @-> - returning (some_to_ok window_opt)) + returning window_opt) let create_window t ?(x = Window.pos_undefined) ?(y = Window.pos_undefined) - ~w ~h flags = create_window t x y w h flags + ~w ~h flags = create_window t x y w h flags |> some_to_ok let create_window_and_renderer = foreign "SDL_CreateWindowAndRenderer" (int @-> int @-> uint32_t @-> ptr window @-> ptr renderer @-> - (returning zero_to_ok)) + (returning int)) let create_window_and_renderer ~w ~h flags = let win = allocate window null in let r = allocate renderer null in match create_window_and_renderer w h flags win r with - | Ok () -> Ok (!@ win, !@ r) | Error _ as e -> e + | 0 -> Ok (!@ win, !@ r) | _ -> error () let destroy_window = foreign "SDL_DestroyWindow" (window @-> returning void) @@ -2016,7 +2038,7 @@ let get_window_brightness = let get_window_borders_size = foreign "SDL_GetWindowBordersSize" (window @-> ptr int @-> ptr int @-> ptr int @-> ptr int @-> - returning zero_to_ok) + returning int) let get_window_borders_size w = let top = allocate int 0 in @@ -2024,11 +2046,12 @@ let get_window_borders_size w = let bottom = allocate int 0 in let right = allocate int 0 in match get_window_borders_size w top bottom left right with - | Ok () -> Ok (!@ top, !@ left, !@ bottom, !@ right) - | Error _ as err -> err + | 0 -> Ok (!@ top, !@ left, !@ bottom, !@ right) + | _ -> error () let get_window_display_index = - foreign "SDL_GetWindowDisplayIndex" (window @-> returning nat_to_ok) + foreign "SDL_GetWindowDisplayIndex" (window @-> returning int) +let get_window_display_index w = get_window_display_index w |> nat_to_ok let get_window_display_mode = foreign "SDL_GetWindowDisplayMode" @@ -2044,18 +2067,19 @@ let get_window_flags = let get_window_from_id = foreign "SDL_GetWindowFromID" - (int_as_uint32_t @-> returning (some_to_ok window_opt)) + (int_as_uint32_t @-> returning window_opt) +let get_window_from_id x = get_window_from_id x |> some_to_ok let get_window_gamma_ramp = foreign "SDL_GetWindowGammaRamp" - (window @-> ptr void @-> ptr void @-> ptr void @-> returning zero_to_ok) + (window @-> ptr void @-> ptr void @-> ptr void @-> returning int) let get_window_gamma_ramp w = let create_ramp () = ba_create Bigarray.int16_unsigned 256 in let r, g, b = create_ramp (), create_ramp (), create_ramp () in let ramp_ptr r = to_voidp (bigarray_start array1 r) in match get_window_gamma_ramp w (ramp_ptr r) (ramp_ptr g) (ramp_ptr b) with - | Ok () -> Ok (r, g, b) | Error _ as e -> e + | 0 -> Ok (r, g, b) | _ -> error () let get_window_grab = foreign "SDL_GetWindowGrab" (window @-> returning bool) @@ -2088,13 +2112,13 @@ let get_window_minimum_size win = let get_window_opacity = foreign "SDL_GetWindowOpacity" - (window @-> (ptr float) @-> returning zero_to_ok) + (window @-> (ptr float) @-> returning int) let get_window_opacity win = let x = allocate float 0. in match get_window_opacity win x with - | Ok () -> Ok !@x - | Error _ as e -> e + | 0 -> Ok !@x + | _ -> error () let get_window_pixel_format = foreign "SDL_GetWindowPixelFormat" (window @-> returning uint32_t) @@ -2121,7 +2145,8 @@ let get_window_size win = let get_window_surface = foreign "SDL_GetWindowSurface" - (window @-> returning (some_to_ok surface_opt)) + (window @-> returning surface_opt) +let get_window_surface w = get_window_surface w |> some_to_ok let get_window_title = foreign "SDL_GetWindowTitle" (window @-> returning string) @@ -2146,28 +2171,30 @@ let set_window_bordered = let set_window_brightness = foreign "SDL_SetWindowBrightness" - (window @-> float @-> returning zero_to_ok) + (window @-> float @-> returning int) +let set_window_brightness w x = set_window_brightness w x |> zero_to_ok let set_window_display_mode = foreign "SDL_SetWindowDisplayMode" - (window @-> (ptr display_mode) @-> returning zero_to_ok) + (window @-> (ptr display_mode) @-> returning int) let set_window_display_mode w m = let mode = display_mode_to_c m in - set_window_display_mode w (addr mode) + set_window_display_mode w (addr mode) |> zero_to_ok let set_window_fullscreen = foreign "SDL_SetWindowFullscreen" - (window @-> uint32_t @-> returning zero_to_ok) + (window @-> uint32_t @-> returning int) +let set_window_fullscreen w x = set_window_fullscreen w x |> zero_to_ok let set_window_gamma_ramp = foreign "SDL_SetWindowGammaRamp" (window @-> ptr void @-> ptr void @-> ptr void @-> - returning zero_to_ok) + returning int) let set_window_gamma_ramp w r g b = let ramp_ptr r = to_voidp (bigarray_start array1 r) in - set_window_gamma_ramp w (ramp_ptr r) (ramp_ptr g) (ramp_ptr b) + set_window_gamma_ramp w (ramp_ptr r) (ramp_ptr g) (ramp_ptr b) |> zero_to_ok let set_window_grab = foreign "SDL_SetWindowGrab" (window @-> bool @-> returning void) @@ -2176,7 +2203,8 @@ let set_window_icon = foreign "SDL_SetWindowIcon" (window @-> surface @-> returning void) let set_window_input_focus = - foreign "SDL_SetWindowInputFocus" (window @-> returning zero_to_ok) + foreign "SDL_SetWindowInputFocus" (window @-> returning int) +let set_window_input_focus w = set_window_input_focus w |> zero_to_ok let set_window_maximum_size = foreign "SDL_SetWindowMaximumSize" @@ -2193,12 +2221,13 @@ let set_window_minimum_size win ~w ~h = set_window_minimum_size win w h let set_window_modal_for = - foreign "SDL_SetWindowModalFor" ( window @-> window @-> returning zero_to_ok) + foreign "SDL_SetWindowModalFor" ( window @-> window @-> returning int) -let set_window_modal_for ~modal ~parent = set_window_modal_for modal parent +let set_window_modal_for ~modal ~parent = set_window_modal_for modal parent |> zero_to_ok let set_window_opacity = - foreign "SDL_SetWindowOpacity" ( window @-> float @-> returning zero_to_ok) + foreign "SDL_SetWindowOpacity" ( window @-> float @-> returning int) +let set_window_opacity w x = set_window_opacity w x |> zero_to_ok let set_window_position = foreign "SDL_SetWindowPosition" @@ -2223,23 +2252,24 @@ let show_window = foreign "SDL_ShowWindow" (window @-> returning void) let update_window_surface = - foreign "SDL_UpdateWindowSurface" (window @-> returning zero_to_ok) + foreign "SDL_UpdateWindowSurface" (window @-> returning int) +let update_window_surface w = update_window_surface w |> zero_to_ok let update_window_surface_rects = foreign "SDL_UpdateWindowSurfaceRects" - (window @-> ptr void @-> int @-> returning zero_to_ok) + (window @-> ptr void @-> int @-> returning int) let update_window_surface_rects_ba w rs = let len = Bigarray.Array1.dim rs in if len mod 4 <> 0 then invalid_arg (err_length_mul len 4) else let count = len / 4 in let rs = to_voidp (bigarray_start array1 rs) in - update_window_surface_rects w rs count + update_window_surface_rects w rs count |> zero_to_ok let update_window_surface_rects w rs = let a = CArray.of_list rect rs in let rs = to_voidp (CArray.start a) in - update_window_surface_rects w rs (CArray.length a) + update_window_surface_rects w rs (CArray.length a) |> zero_to_ok (* OpenGL contexts *) @@ -2293,17 +2323,18 @@ end let gl_bind_texture = foreign "SDL_GL_BindTexture" - (texture @-> ptr float @-> ptr float @-> returning zero_to_ok) + (texture @-> ptr float @-> ptr float @-> returning int) let gl_bind_texture t = let w = allocate float 0. in let h = allocate float 0. in match gl_bind_texture t w h with - | Ok () -> Ok (!@ w, !@ h) | Error _ as e -> e + | 0 -> Ok (!@ w, !@ h) | _ -> error () let gl_create_context = foreign "SDL_GL_CreateContext" - (window @-> returning (some_to_ok gl_context_opt)) + (window @-> returning gl_context_opt) +let gl_create_context w = gl_create_context w |> some_to_ok let gl_delete_context = foreign "SDL_GL_DeleteContext" (gl_context @-> returning void) @@ -2321,7 +2352,8 @@ let gl_get_attribute att = let gl_get_current_context = foreign "SDL_GL_GetCurrentContext" - (void @-> returning (some_to_ok gl_context_opt)) + (void @-> returning gl_context_opt) +let gl_get_current_context () = gl_get_current_context () |> some_to_ok let gl_get_drawable_size = foreign "SDL_GL_GetDrawableSize" @@ -2333,31 +2365,32 @@ let gl_get_drawable_size win = gl_get_drawable_size win w h; (!@ w, !@ h) -let int_to_ok = - let read n = Ok n in - view ~read ~write:write_never int - let gl_get_swap_interval = - foreign "SDL_GL_GetSwapInterval" (void @-> returning int_to_ok) + foreign "SDL_GL_GetSwapInterval" (void @-> returning int) +let gl_get_swap_interval () = Ok (gl_get_swap_interval ()) let gl_make_current = foreign "SDL_GL_MakeCurrent" - (window @-> gl_context @-> returning zero_to_ok) + (window @-> gl_context @-> returning int) +let gl_make_current w g = gl_make_current w g |> zero_to_ok let gl_reset_attributes = foreign "SDL_GL_ResetAttributes" ~stub (void @-> returning void) let gl_set_attribute = - foreign "SDL_GL_SetAttribute" (int @-> int @-> returning zero_to_ok) + foreign "SDL_GL_SetAttribute" (int @-> int @-> returning int) +let gl_set_attribute x y = gl_set_attribute x y |> zero_to_ok let gl_set_swap_interval = - foreign "SDL_GL_SetSwapInterval" (int @-> returning zero_to_ok) + foreign "SDL_GL_SetSwapInterval" (int @-> returning int) +let gl_set_swap_interval x = gl_set_swap_interval x |> zero_to_ok let gl_swap_window = foreign "SDL_GL_SwapWindow" (window @-> returning void) let gl_unbind_texture = - foreign "SDL_GL_UnbindTexture" (texture @-> returning zero_to_ok) + foreign "SDL_GL_UnbindTexture" (texture @-> returning int) +let gl_unbind_texture t = gl_unbind_texture t |> zero_to_ok (* Vulkan *) @@ -2374,7 +2407,8 @@ module Vulkan = struct let unsafe_surface_of_uint64 x = x let load_library = - foreign "SDL_Vulkan_LoadLibrary" (string_opt @-> returning zero_to_ok) + foreign "SDL_Vulkan_LoadLibrary" (string_opt @-> returning int) + let load_library s = load_library s |> zero_to_ok let unload_library = foreign "SDL_Vulkan_UnloadLibrary" (void @-> returning void) @@ -2540,20 +2574,20 @@ end let show_message_box = foreign "SDL_ShowMessageBox" - (ptr Message_box.data @-> ptr int @-> returning zero_to_ok) + (ptr Message_box.data @-> ptr int @-> returning int) let show_message_box d = let d = addr (Message_box.data_to_c d) in let ret = allocate int 0 in match show_message_box d ret with - | Ok () -> Ok (!@ ret) | Error _ as e -> e + | 0 -> Ok (!@ ret) | _ -> error () let show_simple_message_box = foreign "SDL_ShowSimpleMessageBox" - (uint32_t @-> string @-> string @-> window_opt @-> returning zero_to_ok) + (uint32_t @-> string @-> string @-> window_opt @-> returning int) let show_simple_message_box t ~title msg w = - show_simple_message_box t title msg w + show_simple_message_box t title msg w |> zero_to_ok (* Clipboard *) @@ -2576,7 +2610,8 @@ let has_clipboard_text = foreign "SDL_HasClipboardText" (void @-> returning bool) let set_clipboard_text = - foreign "SDL_SetClipboardText" (string @-> returning zero_to_ok) + foreign "SDL_SetClipboardText" (string @-> returning int) +let set_clipboard_text s = set_clipboard_text s |> zero_to_ok (* Input *) @@ -3253,29 +3288,31 @@ module Button = struct end let capture_mouse = - foreign "SDL_CaptureMouse" (bool @-> returning zero_to_ok) + foreign "SDL_CaptureMouse" (bool @-> returning int) +let capture_mouse b = capture_mouse b |> zero_to_ok let create_color_cursor = foreign "SDL_CreateColorCursor" - (surface @-> int @-> int @-> returning (some_to_ok cursor_opt)) + (surface @-> int @-> int @-> returning cursor_opt) let create_color_cursor s ~hot_x ~hot_y = - create_color_cursor s hot_x hot_y + create_color_cursor s hot_x hot_y |> some_to_ok let create_cursor = foreign "SDL_CreateCursor" (ptr void @-> ptr void @-> int @-> int @-> int @-> int @-> - returning (some_to_ok cursor_opt)) + returning cursor_opt) let create_cursor d m ~w ~h ~hot_x ~hot_y = (* FIXME: we could try to check bounds *) let d = to_voidp (bigarray_start array1 d) in let m = to_voidp (bigarray_start array1 m) in - create_cursor d m w h hot_x hot_y + create_cursor d m w h hot_x hot_y |> some_to_ok let create_system_cursor = foreign "SDL_CreateSystemCursor" - (int @-> returning (some_to_ok cursor_opt)) + (int @-> returning cursor_opt) +let create_system_cursor i = create_system_cursor i |> some_to_ok let free_cursor = foreign "SDL_FreeCursor" (cursor @-> returning void) @@ -3323,19 +3360,20 @@ let get_relative_mouse_state () = s, (!@ x, !@ y) let show_cursor = - foreign "SDL_ShowCursor" (int @-> returning bool_to_ok) + foreign "SDL_ShowCursor" (int @-> returning int) let get_cursor_shown () = - show_cursor (-1) + show_cursor (-1) |> bool_to_ok let set_cursor = foreign "SDL_SetCursor" (cursor_opt @-> returning void) let set_relative_mouse_mode = - foreign "SDL_SetRelativeMouseMode" (bool @-> returning zero_to_ok) + foreign "SDL_SetRelativeMouseMode" (bool @-> returning int) +let set_relative_mouse_mode b = set_relative_mouse_mode b |> zero_to_ok let show_cursor b = - show_cursor (if b then 1 else 0) + show_cursor (if b then 1 else 0) |> bool_to_ok let warp_mouse_in_window = foreign "SDL_WarpMouseInWindow" @@ -3345,10 +3383,10 @@ let warp_mouse_in_window w ~x ~y = warp_mouse_in_window w x y let warp_mouse_global= - foreign "SDL_WarpMouseGlobal" (int @-> int @-> returning zero_to_ok) + foreign "SDL_WarpMouseGlobal" (int @-> int @-> returning int) let warp_mouse_global ~x ~y = - warp_mouse_global x y + warp_mouse_global x y |> zero_to_ok (* Touch *) @@ -3401,17 +3439,21 @@ let get_touch_finger id i = let load_dollar_templates = foreign "SDL_LoadDollarTemplates" - (touch_id @-> rw_ops @-> returning zero_to_ok) + (touch_id @-> rw_ops @-> returning int) +let load_dollar_templates x y = load_dollar_templates x y |> zero_to_ok let record_gesture = - foreign "SDL_RecordGesture" (touch_id @-> returning one_to_ok) + foreign "SDL_RecordGesture" (touch_id @-> returning int) +let record_gesture i = record_gesture i |> one_to_ok let save_dollar_template = foreign "SDL_SaveDollarTemplate" - (gesture_id @-> rw_ops @-> returning zero_to_ok) + (gesture_id @-> rw_ops @-> returning int) +let save_dollar_template x y = save_dollar_template x y |> zero_to_ok let save_all_dollar_templates = - foreign "SDL_SaveAllDollarTemplates" (rw_ops @-> returning zero_to_ok) + foreign "SDL_SaveAllDollarTemplates" (rw_ops @-> returning int) +let save_all_dollar_templates o = save_all_dollar_templates o |> zero_to_ok (* Joystick *) @@ -3496,7 +3538,8 @@ let joystick_current_power_level = (joystick @-> returning int) let joystick_event_state = - foreign "SDL_JoystickEventState" (int @-> returning nat_to_ok) + foreign "SDL_JoystickEventState" (int @-> returning int) +let joystick_event_state i = joystick_event_state i |> nat_to_ok let joystick_from_instance_id = foreign "SDL_JoystickFromInstanceID" (joystick_id @-> returning joystick) @@ -3590,31 +3633,39 @@ let joystick_instance_id j = | n when n < 0l -> error () | n -> Ok n let joystick_name = - foreign "SDL_JoystickName" (joystick @-> returning (some_to_ok string_opt)) + foreign "SDL_JoystickName" (joystick @-> returning string_opt) +let joystick_name j = joystick_name j |> some_to_ok let joystick_name_for_index = - foreign "SDL_JoystickNameForIndex" (int @-> returning (some_to_ok string_opt)) + foreign "SDL_JoystickNameForIndex" (int @-> returning string_opt) +let joystick_name_for_index i = joystick_name_for_index i |> some_to_ok let joystick_num_axes = - foreign "SDL_JoystickNumAxes" (joystick @-> returning nat_to_ok) + foreign "SDL_JoystickNumAxes" (joystick @-> returning int) +let joystick_num_axes j = joystick_num_axes j |> nat_to_ok let joystick_num_balls = - foreign "SDL_JoystickNumBalls" (joystick @-> returning nat_to_ok) + foreign "SDL_JoystickNumBalls" (joystick @-> returning int) +let joystick_num_balls j = joystick_num_balls j |> nat_to_ok let joystick_num_buttons = - foreign "SDL_JoystickNumButtons" (joystick @-> returning nat_to_ok) + foreign "SDL_JoystickNumButtons" (joystick @-> returning int) +let joystick_num_buttons j = joystick_num_buttons j |> nat_to_ok let joystick_num_hats = - foreign "SDL_JoystickNumHats" (joystick @-> returning nat_to_ok) + foreign "SDL_JoystickNumHats" (joystick @-> returning int) +let joystick_num_hats j = joystick_num_hats j |> nat_to_ok let joystick_open = - foreign "SDL_JoystickOpen" (int @-> returning (some_to_ok joystick_opt)) + foreign "SDL_JoystickOpen" (int @-> returning joystick_opt) +let joystick_open i = joystick_open i |> some_to_ok let joystick_update = foreign "SDL_JoystickUpdate" (void @-> returning void) let num_joysticks = - foreign "SDL_NumJoysticks" (void @-> returning nat_to_ok) + foreign "SDL_NumJoysticks" (void @-> returning int) +let num_joysticks () = num_joysticks () |> nat_to_ok (* Game controller *) @@ -3679,17 +3730,20 @@ module Controller = struct end let game_controller_add_mapping = - foreign "SDL_GameControllerAddMapping" (string @-> returning bool_to_ok) + foreign "SDL_GameControllerAddMapping" (string @-> returning int) +let game_controller_add_mapping s = game_controller_add_mapping s |> bool_to_ok let game_controller_add_mapping_from_rw = foreign "SDL_GameControllerAddMappingsFromRW" - ~stub (rw_ops @-> bool @-> returning nat_to_ok) + ~stub (rw_ops @-> bool @-> returning int) +let game_controller_add_mapping_from_rw r b = game_controller_add_mapping_from_rw r b |> nat_to_ok let game_controller_close = foreign "SDL_GameControllerClose" (game_controller @-> returning void) let game_controller_event_state = - foreign "SDL_GameControllerEventState" (int @-> returning nat_to_ok) + foreign "SDL_GameControllerEventState" (int @-> returning int) +let game_controller_event_state i = game_controller_event_state i |> nat_to_ok let game_controller_from_instance_id = foreign "SDL_GameControllerFromInstanceID" @@ -3729,7 +3783,8 @@ let game_controller_get_button_from_string = let game_controller_get_joystick = foreign "SDL_GameControllerGetJoystick" - (game_controller @-> returning (some_to_ok joystick_opt)) + (game_controller @-> returning joystick_opt) +let game_controller_get_joystick c = game_controller_get_joystick c |> some_to_ok let game_controller_get_product = foreign "SDL_GameControllerGetProduct" @@ -3751,30 +3806,36 @@ let game_controller_get_vendor = let game_controller_mapping = foreign "SDL_GameControllerMapping" - (game_controller @-> returning (some_to_ok string_opt)) + (game_controller @-> returning string_opt) +let game_controller_mapping c = game_controller_mapping c |> some_to_ok let game_controller_mapping_for_index = foreign "SDL_GameControllerMappingForIndex" - (int @-> returning (some_to_ok string_opt)) + (int @-> returning string_opt) +let game_controller_mapping_for_index i = game_controller_mapping_for_index i |> some_to_ok let game_controller_mapping_for_guid = foreign "SDL_GameControllerMappingForGUID" - (joystick_guid @-> returning (some_to_ok string_opt)) + (joystick_guid @-> returning string_opt) +let game_controller_mapping_for_guid g = game_controller_mapping_for_guid g |> some_to_ok let game_controller_name = foreign "SDL_GameControllerName" - (game_controller @-> returning (some_to_ok string_opt)) + (game_controller @-> returning string_opt) +let game_controller_name c = game_controller_name c |> some_to_ok let game_controller_name_for_index = foreign "SDL_GameControllerNameForIndex" - (int @-> returning (some_to_ok string_opt)) + (int @-> returning string_opt) +let game_controller_name_for_index i = game_controller_name_for_index i |> some_to_ok let game_controller_num_mappings = foreign "SDL_GameControllerNumMappings" (void @-> returning int) let game_controller_open = foreign "SDL_GameControllerOpen" - (int @-> returning (some_to_ok game_controller_opt)) + (int @-> returning game_controller_opt) +let game_controller_open i = game_controller_open i |> some_to_ok let game_controller_update = foreign "SDL_GameControllerUpdate" (void @-> returning void) @@ -4621,10 +4682,10 @@ let pump_events = foreign "SDL_PumpEvents" (void @-> returning void) let push_event = - foreign "SDL_PushEvent" (ptr Event.t @-> returning bool_to_ok) + foreign "SDL_PushEvent" (ptr Event.t @-> returning int) let push_event e = - push_event (addr e) + push_event (addr e) |> bool_to_ok let register_events = foreign "SDL_RegisterEvents" (int @-> returning uint32_t) @@ -4983,47 +5044,56 @@ let haptic_destroy_effect = let haptic_effect_supported = foreign "SDL_HapticEffectSupported" - (haptic @-> ptr Haptic.Effect.t @-> returning bool_to_ok) + (haptic @-> ptr Haptic.Effect.t @-> returning int) let haptic_effect_supported h e = - haptic_effect_supported h (addr e) + haptic_effect_supported h (addr e) |> bool_to_ok let haptic_get_effect_status = foreign "SDL_HapticGetEffectStatus" - (haptic @-> haptic_effect_id @-> returning bool_to_ok) + (haptic @-> haptic_effect_id @-> returning int) +let haptic_get_effect_status h i = haptic_get_effect_status h i |> bool_to_ok let haptic_index = - foreign "SDL_HapticIndex" (haptic @-> returning nat_to_ok) + foreign "SDL_HapticIndex" (haptic @-> returning int) +let haptic_index h = haptic_index h |> nat_to_ok let haptic_name = - foreign "SDL_HapticName" (int @-> returning (some_to_ok string_opt)) + foreign "SDL_HapticName" (int @-> returning string_opt) +let haptic_name i = haptic_name i |> some_to_ok let haptic_new_effect = foreign "SDL_HapticNewEffect" - (haptic @-> ptr Haptic.Effect.t @-> returning nat_to_ok) + (haptic @-> ptr Haptic.Effect.t @-> returning int) let haptic_new_effect h e = - haptic_new_effect h (addr e) + haptic_new_effect h (addr e) |> nat_to_ok let haptic_num_axes = - foreign "SDL_HapticNumAxes" (haptic @-> returning nat_to_ok) + foreign "SDL_HapticNumAxes" (haptic @-> returning int) +let haptic_num_axes h = haptic_num_axes h |> nat_to_ok let haptic_num_effects = - foreign "SDL_HapticNumEffects" (haptic @-> returning nat_to_ok) + foreign "SDL_HapticNumEffects" (haptic @-> returning int) +let haptic_num_effects h = haptic_num_effects h |> nat_to_ok let haptic_num_effects_playing = - foreign "SDL_HapticNumEffectsPlaying" (haptic @-> returning nat_to_ok) + foreign "SDL_HapticNumEffectsPlaying" (haptic @-> returning int) +let haptic_num_effects_playing h = haptic_num_effects_playing h |> nat_to_ok let haptic_open = - foreign "SDL_HapticOpen" (int @-> returning (some_to_ok haptic_opt)) + foreign "SDL_HapticOpen" (int @-> returning haptic_opt) +let haptic_open i = haptic_open i |> some_to_ok let haptic_open_from_joystick = foreign "SDL_HapticOpenFromJoystick" - (joystick @-> returning (some_to_ok haptic_opt)) + (joystick @-> returning haptic_opt) +let haptic_open_from_joystick j = haptic_open_from_joystick j |> some_to_ok let haptic_open_from_mouse = foreign "SDL_HapticOpenFromMouse" - (void @-> returning (some_to_ok haptic_opt)) + (void @-> returning haptic_opt) +let haptic_open_from_mouse () = haptic_open_from_mouse () |> some_to_ok let haptic_opened = foreign "SDL_HapticOpened" (int @-> returning int) @@ -5032,81 +5102,98 @@ let haptic_opened i = match haptic_opened i with | 0 -> false | 1 -> true | _ -> assert false let haptic_pause = - foreign "SDL_HapticPause" (haptic @-> returning zero_to_ok) + foreign "SDL_HapticPause" (haptic @-> returning int) +let haptic_pause h = haptic_pause h |> zero_to_ok let haptic_query = foreign "SDL_HapticQuery" (haptic @-> returning int) let haptic_rumble_init = - foreign "SDL_HapticRumbleInit" (haptic @-> returning zero_to_ok) + foreign "SDL_HapticRumbleInit" (haptic @-> returning int) +let haptic_rumble_init h = haptic_rumble_init h |> zero_to_ok let haptic_rumble_play = foreign "SDL_HapticRumblePlay" - (haptic @-> float @-> int32_t @-> returning zero_to_ok) + (haptic @-> float @-> int32_t @-> returning int) +let haptic_rumble_play h x y = haptic_rumble_play h x y |> zero_to_ok let haptic_rumble_stop = - foreign "SDL_HapticRumbleStop" (haptic @-> returning zero_to_ok) + foreign "SDL_HapticRumbleStop" (haptic @-> returning int) +let haptic_rumble_stop h = haptic_rumble_stop h |> zero_to_ok let haptic_rumble_supported = - foreign "SDL_HapticRumbleSupported" (haptic @-> returning bool_to_ok) + foreign "SDL_HapticRumbleSupported" (haptic @-> returning int) +let haptic_rumble_supported h = haptic_rumble_supported h |> bool_to_ok let haptic_run_effect = foreign "SDL_HapticRunEffect" - (haptic @-> haptic_effect_id @-> int32_t @-> returning zero_to_ok) + (haptic @-> haptic_effect_id @-> int32_t @-> returning int) +let haptic_run_effect h i n = haptic_run_effect h i n |> zero_to_ok let haptic_set_autocenter = - foreign "SDL_HapticSetAutocenter" (haptic @-> int @-> returning zero_to_ok) + foreign "SDL_HapticSetAutocenter" (haptic @-> int @-> returning int) +let haptic_set_autocenter h n = haptic_set_autocenter h n |> zero_to_ok let haptic_set_gain = - foreign "SDL_HapticSetGain" (haptic @-> int @-> returning zero_to_ok) + foreign "SDL_HapticSetGain" (haptic @-> int @-> returning int) +let haptic_set_gain h n = haptic_set_gain h n |> zero_to_ok let haptic_stop_all = - foreign "SDL_HapticStopAll" (haptic @-> returning zero_to_ok) + foreign "SDL_HapticStopAll" (haptic @-> returning int) +let haptic_stop_all h = haptic_stop_all h |> zero_to_ok let haptic_stop_effect = foreign "SDL_HapticStopEffect" - (haptic @-> haptic_effect_id @-> returning zero_to_ok) + (haptic @-> haptic_effect_id @-> returning int) +let haptic_stop_effect h i = haptic_stop_effect h i |> zero_to_ok let haptic_unpause = - foreign "SDL_HapticUnpause" (haptic @-> returning zero_to_ok) + foreign "SDL_HapticUnpause" (haptic @-> returning int) +let haptic_unpause h = haptic_unpause h |> zero_to_ok let haptic_update_effect = foreign "SDL_HapticUpdateEffect" (haptic @-> haptic_effect_id @-> ptr Haptic.Effect.t @-> - returning zero_to_ok) + returning int) let haptic_update_effect h id e = - haptic_update_effect h id (addr e) + haptic_update_effect h id (addr e) |> zero_to_ok let joystick_is_haptic = foreign "SDL_JoystickIsHaptic" - (joystick @-> returning bool_to_ok) + (joystick @-> returning int) +let joystick_is_haptic j = joystick_is_haptic j |> bool_to_ok let mouse_is_haptic = - foreign "SDL_MouseIsHaptic" (void @-> returning bool_to_ok) + foreign "SDL_MouseIsHaptic" (void @-> returning int) +let mouse_is_haptic () = mouse_is_haptic () |> bool_to_ok let num_haptics = - foreign "SDL_NumHaptics" (void @-> returning nat_to_ok) + foreign "SDL_NumHaptics" (void @-> returning int) +let num_haptics () = num_haptics () |> nat_to_ok (* Audio *) (* Audio drivers *) let audio_init = - foreign "SDL_AudioInit" (string_opt @-> returning zero_to_ok) + foreign "SDL_AudioInit" (string_opt @-> returning int) +let audio_init s = audio_init s |> zero_to_ok let audio_quit = foreign "SDL_AudioQuit" (void @-> returning void) let get_audio_driver = foreign "SDL_GetAudioDriver" - (int @-> returning (some_to_ok string_opt)) + (int @-> returning string_opt) +let get_audio_driver i = get_audio_driver i |> some_to_ok let get_current_audio_driver = foreign "SDL_GetCurrentAudioDriver" (void @-> returning string_opt) let get_num_audio_drivers = - foreign "SDL_GetNumAudioDrivers" (void @-> returning nat_to_ok) + foreign "SDL_GetNumAudioDrivers" (void @-> returning int) +let get_num_audio_drivers () = get_num_audio_drivers () |> nat_to_ok (* Audio devices *) @@ -5221,25 +5308,27 @@ let free_wav ba = let get_audio_device_name = foreign "SDL_GetAudioDeviceName" - (int @-> bool @-> returning (some_to_ok string_opt)) + (int @-> bool @-> returning string_opt) +let get_audio_device_name i b = get_audio_device_name i b |> some_to_ok let get_audio_device_status = foreign "SDL_GetAudioDeviceStatus" (audio_device_id @-> returning int) let get_num_audio_devices = - foreign "SDL_GetNumAudioDevices" (bool @-> returning nat_to_ok) + foreign "SDL_GetNumAudioDevices" (bool @-> returning int) +let get_num_audio_devices b = get_num_audio_devices b |> nat_to_ok let load_wav_rw = foreign ~release_runtime_lock:true "SDL_LoadWAV_RW" (rw_ops @-> int @-> ptr audio_spec @-> ptr (ptr void) @-> ptr uint32_t @-> - returning (some_to_ok (ptr_opt audio_spec))) + returning (ptr_opt audio_spec)) let load_wav_rw ops spec kind = let d = allocate (ptr void) null in let len = allocate uint32_t Unsigned.UInt32.zero in match load_wav_rw ops 0 (addr (audio_spec_to_c spec)) d len with - | Error _ as e -> e - | Ok r -> + | None -> error () + | Some r -> let rspec = audio_spec_of_c (!@ r) in let kind_size = ba_kind_byte_size kind in let len = Unsigned.UInt32.to_int (!@ len) in @@ -5275,12 +5364,12 @@ let unlock_audio_device = let queue_audio = foreign "SDL_QueueAudio" - (audio_device_id @-> ptr void @-> int_as_uint32_t @-> returning zero_to_ok) + (audio_device_id @-> ptr void @-> int_as_uint32_t @-> returning int) let queue_audio dev ba = let len = Bigarray.Array1.dim ba in let kind_size = ba_kind_byte_size (Bigarray.Array1.kind ba) in - queue_audio dev (to_voidp (bigarray_start array1 ba)) (len * kind_size) + queue_audio dev (to_voidp (bigarray_start array1 ba)) (len * kind_size) |> zero_to_ok let dequeue_audio = foreign "SDL_DequeueAudio" @@ -5321,7 +5410,8 @@ let get_platform = foreign "SDL_GetPlatform" (void @-> returning string) let get_cpu_cache_line_size = - foreign "SDL_GetCPUCacheLineSize" (void @-> returning nat_to_ok) + foreign "SDL_GetCPUCacheLineSize" (void @-> returning int) +let get_cpu_cache_line_size () = get_cpu_cache_line_size () |> nat_to_ok let get_cpu_count = foreign "SDL_GetCPUCount" (void @-> returning int) From 1e026d5da9d19060308a428391953bf1b3433276 Mon Sep 17 00:00:00 2001 From: Pierre Boutillier Date: Mon, 3 Mar 2025 17:13:04 +0100 Subject: [PATCH 2/8] Please un-used variable compiler warning --- src/tsdl.ml | 48 ++++++++++++++++++++++---------------------- test/test_tsdl.ml | 8 ++++---- test/testing_tsdl.ml | 2 +- 3 files changed, 29 insertions(+), 29 deletions(-) diff --git a/src/tsdl.ml b/src/tsdl.ml index a93d835..1e0379c 100644 --- a/src/tsdl.ml +++ b/src/tsdl.ml @@ -17,7 +17,7 @@ open Tsdl_consts (* Formatting with continuation. *) let kpp k fmt = - let k fmt = k (Format.flush_str_formatter ()) in + let k _fmt = k (Format.flush_str_formatter ()) in Format.kfprintf k Format.str_formatter fmt (* Invalid_argument strings *) @@ -134,7 +134,7 @@ let ba_kind_byte_size : ('a, 'b) Bigarray.kind -> int = fun k -> | k when k = float64 || k = int64 || k = complex32 -> 8 | k when k = complex64 -> 16 | k when k = int || k = nativeint -> Sys.word_size / 8 - | k -> assert false + | _ -> assert false let access_ptr_typ_of_ba_kind : ('a, 'b) Bigarray.kind -> 'a ptr typ = fun k -> let open Bigarray in @@ -331,15 +331,15 @@ let rw_ops_struct : _rw_ops structure typ = structure "SDL_RWops" let rw_ops : _rw_ops structure ptr typ = ptr rw_ops_struct let rw_ops_opt : _rw_ops structure ptr option typ = ptr_opt rw_ops_struct -let rw_ops_size = field rw_ops_struct "size" +let _rw_ops_size = field rw_ops_struct "size" (funptr (rw_ops @-> returning int64_t)) -let rw_ops_seek = field rw_ops_struct "seek" +let _rw_ops_seek = field rw_ops_struct "seek" (funptr (rw_ops @-> int64_t @-> int @-> returning int64_t)) -let rw_ops_read = field rw_ops_struct "read" +let _rw_ops_read = field rw_ops_struct "read" (funptr (rw_ops @-> ptr void @-> size_t @-> size_t @-> returning size_t)) -let rw_ops_write = field rw_ops_struct "write" +let _rw_ops_write = field rw_ops_struct "write" (funptr (rw_ops @-> ptr void @-> size_t @-> size_t @-> returning size_t)) -let rw_ops_close = field rw_ops_struct "close" +let _rw_ops_close = field rw_ops_struct "close" (funptr (rw_ops @-> returning int)) let _ = field rw_ops_struct "type" uint32_t (* ... #ifdef'd union follows, we don't care we don't use Ctypes.make *) @@ -832,7 +832,7 @@ type _pixel_format type pixel_format_struct = _pixel_format structure let pixel_format_struct : pixel_format_struct typ = structure "SDL_PixelFormat" let pf_format = field pixel_format_struct "format" uint32_t -let pf_palette = field pixel_format_struct "palette" palette +let _pf_palette = field pixel_format_struct "palette" palette let pf_bits_per_pixel = field pixel_format_struct "BitsPerPixel" uint8_t let pf_bytes_per_pixel = field pixel_format_struct "BytesPerPixel" uint8_t let _ = field pixel_format_struct "padding" uint16_t @@ -2060,7 +2060,7 @@ let get_window_display_mode = let get_window_display_mode w = let mode = make display_mode in match get_window_display_mode w (addr mode) with - | 0 -> Ok (display_mode_of_c mode) | err -> error () + | 0 -> Ok (display_mode_of_c mode) | _err -> error () let get_window_flags = foreign "SDL_GetWindowFlags" (window @-> returning uint32_t) @@ -2348,7 +2348,7 @@ let gl_get_attribute = let gl_get_attribute att = let value = allocate int 0 in match gl_get_attribute att value with - | 0 -> Ok (!@ value) | err -> error () + | 0 -> Ok (!@ value) | _err -> error () let gl_get_current_context = foreign "SDL_GL_GetCurrentContext" @@ -3929,13 +3929,13 @@ module Event = struct let window_id = field t "windowID" int_as_uint32_t let state = field t "state" int_as_uint8_t let repeat = field t "repeat" int_as_uint8_t - let padding2 = field t "padding2" uint8_t - let padding3 = field t "padding3" uint8_t + let _padding2 = field t "padding2" uint8_t + let _padding3 = field t "padding3" uint8_t (* We inline the definition of SDL_Keysym *) let scancode = field t "scancode" scancode let keycode = field t "sym" keycode let keymod = field t "mod" keymod - let unused = field t "unused" uint32_t + let _unused = field t "unused" uint32_t let () = seal t end @@ -4159,9 +4159,9 @@ module Event = struct let _ = field t "timestamp" int32_as_uint32_t let window_id = field t "windowID" int_as_uint32_t let event = field t "event" int_as_uint8_t - let padding1 = field t "padding1" uint8_t - let padding2 = field t "padding2" uint8_t - let padding3 = field t "padding3" uint8_t + let _padding1 = field t "padding1" uint8_t + let _padding2 = field t "padding2" uint8_t + let _padding3 = field t "padding3" uint8_t let data1 = field t "data1" int32_t let data2 = field t "data2" int32_t let () = seal t @@ -4174,9 +4174,9 @@ module Event = struct let _ = field t "timestamp" int32_as_uint32_t let display = field t "display" int32_as_uint32_t let event = field t "event" int_as_uint8_t - let padding1 = field t "padding1" uint8_t - let padding2 = field t "padding2" uint8_t - let padding3 = field t "padding3" uint8_t + let _padding1 = field t "padding1" uint8_t + let _padding2 = field t "padding2" uint8_t + let _padding3 = field t "padding3" uint8_t let data1 = field t "data1" int32_t let () = seal t end @@ -4193,7 +4193,7 @@ module Event = struct type t let t : t union typ = union "SDL_Event" - let typ = field t "type" int_as_uint32_t + let _typ = field t "type" int_as_uint32_t let audio_device_event = field t "adevice" Audio_device_event.t let common = field t "common" Common.t let controller_axis_event = field t "caxis" Controller_axis_event.t @@ -4211,8 +4211,8 @@ module Event = struct let mouse_motion_event = field t "motion" Mouse_motion_event.t let mouse_wheel_event = field t "wheel" Mouse_wheel_event.t let multi_gesture_event = field t "mgesture" Multi_gesture_event.t - let quit_event = field t "quit" Quit_event.t - let sys_wm_event = field t "syswm" Sys_wm_event.t + let _quit_event = field t "quit" Quit_event.t + let _sys_wm_event = field t "syswm" Sys_wm_event.t let text_editing_event = field t "edit" Text_editing_event.t let text_input_event = field t "text" Text_input_event.t let touch_finger_event = field t "tfinger" Touch_finger_event.t @@ -4220,7 +4220,7 @@ module Event = struct let window_event = field t "window" Window_event.t let display_event = field t "display" Display_event.t let sensor_event = field t "sensor" Sensor_event.t - let padding = field t "padding" + let _padding = field t "padding" (abstract ~name:"padding" ~size:tsdl_sdl_event_size ~alignment:1) let () = seal t @@ -4891,7 +4891,7 @@ module Haptic = struct module Effect = struct type t let t : t union typ = union "SDL_HapticEffect" - let typ = field t "type" int_as_uint16_t + let _typ = field t "type" int_as_uint16_t let constant = field t "constant" Constant.t let periodic = field t "periodic" Periodic.t let condition = field t "condition" Condition.t diff --git a/test/test_tsdl.ml b/test/test_tsdl.ml index d1f969f..41d997e 100644 --- a/test/test_tsdl.ml +++ b/test/test_tsdl.ml @@ -260,7 +260,7 @@ let test_pixel_formats () = end; begin match Sdl.pixel_format_enum_to_masks Sdl.Pixel.format_argb8888 with | Error (`Msg e) -> log_err " Could not get pixel format masks: %s" e - | Ok (bpp, rm, gm, bm, am) -> + | Ok (_bpp, _rm, _gm, _bm, _am) -> let bpp', rm', gm', bm', am' = 32, 0x00FF0000l, 0x0000FF00l, 0x000000FFl, 0xFF000000l in @@ -437,7 +437,7 @@ let test_vsync r = let n = 100 in let threadfun () = let t0 = Sdl.get_ticks () in - for i = 1 to n do + for _ = 1 to n do Unix.sleepf 0.001; done; delta := Int32.sub (Sdl.get_ticks ()) t0; @@ -799,7 +799,7 @@ let test_displays () = begin match Sdl.get_num_display_modes d with | Error (`Msg e) -> log_err " Could not get number of display modes: %s" e - | Ok count -> + | Ok _count -> begin match Sdl.get_num_display_modes d with | Error (`Msg e) -> log_err " Could not get number of display modes: %s" e @@ -999,7 +999,7 @@ let test_opengl_contexts () = | Ok t -> begin match Sdl.gl_bind_texture t with | Error (`Msg e) -> log " Could not bind texture: %s" e - | Ok (w, h) -> + | Ok (_w, _h) -> (* FIXME: this segfaults in 2.0.1 see https://bugzilla.libsdl.org/show_bug.cgi?id=2296 *) (* assert (Sdl.gl_unbind_texture t = Ok ()); *) diff --git a/test/testing_tsdl.ml b/test/testing_tsdl.ml index 6b62084..8bb5ef2 100644 --- a/test/testing_tsdl.ml +++ b/test/testing_tsdl.ml @@ -230,7 +230,7 @@ let pp_window_event ppf e = Sdl.Event.(get e window_data1) Sdl.Event.(get e window_data2) -let cst s ppf e = pp ppf "%s" s +let cst s ppf _e = pp ppf "%s" s let event_pp e = try List.assoc (Sdl.Event.(get e typ)) [ Sdl.Event.app_did_enter_background, cst "app_did_enter_background"; From 1a6ffc57a47f21d45162394a57b9467f57c19b03 Mon Sep 17 00:00:00 2001 From: Pierre Boutillier Date: Tue, 10 Dec 2024 09:44:50 +0100 Subject: [PATCH 3/8] SDL_GetRevisionNumber is legacy --- CHANGES.md | 2 ++ src/tsdl.ml | 3 --- src/tsdl.mli | 8 +++----- test/test_tsdl.ml | 1 - 4 files changed, 5 insertions(+), 9 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 30db52c..51f32ff 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,7 @@ - Fix bug in `Message_box` color scheme handling. Thanks to Matthieu Dubuget for the patch (#105). +- Remove legacy function `get_revision_number` (`get_revision` should + be used instead). v1.1.0 2024-09-12 Zagreb ------------------------ diff --git a/src/tsdl.ml b/src/tsdl.ml index 1e0379c..edf51e3 100644 --- a/src/tsdl.ml +++ b/src/tsdl.ml @@ -321,9 +321,6 @@ let get_version () = let get_revision = foreign "SDL_GetRevision" (void @-> returning string) -let get_revision_number = - foreign "SDL_GetRevisionNumber" (void @-> returning int) - (* IO absraction *) type _rw_ops diff --git a/src/tsdl.mli b/src/tsdl.mli index 22e7085..82f2c70 100644 --- a/src/tsdl.mli +++ b/src/tsdl.mli @@ -292,10 +292,6 @@ val get_version : unit -> (int * int * int) val get_revision : unit -> string (** {{:http://wiki.libsdl.org/SDL2/SDL_GetRevision}SDL_GetRevision} *) -val get_revision_number : unit -> int -(** {{:http://wiki.libsdl.org/SDL2/SDL_GetRevisionNumber} - SDL_GetRevisionNumber} *) - (** {1:fileabstraction Files and IO abstraction} *) (** {2:io {{:https://wiki.libsdl.org/SDL2/CategoryIO}IO abstraction}} *) @@ -3987,7 +3983,9 @@ val get_power_info : unit -> power_info {- {{:http://wiki.libsdl.org/SDL2/SDL_PauseAudio}SDL_PauseAudio} (SDL legacy function)} {- {{:http://wiki.libsdl.org/SDL2/SDL_UnlockAudio}SDL_UnlockAudio} - (SDL legacy function)}} *) + (SDL legacy function)} + {- {{:http://wiki.libsdl.org/SDL2/SDL_GetRevisionNumber} + SDL_GetRevisionNumber} (SDL legacy function)}} *) end (** {1:conventions Binding conventions} diff --git a/test/test_tsdl.ml b/test/test_tsdl.ml index 41d997e..2f724ce 100644 --- a/test/test_tsdl.ml +++ b/test/test_tsdl.ml @@ -78,7 +78,6 @@ let test_version () = let min, maj, patch = Sdl.get_version () in log " Version: SDL %d.%d.%d" min maj patch; log " Revision: %s" (Sdl.get_revision ()); - log " Revision number: %d" (Sdl.get_revision_number ()); () let test_rw_ops () = From dbda5804594a082721b993ba60b02d1ac2aed8db Mon Sep 17 00:00:00 2001 From: Pierre Boutillier Date: Thu, 16 Jan 2025 14:31:06 +0100 Subject: [PATCH 4/8] Hardwired plumbing to generates types using cTypes.stubs --- _tags | 6 +- myocamlbuild.ml | 25 +- src/tsdl.ml | 3123 +++++++++++---------------------------- src/tsdl.mllib | 2 + src/type_description.ml | 1799 ++++++++++++++++++++++ support/consts_stub.c | 960 ------------ support/types_c_gen.ml | 11 + 7 files changed, 2734 insertions(+), 3192 deletions(-) create mode 100644 src/type_description.ml create mode 100644 support/types_c_gen.ml diff --git a/_tags b/_tags index 1ee7ea9..b188bb8 100644 --- a/_tags +++ b/_tags @@ -1,11 +1,15 @@ true: bin_annot, safe_string, thread <_b0> : -traverse : include + : include - : use_sdl2 + : use_sdl2 : custom, link_consts_stub + : package(ctypes.stubs) + : package(ctypes) : package(ctypes ctypes-foreign) + : package(ctypes) : sdl_consts : use_sdl2 : use_sdl2 diff --git a/myocamlbuild.ml b/myocamlbuild.ml index c686c66..cfc60a1 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -87,11 +87,34 @@ let sdl_consts_build () = end; ;; +let ctypes_stub_gen () = + (* 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:"support/%_stubs_gen" + ~prod:"src/%_stubs.ml" + (fun env _build -> Cmd (S[A (env "support/%_stubs_gen"); Sh">"; A (env "src/%_stubs.ml")])); + let () = dispatch begin function | After_rules -> lib_with_clib ~lib:"tsdl" ~clib:"sdl2" ~has_lib:"-DHAS_SDL2" ~src_dir:"src" ~stublib:"tsdl_stubs"; - sdl_consts_build () + sdl_consts_build (); + ctypes_stub_gen () | _ -> () end diff --git a/src/tsdl.ml b/src/tsdl.ml index edf51e3..79433b0 100644 --- a/src/tsdl.ml +++ b/src/tsdl.ml @@ -10,9 +10,7 @@ open Foreign module Sdl = struct -(* Enum cases and #ifdef'd constants, see support/ in the distribution *) - -open Tsdl_consts +module Types = Type_description.Types(Types_stubs) (* Formatting with continuation. *) @@ -167,15 +165,7 @@ module Init = struct let test f m = Unsigned.UInt32.(compare (logand f m) zero <> 0) let eq f f' = Unsigned.UInt32.(compare f f' = 0) let nothing = i 0 - let timer = i sdl_init_timer - let audio = i sdl_init_audio - let video = i sdl_init_video - let joystick = i sdl_init_joystick - let haptic = i sdl_init_haptic - let gamecontroller = i sdl_init_gamecontroller - let events = i sdl_init_events - let everything = i sdl_init_everything - let noparachute = i sdl_init_noparachute + include Types.Init end let init = @@ -203,29 +193,28 @@ let was_init = function module Hint = struct type t = string - let audio_resampling_mode = sdl_hint_audio_resampling_mode - let framebuffer_acceleration = sdl_hint_framebuffer_acceleration - let idle_timer_disabled = sdl_hint_idle_timer_disabled - let orientations = sdl_hint_orientations - let mouse_focus_clickthrough = sdl_hint_mouse_focus_clickthrough - let mouse_normal_speed_scale = sdl_hint_mouse_normal_speed_scale - let mouse_relative_speed_scale = sdl_hint_mouse_relative_speed_scale - let render_driver = sdl_hint_render_driver - let render_logical_size_mode = sdl_hint_render_logical_size_mode - let render_opengl_shaders = sdl_hint_render_opengl_shaders - let render_scale_quality = sdl_hint_render_scale_quality - let render_vsync = sdl_hint_render_vsync - let no_signal_handlers = sdl_hint_no_signal_handlers - let thread_stack_size = sdl_hint_thread_stack_size - let touch_mouse_events = sdl_hint_touch_mouse_events - let mouse_touch_events = sdl_hint_mouse_touch_events + let audio_resampling_mode = Tsdl_consts.sdl_hint_audio_resampling_mode + let framebuffer_acceleration = Tsdl_consts.sdl_hint_framebuffer_acceleration + let idle_timer_disabled = Tsdl_consts.sdl_hint_idle_timer_disabled + let orientations = Tsdl_consts.sdl_hint_orientations + let mouse_focus_clickthrough = Tsdl_consts.sdl_hint_mouse_focus_clickthrough + let mouse_normal_speed_scale = Tsdl_consts.sdl_hint_mouse_normal_speed_scale + let mouse_relative_speed_scale = Tsdl_consts.sdl_hint_mouse_relative_speed_scale + let render_driver = Tsdl_consts.sdl_hint_render_driver + let render_logical_size_mode = Tsdl_consts.sdl_hint_render_logical_size_mode + let render_opengl_shaders = Tsdl_consts.sdl_hint_render_opengl_shaders + let render_scale_quality = Tsdl_consts.sdl_hint_render_scale_quality + let render_vsync = Tsdl_consts.sdl_hint_render_vsync + let no_signal_handlers = Tsdl_consts.sdl_hint_no_signal_handlers + let thread_stack_size = Tsdl_consts.sdl_hint_thread_stack_size + let touch_mouse_events = Tsdl_consts.sdl_hint_touch_mouse_events + let mouse_touch_events = Tsdl_consts.sdl_hint_mouse_touch_events let window_frame_usable_while_cursor_hidden = - sdl_hint_window_frame_usable_while_cursor_hidden + Tsdl_consts.sdl_hint_window_frame_usable_while_cursor_hidden type priority = int - let default = sdl_hint_default - let normal = sdl_hint_normal - let override = sdl_hint_override + + include Types.Hint end let clear_hints = @@ -259,23 +248,10 @@ let set_error fmt = module Log = struct type category = int - let category_application = sdl_log_category_application - let category_error = sdl_log_category_error - let category_system = sdl_log_category_system - let category_audio = sdl_log_category_audio - let category_video = sdl_log_category_video - let category_render = sdl_log_category_render - let category_input = sdl_log_category_input - let category_custom = sdl_log_category_custom - type priority = int let priority_compare : int -> int -> int = compare - let priority_verbose = sdl_log_priority_verbose - let priority_debug = sdl_log_priority_debug - let priority_info = sdl_log_priority_info - let priority_warn = sdl_log_priority_warn - let priority_error = sdl_log_priority_error - let priority_critical = sdl_log_priority_critical + + include Types.Log end external log_message : int -> int -> string -> unit = "ocaml_tsdl_log_message" @@ -303,69 +279,46 @@ let log_set_priority = (* Version *) -let version = structure "SDL_version" -let version_major = field version "major" uint8_t -let version_minor = field version "minor" uint8_t -let version_patch = field version "patch" uint8_t -let () = seal version - let get_version = - foreign "SDL_GetVersion" (ptr version @-> returning void) + foreign "SDL_GetVersion" (ptr Types.version @-> returning void) let get_version () = let get v f = Unsigned.UInt8.to_int (getf v f) in - let v = make version in + let v = make Types.version in get_version (addr v); - (get v version_major), (get v version_minor), (get v version_patch) + (get v Types.version_major), + (get v Types.version_minor), + (get v Types.version_patch) let get_revision = foreign "SDL_GetRevision" (void @-> returning string) (* IO absraction *) -type _rw_ops -let rw_ops_struct : _rw_ops structure typ = structure "SDL_RWops" -let rw_ops : _rw_ops structure ptr typ = ptr rw_ops_struct -let rw_ops_opt : _rw_ops structure ptr option typ = ptr_opt rw_ops_struct - -let _rw_ops_size = field rw_ops_struct "size" - (funptr (rw_ops @-> returning int64_t)) -let _rw_ops_seek = field rw_ops_struct "seek" - (funptr (rw_ops @-> int64_t @-> int @-> returning int64_t)) -let _rw_ops_read = field rw_ops_struct "read" - (funptr (rw_ops @-> ptr void @-> size_t @-> size_t @-> returning size_t)) -let _rw_ops_write = field rw_ops_struct "write" - (funptr (rw_ops @-> ptr void @-> size_t @-> size_t @-> returning size_t)) -let _rw_ops_close = field rw_ops_struct "close" - (funptr (rw_ops @-> returning int)) -let _ = field rw_ops_struct "type" uint32_t -(* ... #ifdef'd union follows, we don't care we don't use Ctypes.make *) -let () = seal rw_ops_struct - -type rw_ops = _rw_ops structure ptr +type rw_ops = Types.rw_ops let load_file_rw = foreign "SDL_LoadFile_RW" - (rw_ops @-> ptr int @-> bool @-> returning string_opt) + (Types.rw_ops @-> ptr int @-> bool @-> returning string_opt) let load_file_rw rw_ops close = load_file_rw rw_ops (coerce (ptr void) (ptr int) null) close |> some_to_ok let rw_from_file = foreign "SDL_RWFromFile" - (string @-> string @-> returning rw_ops_opt) + (string @-> string @-> returning Types.rw_ops_opt) let rw_from_file x y = rw_from_file x y |> some_to_ok let rw_from_const_mem = foreign "SDL_RWFromConstMem" - (ocaml_string @-> int @-> returning rw_ops_opt) + (ocaml_string @-> int @-> returning Types.rw_ops_opt) let rw_from_const_mem str = rw_from_const_mem (ocaml_string_start str) (String.length str) |> some_to_ok let rw_from_mem = foreign "SDL_RWFromMem" - (ocaml_bytes @-> int @-> returning rw_ops_opt) + (ocaml_bytes @-> int @-> returning Types.rw_ops_opt) let rw_from_mem b = rw_from_mem (ocaml_bytes_start b) (Bytes.length b) |> some_to_ok @@ -376,13 +329,13 @@ let load_file filename = (* defined as a macro in SDL_rwops.h *) | Ok rw -> load_file_rw rw true let rw_close = - foreign "SDL_RWclose" (rw_ops @-> returning int) + foreign "SDL_RWclose" (Types.rw_ops @-> returning int) let rw_close ops = if rw_close ops = 0 then Ok () else (error ()) -let unsafe_rw_ops_of_ptr addr : rw_ops = - from_voidp rw_ops_struct (ptr_of_raw_address addr) +let unsafe_rw_ops_of_ptr addr : Types.rw_ops = + from_voidp Types.rw_ops_struct (ptr_of_raw_address addr) let unsafe_ptr_of_rw_ops rw_ops = raw_address_of_ptr (to_voidp rw_ops) @@ -408,229 +361,190 @@ let get_pref_path ~org ~app = (* Video *) -type window = unit ptr -let window : window typ = ptr void -let window_opt : window option typ = ptr_opt void +type window = Types.Window.t let unsafe_window_of_ptr addr : window = - ptr_of_raw_address addr + from_voidp Types.Window.raw (ptr_of_raw_address addr) let unsafe_ptr_of_window window = raw_address_of_ptr (to_voidp window) (* Colors *) -type _color -type color = _color structure -let color : color typ = structure "SDL_Color" -let color_r = field color "r" uint8_t -let color_g = field color "g" uint8_t -let color_b = field color "b" uint8_t -let color_a = field color "a" uint8_t -let () = seal color +type color = Types.Color.t module Color = struct let create ~r ~g ~b ~a = - let c = make color in - setf c color_r (Unsigned.UInt8.of_int r); - setf c color_g (Unsigned.UInt8.of_int g); - setf c color_b (Unsigned.UInt8.of_int b); - setf c color_a (Unsigned.UInt8.of_int a); + let c = make Types.Color.t in + setf c Types.Color.r (Unsigned.UInt8.of_int r); + setf c Types.Color.g (Unsigned.UInt8.of_int g); + setf c Types.Color.b (Unsigned.UInt8.of_int b); + setf c Types.Color.a (Unsigned.UInt8.of_int a); c - let r c = Unsigned.UInt8.to_int (getf c color_r) - let g c = Unsigned.UInt8.to_int (getf c color_g) - let b c = Unsigned.UInt8.to_int (getf c color_b) - let a c = Unsigned.UInt8.to_int (getf c color_a) + let r c = Unsigned.UInt8.to_int (getf c Types.Color.r) + let g c = Unsigned.UInt8.to_int (getf c Types.Color.g) + let b c = Unsigned.UInt8.to_int (getf c Types.Color.b) + let a c = Unsigned.UInt8.to_int (getf c Types.Color.a) - let set_r c r = setf c color_r (Unsigned.UInt8.of_int r) - let set_g c g = setf c color_g (Unsigned.UInt8.of_int g) - let set_b c b = setf c color_b (Unsigned.UInt8.of_int b) - let set_a c a = setf c color_a (Unsigned.UInt8.of_int a) + let set_r c r = setf c Types.Color.r (Unsigned.UInt8.of_int r) + let set_g c g = setf c Types.Color.g (Unsigned.UInt8.of_int g) + let set_b c b = setf c Types.Color.b (Unsigned.UInt8.of_int b) + let set_a c a = setf c Types.Color.a (Unsigned.UInt8.of_int a) end (* Points *) -type _point -type point = _point structure -let point : point typ = structure "SDL_Point" -let point_x = field point "x" int -let point_y = field point "y" int -let () = seal point +type point = Types.Point.t module Point = struct let create ~x ~y = - let p = make point in - setf p point_x x; - setf p point_y y; + let p = make Types.Point.t in + setf p Types.Point.x x; + setf p Types.Point.y y; p - let x p = getf p point_x - let y p = getf p point_y + let x p = getf p Types.Point.x + let y p = getf p Types.Point.y - let set_x p x = setf p point_x x - let set_y p y = setf p point_y y + let set_x p x = setf p Types.Point.x x + let set_y p y = setf p Types.Point.y y let opt_addr = function - | None -> coerce (ptr void) (ptr point) null + | None -> coerce (ptr void) (ptr Types.Point.t) null | Some v -> addr v end (* Float Points *) -type _fpoint -type fpoint = _fpoint structure -let fpoint : fpoint typ = structure "SDL_FPoint" -let fpoint_x = field fpoint "x" float -let fpoint_y = field fpoint "y" float -let () = seal fpoint +type fpoint = Types.Fpoint.t module Fpoint = struct let create ~x ~y = - let p = make fpoint in - setf p fpoint_x x; - setf p fpoint_y y; + let p = make Types.Fpoint.t in + setf p Types.Fpoint.x x; + setf p Types.Fpoint.y y; p - let x p = getf p fpoint_x - let y p = getf p fpoint_y + let x p = getf p Types.Fpoint.x + let y p = getf p Types.Fpoint.y - let set_x p x = setf p fpoint_x x - let set_y p y = setf p fpoint_y y + let set_x p x = setf p Types.Fpoint.x x + let set_y p y = setf p Types.Fpoint.y y end (* Vertices *) -type _vertex -type vertex = _vertex structure -let vertex : vertex typ = structure "SDL_Vertex" -let vertex_position = field vertex "position" fpoint -let vertex_color = field vertex "color" color -let vertex_tex_coord = field vertex "tex_coord" fpoint -let () = seal vertex +type vertex = Types.Vertex.t module Vertex = struct let create ~position ~color ~tex_coord = - let v = make vertex in - setf v vertex_position position; - setf v vertex_color color; - setf v vertex_tex_coord tex_coord; + let v = make Types.Vertex.t in + setf v Types.Vertex.position position; + setf v Types.Vertex.color color; + setf v Types.Vertex.tex_coord tex_coord; v - let position v = getf v vertex_position - let color v = getf v vertex_color - let tex_coord v = getf v vertex_tex_coord + let position v = getf v Types.Vertex.position + let color v = getf v Types.Vertex.color + let tex_coord v = getf v Types.Vertex.tex_coord - let set_position v position = setf v vertex_position position - let set_color v color = setf v vertex_color color - let set_tex_coord v tex_coord = setf v vertex_tex_coord tex_coord + let set_position v position = setf v Types.Vertex.position position + let set_color v color = setf v Types.Vertex.color color + let set_tex_coord v tex_coord = setf v Types.Vertex.tex_coord tex_coord end (* Rectangle *) -type _rect -type rect = _rect structure -let rect : rect typ = structure "SDL_Rect" -let rect_x = field rect "x" int -let rect_y = field rect "y" int -let rect_w = field rect "w" int -let rect_h = field rect "h" int -let () = seal rect +type rect = Types.Rect.t module Rect = struct let create ~x ~y ~w ~h = - let r = make rect in - setf r rect_x x; - setf r rect_y y; - setf r rect_w w; - setf r rect_h h; + let r = make Types.Rect.t in + setf r Types.Rect.x x; + setf r Types.Rect.y y; + setf r Types.Rect.w w; + setf r Types.Rect.h h; r - let x r = getf r rect_x - let y r = getf r rect_y - let w r = getf r rect_w - let h r = getf r rect_h + let x r = getf r Types.Rect.x + let y r = getf r Types.Rect.y + let w r = getf r Types.Rect.w + let h r = getf r Types.Rect.h - let set_x r x = setf r rect_x x - let set_y r y = setf r rect_y y - let set_w r w = setf r rect_w w - let set_h r h = setf r rect_h h + let set_x r x = setf r Types.Rect.x x + let set_y r y = setf r Types.Rect.y y + let set_w r w = setf r Types.Rect.w w + let set_h r h = setf r Types.Rect.h h let opt_addr = function - | None -> coerce (ptr void) (ptr rect) null + | None -> coerce (ptr void) (ptr Types.Rect.t) null | Some v -> addr v end (* Float Rectangle *) -type _frect -type frect = _frect structure -let frect : frect typ = structure "SDL_FRect" -let frect_x = field frect "x" float -let frect_y = field frect "y" float -let frect_w = field frect "w" float -let frect_h = field frect "h" float -let () = seal frect +type frect = Types.Frect.t module Frect = struct let create ~x ~y ~w ~h = - let r = make frect in - setf r frect_x x; - setf r frect_y y; - setf r frect_w w; - setf r frect_h h; + let r = make Types.Frect.t in + setf r Types.Frect.x x; + setf r Types.Frect.y y; + setf r Types.Frect.w w; + setf r Types.Frect.h h; r - let x r = getf r frect_x - let y r = getf r frect_y - let w r = getf r frect_w - let h r = getf r frect_h + let x r = getf r Types.Frect.x + let y r = getf r Types.Frect.y + let w r = getf r Types.Frect.w + let h r = getf r Types.Frect.h - let set_x r x = setf r frect_x x - let set_y r y = setf r frect_y y - let set_w r w = setf r frect_w w - let set_h r h = setf r frect_h h + let set_x r x = setf r Types.Frect.x x + let set_y r y = setf r Types.Frect.y y + let set_w r w = setf r Types.Frect.w w + let set_h r h = setf r Types.Frect.h h end let enclose_points = foreign "SDL_EnclosePoints" - (ptr void @-> int @-> ptr rect @-> ptr rect @-> returning bool) + (ptr void @-> int @-> ptr Types.Rect.t @-> ptr Types.Rect.t @-> returning bool) let enclose_points_ba ?clip ps = let len = Bigarray.Array1.dim ps in if len mod 2 <> 0 then invalid_arg (err_length_mul len 2) else let count = len / 2 in let ps = to_voidp (bigarray_start array1 ps) in - let res = make rect in + let res = make Types.Rect.t in if enclose_points ps count (Rect.opt_addr clip) (addr res) then Some res else None let enclose_points ?clip ps = - let a = CArray.of_list point ps in + let a = CArray.of_list Types.Point.t ps in let ps = to_voidp (CArray.start a) in - let res = make rect in + let res = make Types.Rect.t in if enclose_points ps (CArray.length a) (Rect.opt_addr clip) (addr res) then Some res else None let has_intersection = foreign "SDL_HasIntersection" - (ptr rect @-> ptr rect @-> returning bool) + (ptr Types.Rect.t @-> ptr Types.Rect.t @-> returning bool) let has_intersection a b = has_intersection (addr a) (addr b) let intersect_rect = foreign "SDL_IntersectRect" - (ptr rect @-> ptr rect @-> ptr rect @-> returning bool) + (ptr Types.Rect.t @-> ptr Types.Rect.t @-> ptr Types.Rect.t @-> returning bool) let intersect_rect a b = - let res = make rect in + let res = make Types.Rect.t in if intersect_rect (addr a) (addr b) (addr res) then Some res else None let intersect_rect_and_line = foreign "SDL_IntersectRectAndLine" - (ptr rect @-> ptr int @-> ptr int @-> ptr int @-> ptr int @-> + (ptr Types.Rect.t @-> ptr int @-> ptr int @-> ptr int @-> ptr int @-> returning bool) let intersect_rect_and_line r x1 y1 x2 y2 = @@ -662,64 +576,53 @@ let rect_equals a b = let union_rect = foreign "SDL_UnionRect" - (ptr rect @-> ptr rect @-> ptr rect @-> returning void) + (ptr Types.Rect.t @-> ptr Types.Rect.t @-> ptr Types.Rect.t @-> returning void) let union_rect a b = - let res = make rect in + let res = make Types.Rect.t in union_rect (addr a) (addr b) (addr res); res (* Palettes *) -type _palette -type palette_struct = _palette structure -let palette_struct : palette_struct typ = structure "SDL_Palette" -let palette_ncolors = field palette_struct "ncolors" int -let palette_colors = field palette_struct "colors" (ptr color) -let _ = field palette_struct "version" uint32_t -let _ = field palette_struct "refcount" int -let () = seal palette_struct - -type palette = palette_struct ptr -let palette : palette typ = ptr palette_struct -let palette_opt : palette option typ = ptr_opt palette_struct +type palette = Types.palette ptr let unsafe_palette_of_ptr addr : palette = - from_voidp palette_struct (ptr_of_raw_address addr) + from_voidp Types.palette (ptr_of_raw_address addr) let unsafe_ptr_of_palette palette = raw_address_of_ptr (to_voidp palette) let alloc_palette = foreign "SDL_AllocPalette" - (int @-> returning palette_opt) + (int @-> returning (ptr_opt Types.palette)) let alloc_palette x = alloc_palette x |> some_to_ok let free_palette = - foreign "SDL_FreePalette" (palette @-> returning void) + foreign "SDL_FreePalette" (ptr Types.palette @-> returning void) let get_palette_ncolors p = - getf (!@ p) palette_ncolors + getf (!@ p) Types.palette_ncolors let get_palette_colors p = let ps = !@ p in CArray.to_list - (CArray.from_ptr (getf ps palette_colors) (getf ps palette_ncolors)) + (CArray.from_ptr (getf ps Types.palette_colors) (getf ps Types.palette_ncolors)) let get_palette_colors_ba p = let ps = !@ p in (* FIXME: ctypes should have a CArray.copy function *) - let n = getf ps palette_ncolors in + let n = getf ps Types.palette_ncolors in let ba = Bigarray.(Array1.create int8_unsigned c_layout (n * 4)) in let ba_ptr = - CArray.from_ptr (coerce (ptr int) (ptr color) (bigarray_start array1 ba)) n + CArray.from_ptr (coerce (ptr int) (ptr Types.Color.t) (bigarray_start array1 ba)) n in - let ca = CArray.from_ptr (getf ps palette_colors) n in + let ca = CArray.from_ptr (getf ps Types.palette_colors) n in for i = 0 to n - 1 do CArray.set ba_ptr i (CArray.get ca i) done; ba let set_palette_colors = foreign "SDL_SetPaletteColors" - (palette @-> ptr void @-> int @-> int @-> returning int) + (ptr Types.palette @-> ptr void @-> int @-> int @-> returning int) let set_palette_colors x y z t = set_palette_colors x y z t |> zero_to_ok let set_palette_colors_ba p cs ~fst = @@ -730,7 +633,7 @@ let set_palette_colors_ba p cs ~fst = set_palette_colors p cs fst count let set_palette_colors p cs ~fst = - let a = CArray.of_list color cs in + let a = CArray.of_list Types.Color.t cs in set_palette_colors p (to_voidp (CArray.start a)) fst (CArray.length a) (* Pixel formats *) @@ -747,31 +650,9 @@ let calculate_gamma_ramp g = ba module Blend = struct - type mode = Unsigned.UInt.t - let mode_none = Unsigned.UInt.of_int sdl_blendmode_none - let mode_blend = Unsigned.UInt.of_int sdl_blendmode_blend - let mode_add = Unsigned.UInt.of_int sdl_blendmode_add - let mode_mod = Unsigned.UInt.of_int sdl_blendmode_mod - - type operation = int - let add = sdl_blendoperation_add - let subtract = sdl_blendoperation_subtract - let rev_subtract = sdl_blendoperation_rev_subtract - let minimum = sdl_blendoperation_minimum - let maximum = sdl_blendoperation_maximum - type factor = int - let zero = sdl_blendfactor_zero - let one = sdl_blendfactor_one - let src_color = sdl_blendfactor_src_color - let one_minus_src_color = sdl_blendfactor_one_minus_src_color - let src_alpha = sdl_blendfactor_src_alpha - let one_minus_src_alpha = sdl_blendfactor_one_minus_src_alpha - let dst_color = sdl_blendfactor_dst_color - let one_minus_dst_color = sdl_blendfactor_one_minus_dst_color - let dst_alpha = sdl_blendfactor_dst_alpha - let one_minus_dst_alpha = sdl_blendfactor_one_minus_dst_alpha - + type operation = int + include Types.Blend end let compose_custom_blend_mode = @@ -783,104 +664,43 @@ module Pixel = struct let i = Unsigned.UInt32.of_int32 let to_uint32 = Unsigned.UInt32.to_int32 let eq f f' = Unsigned.UInt32.(compare f f' = 0) - let format_unknown = i sdl_pixelformat_unknown - let format_index1lsb = i sdl_pixelformat_index1lsb - let format_index1msb = i sdl_pixelformat_index1msb - let format_index4lsb = i sdl_pixelformat_index4lsb - let format_index4msb = i sdl_pixelformat_index4msb - let format_index8 = i sdl_pixelformat_index8 - let format_rgb332 = i sdl_pixelformat_rgb332 - let format_rgb444 = i sdl_pixelformat_rgb444 - let format_rgb555 = i sdl_pixelformat_rgb555 - let format_bgr555 = i sdl_pixelformat_bgr555 - let format_argb4444 = i sdl_pixelformat_argb4444 - let format_rgba4444 = i sdl_pixelformat_rgba4444 - let format_abgr4444 = i sdl_pixelformat_abgr4444 - let format_bgra4444 = i sdl_pixelformat_bgra4444 - let format_argb1555 = i sdl_pixelformat_argb1555 - let format_rgba5551 = i sdl_pixelformat_rgba5551 - let format_abgr1555 = i sdl_pixelformat_abgr1555 - let format_bgra5551 = i sdl_pixelformat_bgra5551 - let format_rgb565 = i sdl_pixelformat_rgb565 - let format_bgr565 = i sdl_pixelformat_bgr565 - let format_rgb24 = i sdl_pixelformat_rgb24 - let format_bgr24 = i sdl_pixelformat_bgr24 - let format_rgb888 = i sdl_pixelformat_rgb888 - let format_rgbx8888 = i sdl_pixelformat_rgbx8888 - let format_bgr888 = i sdl_pixelformat_bgr888 - let format_bgrx8888 = i sdl_pixelformat_bgrx8888 - let format_argb8888 = i sdl_pixelformat_argb8888 - let format_rgba8888 = i sdl_pixelformat_rgba8888 - let format_abgr8888 = i sdl_pixelformat_abgr8888 - let format_bgra8888 = i sdl_pixelformat_bgra8888 - let format_argb2101010 = i sdl_pixelformat_argb2101010 - let format_yv12 = i sdl_pixelformat_yv12 - let format_iyuv = i sdl_pixelformat_iyuv - let format_yuy2 = i sdl_pixelformat_yuy2 - let format_uyvy = i sdl_pixelformat_uyvy - let format_yvyu = i sdl_pixelformat_yvyu + include Types.Pixel end (* Note. Giving direct access to the palette field of SDL_PixelFormat is problematic. We can't ensure the pointer won't become invalid at a certain point. *) -type _pixel_format -type pixel_format_struct = _pixel_format structure -let pixel_format_struct : pixel_format_struct typ = structure "SDL_PixelFormat" -let pf_format = field pixel_format_struct "format" uint32_t -let _pf_palette = field pixel_format_struct "palette" palette -let pf_bits_per_pixel = field pixel_format_struct "BitsPerPixel" uint8_t -let pf_bytes_per_pixel = field pixel_format_struct "BytesPerPixel" uint8_t -let _ = field pixel_format_struct "padding" uint16_t -let _ = field pixel_format_struct "Rmask" uint32_t -let _ = field pixel_format_struct "Gmask" uint32_t -let _ = field pixel_format_struct "Bmask" uint32_t -let _ = field pixel_format_struct "Amask" uint32_t -let _ = field pixel_format_struct "Rloss" uint8_t -let _ = field pixel_format_struct "Gloss" uint8_t -let _ = field pixel_format_struct "Bloss" uint8_t -let _ = field pixel_format_struct "Aloss" uint8_t -let _ = field pixel_format_struct "Rshift" uint8_t -let _ = field pixel_format_struct "Gshift" uint8_t -let _ = field pixel_format_struct "Bshift" uint8_t -let _ = field pixel_format_struct "Ashift" uint8_t -let _ = field pixel_format_struct "refcount" int -let _ = field pixel_format_struct "next" (ptr pixel_format_struct) -let () = seal pixel_format_struct - -type pixel_format = pixel_format_struct ptr -let pixel_format : pixel_format typ = ptr pixel_format_struct -let pixel_format_opt : pixel_format option typ = ptr_opt pixel_format_struct +type pixel_format = Types.pixel_format ptr let unsafe_pixel_format_of_ptr addr : pixel_format = - from_voidp pixel_format_struct (ptr_of_raw_address addr) + from_voidp Types.pixel_format (ptr_of_raw_address addr) let unsafe_ptr_of_pixel_format pixel_format = raw_address_of_ptr (to_voidp pixel_format) let alloc_format = foreign "SDL_AllocFormat" - (uint32_t @-> returning pixel_format_opt) + (uint32_t @-> returning (ptr_opt Types.pixel_format)) let alloc_format x = alloc_format x |> some_to_ok let free_format = - foreign "SDL_FreeFormat" (pixel_format @-> returning void) + foreign "SDL_FreeFormat" (ptr Types.pixel_format @-> returning void) let get_pixel_format_name = foreign "SDL_GetPixelFormatName" (uint32_t @-> returning string) let get_pixel_format_format pf = - getf (!@ pf) pf_format + getf (!@ pf) Types.pf_format let get_pixel_format_bits_pp pf = - Unsigned.UInt8.to_int (getf (!@ pf) pf_bits_per_pixel) + Unsigned.UInt8.to_int (getf (!@ pf) Types.pf_bits_per_pixel) let get_pixel_format_bytes_pp pf = - Unsigned.UInt8.to_int (getf (!@ pf) pf_bytes_per_pixel) + Unsigned.UInt8.to_int (getf (!@ pf) Types.pf_bytes_per_pixel) let get_rgb = foreign "SDL_GetRGB" - (int32_as_uint32_t @-> pixel_format @-> ptr uint8_t @-> + (int32_as_uint32_t @-> ptr Types.pixel_format @-> ptr uint8_t @-> ptr uint8_t @-> ptr uint8_t @-> returning void) let get_rgb pf p = @@ -892,7 +712,7 @@ let get_rgb pf p = let get_rgba = foreign "SDL_GetRGBA" - (int32_as_uint32_t @-> pixel_format @-> ptr uint8_t @-> + (int32_as_uint32_t @-> ptr Types.pixel_format @-> ptr uint8_t @-> ptr uint8_t @-> ptr uint8_t @-> ptr uint8_t @-> returning void) let get_rgba pf p = @@ -904,12 +724,12 @@ let get_rgba pf p = let map_rgb = foreign "SDL_MapRGB" - (pixel_format @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> + (ptr Types.pixel_format @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> returning int32_as_uint32_t) let map_rgba = foreign "SDL_MapRGBA" - (pixel_format @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> + (ptr Types.pixel_format @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> returning int32_as_uint32_t) let masks_to_pixel_format_enum = @@ -933,41 +753,24 @@ let pixel_format_enum_to_masks pf = let set_pixel_format_palette = foreign "SDL_SetPixelFormatPalette" - (pixel_format @-> palette @-> returning int) + (ptr Types.pixel_format @-> ptr Types.palette @-> returning int) let set_pixel_format_palette x y = set_pixel_format_palette x y |> zero_to_ok (* Surface *) -type _surface -type surface_struct = _surface structure -let surface_struct : surface_struct typ = structure "SDL_Surface" -let _ = field surface_struct "flags" uint32_t -let surface_format = field surface_struct "format" pixel_format -let surface_w = field surface_struct "w" int -let surface_h = field surface_struct "h" int -let surface_pitch = field surface_struct "pitch" int -let surface_pixels = field surface_struct "pixels" (ptr void) -let _ = field surface_struct "userdata" (ptr void) -let _ = field surface_struct "locked" int -let _ = field surface_struct "list_blitmap" (ptr void) -let _ = field surface_struct "clip_rect" rect -let _ = field surface_struct "map" (ptr void) -let _ = field surface_struct "refcount" int -let () = seal surface_struct - -type surface = surface_struct ptr -let surface : surface typ = ptr surface_struct -let surface_opt : surface option typ = ptr_opt surface_struct +type surface = Types.surface ptr +let surface : surface typ = ptr Types.surface +let surface_opt : surface option typ = ptr_opt Types.surface let unsafe_surface_of_ptr addr : surface = - from_voidp surface_struct (ptr_of_raw_address addr) + from_voidp Types.surface (ptr_of_raw_address addr) let unsafe_ptr_of_surface surface = raw_address_of_ptr (to_voidp surface) let blit_scaled = (* SDL_BlitScaled is #ifdef'd to SDL_UpperBlitScaled *) foreign "SDL_UpperBlitScaled" - (surface @-> ptr rect @-> surface @-> ptr rect @-> returning int) + (surface @-> ptr Types.Rect.t @-> surface @-> ptr Types.Rect.t @-> returning int) let blit_scaled ~src sr ~dst dr = blit_scaled src (Rect.opt_addr sr) dst (Rect.opt_addr dr) |> zero_to_ok @@ -975,7 +778,7 @@ let blit_scaled ~src sr ~dst dr = let blit_surface = (* SDL_BlitSurface is #ifdef'd to SDL_UpperBlit *) foreign "SDL_UpperBlit" - (surface @-> ptr rect @-> surface @-> ptr rect @-> returning int) + (surface @-> ptr Types.Rect.t @-> surface @-> ptr Types.Rect.t @-> returning int) let blit_surface ~src sr ~dst dr = blit_surface src (Rect.opt_addr sr) dst (Rect.opt_addr dr) |> zero_to_ok @@ -995,7 +798,7 @@ let convert_pixels ~w ~h ~src sp spitch ~dst dp dpitch = let convert_surface = foreign "SDL_ConvertSurface" - (surface @-> pixel_format @-> uint32_t @-> + (surface @-> ptr Types.pixel_format @-> uint32_t @-> returning surface_opt) let convert_surface s pf = @@ -1053,7 +856,7 @@ let duplicate_surface = let fill_rect = foreign "SDL_FillRect" - (surface @-> ptr rect @-> int32_as_uint32_t @-> returning int) + (surface @-> ptr Types.Rect.t @-> int32_as_uint32_t @-> returning int) let fill_rect s r c = fill_rect s (Rect.opt_addr r) c |> zero_to_ok @@ -1071,17 +874,17 @@ let fill_rects_ba s rs col = fill_rects s rs count col |> zero_to_ok let fill_rects s rs col = - let a = CArray.of_list rect rs in + let a = CArray.of_list Types.Rect.t rs in fill_rects s (to_voidp (CArray.start a)) (CArray.length a) col |> zero_to_ok let free_surface = foreign "SDL_FreeSurface" (surface @-> returning void) let get_clip_rect = - foreign "SDL_GetClipRect" (surface @-> ptr rect @-> returning void) + foreign "SDL_GetClipRect" (surface @-> ptr Types.Rect.t @-> returning void) let get_clip_rect s = - let r = make rect in + let r = make Types.Rect.t in (get_clip_rect s (addr r); r) let get_color_key = @@ -1126,10 +929,10 @@ let get_surface_color_mod s = let get_surface_format_enum s = (* We don't give direct access to the format field. This prevents memory ownership problems. *) - get_pixel_format_format (getf (!@ s) surface_format) + get_pixel_format_format (getf (!@ s) Types.surface_format) let get_surface_pitch s = - getf (!@ s) surface_pitch + getf (!@ s) Types.surface_pitch let get_surface_pixels s kind = let pitch = get_surface_pitch s in @@ -1137,18 +940,18 @@ let get_surface_pixels s kind = if pitch mod kind_size <> 0 then invalid_arg (err_bigarray_pitch pitch kind_size) else - let h = getf (!@ s) surface_h in + let h = getf (!@ s) Types.surface_h in let ba_size = (pitch * h) / kind_size in - let pixels = getf (!@ s) surface_pixels in + let pixels = getf (!@ s) Types.surface_pixels in let pixels = coerce (ptr void) (access_ptr_typ_of_ba_kind kind) pixels in bigarray_of_ptr array1 ba_size kind pixels let get_surface_size s = - getf (!@ s) surface_w, getf (!@ s) surface_h + getf (!@ s) Types.surface_w, getf (!@ s) Types.surface_h let load_bmp_rw = foreign "SDL_LoadBMP_RW" - (rw_ops @-> bool @-> returning surface_opt) + (Types.rw_ops @-> bool @-> returning surface_opt) let load_bmp_rw rw ~close = load_bmp_rw rw close |> some_to_ok @@ -1165,21 +968,21 @@ let lock_surface x = lock_surface x |> zero_to_ok let lower_blit = foreign "SDL_LowerBlit" - (surface @-> ptr rect @-> surface @-> ptr rect @-> returning int) + (surface @-> ptr Types.Rect.t @-> surface @-> ptr Types.Rect.t @-> returning int) let lower_blit ~src sr ~dst dr = lower_blit src (addr sr) dst (addr dr) |> zero_to_ok let lower_blit_scaled = foreign "SDL_LowerBlitScaled" - (surface @-> ptr rect @-> surface @-> ptr rect @-> returning int) + (surface @-> ptr Types.Rect.t @-> surface @-> ptr Types.Rect.t @-> returning int) let lower_blit_scaled ~src sr ~dst dr = lower_blit_scaled src (addr sr) dst (addr dr) |> zero_to_ok let save_bmp_rw = foreign "SDL_SaveBMP_RW" - (surface @-> rw_ops @-> bool @-> returning int) + (surface @-> Types.rw_ops @-> bool @-> returning int) let save_bmp_rw s rw ~close = save_bmp_rw s rw close |> zero_to_ok @@ -1191,7 +994,7 @@ let save_bmp s file = | Ok rw -> save_bmp_rw s rw ~close:true let set_clip_rect = - foreign "SDL_SetClipRect" (surface @-> ptr rect @-> returning bool) + foreign "SDL_SetClipRect" (surface @-> ptr Types.Rect.t @-> returning bool) let set_clip_rect s r = set_clip_rect s (addr r) @@ -1219,7 +1022,7 @@ let set_surface_color_mod s x y z = set_surface_color_mod s x y z |> zero_to_ok let set_surface_palette = foreign "SDL_SetSurfacePalette" - (surface @-> palette @-> returning int) + (surface @-> ptr Types.palette @-> returning int) let set_surface_palette s p = set_surface_palette s p |> zero_to_ok let set_surface_rle = @@ -1234,9 +1037,7 @@ let unlock_surface = type flip = int module Flip = struct let ( + ) = ( lor ) - let none = sdl_flip_none - let horizontal = sdl_flip_horizontal - let vertical = sdl_flip_vertical + include Types.Flip end type texture = unit ptr @@ -1264,10 +1065,7 @@ module Renderer = struct let ( - ) f f' = Unsigned.UInt32.(logand f (lognot f')) let test f m = Unsigned.UInt32.(compare (logand f m) zero <> 0) let eq f f' = Unsigned.UInt32.(compare f f' = 0) - let software = i sdl_renderer_software - let accelerated = i sdl_renderer_accelerated - let presentvsync = i sdl_renderer_presentvsync - let targettexture = i sdl_renderer_targettexture + include Types.Renderer end type renderer_info = @@ -1277,33 +1075,24 @@ type renderer_info = ri_max_texture_width : int; ri_max_texture_height : int; } -let renderer_info = structure "SDL_RendererInfo" -let ri_name = field renderer_info "name" string -let ri_flags = field renderer_info "flags" uint32_t -let ri_num_tf = field renderer_info "num_texture_formats" uint32_t -let ri_tfs = field renderer_info "texture_formats" (array 16 uint32_t) -let ri_max_texture_width = field renderer_info "max_texture_width" int -let ri_max_texture_height = field renderer_info "max_texture_height" int -let () = seal renderer_info - let renderer_info_of_c c = - let ri_name = getf c ri_name in - let ri_flags = getf c ri_flags in - let num_tf = Unsigned.UInt32.to_int (getf c ri_num_tf) in - let tfs = getf c ri_tfs in + let ri_name = getf c Types.ri_name in + let ri_flags = getf c Types.ri_flags in + let num_tf = Unsigned.UInt32.to_int (getf c Types.ri_num_tf) in + let tfs = getf c Types.ri_tfs in let ri_texture_formats = let acc = ref [] in for i = 0 to num_tf - 1 do acc := (CArray.get tfs i) :: !acc done; List.rev !acc in - let ri_max_texture_width = getf c ri_max_texture_width in - let ri_max_texture_height = getf c ri_max_texture_height in + let ri_max_texture_width = getf c Types.ri_max_texture_width in + let ri_max_texture_height = getf c Types.ri_max_texture_height in { ri_name; ri_flags; ri_texture_formats; ri_max_texture_width; ri_max_texture_height } let create_renderer = foreign "SDL_CreateRenderer" - (window @-> int @-> uint32_t @-> returning renderer_opt) + (Types.Window.t @-> int @-> uint32_t @-> returning renderer_opt) let create_renderer ?(index = -1) ?(flags = Unsigned.UInt32.zero) w = create_renderer w index flags |> some_to_ok @@ -1343,10 +1132,10 @@ let get_render_draw_color rend = let get_render_driver_info = foreign "SDL_GetRenderDriverInfo" - (int @-> ptr renderer_info @-> returning int) + (int @-> ptr Types.renderer_info @-> returning int) let get_render_driver_info i = - let info = make renderer_info in + let info = make Types.renderer_info in match get_render_driver_info i (addr info) with | 0 -> Ok (renderer_info_of_c info) | _ -> error () @@ -1355,15 +1144,15 @@ let get_render_target = let get_renderer = foreign "SDL_GetRenderer" - (window @-> returning renderer_opt) + (Types.Window.t @-> returning renderer_opt) let get_renderer w = get_renderer w |> some_to_ok let get_renderer_info = foreign "SDL_GetRendererInfo" - (renderer @-> ptr renderer_info @-> returning int) + (renderer @-> ptr Types.renderer_info @-> returning int) let get_renderer_info r = - let info = make renderer_info in + let info = make Types.renderer_info in match get_renderer_info r (addr info) with | 0 -> Ok (renderer_info_of_c info) | _ -> error () @@ -1383,7 +1172,7 @@ let render_clear r = render_clear r |> zero_to_ok let render_copy = foreign "SDL_RenderCopy" - (renderer @-> texture @-> ptr rect @-> ptr rect @-> + (renderer @-> texture @-> ptr Types.Rect.t @-> ptr Types.Rect.t @-> returning int) let render_copy ?src ?dst r t = @@ -1391,8 +1180,8 @@ let render_copy ?src ?dst r t = let render_copy_ex = foreign "SDL_RenderCopyEx" - (renderer @-> texture @-> ptr rect @-> ptr rect @-> double @-> - ptr point @-> int @-> returning int) + (renderer @-> texture @-> ptr Types.Rect.t @-> ptr Types.Rect.t @-> double @-> + ptr Types.Point.t @-> int @-> returning int) let render_copy_ex ?src ?dst r t angle c flip = render_copy_ex r t (Rect.opt_addr src) (Rect.opt_addr dst) angle @@ -1420,7 +1209,7 @@ let render_draw_lines_ba r ps = render_draw_lines r ps count |> zero_to_ok let render_draw_lines r ps = - let a = CArray.of_list point ps in + let a = CArray.of_list Types.Point.t ps in render_draw_lines r (to_voidp (CArray.start a)) (CArray.length a) |> zero_to_ok let render_draw_point = @@ -1440,7 +1229,7 @@ let render_draw_points_ba r ps = render_draw_points r ps count |> zero_to_ok let render_draw_points r ps = - let a = CArray.of_list point ps in + let a = CArray.of_list Types.Point.t ps in render_draw_points r (to_voidp (CArray.start a)) (CArray.length a) |> zero_to_ok let render_draw_point_f = @@ -1460,12 +1249,12 @@ let render_draw_points_f_ba r ps = render_draw_points_f r ps count |> zero_to_ok let render_draw_points_f r ps = - let a = CArray.of_list fpoint ps in + let a = CArray.of_list Types.Fpoint.t ps in render_draw_points_f r (to_voidp (CArray.start a)) (CArray.length a) |> zero_to_ok let render_draw_rect = foreign "SDL_RenderDrawRect" - (renderer @-> ptr rect @-> returning int) + (renderer @-> ptr Types.Rect.t @-> returning int) let render_draw_rect rend r = render_draw_rect rend (Rect.opt_addr r) |> zero_to_ok @@ -1482,12 +1271,12 @@ let render_draw_rects_ba r rs = render_draw_rects r rs count |> zero_to_ok let render_draw_rects r rs = - let a = CArray.of_list rect rs in + let a = CArray.of_list Types.Rect.t rs in render_draw_rects r (to_voidp (CArray.start a)) (CArray.length a) |> zero_to_ok let render_fill_rect = foreign "SDL_RenderFillRect" - (renderer @-> ptr rect @-> returning int) + (renderer @-> ptr Types.Rect.t @-> returning int) let render_fill_rect rend r = render_fill_rect rend (Rect.opt_addr r) |> zero_to_ok @@ -1504,7 +1293,7 @@ let render_fill_rects_ba r rs = render_fill_rects r rs count |> zero_to_ok let render_fill_rects r rs = - let a = CArray.of_list rect rs in + let a = CArray.of_list Types.Rect.t rs in render_fill_rects r (to_voidp (CArray.start a)) (CArray.length a) |> zero_to_ok let render_geometry = @@ -1513,7 +1302,7 @@ let render_geometry = returning int) let render_geometry ?indices ?texture r vertices = - let a1 = CArray.of_list vertex vertices in + let a1 = CArray.of_list Types.Vertex.t vertices in let t = match texture with | None -> null | Some texture -> texture in @@ -1577,10 +1366,10 @@ let render_geometry_raw let render_get_clip_rect = foreign "SDL_RenderGetClipRect" - (renderer @-> ptr rect @-> returning void) + (renderer @-> ptr Types.Rect.t @-> returning void) let render_get_clip_rect rend = - let r = make rect in + let r = make Types.Rect.t in render_get_clip_rect rend (addr r); r @@ -1613,10 +1402,10 @@ let render_get_scale r = let render_get_viewport = foreign "SDL_RenderGetViewport" - (renderer @-> ptr rect @-> returning void) + (renderer @-> ptr Types.Rect.t @-> returning void) let render_get_viewport rend = - let r = make rect in + let r = make Types.Rect.t in render_get_viewport rend (addr r); r @@ -1626,7 +1415,7 @@ let render_present = let render_read_pixels = foreign "SDL_RenderReadPixels" - (renderer @-> ptr rect @-> uint32_t @-> ptr void @-> int @-> + (renderer @-> ptr Types.Rect.t @-> uint32_t @-> ptr void @-> int @-> returning int) let render_read_pixels r rect format pixels pitch = @@ -1636,7 +1425,7 @@ let render_read_pixels r rect format pixels pitch = let render_set_clip_rect = foreign "SDL_RenderSetClipRect" - (renderer @-> ptr rect @-> returning int) + (renderer @-> ptr Types.Rect.t @-> returning int) let render_set_clip_rect rend r = render_set_clip_rect rend (Rect.opt_addr r) |> zero_to_ok @@ -1658,7 +1447,7 @@ let render_set_scale r x y = render_set_scale r x y |> zero_to_ok let render_set_viewport = foreign "SDL_RenderSetViewport" - (renderer @-> ptr rect @-> returning int) + (renderer @-> ptr Types.Rect.t @-> returning int) let render_set_viewport rend r = render_set_viewport rend (Rect.opt_addr r) |> zero_to_ok @@ -1689,15 +1478,9 @@ let set_render_target r t = module Texture = struct type access = int - let access_static = sdl_textureaccess_static - let access_streaming = sdl_textureaccess_streaming - let access_target = sdl_textureaccess_target - let i = Unsigned.UInt32.of_int type modulate = Unsigned.uint32 - let modulate_none = i sdl_texturemodulate_none - let modulate_color = i sdl_texturemodulate_color - let modulate_alpha = i sdl_texturemodulate_alpha + include Types.Texture end let create_texture = @@ -1760,7 +1543,7 @@ let _texture_height t = let lock_texture = foreign "SDL_LockTexture" - (texture @-> ptr rect @-> ptr (ptr void) @-> ptr int @-> + (texture @-> ptr Types.Rect.t @-> ptr (ptr void) @-> ptr int @-> returning int) let lock_texture t r kind = @@ -1811,7 +1594,7 @@ let unlock_texture = let update_texture = foreign "SDL_UpdateTexture" - (texture @-> ptr rect @-> ptr void @-> int @-> returning int) + (texture @-> ptr Types.Rect.t @-> ptr void @-> int @-> returning int) let update_texture t rect pixels pitch = let pitch = pitch * (ba_kind_byte_size (Bigarray.Array1.kind pixels)) in @@ -1820,7 +1603,7 @@ let update_texture t rect pixels pitch = let update_yuv_texture = foreign "SDL_UpdateYUVTexture" - (texture @-> ptr rect @-> + (texture @-> ptr Types.Rect.t @-> ptr void @-> int @-> ptr void @-> int @-> ptr void @-> int @-> returning int) @@ -1862,71 +1645,62 @@ type display_mode = dm_refresh_rate : int option; dm_driverdata : driverdata option } -type _display_mode -let display_mode : _display_mode structure typ = structure "SDL_DisplayMode" -let dm_format = field display_mode "format" uint32_t -let dm_w = field display_mode "w" int -let dm_h = field display_mode "h" int -let dm_refresh_rate = field display_mode "refresh_rate" int -let dm_driverdata = field display_mode "driverdata" driverdata -let () = seal display_mode - let display_mode_to_c o = - let c = make display_mode in + let c = make Types.display_mode in let rate = match o.dm_refresh_rate with None -> 0 | Some r -> r in - setf c dm_format o.dm_format; - setf c dm_w o.dm_w; - setf c dm_h o.dm_h; - setf c dm_refresh_rate rate; - setf c dm_driverdata o.dm_driverdata; + setf c Types.dm_format o.dm_format; + setf c Types.dm_w o.dm_w; + setf c Types.dm_h o.dm_h; + setf c Types.dm_refresh_rate rate; + setf c Types.dm_driverdata o.dm_driverdata; c let display_mode_of_c c = - let dm_format = getf c dm_format in - let dm_w = getf c dm_w in - let dm_h = getf c dm_h in - let dm_refresh_rate = match getf c dm_refresh_rate with + let dm_format = getf c Types.dm_format in + let dm_w = getf c Types.dm_w in + let dm_h = getf c Types.dm_h in + let dm_refresh_rate = match getf c Types.dm_refresh_rate with | 0 -> None | r -> Some r in - let dm_driverdata = getf c dm_driverdata in + let dm_driverdata = getf c Types.dm_driverdata in { dm_format; dm_w; dm_h; dm_refresh_rate; dm_driverdata } let get_closest_display_mode = foreign "SDL_GetClosestDisplayMode" - (int @-> ptr display_mode @-> ptr display_mode @-> + (int @-> ptr Types.display_mode @-> ptr Types.display_mode @-> returning (ptr_opt void)) let get_closest_display_mode i m = let mode = display_mode_to_c m in - let closest = make display_mode in + let closest = make Types.display_mode in match get_closest_display_mode i (addr mode) (addr closest) with | None -> None | Some _ -> Some (display_mode_of_c closest) let get_current_display_mode = foreign "SDL_GetCurrentDisplayMode" - (int @-> ptr display_mode @-> returning int) + (int @-> ptr Types.display_mode @-> returning int) let get_current_display_mode i = - let mode = make display_mode in + let mode = make Types.display_mode in match get_current_display_mode i (addr mode) with | 0 -> Ok (display_mode_of_c mode) | _ -> error () let get_desktop_display_mode = foreign "SDL_GetDesktopDisplayMode" - (int @-> ptr display_mode @-> returning int) + (int @-> ptr Types.display_mode @-> returning int) let get_desktop_display_mode i = - let mode = make display_mode in + let mode = make Types.display_mode in match get_desktop_display_mode i (addr mode) with | 0 -> Ok (display_mode_of_c mode) | _ -> error () let get_display_bounds = foreign "SDL_GetDisplayBounds" - (int @-> ptr rect @-> returning int) + (int @-> ptr Types.Rect.t @-> returning int) let get_display_bounds i = - let r = make rect in + let r = make Types.Rect.t in match get_display_bounds i (addr r) with | 0 -> Ok r | _ -> error () @@ -1944,19 +1718,19 @@ let get_display_dpi display = let get_display_mode = foreign "SDL_GetDisplayMode" - (int @-> int @-> ptr display_mode @-> returning int) + (int @-> int @-> ptr Types.display_mode @-> returning int) let get_display_mode d i = - let mode = make display_mode in + let mode = make Types.display_mode in match get_display_mode d i (addr mode) with | 0 -> Ok (display_mode_of_c mode) | _ -> error () let get_display_usable_bounds = foreign "SDL_GetDisplayUsableBounds" - (int @-> ptr rect @-> returning int) + (int @-> ptr Types.Rect.t @-> returning int) let get_display_usable_bounds i = - let r = make rect in + let r = make Types.Rect.t in match get_display_usable_bounds i (addr r) with | 0 -> Ok r | _ -> error () @@ -1975,9 +1749,6 @@ let get_num_video_displays () = get_num_video_displays () |> nat_to_ok (* Windows *) module Window = struct - let pos_undefined = sdl_windowpos_undefined - let pos_centered = sdl_windowpos_centered - type flags = Unsigned.uint32 let i = Unsigned.UInt32.of_int let ( + ) = Unsigned.UInt32.logor @@ -1985,56 +1756,37 @@ module Window = struct let test f m = Unsigned.UInt32.(compare (logand f m) zero <> 0) let eq f f' = Unsigned.UInt32.(compare f f' = 0) let windowed = i 0 - let fullscreen = i sdl_window_fullscreen - let fullscreen_desktop = i sdl_window_fullscreen_desktop - let opengl = i sdl_window_opengl - let shown = i sdl_window_shown - let hidden = i sdl_window_hidden - let borderless = i sdl_window_borderless - let resizable = i sdl_window_resizable - let minimized = i sdl_window_minimized - let maximized = i sdl_window_maximized - let input_grabbed = i sdl_window_input_grabbed - let input_focus = i sdl_window_input_focus - let mouse_focus = i sdl_window_mouse_focus - let foreign = i sdl_window_foreign - let allow_highdpi = i sdl_window_allow_highdpi - let mouse_capture = i sdl_window_mouse_capture - let always_on_top = i sdl_window_always_on_top - let skip_taskbar = i sdl_window_skip_taskbar - let utility = i sdl_window_utility - let popup_menu = i sdl_window_popup_menu - let vulkan = i sdl_window_vulkan + include Types.Window end let create_window = foreign "SDL_CreateWindow" (string @-> int @-> int @-> int @-> int @-> uint32_t @-> - returning window_opt) + returning Types.Window.opt) let create_window t ?(x = Window.pos_undefined) ?(y = Window.pos_undefined) ~w ~h flags = create_window t x y w h flags |> some_to_ok let create_window_and_renderer = foreign "SDL_CreateWindowAndRenderer" - (int @-> int @-> uint32_t @-> ptr window @-> ptr renderer @-> + (int @-> int @-> uint32_t @-> ptr Types.Window.t @-> ptr renderer @-> (returning int)) let create_window_and_renderer ~w ~h flags = - let win = allocate window null in + let win = allocate Window.t (from_voidp Window.raw null) in let r = allocate renderer null in match create_window_and_renderer w h flags win r with | 0 -> Ok (!@ win, !@ r) | _ -> error () let destroy_window = - foreign "SDL_DestroyWindow" (window @-> returning void) + foreign "SDL_DestroyWindow" (Types.Window.t @-> returning void) let get_window_brightness = - foreign "SDL_GetWindowBrightness" (window @-> returning float) + foreign "SDL_GetWindowBrightness" (Types.Window.t @-> returning float) let get_window_borders_size = foreign "SDL_GetWindowBordersSize" - (window @-> ptr int @-> ptr int @-> ptr int @-> ptr int @-> + (Types.Window.t @-> ptr int @-> ptr int @-> ptr int @-> ptr int @-> returning int) let get_window_borders_size w = @@ -2047,29 +1799,29 @@ let get_window_borders_size w = | _ -> error () let get_window_display_index = - foreign "SDL_GetWindowDisplayIndex" (window @-> returning int) + foreign "SDL_GetWindowDisplayIndex" (Types.Window.t @-> returning int) let get_window_display_index w = get_window_display_index w |> nat_to_ok let get_window_display_mode = foreign "SDL_GetWindowDisplayMode" - (window @-> (ptr display_mode) @-> returning int) + (Types.Window.t @-> (ptr Types.display_mode) @-> returning int) let get_window_display_mode w = - let mode = make display_mode in + let mode = make Types.display_mode in match get_window_display_mode w (addr mode) with | 0 -> Ok (display_mode_of_c mode) | _err -> error () let get_window_flags = - foreign "SDL_GetWindowFlags" (window @-> returning uint32_t) + foreign "SDL_GetWindowFlags" (Types.Window.t @-> returning uint32_t) let get_window_from_id = foreign "SDL_GetWindowFromID" - (int_as_uint32_t @-> returning window_opt) + (int_as_uint32_t @-> returning Types.Window.opt) let get_window_from_id x = get_window_from_id x |> some_to_ok let get_window_gamma_ramp = foreign "SDL_GetWindowGammaRamp" - (window @-> ptr void @-> ptr void @-> ptr void @-> returning int) + (Types.Window.t @-> ptr void @-> ptr void @-> ptr void @-> returning int) let get_window_gamma_ramp w = let create_ramp () = ba_create Bigarray.int16_unsigned 256 in @@ -2079,17 +1831,17 @@ let get_window_gamma_ramp w = | 0 -> Ok (r, g, b) | _ -> error () let get_window_grab = - foreign "SDL_GetWindowGrab" (window @-> returning bool) + foreign "SDL_GetWindowGrab" (Types.Window.t @-> returning bool) let get_grabbed_window = - foreign "SDL_GetGrabbedWindow" (void @-> returning window) + foreign "SDL_GetGrabbedWindow" (void @-> returning Types.Window.t) let get_window_id = - foreign "SDL_GetWindowID" (window @-> returning int_as_uint32_t) + foreign "SDL_GetWindowID" (Types.Window.t @-> returning int_as_uint32_t) let get_window_maximum_size = foreign "SDL_GetWindowMaximumSize" - (window @-> (ptr int) @-> (ptr int) @-> returning void) + (Types.Window.t @-> (ptr int) @-> (ptr int) @-> returning void) let get_window_maximum_size win = let w = allocate int 0 in @@ -2099,7 +1851,7 @@ let get_window_maximum_size win = let get_window_minimum_size = foreign "SDL_GetWindowMinimumSize" - (window @-> (ptr int) @-> (ptr int) @-> returning void) + (Types.Window.t @-> (ptr int) @-> (ptr int) @-> returning void) let get_window_minimum_size win = let w = allocate int 0 in @@ -2109,7 +1861,7 @@ let get_window_minimum_size win = let get_window_opacity = foreign "SDL_GetWindowOpacity" - (window @-> (ptr float) @-> returning int) + (Types.Window.t @-> (ptr float) @-> returning int) let get_window_opacity win = let x = allocate float 0. in @@ -2118,11 +1870,11 @@ let get_window_opacity win = | _ -> error () let get_window_pixel_format = - foreign "SDL_GetWindowPixelFormat" (window @-> returning uint32_t) + foreign "SDL_GetWindowPixelFormat" (Types.Window.t @-> returning uint32_t) let get_window_position = foreign "SDL_GetWindowPosition" - (window @-> (ptr int) @-> (ptr int) @-> returning void) + (Types.Window.t @-> (ptr int) @-> (ptr int) @-> returning void) let get_window_position win = let x = allocate int 0 in @@ -2132,7 +1884,7 @@ let get_window_position win = let get_window_size = foreign "SDL_GetWindowSize" - (window @-> (ptr int) @-> (ptr int) @-> returning void) + (Types.Window.t @-> (ptr int) @-> (ptr int) @-> returning void) let get_window_size win = let w = allocate int 0 in @@ -2142,38 +1894,38 @@ let get_window_size win = let get_window_surface = foreign "SDL_GetWindowSurface" - (window @-> returning surface_opt) + (Types.Window.t @-> returning surface_opt) let get_window_surface w = get_window_surface w |> some_to_ok let get_window_title = - foreign "SDL_GetWindowTitle" (window @-> returning string) + foreign "SDL_GetWindowTitle" (Types.Window.t @-> returning string) let hide_window = - foreign "SDL_HideWindow" (window @-> returning void) + foreign "SDL_HideWindow" (Types.Window.t @-> returning void) let maximize_window = - foreign "SDL_MaximizeWindow" (window @-> returning void) + foreign "SDL_MaximizeWindow" (Types.Window.t @-> returning void) let minimize_window = - foreign "SDL_MinimizeWindow" (window @-> returning void) + foreign "SDL_MinimizeWindow" (Types.Window.t @-> returning void) let raise_window = - foreign "SDL_RaiseWindow" (window @-> returning void) + foreign "SDL_RaiseWindow" (Types.Window.t @-> returning void) let restore_window = - foreign "SDL_RestoreWindow" (window @-> returning void) + foreign "SDL_RestoreWindow" (Types.Window.t @-> returning void) let set_window_bordered = - foreign "SDL_SetWindowBordered" (window @-> bool @-> returning void) + foreign "SDL_SetWindowBordered" (Types.Window.t @-> bool @-> returning void) let set_window_brightness = foreign "SDL_SetWindowBrightness" - (window @-> float @-> returning int) + (Types.Window.t @-> float @-> returning int) let set_window_brightness w x = set_window_brightness w x |> zero_to_ok let set_window_display_mode = foreign "SDL_SetWindowDisplayMode" - (window @-> (ptr display_mode) @-> returning int) + (Types.Window.t @-> (ptr Types.display_mode) @-> returning int) let set_window_display_mode w m = let mode = display_mode_to_c m in @@ -2181,12 +1933,12 @@ let set_window_display_mode w m = let set_window_fullscreen = foreign "SDL_SetWindowFullscreen" - (window @-> uint32_t @-> returning int) + (Types.Window.t @-> uint32_t @-> returning int) let set_window_fullscreen w x = set_window_fullscreen w x |> zero_to_ok let set_window_gamma_ramp = foreign "SDL_SetWindowGammaRamp" - (window @-> ptr void @-> ptr void @-> ptr void @-> + (Types.Window.t @-> ptr void @-> ptr void @-> ptr void @-> returning int) let set_window_gamma_ramp w r g b = @@ -2194,67 +1946,67 @@ let set_window_gamma_ramp w r g b = set_window_gamma_ramp w (ramp_ptr r) (ramp_ptr g) (ramp_ptr b) |> zero_to_ok let set_window_grab = - foreign "SDL_SetWindowGrab" (window @-> bool @-> returning void) + foreign "SDL_SetWindowGrab" (Types.Window.t @-> bool @-> returning void) let set_window_icon = - foreign "SDL_SetWindowIcon" (window @-> surface @-> returning void) + foreign "SDL_SetWindowIcon" (Types.Window.t @-> surface @-> returning void) let set_window_input_focus = - foreign "SDL_SetWindowInputFocus" (window @-> returning int) + foreign "SDL_SetWindowInputFocus" (Types.Window.t @-> returning int) let set_window_input_focus w = set_window_input_focus w |> zero_to_ok let set_window_maximum_size = foreign "SDL_SetWindowMaximumSize" - (window @-> int @-> int @-> returning void) + (Types.Window.t @-> int @-> int @-> returning void) let set_window_maximum_size win ~w ~h = set_window_maximum_size win w h let set_window_minimum_size = foreign "SDL_SetWindowMinimumSize" - (window @-> int @-> int @-> returning void) + (Types.Window.t @-> int @-> int @-> returning void) let set_window_minimum_size win ~w ~h = set_window_minimum_size win w h let set_window_modal_for = - foreign "SDL_SetWindowModalFor" ( window @-> window @-> returning int) + foreign "SDL_SetWindowModalFor" ( Types.Window.t @-> Types.Window.t @-> returning int) let set_window_modal_for ~modal ~parent = set_window_modal_for modal parent |> zero_to_ok let set_window_opacity = - foreign "SDL_SetWindowOpacity" ( window @-> float @-> returning int) + foreign "SDL_SetWindowOpacity" ( Types.Window.t @-> float @-> returning int) let set_window_opacity w x = set_window_opacity w x |> zero_to_ok let set_window_position = foreign "SDL_SetWindowPosition" - (window @-> int @-> int @-> returning void) + (Types.Window.t @-> int @-> int @-> returning void) let set_window_position win ~x ~y = set_window_position win x y let set_window_resizable = - foreign "SDL_SetWindowResizable" (window @-> bool @-> returning void) + foreign "SDL_SetWindowResizable" (Types.Window.t @-> bool @-> returning void) let set_window_size = - foreign "SDL_SetWindowSize" (window @-> int @-> int @-> returning void) + foreign "SDL_SetWindowSize" (Types.Window.t @-> int @-> int @-> returning void) let set_window_size win ~w ~h = set_window_size win w h let set_window_title = - foreign "SDL_SetWindowTitle" (window @-> string @-> returning void) + foreign "SDL_SetWindowTitle" (Types.Window.t @-> string @-> returning void) let show_window = - foreign "SDL_ShowWindow" (window @-> returning void) + foreign "SDL_ShowWindow" (Types.Window.t @-> returning void) let update_window_surface = - foreign "SDL_UpdateWindowSurface" (window @-> returning int) + foreign "SDL_UpdateWindowSurface" (Types.Window.t @-> returning int) let update_window_surface w = update_window_surface w |> zero_to_ok let update_window_surface_rects = foreign "SDL_UpdateWindowSurfaceRects" - (window @-> ptr void @-> int @-> returning int) + (Types.Window.t @-> ptr void @-> int @-> returning int) let update_window_surface_rects_ba w rs = let len = Bigarray.Array1.dim rs in @@ -2264,7 +2016,7 @@ let update_window_surface_rects_ba w rs = update_window_surface_rects w rs count |> zero_to_ok let update_window_surface_rects w rs = - let a = CArray.of_list rect rs in + let a = CArray.of_list Types.Rect.t rs in let rs = to_voidp (CArray.start a) in update_window_surface_rects w rs (CArray.length a) |> zero_to_ok @@ -2281,41 +2033,9 @@ let unsafe_ptr_of_gl_context gl_context = module Gl = struct type context_flags = int - let context_debug_flag = sdl_gl_context_debug_flag - let context_forward_compatible_flag = sdl_gl_context_forward_compatible_flag - let context_robust_access_flag = sdl_gl_context_robust_access_flag - let context_reset_isolation_flag = sdl_gl_context_reset_isolation_flag - type profile = int - let context_profile_core = sdl_gl_context_profile_core - let context_profile_compatibility = sdl_gl_context_profile_compatibility - let context_profile_es = sdl_gl_context_profile_es - type attr = int - let red_size = sdl_gl_red_size - let green_size = sdl_gl_green_size - let blue_size = sdl_gl_blue_size - let alpha_size = sdl_gl_alpha_size - let buffer_size = sdl_gl_buffer_size - let doublebuffer = sdl_gl_doublebuffer - let depth_size = sdl_gl_depth_size - let stencil_size = sdl_gl_stencil_size - let accum_red_size = sdl_gl_accum_red_size - let accum_green_size = sdl_gl_accum_green_size - let accum_blue_size = sdl_gl_accum_blue_size - let accum_alpha_size = sdl_gl_accum_alpha_size - let stereo = sdl_gl_stereo - let multisamplebuffers = sdl_gl_multisamplebuffers - let multisamplesamples = sdl_gl_multisamplesamples - let accelerated_visual = sdl_gl_accelerated_visual - let context_major_version = sdl_gl_context_major_version - let context_minor_version = sdl_gl_context_minor_version - let context_egl = sdl_gl_context_egl - let context_flags = sdl_gl_context_flags - let context_profile_mask = sdl_gl_context_profile_mask - let context_release_behavior = sdl_gl_context_release_behavior - let share_with_current_context = sdl_gl_share_with_current_context - let framebuffer_srgb_capable = sdl_gl_framebuffer_srgb_capable + include Types.Gl end let gl_bind_texture = @@ -2330,7 +2050,7 @@ let gl_bind_texture t = let gl_create_context = foreign "SDL_GL_CreateContext" - (window @-> returning gl_context_opt) + (Types.Window.t @-> returning gl_context_opt) let gl_create_context w = gl_create_context w |> some_to_ok let gl_delete_context = @@ -2354,7 +2074,7 @@ let gl_get_current_context () = gl_get_current_context () |> some_to_ok let gl_get_drawable_size = foreign "SDL_GL_GetDrawableSize" - (window @-> ptr int @-> ptr int @-> returning void) + (Types.Window.t @-> ptr int @-> ptr int @-> returning void) let gl_get_drawable_size win = let w = allocate int 0 in @@ -2368,7 +2088,7 @@ let gl_get_swap_interval () = Ok (gl_get_swap_interval ()) let gl_make_current = foreign "SDL_GL_MakeCurrent" - (window @-> gl_context @-> returning int) + (Types.Window.t @-> gl_context @-> returning int) let gl_make_current w g = gl_make_current w g |> zero_to_ok let gl_reset_attributes = @@ -2383,7 +2103,7 @@ let gl_set_swap_interval = let gl_set_swap_interval x = gl_set_swap_interval x |> zero_to_ok let gl_swap_window = - foreign "SDL_GL_SwapWindow" (window @-> returning void) + foreign "SDL_GL_SwapWindow" (Types.Window.t @-> returning void) let gl_unbind_texture = foreign "SDL_GL_UnbindTexture" (texture @-> returning int) @@ -2412,7 +2132,7 @@ module Vulkan = struct let get_instance_extensions = foreign "SDL_Vulkan_GetInstanceExtensions" - (window @-> ptr int @-> ptr string @-> returning bool) + (Types.Window.t @-> ptr int @-> ptr string @-> returning bool) let get_instance_extensions window = let n = allocate int 0 in @@ -2427,7 +2147,7 @@ module Vulkan = struct let create_surface = foreign "SDL_Vulkan_CreateSurface" - (window @-> instance @-> ptr surface @-> returning bool) + (Types.Window.t @-> instance @-> ptr surface @-> returning bool) let create_surface window instance = let s = allocate_n surface ~count:1 in @@ -2438,7 +2158,7 @@ module Vulkan = struct let get_drawable_size = foreign "SDL_Vulkan_GetDrawableSize" - (window @-> ptr int @-> ptr int @-> returning void) + (Types.Window.t @-> ptr int @-> ptr int @-> returning void) let get_drawable_size window = let w = allocate int 0 in @@ -2461,42 +2181,20 @@ let is_screen_saver_enabled = (* Message boxes *) module Message_box = struct + include Types.Message_box let i = Unsigned.UInt32.of_int type button_flags = Unsigned.uint32 let button_no_default = i 0 - let button_returnkey_default = i sdl_messagebox_button_returnkey_default - let button_escapekey_default = i sdl_messagebox_button_escapekey_default type button_data = { button_flags : button_flags; button_id : int; button_text : string } - let button_data = structure "SDL_MessageBoxButtonData" - let button_flags = field button_data "flags" uint32_t - let button_buttonid = field button_data "buttonid" int - let button_text = field button_data "text" string - let () = seal button_data - type flags = Unsigned.uint32 - let error = i sdl_messagebox_error - let warning = i sdl_messagebox_warning - let information = i sdl_messagebox_information type color = int * int * int - let color = structure "SDL_MessageBoxColor" - let color_r = field color "r" uint8_t - let color_g = field color "g" uint8_t - let color_b = field color "b" uint8_t - let () = seal color - - let color_background = sdl_messagebox_color_background - let color_text = sdl_messagebox_color_text - let color_button_border = sdl_messagebox_color_button_border - let color_button_background = sdl_messagebox_color_button_background - let color_button_selected = sdl_messagebox_color_button_selected - let color_button_max = sdl_messagebox_color_max type color_scheme = { color_background : color; @@ -2505,10 +2203,6 @@ module Message_box = struct color_button_background : color; color_button_selected : color; } - let color_scheme = structure "SDL_MessageBoxColorScheme" - let colors = field color_scheme "colors" (array color_button_max color) - let () = seal color_scheme - type data = { flags : flags; window : window option; @@ -2517,16 +2211,6 @@ module Message_box = struct buttons : button_data list; color_scheme : color_scheme option } - let data = structure "SDL_MessageBoxData" - let d_flags = field data "flags" uint32_t - let d_window = field data "window" window - let d_title = field data "title" string - let d_message = field data "message" string - let d_numbuttons = field data "numbuttons" int - let d_buttons = field data "buttons" (ptr button_data) - let d_color_scheme = field data "colorScheme" (ptr color_scheme) - let () = seal data - let buttons_to_c bl = let button_data_to_c b = let bt = make button_data in @@ -2556,16 +2240,13 @@ module Message_box = struct let data_to_c d = let dt = make data in setf dt d_flags d.flags; - setf dt d_window (match d.window with None -> null | Some w -> w); + setf dt d_window d.window; setf dt d_title d.title; setf dt d_message d.message; setf dt d_numbuttons (List.length d.buttons); setf dt d_buttons (buttons_to_c d.buttons); setf dt d_color_scheme - begin match d.color_scheme with - | None -> coerce (ptr void) (ptr color_scheme) null - | Some s -> addr (color_scheme_to_c s) - end; + (Option.map (fun s -> addr (color_scheme_to_c s)) d.color_scheme); dt end @@ -2581,7 +2262,7 @@ let show_message_box d = let show_simple_message_box = foreign "SDL_ShowSimpleMessageBox" - (uint32_t @-> string @-> string @-> window_opt @-> returning int) + (uint32_t @-> string @-> string @-> Types.Window.opt @-> returning int) let show_simple_message_box t ~title msg w = show_simple_message_box t title msg w |> zero_to_ok @@ -2612,13 +2293,13 @@ let set_clipboard_text s = set_clipboard_text s |> zero_to_ok (* Input *) -type button_state = uint8 -let pressed = sdl_pressed -let released = sdl_released +type button_state = Unsigned.uint8 +let pressed = Types.pressed +let released = Types.released -type toggle_state = uint8 -let disable = sdl_disable -let enable = sdl_enable +type toggle_state = Unsigned.uint8 +let disable = Types.disable +let enable = Types.enable (* Keyboard *) @@ -2626,248 +2307,7 @@ type scancode = int let scancode = int module Scancode = struct - let num_scancodes = sdl_num_scancodes - let unknown = sdl_scancode_unknown - let a = sdl_scancode_a - let b = sdl_scancode_b - let c = sdl_scancode_c - let d = sdl_scancode_d - let e = sdl_scancode_e - let f = sdl_scancode_f - let g = sdl_scancode_g - let h = sdl_scancode_h - let i = sdl_scancode_i - let j = sdl_scancode_j - let k = sdl_scancode_k - let l = sdl_scancode_l - let m = sdl_scancode_m - let n = sdl_scancode_n - let o = sdl_scancode_o - let p = sdl_scancode_p - let q = sdl_scancode_q - let r = sdl_scancode_r - let s = sdl_scancode_s - let t = sdl_scancode_t - let u = sdl_scancode_u - let v = sdl_scancode_v - let w = sdl_scancode_w - let x = sdl_scancode_x - let y = sdl_scancode_y - let z = sdl_scancode_z - let k1 = sdl_scancode_1 - let k2 = sdl_scancode_2 - let k3 = sdl_scancode_3 - let k4 = sdl_scancode_4 - let k5 = sdl_scancode_5 - let k6 = sdl_scancode_6 - let k7 = sdl_scancode_7 - let k8 = sdl_scancode_8 - let k9 = sdl_scancode_9 - let k0 = sdl_scancode_0 - let return = sdl_scancode_return - let escape = sdl_scancode_escape - let backspace = sdl_scancode_backspace - let tab = sdl_scancode_tab - let space = sdl_scancode_space - let minus = sdl_scancode_minus - let equals = sdl_scancode_equals - let leftbracket = sdl_scancode_leftbracket - let rightbracket = sdl_scancode_rightbracket - let backslash = sdl_scancode_backslash - let nonushash = sdl_scancode_nonushash - let semicolon = sdl_scancode_semicolon - let apostrophe = sdl_scancode_apostrophe - let grave = sdl_scancode_grave - let comma = sdl_scancode_comma - let period = sdl_scancode_period - let slash = sdl_scancode_slash - let capslock = sdl_scancode_capslock - let f1 = sdl_scancode_f1 - let f2 = sdl_scancode_f2 - let f3 = sdl_scancode_f3 - let f4 = sdl_scancode_f4 - let f5 = sdl_scancode_f5 - let f6 = sdl_scancode_f6 - let f7 = sdl_scancode_f7 - let f8 = sdl_scancode_f8 - let f9 = sdl_scancode_f9 - let f10 = sdl_scancode_f10 - let f11 = sdl_scancode_f11 - let f12 = sdl_scancode_f12 - let printscreen = sdl_scancode_printscreen - let scrolllock = sdl_scancode_scrolllock - let pause = sdl_scancode_pause - let insert = sdl_scancode_insert - let home = sdl_scancode_home - let pageup = sdl_scancode_pageup - let delete = sdl_scancode_delete - let kend = sdl_scancode_end - let pagedown = sdl_scancode_pagedown - let right = sdl_scancode_right - let left = sdl_scancode_left - let down = sdl_scancode_down - let up = sdl_scancode_up - let numlockclear = sdl_scancode_numlockclear - let kp_divide = sdl_scancode_kp_divide - let kp_multiply = sdl_scancode_kp_multiply - let kp_minus = sdl_scancode_kp_minus - let kp_plus = sdl_scancode_kp_plus - let kp_enter = sdl_scancode_kp_enter - let kp_1 = sdl_scancode_kp_1 - let kp_2 = sdl_scancode_kp_2 - let kp_3 = sdl_scancode_kp_3 - let kp_4 = sdl_scancode_kp_4 - let kp_5 = sdl_scancode_kp_5 - let kp_6 = sdl_scancode_kp_6 - let kp_7 = sdl_scancode_kp_7 - let kp_8 = sdl_scancode_kp_8 - let kp_9 = sdl_scancode_kp_9 - let kp_0 = sdl_scancode_kp_0 - let kp_period = sdl_scancode_kp_period - let nonusbackslash = sdl_scancode_nonusbackslash - let application = sdl_scancode_application - let kp_equals = sdl_scancode_kp_equals - let f13 = sdl_scancode_f13 - let f14 = sdl_scancode_f14 - let f15 = sdl_scancode_f15 - let f16 = sdl_scancode_f16 - let f17 = sdl_scancode_f17 - let f18 = sdl_scancode_f18 - let f19 = sdl_scancode_f19 - let f20 = sdl_scancode_f20 - let f21 = sdl_scancode_f21 - let f22 = sdl_scancode_f22 - let f23 = sdl_scancode_f23 - let f24 = sdl_scancode_f24 - let execute = sdl_scancode_execute - let help = sdl_scancode_help - let menu = sdl_scancode_menu - let select = sdl_scancode_select - let stop = sdl_scancode_stop - let again = sdl_scancode_again - let undo = sdl_scancode_undo - let cut = sdl_scancode_cut - let copy = sdl_scancode_copy - let paste = sdl_scancode_paste - let find = sdl_scancode_find - let mute = sdl_scancode_mute - let volumeup = sdl_scancode_volumeup - let volumedown = sdl_scancode_volumedown - let kp_comma = sdl_scancode_kp_comma - let kp_equalsas400 = sdl_scancode_kp_equalsas400 - let international1 = sdl_scancode_international1 - let international2 = sdl_scancode_international2 - let international3 = sdl_scancode_international3 - let international4 = sdl_scancode_international4 - let international5 = sdl_scancode_international5 - let international6 = sdl_scancode_international6 - let international7 = sdl_scancode_international7 - let international8 = sdl_scancode_international8 - let international9 = sdl_scancode_international9 - let lang1 = sdl_scancode_lang1 - let lang2 = sdl_scancode_lang2 - let lang3 = sdl_scancode_lang3 - let lang4 = sdl_scancode_lang4 - let lang5 = sdl_scancode_lang5 - let lang6 = sdl_scancode_lang6 - let lang7 = sdl_scancode_lang7 - let lang8 = sdl_scancode_lang8 - let lang9 = sdl_scancode_lang9 - let alterase = sdl_scancode_alterase - let sysreq = sdl_scancode_sysreq - let cancel = sdl_scancode_cancel - let clear = sdl_scancode_clear - let prior = sdl_scancode_prior - let return2 = sdl_scancode_return2 - let separator = sdl_scancode_separator - let out = sdl_scancode_out - let oper = sdl_scancode_oper - let clearagain = sdl_scancode_clearagain - let crsel = sdl_scancode_crsel - let exsel = sdl_scancode_exsel - let kp_00 = sdl_scancode_kp_00 - let kp_000 = sdl_scancode_kp_000 - let thousandsseparator = sdl_scancode_thousandsseparator - let decimalseparator = sdl_scancode_decimalseparator - let currencyunit = sdl_scancode_currencyunit - let currencysubunit = sdl_scancode_currencysubunit - let kp_leftparen = sdl_scancode_kp_leftparen - let kp_rightparen = sdl_scancode_kp_rightparen - let kp_leftbrace = sdl_scancode_kp_leftbrace - let kp_rightbrace = sdl_scancode_kp_rightbrace - let kp_tab = sdl_scancode_kp_tab - let kp_backspace = sdl_scancode_kp_backspace - let kp_a = sdl_scancode_kp_a - let kp_b = sdl_scancode_kp_b - let kp_c = sdl_scancode_kp_c - let kp_d = sdl_scancode_kp_d - let kp_e = sdl_scancode_kp_e - let kp_f = sdl_scancode_kp_f - let kp_xor = sdl_scancode_kp_xor - let kp_power = sdl_scancode_kp_power - let kp_percent = sdl_scancode_kp_percent - let kp_less = sdl_scancode_kp_less - let kp_greater = sdl_scancode_kp_greater - let kp_ampersand = sdl_scancode_kp_ampersand - let kp_dblampersand = sdl_scancode_kp_dblampersand - let kp_verticalbar = sdl_scancode_kp_verticalbar - let kp_dblverticalbar = sdl_scancode_kp_dblverticalbar - let kp_colon = sdl_scancode_kp_colon - let kp_hash = sdl_scancode_kp_hash - let kp_space = sdl_scancode_kp_space - let kp_at = sdl_scancode_kp_at - let kp_exclam = sdl_scancode_kp_exclam - let kp_memstore = sdl_scancode_kp_memstore - let kp_memrecall = sdl_scancode_kp_memrecall - let kp_memclear = sdl_scancode_kp_memclear - let kp_memadd = sdl_scancode_kp_memadd - let kp_memsubtract = sdl_scancode_kp_memsubtract - let kp_memmultiply = sdl_scancode_kp_memmultiply - let kp_memdivide = sdl_scancode_kp_memdivide - let kp_plusminus = sdl_scancode_kp_plusminus - let kp_clear = sdl_scancode_kp_clear - let kp_clearentry = sdl_scancode_kp_clearentry - let kp_binary = sdl_scancode_kp_binary - let kp_octal = sdl_scancode_kp_octal - let kp_decimal = sdl_scancode_kp_decimal - let kp_hexadecimal = sdl_scancode_kp_hexadecimal - let lctrl = sdl_scancode_lctrl - let lshift = sdl_scancode_lshift - let lalt = sdl_scancode_lalt - let lgui = sdl_scancode_lgui - let rctrl = sdl_scancode_rctrl - let rshift = sdl_scancode_rshift - let ralt = sdl_scancode_ralt - let rgui = sdl_scancode_rgui - let mode = sdl_scancode_mode - let audionext = sdl_scancode_audionext - let audioprev = sdl_scancode_audioprev - let audiostop = sdl_scancode_audiostop - let audioplay = sdl_scancode_audioplay - let audiomute = sdl_scancode_audiomute - let mediaselect = sdl_scancode_mediaselect - let www = sdl_scancode_www - let mail = sdl_scancode_mail - let calculator = sdl_scancode_calculator - let computer = sdl_scancode_computer - let ac_search = sdl_scancode_ac_search - let ac_home = sdl_scancode_ac_home - let ac_back = sdl_scancode_ac_back - let ac_forward = sdl_scancode_ac_forward - let ac_stop = sdl_scancode_ac_stop - let ac_refresh = sdl_scancode_ac_refresh - let ac_bookmarks = sdl_scancode_ac_bookmarks - let brightnessdown = sdl_scancode_brightnessdown - let brightnessup = sdl_scancode_brightnessup - let displayswitch = sdl_scancode_displayswitch - let kbdillumtoggle = sdl_scancode_kbdillumtoggle - let kbdillumdown = sdl_scancode_kbdillumdown - let kbdillumup = sdl_scancode_kbdillumup - let eject = sdl_scancode_eject - let sleep = sdl_scancode_sleep - let app1 = sdl_scancode_app1 - let app2 = sdl_scancode_app2 - + include Types.Scancode let enum_of_scancode = [| `Unknown; `Unknown; `Unknown; `Unknown; `A; `B; `C; `D; `E; `F; `G; `H; `I; `J; `K; `L; `M; `N; `O; `P; `Q; `R; `S; `T; `U; `V; @@ -2923,271 +2363,15 @@ end type keycode = int let keycode = int -module K = struct - let scancode_mask = sdlk_scancode_mask - let unknown = sdlk_unknown - let return = sdlk_return - let escape = sdlk_escape - let backspace = sdlk_backspace - let tab = sdlk_tab - let space = sdlk_space - let exclaim = sdlk_exclaim - let quotedbl = sdlk_quotedbl - let hash = sdlk_hash - let percent = sdlk_percent - let dollar = sdlk_dollar - let ampersand = sdlk_ampersand - let quote = sdlk_quote - let leftparen = sdlk_leftparen - let rightparen = sdlk_rightparen - let asterisk = sdlk_asterisk - let plus = sdlk_plus - let comma = sdlk_comma - let minus = sdlk_minus - let period = sdlk_period - let slash = sdlk_slash - let k0 = sdlk_0 - let k1 = sdlk_1 - let k2 = sdlk_2 - let k3 = sdlk_3 - let k4 = sdlk_4 - let k5 = sdlk_5 - let k6 = sdlk_6 - let k7 = sdlk_7 - let k8 = sdlk_8 - let k9 = sdlk_9 - let colon = sdlk_colon - let semicolon = sdlk_semicolon - let less = sdlk_less - let equals = sdlk_equals - let greater = sdlk_greater - let question = sdlk_question - let at = sdlk_at - let leftbracket = sdlk_leftbracket - let backslash = sdlk_backslash - let rightbracket = sdlk_rightbracket - let caret = sdlk_caret - let underscore = sdlk_underscore - let backquote = sdlk_backquote - let a = sdlk_a - let b = sdlk_b - let c = sdlk_c - let d = sdlk_d - let e = sdlk_e - let f = sdlk_f - let g = sdlk_g - let h = sdlk_h - let i = sdlk_i - let j = sdlk_j - let k = sdlk_k - let l = sdlk_l - let m = sdlk_m - let n = sdlk_n - let o = sdlk_o - let p = sdlk_p - let q = sdlk_q - let r = sdlk_r - let s = sdlk_s - let t = sdlk_t - let u = sdlk_u - let v = sdlk_v - let w = sdlk_w - let x = sdlk_x - let y = sdlk_y - let z = sdlk_z - let capslock = sdlk_capslock - let f1 = sdlk_f1 - let f2 = sdlk_f2 - let f3 = sdlk_f3 - let f4 = sdlk_f4 - let f5 = sdlk_f5 - let f6 = sdlk_f6 - let f7 = sdlk_f7 - let f8 = sdlk_f8 - let f9 = sdlk_f9 - let f10 = sdlk_f10 - let f11 = sdlk_f11 - let f12 = sdlk_f12 - let printscreen = sdlk_printscreen - let scrolllock = sdlk_scrolllock - let pause = sdlk_pause - let insert = sdlk_insert - let home = sdlk_home - let pageup = sdlk_pageup - let delete = sdlk_delete - let kend = sdlk_end - let pagedown = sdlk_pagedown - let right = sdlk_right - let left = sdlk_left - let down = sdlk_down - let up = sdlk_up - let numlockclear = sdlk_numlockclear - let kp_divide = sdlk_kp_divide - let kp_multiply = sdlk_kp_multiply - let kp_minus = sdlk_kp_minus - let kp_plus = sdlk_kp_plus - let kp_enter = sdlk_kp_enter - let kp_1 = sdlk_kp_1 - let kp_2 = sdlk_kp_2 - let kp_3 = sdlk_kp_3 - let kp_4 = sdlk_kp_4 - let kp_5 = sdlk_kp_5 - let kp_6 = sdlk_kp_6 - let kp_7 = sdlk_kp_7 - let kp_8 = sdlk_kp_8 - let kp_9 = sdlk_kp_9 - let kp_0 = sdlk_kp_0 - let kp_period = sdlk_kp_period - let application = sdlk_application - let power = sdlk_power - let kp_equals = sdlk_kp_equals - let f13 = sdlk_f13 - let f14 = sdlk_f14 - let f15 = sdlk_f15 - let f16 = sdlk_f16 - let f17 = sdlk_f17 - let f18 = sdlk_f18 - let f19 = sdlk_f19 - let f20 = sdlk_f20 - let f21 = sdlk_f21 - let f22 = sdlk_f22 - let f23 = sdlk_f23 - let f24 = sdlk_f24 - let execute = sdlk_execute - let help = sdlk_help - let menu = sdlk_menu - let select = sdlk_select - let stop = sdlk_stop - let again = sdlk_again - let undo = sdlk_undo - let cut = sdlk_cut - let copy = sdlk_copy - let paste = sdlk_paste - let find = sdlk_find - let mute = sdlk_mute - let volumeup = sdlk_volumeup - let volumedown = sdlk_volumedown - let kp_comma = sdlk_kp_comma - let kp_equalsas400 = sdlk_kp_equalsas400 - let alterase = sdlk_alterase - let sysreq = sdlk_sysreq - let cancel = sdlk_cancel - let clear = sdlk_clear - let prior = sdlk_prior - let return2 = sdlk_return2 - let separator = sdlk_separator - let out = sdlk_out - let oper = sdlk_oper - let clearagain = sdlk_clearagain - let crsel = sdlk_crsel - let exsel = sdlk_exsel - let kp_00 = sdlk_kp_00 - let kp_000 = sdlk_kp_000 - let thousandsseparator = sdlk_thousandsseparator - let decimalseparator = sdlk_decimalseparator - let currencyunit = sdlk_currencyunit - let currencysubunit = sdlk_currencysubunit - let kp_leftparen = sdlk_kp_leftparen - let kp_rightparen = sdlk_kp_rightparen - let kp_leftbrace = sdlk_kp_leftbrace - let kp_rightbrace = sdlk_kp_rightbrace - let kp_tab = sdlk_kp_tab - let kp_backspace = sdlk_kp_backspace - let kp_a = sdlk_kp_a - let kp_b = sdlk_kp_b - let kp_c = sdlk_kp_c - let kp_d = sdlk_kp_d - let kp_e = sdlk_kp_e - let kp_f = sdlk_kp_f - let kp_xor = sdlk_kp_xor - let kp_power = sdlk_kp_power - let kp_percent = sdlk_kp_percent - let kp_less = sdlk_kp_less - let kp_greater = sdlk_kp_greater - let kp_ampersand = sdlk_kp_ampersand - let kp_dblampersand = sdlk_kp_dblampersand - let kp_verticalbar = sdlk_kp_verticalbar - let kp_dblverticalbar = sdlk_kp_dblverticalbar - let kp_colon = sdlk_kp_colon - let kp_hash = sdlk_kp_hash - let kp_space = sdlk_kp_space - let kp_at = sdlk_kp_at - let kp_exclam = sdlk_kp_exclam - let kp_memstore = sdlk_kp_memstore - let kp_memrecall = sdlk_kp_memrecall - let kp_memclear = sdlk_kp_memclear - let kp_memadd = sdlk_kp_memadd - let kp_memsubtract = sdlk_kp_memsubtract - let kp_memmultiply = sdlk_kp_memmultiply - let kp_memdivide = sdlk_kp_memdivide - let kp_plusminus = sdlk_kp_plusminus - let kp_clear = sdlk_kp_clear - let kp_clearentry = sdlk_kp_clearentry - let kp_binary = sdlk_kp_binary - let kp_octal = sdlk_kp_octal - let kp_decimal = sdlk_kp_decimal - let kp_hexadecimal = sdlk_kp_hexadecimal - let lctrl = sdlk_lctrl - let lshift = sdlk_lshift - let lalt = sdlk_lalt - let lgui = sdlk_lgui - let rctrl = sdlk_rctrl - let rshift = sdlk_rshift - let ralt = sdlk_ralt - let rgui = sdlk_rgui - let mode = sdlk_mode - let audionext = sdlk_audionext - let audioprev = sdlk_audioprev - let audiostop = sdlk_audiostop - let audioplay = sdlk_audioplay - let audiomute = sdlk_audiomute - let mediaselect = sdlk_mediaselect - let www = sdlk_www - let mail = sdlk_mail - let calculator = sdlk_calculator - let computer = sdlk_computer - let ac_search = sdlk_ac_search - let ac_home = sdlk_ac_home - let ac_back = sdlk_ac_back - let ac_forward = sdlk_ac_forward - let ac_stop = sdlk_ac_stop - let ac_refresh = sdlk_ac_refresh - let ac_bookmarks = sdlk_ac_bookmarks - let brightnessdown = sdlk_brightnessdown - let brightnessup = sdlk_brightnessup - let displayswitch = sdlk_displayswitch - let kbdillumtoggle = sdlk_kbdillumtoggle - let kbdillumdown = sdlk_kbdillumdown - let kbdillumup = sdlk_kbdillumup - let eject = sdlk_eject - let sleep = sdlk_sleep -end +module K = Types.K type keymod = int let keymod = int_as_uint16_t -module Kmod = struct - let none = kmod_none - let lshift = kmod_lshift - let rshift = kmod_rshift - let lctrl = kmod_lctrl - let rctrl = kmod_rctrl - let lalt = kmod_lalt - let ralt = kmod_ralt - let lgui = kmod_lgui - let rgui = kmod_rgui - let num = kmod_num - let caps = kmod_caps - let mode = kmod_mode - let reserved = kmod_reserved - let ctrl = kmod_ctrl - let shift = kmod_shift - let alt = kmod_alt - let gui = kmod_gui -end +module Kmod = Types.Kmod let get_keyboard_focus = - foreign "SDL_GetKeyboardFocus" (void @-> returning window_opt) + foreign "SDL_GetKeyboardFocus" (void @-> returning Types.Window.opt) let get_keyboard_state = foreign "SDL_GetKeyboardState" (ptr int @-> returning (ptr int)) @@ -3222,7 +2406,7 @@ let has_screen_keyboard_support = foreign "SDL_HasScreenKeyboardSupport" (void @-> returning bool) let is_screen_keyboard_shown = - foreign "SDL_IsScreenKeyboardShown" (window @-> returning bool) + foreign "SDL_IsScreenKeyboardShown" (Types.Window.t @-> returning bool) let is_text_input_active = foreign "SDL_IsTextInputActive" (void @-> returning bool) @@ -3231,7 +2415,7 @@ let set_mod_state = foreign "SDL_SetModState" (keymod @-> returning void) let set_text_input_rect = - foreign "SDL_SetTextInputRect" (ptr rect @-> returning void) + foreign "SDL_SetTextInputRect" (ptr Types.Rect.t @-> returning void) let set_text_input_rect r = set_text_input_rect (Rect.opt_addr r) @@ -3255,34 +2439,10 @@ let unsafe_ptr_of_cursor cursor = module System_cursor = struct type t = int - let arrow = sdl_system_cursor_arrow - let ibeam = sdl_system_cursor_ibeam - let wait = sdl_system_cursor_wait - let crosshair = sdl_system_cursor_crosshair - let waitarrow = sdl_system_cursor_waitarrow - let size_nw_se = sdl_system_cursor_sizenwse - let size_ne_sw = sdl_system_cursor_sizenesw - let size_we = sdl_system_cursor_sizewe - let size_ns = sdl_system_cursor_sizens - let size_all = sdl_system_cursor_sizeall - let no = sdl_system_cursor_no - let hand = sdl_system_cursor_hand + include Types.System_cursor end -module Button = struct - let left = sdl_button_left - let right = sdl_button_right - let middle = sdl_button_middle - let x1 = sdl_button_x1 - let x2 = sdl_button_x2 - - let i = Int32.of_int - let lmask = i sdl_button_lmask - let mmask = i sdl_button_mmask - let rmask = i sdl_button_rmask - let x1mask = i sdl_button_x1mask - let x2mask = i sdl_button_x2mask -end +module Button = Types.Button let capture_mouse = foreign "SDL_CaptureMouse" (bool @-> returning int) @@ -3331,7 +2491,7 @@ let get_global_mouse_state () = s, (!@ x, !@ y) let get_mouse_focus = - foreign "SDL_GetMouseFocus" (void @-> returning window_opt) + foreign "SDL_GetMouseFocus" (void @-> returning Types.Window.opt) let get_mouse_state = foreign "SDL_GetMouseState" @@ -3374,7 +2534,7 @@ let show_cursor b = let warp_mouse_in_window = foreign "SDL_WarpMouseInWindow" - (window_opt @-> int @-> int @-> returning void) + (Types.Window.opt @-> int @-> int @-> returning void) let warp_mouse_in_window w ~x ~y = warp_mouse_in_window w x y @@ -3389,7 +2549,7 @@ let warp_mouse_global ~x ~y = type touch_id = int64 let touch_id = int64_t -let touch_mouse_id = Int64.of_int32 (sdl_touch_mouseid) +let touch_mouse_id = Types.touch_mouseid type gesture_id = int64 let gesture_id = int64_t @@ -3397,21 +2557,13 @@ let gesture_id = int64_t type finger_id = int64 let finger_id = int64_t -type _finger -type finger = _finger structure -let finger : finger typ = structure "SDL_Finger" -let finger_finger_id = field finger "id" finger_id -let finger_x = field finger "x" float -let finger_y = field finger "y" float -let finger_pressure = field finger "pressure" float -let () = seal finger - module Finger = struct - let id f = getf f finger_finger_id - let x f = getf f finger_x - let y f = getf f finger_y - let pressure f = getf f finger_pressure + let id f = getf f Types.Finger.id + let x f = getf f Types.Finger.x + let y f = getf f Types.Finger.y + let pressure f = getf f Types.Finger.pressure end +type finger = Types.Finger.t let get_num_touch_devices = foreign "SDL_GetNumTouchDevices" (void @-> returning int) @@ -3428,7 +2580,7 @@ let get_touch_device i = let get_touch_finger = foreign "SDL_GetTouchFinger" - (touch_id @-> int @-> returning (ptr_opt finger)) + (touch_id @-> int @-> returning (ptr_opt Types.Finger.t)) let get_touch_finger id i = match get_touch_finger id i with @@ -3436,7 +2588,7 @@ let get_touch_finger id i = let load_dollar_templates = foreign "SDL_LoadDollarTemplates" - (touch_id @-> rw_ops @-> returning int) + (touch_id @-> Types.rw_ops @-> returning int) let load_dollar_templates x y = load_dollar_templates x y |> zero_to_ok let record_gesture = @@ -3445,121 +2597,92 @@ let record_gesture i = record_gesture i |> one_to_ok let save_dollar_template = foreign "SDL_SaveDollarTemplate" - (gesture_id @-> rw_ops @-> returning int) + (gesture_id @-> Types.rw_ops @-> returning int) let save_dollar_template x y = save_dollar_template x y |> zero_to_ok let save_all_dollar_templates = - foreign "SDL_SaveAllDollarTemplates" (rw_ops @-> returning int) + foreign "SDL_SaveAllDollarTemplates" (Types.rw_ops @-> returning int) let save_all_dollar_templates o = save_all_dollar_templates o |> zero_to_ok (* Joystick *) -type _joystick_guid -type joystick_guid = _joystick_guid structure -let joystick_guid : joystick_guid typ = structure "SDL_JoystickGUID" -(* FIXME: No array here, see - https://github.com/ocamllabs/ocaml-ctypes/issues/113 *) -(* let _= field joystick_guid "data" (array 16 uint8_t) *) -let _= field joystick_guid "data0" uint8_t -let _= field joystick_guid "data1" uint8_t -let _= field joystick_guid "data2" uint8_t -let _= field joystick_guid "data3" uint8_t -let _= field joystick_guid "data4" uint8_t -let _= field joystick_guid "data5" uint8_t -let _= field joystick_guid "data6" uint8_t -let _= field joystick_guid "data7" uint8_t -let _= field joystick_guid "data8" uint8_t -let _= field joystick_guid "data9" uint8_t -let _= field joystick_guid "data10" uint8_t -let _= field joystick_guid "data11" uint8_t -let _= field joystick_guid "data12" uint8_t -let _= field joystick_guid "data13" uint8_t -let _= field joystick_guid "data14" uint8_t -let _= field joystick_guid "data15" uint8_t -let () = seal joystick_guid - type joystick_id = int32 let joystick_id = int32_t -type joystick = unit ptr -let joystick : joystick typ = ptr void -let joystick_opt : joystick option typ = ptr_opt void + type _joystick_guid + type joystick_guid = _joystick_guid structure + let joystick_guid : joystick_guid typ = + structure "SDL_JoystickGUID" + (* FIXME: No array here, see + https://github.com/ocamllabs/ocaml-ctypes/issues/113 *) + (* let _= field joystick_guid "data" (array 16 uint8_t) *) + let _= field joystick_guid "data0" uint8_t + let _= field joystick_guid "data1" uint8_t + let _= field joystick_guid "data2" uint8_t + let _= field joystick_guid "data3" uint8_t + let _= field joystick_guid "data4" uint8_t + let _= field joystick_guid "data5" uint8_t + let _= field joystick_guid "data6" uint8_t + let _= field joystick_guid "data7" uint8_t + let _= field joystick_guid "data8" uint8_t + let _= field joystick_guid "data9" uint8_t + let _= field joystick_guid "data10" uint8_t + let _= field joystick_guid "data11" uint8_t + let _= field joystick_guid "data12" uint8_t + let _= field joystick_guid "data13" uint8_t + let _= field joystick_guid "data14" uint8_t + let _= field joystick_guid "data15" uint8_t + let () = seal joystick_guid + +type joystick = Types.joystick ptr let unsafe_joystick_of_ptr addr : joystick = - ptr_of_raw_address addr + from_voidp Types.joystick (ptr_of_raw_address addr) let unsafe_ptr_of_joystick joystick = raw_address_of_ptr (to_voidp joystick) -module Hat = struct - type t = int - let centered = sdl_hat_centered - let up = sdl_hat_up - let right = sdl_hat_right - let down = sdl_hat_down - let left = sdl_hat_left - let rightup = sdl_hat_rightup - let rightdown = sdl_hat_rightdown - let leftup = sdl_hat_leftup - let leftdown = sdl_hat_leftdown -end +module Hat = Types.Hat -module Joystick_power_level = struct - type t = int - let unknown = sdl_joystick_power_unknown - let low = sdl_joystick_power_low - let medium = sdl_joystick_power_medium - let full = sdl_joystick_power_full - let wired = sdl_joystick_power_wired - let max = sdl_joystick_power_max -end +module Joystick_power_level = Types.Joystick_power_level module Joystick_type = struct - type t = int - let unknown = sdl_joystick_type_unknown - let gamecontroller = sdl_joystick_type_gamecontroller - let wheel = sdl_joystick_type_wheel - let arcade_stick = sdl_joystick_type_arcade_stick - let flight_stick = sdl_joystick_type_flight_stick - let dance_pad = sdl_joystick_type_dance_pad - let guitar = sdl_joystick_type_guitar - let drum_kit = sdl_joystick_type_drum_kit - let arcade_pad = sdl_joystick_type_arcade_pad - let throttle = sdl_joystick_type_throttle + include Types.Joystick_type end let joystick_close = - foreign "SDL_JoystickClose" (joystick @-> returning void) + foreign "SDL_JoystickClose" (ptr Types.joystick @-> returning void) let joystick_current_power_level = foreign "SDL_JoystickCurrentPowerLevel" - (joystick @-> returning int) + (ptr Types.joystick @-> returning int) let joystick_event_state = foreign "SDL_JoystickEventState" (int @-> returning int) -let joystick_event_state i = joystick_event_state i |> nat_to_ok +let joystick_event_state i = joystick_event_state i |> nat_to_ok |> Result.map Unsigned.UInt8.of_int let joystick_from_instance_id = - foreign "SDL_JoystickFromInstanceID" (joystick_id @-> returning joystick) + foreign "SDL_JoystickFromInstanceID" + (joystick_id @-> returning (ptr Types.joystick)) let joystick_get_event_state () = - joystick_event_state sdl_query + joystick_event_state Types.sdl_query let joystick_set_event_state s = - joystick_event_state s + joystick_event_state (Unsigned.UInt8.to_int s) let joystick_get_attached = - foreign "SDL_JoystickGetAttached" (joystick @-> returning bool) + foreign "SDL_JoystickGetAttached" (ptr Types.joystick @-> returning bool) let joystick_get_axis = - foreign "SDL_JoystickGetAxis" (joystick @-> int @-> returning int16_t) + foreign "SDL_JoystickGetAxis" (ptr Types.joystick @-> int @-> returning int16_t) let joystick_get_axis_initial_state = foreign "SDL_JoystickGetAxisInitialState" - (joystick @-> int @-> returning int16_t) + (ptr Types.joystick @-> int @-> returning int16_t) let joystick_get_ball = foreign "SDL_JoystickGetBall" - (joystick @-> int @-> (ptr int) @-> (ptr int) @-> returning int) + (ptr Types.joystick @-> int @-> (ptr int) @-> (ptr int) @-> returning int) let joystick_get_ball j i = let x = allocate int 0 in @@ -3569,7 +2692,7 @@ let joystick_get_ball j i = let joystick_get_button = foreign "SDL_JoystickGetButton" - (joystick @-> int @-> returning int_as_uint8_t) + (ptr Types.joystick @-> int @-> returning int_as_uint8_t) let joystick_get_device_guid = foreign "SDL_JoystickGetDeviceGUID" (int @-> returning joystick_guid) @@ -3591,7 +2714,7 @@ let joystick_get_device_vendor = foreign "SDL_JoystickGetDeviceVendor" (int @-> returning int_as_uint16_t) let joystick_get_guid = - foreign "SDL_JoystickGetGUID" (joystick @-> returning joystick_guid) + foreign "SDL_JoystickGetGUID" (ptr Types.joystick @-> returning joystick_guid) let joystick_get_guid_from_string = foreign "SDL_JoystickGetGUIDFromString" (string @-> returning joystick_guid) @@ -3607,30 +2730,34 @@ let joystick_get_guid_string guid = coerce (ptr char) string s let joystick_get_hat = - foreign "SDL_JoystickGetHat" (joystick @-> int @-> returning int_as_uint8_t) + foreign "SDL_JoystickGetHat" + (ptr Types.joystick @-> int @-> returning int_as_uint8_t) let joystick_get_product = - foreign "SDL_JoystickGetProduct" (joystick @-> returning int_as_uint16_t) + foreign "SDL_JoystickGetProduct" + (ptr Types.joystick @-> returning int_as_uint16_t) let joystick_get_product_version = foreign "SDL_JoystickGetProductVersion" - (joystick @-> returning int_as_uint16_t) + (ptr Types.joystick @-> returning int_as_uint16_t) let joystick_get_type = - foreign "SDL_JoystickGetType" (joystick @-> returning int) + foreign "SDL_JoystickGetType" (ptr Types.joystick @-> returning int) let joystick_get_vendor = - foreign "SDL_JoystickGetVendor" (joystick @-> returning int_as_uint16_t) + foreign "SDL_JoystickGetVendor" + (ptr Types.joystick @-> returning int_as_uint16_t) let joystick_instance_id = - foreign "SDL_JoystickInstanceID" (joystick @-> returning joystick_id) + foreign "SDL_JoystickInstanceID" + (ptr Types.joystick @-> returning joystick_id) let joystick_instance_id j = match joystick_instance_id j with | n when n < 0l -> error () | n -> Ok n let joystick_name = - foreign "SDL_JoystickName" (joystick @-> returning string_opt) + foreign "SDL_JoystickName" (ptr Types.joystick @-> returning string_opt) let joystick_name j = joystick_name j |> some_to_ok let joystick_name_for_index = @@ -3638,23 +2765,23 @@ let joystick_name_for_index = let joystick_name_for_index i = joystick_name_for_index i |> some_to_ok let joystick_num_axes = - foreign "SDL_JoystickNumAxes" (joystick @-> returning int) + foreign "SDL_JoystickNumAxes" (ptr Types.joystick @-> returning int) let joystick_num_axes j = joystick_num_axes j |> nat_to_ok let joystick_num_balls = - foreign "SDL_JoystickNumBalls" (joystick @-> returning int) + foreign "SDL_JoystickNumBalls" (ptr Types.joystick @-> returning int) let joystick_num_balls j = joystick_num_balls j |> nat_to_ok let joystick_num_buttons = - foreign "SDL_JoystickNumButtons" (joystick @-> returning int) + foreign "SDL_JoystickNumButtons" (ptr Types.joystick @-> returning int) let joystick_num_buttons j = joystick_num_buttons j |> nat_to_ok let joystick_num_hats = - foreign "SDL_JoystickNumHats" (joystick @-> returning int) + foreign "SDL_JoystickNumHats" (ptr Types.joystick @-> returning int) let joystick_num_hats j = joystick_num_hats j |> nat_to_ok let joystick_open = - foreign "SDL_JoystickOpen" (int @-> returning joystick_opt) + foreign "SDL_JoystickOpen" (int @-> returning (ptr_opt Types.joystick)) let joystick_open i = joystick_open i |> some_to_ok let joystick_update = @@ -3684,41 +2811,7 @@ let button_bind_value2 = field button_bind "value2" int let () = seal button_bind module Controller = struct - type bind_type = int - let bind_type_none = sdl_controller_bindtype_none - let bind_type_button = sdl_controller_bindtype_button - let bind_type_axis = sdl_controller_bindtype_axis - let bind_type_hat = sdl_controller_bindtype_hat - - type axis = int - let axis_invalid = sdl_controller_axis_invalid - let axis_left_x = sdl_controller_axis_leftx - let axis_left_y = sdl_controller_axis_lefty - let axis_right_x = sdl_controller_axis_rightx - let axis_right_y = sdl_controller_axis_righty - let axis_trigger_left = sdl_controller_axis_triggerleft - let axis_trigger_right = sdl_controller_axis_triggerright - let axis_max = sdl_controller_axis_max - - type button = int - let button_invalid = sdl_controller_button_invalid - let button_a = sdl_controller_button_a - let button_b = sdl_controller_button_b - let button_x = sdl_controller_button_x - let button_y = sdl_controller_button_y - let button_back = sdl_controller_button_back - let button_guide = sdl_controller_button_guide - let button_start = sdl_controller_button_start - let button_left_stick = sdl_controller_button_leftstick - let button_right_stick = sdl_controller_button_rightstick - let button_left_shoulder = sdl_controller_button_leftshoulder - let button_right_shoulder = sdl_controller_button_rightshoulder - let button_dpad_up = sdl_controller_button_dpad_up - let button_dpad_down = sdl_controller_button_dpad_down - let button_dpad_left = sdl_controller_button_dpad_left - let button_dpad_right = sdl_controller_button_dpad_right - let button_max = sdl_controller_button_max - + include Types.Controller type button_bind = _button_bind structure let bind_type v = getf v button_bind_bind_type let bind_button_value v = getf v button_bind_value1 @@ -3732,25 +2825,27 @@ let game_controller_add_mapping s = game_controller_add_mapping s |> bool_to_ok let game_controller_add_mapping_from_rw = foreign "SDL_GameControllerAddMappingsFromRW" - ~stub (rw_ops @-> bool @-> returning int) -let game_controller_add_mapping_from_rw r b = game_controller_add_mapping_from_rw r b |> nat_to_ok + ~stub (Types.rw_ops @-> bool @-> returning int) +let game_controller_add_mapping_from_rw r b = + game_controller_add_mapping_from_rw r b |> nat_to_ok let game_controller_close = foreign "SDL_GameControllerClose" (game_controller @-> returning void) let game_controller_event_state = foreign "SDL_GameControllerEventState" (int @-> returning int) -let game_controller_event_state i = game_controller_event_state i |> nat_to_ok +let game_controller_event_state i = + game_controller_event_state i |> nat_to_ok |> Result.map Unsigned.UInt8.of_int let game_controller_from_instance_id = foreign "SDL_GameControllerFromInstanceID" (joystick_id @-> returning game_controller) let game_controller_get_event_state () = - game_controller_event_state sdl_query + game_controller_event_state Types.sdl_query let game_controller_set_event_state t = - game_controller_event_state t + game_controller_event_state (Unsigned.UInt8.to_int t) let game_controller_get_attached = foreign "SDL_GameControllerGetAttached" (game_controller @-> returning bool) @@ -3780,7 +2875,7 @@ let game_controller_get_button_from_string = let game_controller_get_joystick = foreign "SDL_GameControllerGetJoystick" - (game_controller @-> returning joystick_opt) + (game_controller @-> returning (ptr_opt Types.joystick)) let game_controller_get_joystick c = game_controller_get_joystick c |> some_to_ok let game_controller_get_product = @@ -3847,379 +2942,7 @@ let event_type : event_type typ = int_as_uint32_t module Event = struct - (* Event structures *) - - module Common = struct - type t - let t : t structure typ = structure "SDL_CommonEvent" - let typ = field t "type" int_as_uint32_t - let timestamp = field t "timestamp" int32_as_uint32_t - let () = seal t - end - - module Controller_axis_event = struct - type t - let t : t structure typ = structure "SDL_ControllerAxisEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let which = field t "which" joystick_id - let axis = field t "axis" int_as_uint8_t - let _ = field t "padding1" uint8_t - let _ = field t "padding2" uint8_t - let _ = field t "padding3" uint8_t - let value = field t "value" int16_t - let _ = field t "padding4" uint16_t - let () = seal t - end - - module Controller_button_event = struct - type t - let t : t structure typ = structure "SDL_ControllerButtonEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let which = field t "which" joystick_id - let button = field t "button" int_as_uint8_t - let state = field t "state" int_as_uint8_t - let _ = field t "padding1" uint8_t - let _ = field t "padding2" uint8_t - let () = seal t - end - - module Controller_device_event = struct - type t - let t : t structure typ = structure "SDL_ControllerDeviceEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let which = field t "which" joystick_id - let () = seal t - end - - module Dollar_gesture_event = struct - type t - let t : t structure typ = structure "SDL_DollarGestureEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let touch_id = field t "touchId" touch_id - let gesture_id = field t "gestureId" gesture_id - let num_fingers = field t "numFingers" int_as_uint32_t - let error = field t "error" float - let x = field t "x" float - let y = field t "y" float - let () = seal t - end - - module Drop_event = struct - type t - let t : t structure typ = structure "SDL_DropEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let file = field t "file" (ptr char) - let window_id = field t "windowID" int_as_uint32_t - let () = seal t - end - - module Keyboard_event = struct - type t - let t : t structure typ = structure "SDL_KeyboardEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let window_id = field t "windowID" int_as_uint32_t - let state = field t "state" int_as_uint8_t - let repeat = field t "repeat" int_as_uint8_t - let _padding2 = field t "padding2" uint8_t - let _padding3 = field t "padding3" uint8_t - (* We inline the definition of SDL_Keysym *) - let scancode = field t "scancode" scancode - let keycode = field t "sym" keycode - let keymod = field t "mod" keymod - let _unused = field t "unused" uint32_t - let () = seal t - end - - module Joy_axis_event = struct - type t - let t : t structure typ = structure "SDL_JoyAxisEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let which = field t "which" joystick_id - let axis = field t "axis" int_as_uint8_t - let _ = field t "padding1" uint8_t - let _ = field t "padding2" uint8_t - let _ = field t "padding3" uint8_t - let value = field t "value" int16_t - let _ = field t "padding4" uint16_t - let () = seal t - end - - module Joy_ball_event = struct - type t - let t : t structure typ = structure "SDL_JoyBallEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let which = field t "which" joystick_id - let ball = field t "ball" int_as_uint8_t - let _ = field t "padding1" uint8_t - let _ = field t "padding2" uint8_t - let _ = field t "padding3" uint8_t - let xrel = field t "xrel" int16_t - let yrel = field t "yrel" int16_t - let () = seal t - end - - module Joy_button_event = struct - type t - let t : t structure typ = structure "SDL_JoyButtonEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let which = field t "which" joystick_id - let button = field t "button" int_as_uint8_t - let state = field t "state" int_as_uint8_t - let _ = field t "padding1" uint8_t - let _ = field t "padding2" uint8_t - let () = seal t - end - - module Joy_device_event = struct - type t - let t : t structure typ = structure "SDL_JoyDeviceEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let which = field t "which" joystick_id - let () = seal t - end - - module Joy_hat_event = struct - type t - let t : t structure typ = structure "SDL_JoyHatEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let which = field t "which" joystick_id - let hat = field t "hat" int_as_uint8_t - let value = field t "value" int_as_uint8_t - let _ = field t "padding1" uint8_t - let _ = field t "padding2" uint8_t - let () = seal t - end - - module Mouse_button_event = struct - type t - let t : t structure typ = structure "SDL_MouseButtonEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let window_id = field t "windowID" int_as_uint32_t - let which = field t "which" int32_as_uint32_t - let button = field t "button" int_as_uint8_t - let state = field t "state" int_as_uint8_t - let clicks = field t "clicks" int_as_uint8_t - let _ = field t "padding1" int_as_uint8_t - let x = field t "x" int_as_int32_t - let y = field t "y" int_as_int32_t - let () = seal t - end - - module Mouse_motion_event = struct - type t - let t : t structure typ = structure "SDL_MouseMotionEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let window_id = field t "windowID" int_as_uint32_t - let which = field t "which" int32_as_uint32_t - let state = field t "state" int32_as_uint32_t - let x = field t "x" int_as_int32_t - let y = field t "y" int_as_int32_t - let xrel = field t "xrel" int_as_int32_t - let yrel = field t "yrel" int_as_int32_t - let () = seal t - end - - type mouse_wheel_direction = int - let mouse_wheel_normal = sdl_mousewheel_normal - let mouse_wheel_flipped = sdl_mousewheel_flipped - - module Mouse_wheel_event = struct - type t - let t : t structure typ = structure "SDL_MouseWheelEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let window_id = field t "windowID" int_as_uint32_t - let which = field t "which" int32_as_uint32_t - let x = field t "x" int_as_int32_t - let y = field t "y" int_as_int32_t - let direction = field t "direction" int_as_uint32_t - let () = seal t - end - - module Multi_gesture_event = struct - type t - let t : t structure typ = structure "SDL_MultiGestureEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let touch_id = field t "touchId" touch_id - let dtheta = field t "dTheta" float - let ddist = field t "ddist" float - let x = field t "x" float - let y = field t "y" float - let num_fingers = field t "numFingers" int_as_uint16_t - let _ = field t "padding" uint16_t - let () = seal t - end - - module Sensor_event = struct - type t - let t : t structure typ = structure "SDL_SensorEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let which = field t "which" int32_as_uint32_t - (* FIXME: No array here, see - https://github.com/ocamllabs/ocaml-ctypes/issues/113 *) - let data0 = field t "data0" float - let data1 = field t "data1" float - let data2 = field t "data2" float - let data3 = field t "data3" float - let data4 = field t "data4" float - let data5 = field t "data5" float - let () = seal t - end - - module Quit_event = struct - type t - let t : t structure typ = structure "SDL_QuitEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let () = seal t - end - - module Sys_wm_event = struct - type t - let t : t structure typ = structure "SDL_SysWMEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let _ = field t "msg" (ptr void) - let () = seal t - end - - module Text_editing_event = struct - type t - let t : t structure typ = structure "SDL_TextEditingEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let window_id = field t "windowID" int_as_uint32_t - let text = field t "text" (string_as_char_array - sdl_texteditingevent_text_size) - let start = field t "start" int_as_int32_t - let length = field t "end" int_as_int32_t - let () = seal t - end - - module Text_input_event = struct - type t - let t : t structure typ = structure "SDL_TextIfmtsnputEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let window_id = field t "windowID" int_as_uint32_t - let text = field t "text" (string_as_char_array - sdl_textinputevent_text_size) - let () = seal t - end - - module Touch_finger_event = struct - type t - let t : t structure typ = structure "SDL_TouchFingerEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let touch_id = field t "touchId" touch_id - let finger_id = field t "fingerId" finger_id - let x = field t "x" float - let y = field t "y" float - let dx = field t "dx" float - let dy = field t "dy" float - let pressure = field t "pressure" float - let () = seal t - end - - module User_event = struct - type t - let t : t structure typ = structure "SDL_UserEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let window_id = field t "windowID" int_as_uint32_t - let code = field t "code" int_as_int32_t - let _ = field t "data1" (ptr void) - let _ = field t "data2" (ptr void) - let () = seal t - end - - module Window_event = struct - type t - let t : t structure typ = structure "SDL_WindowEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let window_id = field t "windowID" int_as_uint32_t - let event = field t "event" int_as_uint8_t - let _padding1 = field t "padding1" uint8_t - let _padding2 = field t "padding2" uint8_t - let _padding3 = field t "padding3" uint8_t - let data1 = field t "data1" int32_t - let data2 = field t "data2" int32_t - let () = seal t - end - - module Display_event = struct - type t - let t : t structure typ = structure "SDL_DisplayEvent" - let _ = field t "type" int_as_uint32_t - let _ = field t "timestamp" int32_as_uint32_t - let display = field t "display" int32_as_uint32_t - let event = field t "event" int_as_uint8_t - let _padding1 = field t "padding1" uint8_t - let _padding2 = field t "padding2" uint8_t - let _padding3 = field t "padding3" uint8_t - let data1 = field t "data1" int32_t - let () = seal t - end - - module Audio_device_event = struct - type t - let t : t structure typ = structure "SDL_AudioDevice" - let _ = field t "type" int_as_uint32_t - let timestamp = field t "timestamp" int32_as_uint32_t - let which = field t "which" int32_as_uint32_t - let iscapture = field t "iscapture" int_as_uint8_t - let () = seal t - end - - type t - let t : t union typ = union "SDL_Event" - let _typ = field t "type" int_as_uint32_t - let audio_device_event = field t "adevice" Audio_device_event.t - let common = field t "common" Common.t - let controller_axis_event = field t "caxis" Controller_axis_event.t - let controller_button_event = field t "cbutton" Controller_button_event.t - let controller_device_event = field t "cdevice" Controller_device_event.t - let dollar_gesture_event = field t "dgesture" Dollar_gesture_event.t - let drop_event = field t "drop" Drop_event.t - let joy_axis_event = field t "jaxis" Joy_axis_event.t - let joy_ball_event = field t "jball" Joy_ball_event.t - let joy_button_event = field t "jbutton" Joy_button_event.t - let joy_device_event = field t "jdevice" Joy_device_event.t - let joy_hat_event = field t "jhat" Joy_hat_event.t - let keyboard_event = field t "key" Keyboard_event.t - let mouse_button_event = field t "button" Mouse_button_event.t - let mouse_motion_event = field t "motion" Mouse_motion_event.t - let mouse_wheel_event = field t "wheel" Mouse_wheel_event.t - let multi_gesture_event = field t "mgesture" Multi_gesture_event.t - let _quit_event = field t "quit" Quit_event.t - let _sys_wm_event = field t "syswm" Sys_wm_event.t - let text_editing_event = field t "edit" Text_editing_event.t - let text_input_event = field t "text" Text_input_event.t - let touch_finger_event = field t "tfinger" Touch_finger_event.t - let user_event = field t "user" User_event.t - let window_event = field t "window" Window_event.t - let display_event = field t "display" Display_event.t - let sensor_event = field t "sensor" Sensor_event.t - let _padding = field t "padding" - (abstract ~name:"padding" ~size:tsdl_sdl_event_size ~alignment:1) - let () = seal t + include Types.Event let create () = make t let opt_addr = function @@ -4229,85 +2952,60 @@ module Event = struct type _ field = F : (* existential to hide the 'a structure *) (('a structure, t union) Ctypes.field * - ('b, 'a structure) Ctypes.field) -> 'b field - - let get e (F (s, f)) = getf (getf e s) f - let set e (F (s, f)) v = setf (getf e s) f v - - (* Aliases *) + ('b, 'a structure) Ctypes.field * + ('b -> 'c) * ('b -> 'c -> 'b)) -> 'c field - let first_event = sdl_firstevent - let last_event = sdl_lastevent + let get e (F (s, f, c, _)) = c (getf (getf e s) f) + let set e (F (s, f, _, c)) v = let x = getf e s in setf x f (c (getf x f) v) (* Common *) - let typ = F (common, Common.typ) - let timestamp = F (common, Common.timestamp) - - (* Application events. *) - - let app_terminating = sdl_app_terminating - let app_low_memory = sdl_app_lowmemory - let app_will_enter_background = sdl_app_willenterbackground - let app_did_enter_background = sdl_app_didenterbackground - let app_will_enter_foreground = sdl_app_willenterforeground - let app_did_enter_foreground = sdl_app_didenterforeground - - (* Clipboard events *) - - let clipboard_update = sdl_clipboardupdate + let typ = + F (common, Common.typ, + Unsigned.UInt32.to_int, (fun _ x -> Unsigned.UInt32.of_int x)) + let timestamp = + F (common, Common.timestamp, + Unsigned.UInt32.to_int32, (fun _ x -> Unsigned.UInt32.of_int32 x)) (* Controller events *) - let controller_axis_motion = sdl_controlleraxismotion - let controller_button_down = sdl_controllerbuttondown - let controller_button_up = sdl_controllerbuttonup - let controller_device_added = sdl_controllerdeviceadded - let controller_device_remapped = sdl_controllerdeviceremapped - let controller_device_removed = sdl_controllerdeviceremoved - let controller_axis_which = - F (controller_axis_event, Controller_axis_event.which) + F (controller_axis_event, Controller_axis_event.which, Fun.id, (fun _ x -> x)) let controller_axis_axis = - F (controller_axis_event, Controller_axis_event.axis) + F (controller_axis_event, Controller_axis_event.axis, + Unsigned.UInt8.to_int, (fun _ x -> Unsigned.UInt8.of_int x)) let controller_axis_value = - F (controller_axis_event, Controller_axis_event.value) + F (controller_axis_event, Controller_axis_event.value, Fun.id, (fun _ x -> x)) let controller_button_which = - F (controller_button_event, Controller_button_event.which) + F (controller_button_event, Controller_button_event.which, Fun.id, (fun _ x -> x)) let controller_button_button = - F (controller_button_event, Controller_button_event.button) + F (controller_button_event, Controller_button_event.button, + Unsigned.UInt8.to_int, (fun _ x -> Unsigned.UInt8.of_int x)) let controller_button_state = - F (controller_button_event, Controller_button_event.state) + F (controller_button_event, Controller_button_event.state, Fun.id, (fun _ x -> x)) let controller_device_which = - F (controller_device_event, Controller_device_event.which) - - (* Dollar gesture events *) - - let dollar_gesture = sdl_dollargesture - let dollar_record = sdl_dollarrecord + F (controller_device_event, Controller_device_event.which, Fun.id, (fun _ x -> x)) let dollar_gesture_touch_id = - F (dollar_gesture_event, Dollar_gesture_event.touch_id) + F (dollar_gesture_event, Dollar_gesture_event.touch_id, Fun.id, (fun _ x -> x)) let dollar_gesture_gesture_id = - F (dollar_gesture_event, Dollar_gesture_event.gesture_id) + F (dollar_gesture_event, Dollar_gesture_event.gesture_id, Fun.id, (fun _ x -> x)) let dollar_gesture_num_fingers = - F (dollar_gesture_event, Dollar_gesture_event.num_fingers) + F (dollar_gesture_event, Dollar_gesture_event.num_fingers, + Unsigned.UInt32.to_int, (fun _ x -> Unsigned.UInt32.of_int x)) let dollar_gesture_error = - F (dollar_gesture_event, Dollar_gesture_event.error) - let dollar_gesture_x = F (dollar_gesture_event, Dollar_gesture_event.x) - let dollar_gesture_y = F (dollar_gesture_event, Dollar_gesture_event.y) - - (* Drop file event *) - - let drop_file = sdl_dropfile - let drop_text = sdl_droptext - let drop_begin = sdl_dropbegin - let drop_complete = sdl_dropcomplete + F (dollar_gesture_event, Dollar_gesture_event.error, Fun.id, (fun _ x -> x)) + let dollar_gesture_x = + F (dollar_gesture_event, Dollar_gesture_event.x, Fun.id, (fun _ x -> x)) + let dollar_gesture_y = + F (dollar_gesture_event, Dollar_gesture_event.y, Fun.id, (fun _ x -> x)) - let drop_file_file = F (drop_event, Drop_event.file) - let drop_window_id = F (drop_event, Drop_event.window_id) + let drop_file_file = F (drop_event, Drop_event.file, Fun.id, (fun _ x -> x)) + let drop_window_id = + F (drop_event, Drop_event.window_id, + Unsigned.UInt32.to_int, (fun _ x -> Unsigned.UInt32.of_int x)) let drop_file_free e = let sp = to_voidp (get e drop_file_file) in @@ -4319,160 +3017,202 @@ module Event = struct (* Touch events *) - let finger_down = sdl_fingerdown - let finger_motion = sdl_fingermotion - let finger_up = sdl_fingerup - - let touch_finger_touch_id = F (touch_finger_event,Touch_finger_event.touch_id) + let touch_finger_touch_id = + F (touch_finger_event,Touch_finger_event.touch_id, Fun.id, (fun _ x -> x)) let touch_finger_finger_id = - F (touch_finger_event, Touch_finger_event.finger_id) - let touch_finger_x = F (touch_finger_event, Touch_finger_event.x) - let touch_finger_y = F (touch_finger_event, Touch_finger_event.y) - let touch_finger_dx = F (touch_finger_event, Touch_finger_event.dx) - let touch_finger_dy = F (touch_finger_event, Touch_finger_event.dy) + F (touch_finger_event, Touch_finger_event.finger_id, Fun.id, (fun _ x -> x)) + let touch_finger_x = + F (touch_finger_event, Touch_finger_event.x, Fun.id, (fun _ x -> x)) + let touch_finger_y = + F (touch_finger_event, Touch_finger_event.y, Fun.id, (fun _ x -> x)) + let touch_finger_dx = + F (touch_finger_event, Touch_finger_event.dx, Fun.id, (fun _ x -> x)) + let touch_finger_dy = + F (touch_finger_event, Touch_finger_event.dy, Fun.id, (fun _ x -> x)) let touch_finger_pressure = - F (touch_finger_event, Touch_finger_event.pressure) + F (touch_finger_event, Touch_finger_event.pressure, Fun.id, (fun _ x -> x)) (* Joystick events. *) - let joy_axis_motion = sdl_joyaxismotion - let joy_ball_motion = sdl_joyballmotion - let joy_button_down = sdl_joybuttondown - let joy_button_up = sdl_joybuttonup - let joy_device_added = sdl_joydeviceadded - let joy_device_removed = sdl_joydeviceremoved - let joy_hat_motion = sdl_joyhatmotion - - let joy_axis_which = F (joy_axis_event, Joy_axis_event.which) - let joy_axis_axis = F (joy_axis_event, Joy_axis_event.axis) - let joy_axis_value = F (joy_axis_event, Joy_axis_event.value) - - let joy_ball_which = F (joy_ball_event, Joy_ball_event.which) - let joy_ball_ball = F (joy_ball_event, Joy_ball_event.ball) - let joy_ball_xrel = F (joy_ball_event, Joy_ball_event.xrel) - let joy_ball_yrel = F (joy_ball_event, Joy_ball_event.yrel) - - let joy_button_which = F (joy_button_event, Joy_button_event.which) - let joy_button_button = F (joy_button_event, Joy_button_event.button) - let joy_button_state = F (joy_button_event, Joy_button_event.state) - - let joy_device_which = F (joy_device_event, Joy_device_event.which) - - let joy_hat_which = F (joy_hat_event, Joy_hat_event.which) - let joy_hat_hat = F (joy_hat_event, Joy_hat_event.hat) - let joy_hat_value = F (joy_hat_event, Joy_hat_event.value) + let joy_axis_which = + F (joy_axis_event, Joy_axis_event.which, Fun.id, (fun _ x -> x)) + let joy_axis_axis = + F (joy_axis_event, Joy_axis_event.axis, + Unsigned.UInt8.to_int, (fun _ x -> Unsigned.UInt8.of_int x)) + let joy_axis_value = + F (joy_axis_event, Joy_axis_event.value, Fun.id, (fun _ x -> x)) + + let joy_ball_which = + F (joy_ball_event, Joy_ball_event.which, Fun.id, (fun _ x -> x)) + let joy_ball_ball = + F (joy_ball_event, Joy_ball_event.ball, + Unsigned.UInt8.to_int, (fun _ x -> Unsigned.UInt8.of_int x)) + let joy_ball_xrel = + F (joy_ball_event, Joy_ball_event.xrel, Fun.id, (fun _ x -> x)) + let joy_ball_yrel = + F (joy_ball_event, Joy_ball_event.yrel, Fun.id, (fun _ x -> x)) + + let joy_button_which = + F (joy_button_event, Joy_button_event.which, Fun.id, (fun _ x -> x)) + let joy_button_button = + F (joy_button_event, Joy_button_event.button, + Unsigned.UInt8.to_int, (fun _ x -> Unsigned.UInt8.of_int x)) + let joy_button_state = + F (joy_button_event, Joy_button_event.state, Fun.id, (fun _ x -> x)) + + let joy_device_which = + F (joy_device_event, Joy_device_event.which, Fun.id, (fun _ x -> x)) + + let joy_hat_which = + F (joy_hat_event, Joy_hat_event.which, Fun.id, (fun _ x -> x)) + let joy_hat_hat = + F (joy_hat_event, Joy_hat_event.hat, + Unsigned.UInt8.to_int, (fun _ x -> Unsigned.UInt8.of_int x)) + let joy_hat_value = + F (joy_hat_event, Joy_hat_event.value, + Unsigned.UInt8.to_int, (fun _ x -> Unsigned.UInt8.of_int x)) (* Keyboard events *) - let key_down = sdl_keydown - let key_up = sdl_keyup - let keymap_changed = sdl_keymapchanged - - let keyboard_window_id = F (keyboard_event, Keyboard_event.window_id) - let keyboard_repeat = F (keyboard_event, Keyboard_event.repeat) - let keyboard_state = F (keyboard_event, Keyboard_event.state) - let keyboard_scancode = F (keyboard_event, Keyboard_event.scancode) - let keyboard_keycode = F (keyboard_event, Keyboard_event.keycode) - let keyboard_keymod = F (keyboard_event, Keyboard_event.keymod) + let keyboard_window_id = + F (keyboard_event, Keyboard_event.window_id, + Unsigned.UInt32.to_int, (fun _ x -> Unsigned.UInt32.of_int x)) + let keyboard_repeat = + F (keyboard_event, Keyboard_event.repeat, + Unsigned.UInt8.to_int, (fun _ x -> Unsigned.UInt8.of_int x)) + let keyboard_state = + F (keyboard_event, Keyboard_event.state, Fun.id, (fun _ x -> x)) + let keyboard_scancode = + F (keyboard_event, Keyboard_event.keysym, + (fun k -> getf k Keyboard_event.scancode), + (fun k v -> let () = setf k Keyboard_event.scancode v in k)) + let keyboard_keycode = + F (keyboard_event, Keyboard_event.keysym, + (fun k -> getf k Keyboard_event.keycode), + (fun k v -> let () = setf k Keyboard_event.keycode v in k)) + let keyboard_keymod = + F (keyboard_event, Keyboard_event.keysym, + (fun k -> Unsigned.UInt16.to_int (getf k Keyboard_event.keymod)), + (fun k v -> + let () = setf k Keyboard_event.keymod (Unsigned.UInt16.of_int v) in k)) (* Mouse events *) - let mouse_button_down = sdl_mousebuttondown - let mouse_button_up = sdl_mousebuttonup - let mouse_motion = sdl_mousemotion - let mouse_wheel = sdl_mousewheel - let mouse_button_window_id = - F (mouse_button_event, Mouse_button_event.window_id) - let mouse_button_which = F (mouse_button_event, Mouse_button_event.which) - let mouse_button_state = F (mouse_button_event, Mouse_button_event.state) - let mouse_button_button = F (mouse_button_event, Mouse_button_event.button) - let mouse_button_clicks = F (mouse_button_event, Mouse_button_event.clicks) - let mouse_button_x = F (mouse_button_event, Mouse_button_event.x) - let mouse_button_y = F (mouse_button_event, Mouse_button_event.y) + F (mouse_button_event, Mouse_button_event.window_id, + Unsigned.UInt32.to_int, (fun _ x -> Unsigned.UInt32.of_int x)) + let mouse_button_which = + F (mouse_button_event, Mouse_button_event.which, + Unsigned.UInt32.to_int32, (fun _ x -> Unsigned.UInt32.of_int32 x)) + let mouse_button_state = + F (mouse_button_event, Mouse_button_event.state, Fun.id, (fun _ x -> x)) + let mouse_button_button = + F (mouse_button_event, Mouse_button_event.button, + Unsigned.UInt8.to_int, (fun _ x -> Unsigned.UInt8.of_int x)) + let mouse_button_clicks = + F (mouse_button_event, Mouse_button_event.clicks, + Unsigned.UInt8.to_int, (fun _ x -> Unsigned.UInt8.of_int x)) + let mouse_button_x = + F (mouse_button_event, Mouse_button_event.x, + Int32.to_int, (fun _ x -> Int32.of_int x)) + let mouse_button_y = + F (mouse_button_event, Mouse_button_event.y, + Int32.to_int, (fun _ x -> Int32.of_int x)) let mouse_motion_window_id = - F (mouse_motion_event, Mouse_motion_event.window_id) - let mouse_motion_which = F (mouse_motion_event, Mouse_motion_event.which) - let mouse_motion_state = F (mouse_motion_event, Mouse_motion_event.state) - let mouse_motion_x = F (mouse_motion_event, Mouse_motion_event.x) - let mouse_motion_y = F (mouse_motion_event, Mouse_motion_event.y) - let mouse_motion_xrel = F (mouse_motion_event, Mouse_motion_event.xrel) - let mouse_motion_yrel = F (mouse_motion_event, Mouse_motion_event.yrel) - - let mouse_wheel_window_id = F (mouse_wheel_event, Mouse_wheel_event.window_id) - let mouse_wheel_which = F (mouse_wheel_event, Mouse_wheel_event.which) - let mouse_wheel_x = F (mouse_wheel_event, Mouse_wheel_event.x) - let mouse_wheel_y = F (mouse_wheel_event, Mouse_wheel_event.y) - let mouse_wheel_direction = F(mouse_wheel_event, Mouse_wheel_event.direction) + F (mouse_motion_event, Mouse_motion_event.window_id, + Unsigned.UInt32.to_int, (fun _ x -> Unsigned.UInt32.of_int x)) + let mouse_motion_which = + F (mouse_motion_event, Mouse_motion_event.which, + Unsigned.UInt32.to_int32, (fun _ x -> Unsigned.UInt32.of_int32 x)) + let mouse_motion_state = + F (mouse_motion_event, Mouse_motion_event.state, + Unsigned.UInt32.to_int32, (fun _ x -> Unsigned.UInt32.of_int32 x)) + let mouse_motion_x = + F (mouse_motion_event, Mouse_motion_event.x, + Int32.to_int, (fun _ x -> Int32.of_int x)) + let mouse_motion_y = + F (mouse_motion_event, Mouse_motion_event.y, + Int32.to_int, (fun _ x -> Int32.of_int x)) + let mouse_motion_xrel = + F (mouse_motion_event, Mouse_motion_event.xrel, + Int32.to_int, (fun _ x -> Int32.of_int x)) + let mouse_motion_yrel = + F (mouse_motion_event, Mouse_motion_event.yrel, + Int32.to_int, (fun _ x -> Int32.of_int x)) + + let mouse_wheel_window_id = + F (mouse_wheel_event, Mouse_wheel_event.window_id, + Unsigned.UInt32.to_int, (fun _ x -> Unsigned.UInt32.of_int x)) + let mouse_wheel_which = + F (mouse_wheel_event, Mouse_wheel_event.which, + Unsigned.UInt32.to_int32, (fun _ x -> Unsigned.UInt32.of_int32 x)) + let mouse_wheel_x = + F (mouse_wheel_event, Mouse_wheel_event.x, + Int32.to_int, (fun _ x -> Int32.of_int x)) + let mouse_wheel_y = + F (mouse_wheel_event, Mouse_wheel_event.y, + Int32.to_int, (fun _ x -> Int32.of_int x)) + let mouse_wheel_direction = + F(mouse_wheel_event, Mouse_wheel_event.direction, + Unsigned.UInt32.to_int, (fun _ x -> Unsigned.UInt32.of_int x)) (* Multi gesture events *) - let multi_gesture = sdl_multigesture - let multi_gesture_touch_id = - F (multi_gesture_event, Multi_gesture_event.touch_id) - let multi_gesture_dtheta = F (multi_gesture_event, Multi_gesture_event.dtheta) - let multi_gesture_ddist = F (multi_gesture_event, Multi_gesture_event.ddist) - let multi_gesture_x = F (multi_gesture_event, Multi_gesture_event.x) - let multi_gesture_y = F (multi_gesture_event, Multi_gesture_event.y) + F (multi_gesture_event, Multi_gesture_event.touch_id, Fun.id, (fun _ x -> x)) + let multi_gesture_dtheta = + F (multi_gesture_event, Multi_gesture_event.dtheta, Fun.id, (fun _ x -> x)) + let multi_gesture_ddist = + F (multi_gesture_event, Multi_gesture_event.ddist, Fun.id, (fun _ x -> x)) + let multi_gesture_x = + F (multi_gesture_event, Multi_gesture_event.x, Fun.id, (fun _ x -> x)) + let multi_gesture_y = + F (multi_gesture_event, Multi_gesture_event.y, Fun.id, (fun _ x -> x)) let multi_gesture_num_fingers = - F (multi_gesture_event, Multi_gesture_event.num_fingers) - - (* Quit events *) - - let quit = sdl_quit - - (* System window manager events *) - - let sys_wm_event = sdl_syswmevent - - (* Text events *) - - let text_editing = sdl_textediting - let text_input = sdl_textinput + F (multi_gesture_event, Multi_gesture_event.num_fingers, + Unsigned.UInt16.to_int, (fun _ x -> Unsigned.UInt16.of_int x)) let text_editing_window_id = - F (text_editing_event, Text_editing_event.window_id) - let text_editing_text = F (text_editing_event, Text_editing_event.text) - let text_editing_start = F (text_editing_event, Text_editing_event.start) - let text_editing_length = F (text_editing_event, Text_editing_event.length) - - let text_input_window_id = F (text_input_event, Text_input_event.window_id) - let text_input_text = F (text_input_event, Text_input_event.text) + F (text_editing_event, Text_editing_event.window_id, + Unsigned.UInt32.to_int, (fun _ x -> Unsigned.UInt32.of_int x)) + let text_editing_text = + F (text_editing_event, Text_editing_event.text, + (fun p -> string_from_ptr (CArray.start p) ~length:texteditingevent_text_size), + (fun _ x -> CArray.of_string x)) + let text_editing_start = + F (text_editing_event, Text_editing_event.start, + Int32.to_int, (fun _ x -> Int32.of_int x)) + let text_editing_length = + F (text_editing_event, Text_editing_event.length, + Int32.to_int, (fun _ x -> Int32.of_int x)) + + let text_input_window_id = + F (text_input_event, Text_input_event.window_id, + Unsigned.UInt32.to_int, (fun _ x -> Unsigned.UInt32.of_int x)) + let text_input_text = + F (text_input_event, Text_input_event.text, + (fun p -> string_from_ptr (CArray.start p) ~length:textinputevent_text_size), + (fun _ x -> CArray.of_string x)) (* User events *) - let user_window_id = F (user_event, User_event.window_id) - let user_code = F (user_event, User_event.code) - let user_event = sdl_userevent - - (* Window events *) - - type window_event_id = int - let window_event_shown = sdl_windowevent_shown - let window_event_hidden = sdl_windowevent_hidden - let window_event_exposed = sdl_windowevent_exposed - let window_event_moved = sdl_windowevent_moved - let window_event_resized = sdl_windowevent_resized - let window_event_size_changed = sdl_windowevent_size_changed - let window_event_minimized = sdl_windowevent_minimized - let window_event_maximized = sdl_windowevent_maximized - let window_event_restored = sdl_windowevent_restored - let window_event_enter = sdl_windowevent_enter - let window_event_leave = sdl_windowevent_leave - let window_event_focus_gained = sdl_windowevent_focus_gained - let window_event_focus_lost = sdl_windowevent_focus_lost - let window_event_close = sdl_windowevent_close - let window_event_take_focus = sdl_windowevent_take_focus - let window_event_hit_test = sdl_windowevent_hit_test - - let window_window_id = F (window_event, Window_event.window_id) - let window_event_id = F (window_event, Window_event.event) - let window_data1 = F (window_event, Window_event.data1) - let window_data2 = F (window_event, Window_event.data2) - - let window_event = sdl_windowevent + let user_window_id = + F (_user_event, User_event.window_id, + Unsigned.UInt32.to_int, (fun _ x -> Unsigned.UInt32.of_int x)) + let user_code = + F (_user_event, User_event.code, Int32.to_int, (fun _ x -> Int32.of_int x)) + + let window_window_id = + F (_window_event, Window_event.window_id, + Unsigned.UInt32.to_int, (fun _ x -> Unsigned.UInt32.of_int x)) + let window_event_id = + F (_window_event, Window_event.event, + Unsigned.UInt8.to_int, (fun _ x -> Unsigned.UInt8.of_int x)) + let window_data1 = + F (_window_event, Window_event.data1, Fun.id, (fun _ x -> x)) + let window_data2 = + F (_window_event, Window_event.data2, Fun.id, (fun _ x -> x)) (* Window event id enum *) @@ -4483,8 +3223,7 @@ module Event = struct | `Unknown of window_event_id ] let enum_of_window_event_id = - let add acc (k, v) = Imap.add k v acc in - let enums = [ + let enums = [ window_event_shown, `Shown; window_event_hidden, `Hidden; window_event_exposed, `Exposed; @@ -4502,67 +3241,73 @@ module Event = struct window_event_take_focus, `Take_focus; window_event_hit_test, `Hit_test; ] in - List.fold_left add Imap.empty enums + enums let window_event_enum id = - try Imap.find id enum_of_window_event_id with Not_found -> `Unknown id + try List.assoc id enum_of_window_event_id with Not_found -> `Unknown id (* Display event *) let display_display = - F (display_event, Display_event.display) + F (_display_event, Display_event.display, + Unsigned.UInt32.to_int32, (fun _ x -> Unsigned.UInt32.of_int32 x)) let display_event_id = - F (display_event, Display_event.event) + F (_display_event, Display_event.event, + Unsigned.UInt8.to_int, (fun _ x -> Unsigned.UInt8.of_int x)) let display_data1 = - F (display_event, Display_event.data1) - - let display_event = sdl_displayevent + F (_display_event, Display_event.data1, Fun.id, (fun _ x -> x)) (* Sensor event *) let sensor_which = - F (sensor_event, Sensor_event.which) + F (sensor_event, Sensor_event.which, + Unsigned.UInt32.to_int32, (fun _ x -> Unsigned.UInt32.of_int32 x)) let sensor_data0 = - F (sensor_event, Sensor_event.data0) + F (sensor_event, Sensor_event.data, + (fun a -> CArray.get a 0), + (fun a x -> let () = CArray.set a 0 x in a)) let sensor_data1 = - F (sensor_event, Sensor_event.data1) + F (sensor_event, Sensor_event.data, + (fun a -> CArray.get a 1), + (fun a x -> let () = CArray.set a 1 x in a)) let sensor_data2 = - F (sensor_event, Sensor_event.data2) + F (sensor_event, Sensor_event.data, + (fun a -> CArray.get a 2), + (fun a x -> let () = CArray.set a 2 x in a)) let sensor_data3 = - F (sensor_event, Sensor_event.data3) + F (sensor_event, Sensor_event.data, + (fun a -> CArray.get a 3), + (fun a x -> let () = CArray.set a 3 x in a)) let sensor_data4 = - F (sensor_event, Sensor_event.data4) + F (sensor_event, Sensor_event.data, + (fun a -> CArray.get a 4), + (fun a x -> let () = CArray.set a 4 x in a)) let sensor_data5 = - F (sensor_event, Sensor_event.data5) - - let sensor_update = sdl_sensorupdate - - (* Render events *) - - let render_targets_reset = sdl_render_targets_reset - let render_device_reset = sdl_render_device_reset + F (sensor_event, Sensor_event.data, + (fun a -> CArray.get a 5), + (fun a x -> let () = CArray.set a 5 x in a)) (* Audio device event *) - let audio_device_added = sdl_audiodeviceadded - let audio_device_removed = sdl_audiodeviceremoved - let audio_device_timestamp = - F (audio_device_event, Audio_device_event.timestamp) + F (audio_device_event, Audio_device_event.timestamp, + Unsigned.UInt32.to_int32, (fun _ x -> Unsigned.UInt32.of_int32 x)) let audio_device_which = - F (audio_device_event, Audio_device_event.which) + F (audio_device_event, Audio_device_event.which, + Unsigned.UInt32.to_int32, (fun _ x -> Unsigned.UInt32.of_int32 x)) let audio_device_is_capture = - F (audio_device_event, Audio_device_event.iscapture) + F (audio_device_event, Audio_device_event.iscapture, + Unsigned.UInt8.to_int, (fun _ x -> Unsigned.UInt8.of_int x)) (* Event type enum *) @@ -4649,13 +3394,13 @@ end type event = Event.t union let event_state = - foreign "SDL_EventState" (event_type @-> int @-> returning int_as_uint8_t) + foreign "SDL_EventState" (event_type @-> int @-> returning uint8_t) let get_event_state e = - event_state e sdl_query + event_state e Types.sdl_query let set_event_state e s = - ignore (event_state e s) + ignore (event_state e (Unsigned.UInt8.to_int s)) let flush_event = foreign "SDL_FlushEvent" (event_type @-> returning void) @@ -4713,191 +3458,28 @@ let haptic_opt : haptic option typ = ptr_opt void module Haptic = struct let infinity = -1l - (* Features *) - - type feature = int - let gain = sdl_haptic_gain - let autocenter = sdl_haptic_autocenter - let status = sdl_haptic_status - let pause = sdl_haptic_pause - - (* Directions *) - - type direction_type = int - let polar = sdl_haptic_polar - let cartesian = sdl_haptic_cartesian - let spherical = sdl_haptic_spherical + include Types.Haptic module Direction = struct - type _t - type t = _t structure - let t : _t structure typ = structure "SDL_HapticDirection" - let typ = field t "type" int_as_uint8_t - let dir_0 = field t "dir0" int32_t - let dir_1 = field t "dir1" int32_t - let dir_2 = field t "dir2" int32_t - let () = seal t + include Direction let create typv d0 d1 d2 = let d = make t in - setf d typ typv; - setf d dir_0 d0; - setf d dir_1 d1; - setf d dir_2 d2; + setf d typ (Unsigned.UInt8.of_int typv); + let dir = getf d dir in + CArray.set dir 0 d0; + CArray.set dir 1 d1; + CArray.set dir 2 d2; d - let typ d = getf d typ - let dir_0 d = getf d dir_0 - let dir_1 d = getf d dir_1 - let dir_2 d = getf d dir_2 + let typ d = Unsigned.UInt8.to_int (getf d typ) + let dir_0 d = CArray.get (getf d dir) 0 + let dir_1 d = CArray.get (getf d dir) 1 + let dir_2 d = CArray.get (getf d dir) 2 end (* Effects *) - module Constant = struct - type t - let t : t structure typ = structure "SDL_HapticConstant" - let typ = field t "type" int_as_uint16_t - let direction = field t "direction" Direction.t - let length = field t "length" int32_as_uint32_t - let delay = field t "delay" int_as_uint16_t - let button = field t "button" int_as_uint16_t - let interval = field t "interval" int_as_uint16_t - - let level = field t "level" int16_t - let attack_length = field t "attack_length" int_as_uint16_t - let attack_level = field t "attack_level" int_as_uint16_t - let fade_length = field t "fade_length" int_as_uint16_t - let fade_level = field t "fade_level" int_as_uint16_t - let () = seal t - end - - module Periodic = struct - type t - let t : t structure typ = structure "SDL_HapticPeriodic" - let typ = field t "type" int_as_uint16_t - let direction = field t "direction" Direction.t - let length = field t "length" int32_as_uint32_t - let delay = field t "delay" int_as_uint16_t - let button = field t "button" int_as_uint16_t - let interval = field t "interval" int_as_uint16_t - - let period = field t "period" int_as_uint16_t - let magnitude = field t "magnitude" int16_t - let offset = field t "offset" int16_t - let phase = field t "phase" int_as_uint16_t - let attack_length = field t "attack_length" int_as_uint16_t - let attack_level = field t "attack_level" int_as_uint16_t - let fade_length = field t "fade_length" int_as_uint16_t - let fade_level = field t "fade_level" int_as_uint16_t - let () = seal t - end - - module Condition = struct - type t - let t : t structure typ = structure "SDL_HapticCondition" - let typ = field t "type" int_as_uint16_t - let direction = field t "direction" Direction.t - let length = field t "length" int32_as_uint32_t - let delay = field t "delay" int_as_uint16_t - let button = field t "button" int_as_uint16_t - let interval = field t "interval" int_as_uint16_t - - let right_sat_0 = field t "right_sat[0]" int_as_uint16_t - let right_sat_1 = field t "right_sat[1]" int_as_uint16_t - let right_sat_2 = field t "right_sat[2]" int_as_uint16_t - let left_sat_0 = field t "left_sat[0]" int_as_uint16_t - let left_sat_1 = field t "left_sat[1]" int_as_uint16_t - let left_sat_2 = field t "left_sat[2]" int_as_uint16_t - let right_coeff_0 = field t "right_coeff[0]" int16_t - let right_coeff_1 = field t "right_coeff[1]" int16_t - let right_coeff_2 = field t "right_coeff[2]" int16_t - let left_coeff_0 = field t "left_coeff[0]" int16_t - let left_coeff_1 = field t "left_coeff[1]" int16_t - let left_coeff_2 = field t "left_coeff[2]" int16_t - let deadband_0 = field t "deadband[0]" int_as_uint16_t - let deadband_1 = field t "deadband[1]" int_as_uint16_t - let deadband_2 = field t "deadband[2]" int_as_uint16_t - let center_0 = field t "center[0]" int16_t - let center_1 = field t "center[1]" int16_t - let center_2 = field t "center[2]" int16_t - let () = seal t - end - - module Ramp = struct - type t - let t : t structure typ = structure "SDL_HapticRamp" - let typ = field t "type" int_as_uint16_t - let direction = field t "direction" Direction.t - let length = field t "length" int32_as_uint32_t - let delay = field t "delay" int_as_uint16_t - let button = field t "button" int_as_uint16_t - let interval = field t "interval" int_as_uint16_t - - let start = field t "start" int16_t - let end_ = field t "end" int16_t - let attack_length = field t "attack_length" int_as_uint16_t - let attack_level = field t "attack_level" int_as_uint16_t - let fade_length = field t "fade_length" int_as_uint16_t - let fade_level = field t "fade_level" int_as_uint16_t - let () = seal t - end - - module Left_right = struct - type t - let t : t structure typ = structure "SDL_HapticLeftRight" - let typ = field t "type" int_as_uint16_t - let direction = field t "direction" Direction.t - let length = field t "length" int32_as_uint32_t - - let large_magnitude = field t "large_magnitude" int_as_uint16_t - let small_magnitude = field t "small_magnitude" int_as_uint16_t - let () = seal t - end - - module Custom = struct - let int_list_as_uint16_t_ptr = - let read _ = invalid_arg err_read_field in - let write l = - let l = List.map Unsigned.UInt16.of_int l in - let a = CArray.of_list uint16_t l in - CArray.start a - in - view ~read ~write (ptr uint16_t) - - type t - let t : t structure typ = structure "SDL_HapticCustom" - let typ = field t "type" int_as_uint16_t - let direction = field t "direction" Direction.t - let length = field t "length" int32_as_uint32_t - let delay = field t "delay" int_as_uint16_t - let button = field t "button" int_as_uint16_t - let interval = field t "interval" int_as_uint16_t - - let channels = field t "channels" int_as_uint8_t - let period = field t "period" int_as_uint16_t - let samples = field t "samples" int_as_uint16_t - let data = field t "data" int_list_as_uint16_t_ptr - let attack_length = field t "attack_length" int_as_uint16_t - let attack_level = field t "attack_level" int_as_uint16_t - let fade_length = field t "fade_length" int_as_uint16_t - let fade_level = field t "fade_level" int_as_uint16_t - let () = seal t - end - - module Effect = struct - type t - let t : t union typ = union "SDL_HapticEffect" - let _typ = field t "type" int_as_uint16_t - let constant = field t "constant" Constant.t - let periodic = field t "periodic" Periodic.t - let condition = field t "condition" Condition.t - let ramp = field t "ramp" Ramp.t - let left_right = field t "condition" Left_right.t - let custom = field t "custom" Custom.t - let () = seal t - end - type effect_type = int let create_effect () = make Effect.t @@ -4905,126 +3487,255 @@ module Haptic = struct type _ field = F : (* existential to hide the 'a structure *) (('a structure, Effect.t union) Ctypes.field * - ('b, 'a structure) Ctypes.field) -> 'b field + ('b, 'a structure) Ctypes.field * + ('b -> 'c) * ('c -> 'b)) -> 'c field + + let get e (F (s, f, c, _)) = c (getf (getf e s) f) + let set e (F (s, f, _, c)) v = setf (getf e s) f (c v) - let get e (F (s, f)) = getf (getf e s) f - let set e (F (s, f)) v = setf (getf e s) f v - let typ = F (Effect.constant, Constant.typ) (* same in each enum *) + let typ = F (Effect.constant, Constant.typ, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + (* same in each enum *) (* Constant *) - let constant = sdl_haptic_constant - - let constant_type = F (Effect.constant, Constant.typ) - let constant_direction = F (Effect.constant, Constant.direction) - let constant_length = F (Effect.constant, Constant.length) - let constant_delay = F (Effect.constant, Constant.delay) - let constant_button = F (Effect.constant, Constant.button) - let constant_interval = F (Effect.constant, Constant.interval) - let constant_level = F (Effect.constant, Constant.level) - let constant_attack_length = F (Effect.constant, Constant.attack_length) - let constant_attack_level = F (Effect.constant, Constant.attack_level) - let constant_fade_length = F (Effect.constant, Constant.fade_length) - let constant_fade_level = F (Effect.constant, Constant.fade_level) + + let constant_type = + F (Effect.constant, Constant.typ, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let constant_direction = + F (Effect.constant, Constant.direction, Fun.id, Fun.id) + let constant_length = + F (Effect.constant, Constant.length, + Unsigned.UInt32.to_int32, Unsigned.UInt32.of_int32) + let constant_delay = + F (Effect.constant, Constant.delay, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let constant_button = + F (Effect.constant, Constant.button, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let constant_interval = + F (Effect.constant, Constant.interval, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let constant_level = + F (Effect.constant, Constant.level, Fun.id, Fun.id) + let constant_attack_length = + F (Effect.constant, Constant.attack_length, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let constant_attack_level = + F (Effect.constant, Constant.attack_level, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let constant_fade_length = + F (Effect.constant, Constant.fade_length, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let constant_fade_level = + F (Effect.constant, Constant.fade_level, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) (* Periodic *) - let sine = sdl_haptic_sine - let left_right = sdl_haptic_leftright - let triangle = sdl_haptic_triangle - let sawtooth_up = sdl_haptic_sawtoothup - let sawtooth_down = sdl_haptic_sawtoothdown - - let periodic_type = F (Effect.periodic, Periodic.typ) - let periodic_direction = F (Effect.periodic, Periodic.direction) - let periodic_length = F (Effect.periodic, Periodic.length) - let periodic_delay = F (Effect.periodic, Periodic.delay) - let periodic_button = F (Effect.periodic, Periodic.button) - let periodic_interval = F (Effect.periodic, Periodic.interval) - let periodic_period = F (Effect.periodic, Periodic.period) - let periodic_magnitude = F (Effect.periodic, Periodic.magnitude) - let periodic_offset = F (Effect.periodic, Periodic.offset) - let periodic_phase = F (Effect.periodic, Periodic.phase) - let periodic_attack_length = F (Effect.periodic, Periodic.attack_length) - let periodic_attack_level = F (Effect.periodic, Periodic.attack_level) - let periodic_fade_length = F (Effect.periodic, Periodic.fade_length) - let periodic_fade_level = F (Effect.periodic, Periodic.fade_level) + let periodic_type = + F (Effect.periodic, Periodic.typ, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let periodic_direction = + F (Effect.periodic, Periodic.direction, Fun.id, Fun.id) + let periodic_length = + F (Effect.periodic, Periodic.length, + Unsigned.UInt32.to_int32, Unsigned.UInt32.of_int32) + let periodic_delay = + F (Effect.periodic, Periodic.delay, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let periodic_button = + F (Effect.periodic, Periodic.button, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let periodic_interval = + F (Effect.periodic, Periodic.interval, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let periodic_period = + F (Effect.periodic, Periodic.period, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let periodic_magnitude = + F (Effect.periodic, Periodic.magnitude, Fun.id, Fun.id) + let periodic_offset = + F (Effect.periodic, Periodic.offset, Fun.id, Fun.id) + let periodic_phase = + F (Effect.periodic, Periodic.phase, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let periodic_attack_length = + F (Effect.periodic, Periodic.attack_length, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let periodic_attack_level = + F (Effect.periodic, Periodic.attack_level, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let periodic_fade_length = + F (Effect.periodic, Periodic.fade_length, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let periodic_fade_level = + F (Effect.periodic, Periodic.fade_level, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) (* Condition *) - let spring = sdl_haptic_spring - let damper = sdl_haptic_damper - let inertia = sdl_haptic_inertia - let friction = sdl_haptic_friction - - let condition_type = F (Effect.condition, Condition.typ) - let condition_direction = F (Effect.condition, Condition.direction) - let condition_length = F (Effect.condition, Condition.length) - let condition_delay = F (Effect.condition, Condition.delay) - let condition_button = F (Effect.condition, Condition.button) - let condition_interval = F (Effect.condition, Condition.interval) - let condition_right_sat_0 = F (Effect.condition, Condition.right_sat_0) - let condition_right_sat_1 = F (Effect.condition, Condition.right_sat_1) - let condition_right_sat_2 = F (Effect.condition, Condition.right_sat_2) - let condition_left_sat_0 = F (Effect.condition, Condition.left_sat_0) - let condition_left_sat_1 = F (Effect.condition, Condition.left_sat_1) - let condition_left_sat_2 = F (Effect.condition, Condition.left_sat_2) - let condition_right_coeff_0 = F (Effect.condition, Condition.right_coeff_0) - let condition_right_coeff_1 = F (Effect.condition, Condition.right_coeff_1) - let condition_right_coeff_2 = F (Effect.condition, Condition.right_coeff_2) - let condition_left_coeff_0 = F (Effect.condition, Condition.left_coeff_0) - let condition_left_coeff_1 = F (Effect.condition, Condition.left_coeff_1) - let condition_left_coeff_2 = F (Effect.condition, Condition.left_coeff_2) - let condition_deadband_0 = F (Effect.condition, Condition.deadband_0) - let condition_deadband_1 = F (Effect.condition, Condition.deadband_1) - let condition_deadband_2 = F (Effect.condition, Condition.deadband_2) - let condition_center_0 = F (Effect.condition, Condition.center_0) - let condition_center_1 = F (Effect.condition, Condition.center_1) - let condition_center_2 = F (Effect.condition, Condition.center_2) + let condition_type = + F (Effect.condition, Condition.typ, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let condition_direction = + F (Effect.condition, Condition.direction, Fun.id, Fun.id) + let condition_length = + F (Effect.condition, Condition.length, + Unsigned.UInt32.to_int32, Unsigned.UInt32.of_int32) + let condition_delay = + F (Effect.condition, Condition.delay, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let condition_button = + F (Effect.condition, Condition.button, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let condition_interval = + F (Effect.condition, Condition.interval, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let condition_right_sat_0 = + F (Effect.condition, Condition.right_sat_0, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let condition_right_sat_1 = + F (Effect.condition, Condition.right_sat_1, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let condition_right_sat_2 = + F (Effect.condition, Condition.right_sat_2, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let condition_left_sat_0 = + F (Effect.condition, Condition.left_sat_0, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let condition_left_sat_1 = + F (Effect.condition, Condition.left_sat_1, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let condition_left_sat_2 = + F (Effect.condition, Condition.left_sat_2, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let condition_right_coeff_0 = + F (Effect.condition, Condition.right_coeff_0, Fun.id, Fun.id) + let condition_right_coeff_1 = + F (Effect.condition, Condition.right_coeff_1, Fun.id, Fun.id) + let condition_right_coeff_2 = + F (Effect.condition, Condition.right_coeff_2, Fun.id, Fun.id) + let condition_left_coeff_0 = + F (Effect.condition, Condition.left_coeff_0, Fun.id, Fun.id) + let condition_left_coeff_1 = + F (Effect.condition, Condition.left_coeff_1, Fun.id, Fun.id) + let condition_left_coeff_2 = + F (Effect.condition, Condition.left_coeff_2, Fun.id, Fun.id) + let condition_deadband_0 = + F (Effect.condition, Condition.deadband_0, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let condition_deadband_1 = + F (Effect.condition, Condition.deadband_1, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let condition_deadband_2 = + F (Effect.condition, Condition.deadband_2, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let condition_center_0 = + F (Effect.condition, Condition.center_0, Fun.id, Fun.id) + let condition_center_1 = + F (Effect.condition, Condition.center_1, Fun.id, Fun.id) + let condition_center_2 = + F (Effect.condition, Condition.center_2, Fun.id, Fun.id) (* Ramp *) - let ramp = sdl_haptic_ramp - - let ramp_type = F (Effect.ramp, Ramp.typ) - let ramp_direction = F (Effect.ramp, Ramp.direction) - let ramp_length = F (Effect.ramp, Ramp.length) - let ramp_delay = F (Effect.ramp, Ramp.delay) - let ramp_button = F (Effect.ramp, Ramp.button) - let ramp_interval = F (Effect.ramp, Ramp.interval) - let ramp_start = F (Effect.ramp, Ramp.start) - let ramp_end = F (Effect.ramp, Ramp.end_) - let ramp_attack_length = F (Effect.ramp, Ramp.attack_length) - let ramp_attack_level = F (Effect.ramp, Ramp.attack_level) - let ramp_fade_length = F (Effect.ramp, Ramp.fade_length) - let ramp_fade_level = F (Effect.ramp, Ramp.fade_level) + let ramp_type = + F (Effect.ramp, Ramp.typ, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let ramp_direction = + F (Effect.ramp, Ramp.direction, Fun.id, Fun.id) + let ramp_length = + F (Effect.ramp, Ramp.length, + Unsigned.UInt32.to_int32, Unsigned.UInt32.of_int32) + let ramp_delay = + F (Effect.ramp, Ramp.delay, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let ramp_button = + F (Effect.ramp, Ramp.button, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let ramp_interval = + F (Effect.ramp, Ramp.interval, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let ramp_start = + F (Effect.ramp, Ramp.start, Fun.id, Fun.id) + let ramp_end = + F (Effect.ramp, Ramp.end_, Fun.id, Fun.id) + let ramp_attack_length = + F (Effect.ramp, Ramp.attack_length, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let ramp_attack_level = + F (Effect.ramp, Ramp.attack_level, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let ramp_fade_length = + F (Effect.ramp, Ramp.fade_length, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let ramp_fade_level = + F (Effect.ramp, Ramp.fade_level, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) (* Left right *) - let left_right_type = F (Effect.left_right, Left_right.typ) - let left_right_length = F (Effect.left_right, Left_right.length) + let left_right_type = + F (Effect.left_right, Left_right.typ, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let left_right_length = + F (Effect.left_right, Left_right.length, + Unsigned.UInt32.to_int32, Unsigned.UInt32.of_int32) let left_right_large_magnitude = - F (Effect.left_right, Left_right.large_magnitude) + F (Effect.left_right, Left_right.large_magnitude, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) let left_right_small_magnitude = - F (Effect.left_right, Left_right.small_magnitude) + F (Effect.left_right, Left_right.small_magnitude, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) (* Custom *) - let custom = sdl_haptic_custom - - let custom_type = F (Effect.custom, Custom.typ) - let custom_direction = F (Effect.custom, Custom.direction) - let custom_length = F (Effect.custom, Custom.length) - let custom_delay = F (Effect.custom, Custom.delay) - let custom_button = F (Effect.custom, Custom.button) - let custom_interval = F (Effect.custom, Custom.interval) - let custom_channels = F (Effect.custom, Custom.channels) - let custom_period = F (Effect.custom, Custom.period) - let custom_samples = F (Effect.custom, Custom.samples) - let custom_data = F (Effect.custom, Custom.data) - let custom_attack_length = F (Effect.custom, Custom.attack_length) - let custom_attack_level = F (Effect.custom, Custom.attack_level) - let custom_fade_length = F (Effect.custom, Custom.fade_length) - let custom_fade_level = F (Effect.custom, Custom.fade_level) + let custom_type = + F (Effect.custom, Custom.typ, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let custom_direction = + F (Effect.custom, Custom.direction, Fun.id, Fun.id) + let custom_length = + F (Effect.custom, Custom.length, + Unsigned.UInt32.to_int32, Unsigned.UInt32.of_int32) + let custom_delay = + F (Effect.custom, Custom.delay, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let custom_button = + F (Effect.custom, Custom.button, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let custom_interval = + F (Effect.custom, Custom.interval, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let custom_channels = + F (Effect.custom, Custom.channels, + Unsigned.UInt8.to_int, Unsigned.UInt8.of_int) + let custom_period = + F (Effect.custom, Custom.period, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let custom_samples = + F (Effect.custom, Custom.samples, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let custom_data = + F (Effect.custom, Custom.data, + (fun p -> invalid_arg err_read_field), + (fun l -> + let l = List.map Unsigned.UInt16.of_int l in + let a = Ctypes.CArray.of_list Ctypes.uint16_t l in + Ctypes.CArray.start a)) + let custom_attack_length = + F (Effect.custom, Custom.attack_length, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let custom_attack_level = + F (Effect.custom, Custom.attack_level, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let custom_fade_length = + F (Effect.custom, Custom.fade_length, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) + let custom_fade_level = + F (Effect.custom, Custom.fade_level, + Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) end type haptic_effect = Haptic.Effect.t union @@ -5084,7 +3795,7 @@ let haptic_open i = haptic_open i |> some_to_ok let haptic_open_from_joystick = foreign "SDL_HapticOpenFromJoystick" - (joystick @-> returning haptic_opt) + (ptr Types.joystick @-> returning haptic_opt) let haptic_open_from_joystick j = haptic_open_from_joystick j |> some_to_ok let haptic_open_from_mouse = @@ -5158,7 +3869,7 @@ let haptic_update_effect h id e = let joystick_is_haptic = foreign "SDL_JoystickIsHaptic" - (joystick @-> returning int) + (ptr Types.joystick @-> returning int) let joystick_is_haptic j = joystick_is_haptic j |> bool_to_ok let mouse_is_haptic = @@ -5194,40 +3905,7 @@ let get_num_audio_drivers () = get_num_audio_drivers () |> nat_to_ok (* Audio devices *) -module Audio = struct - type status = int - let stopped = sdl_audio_stopped - let playing = sdl_audio_playing - let paused = sdl_audio_paused - - type format = int - let format = int_as_uint16_t - let s8 = audio_s8 - let u8 = audio_u8 - let s16_lsb = audio_s16lsb - let s16_msb = audio_s16msb - let s16_sys = audio_s16sys - let s16 = audio_s16 - let u16_lsb = audio_u16lsb - let u16_msb = audio_u16msb - let u16_sys = audio_u16sys - let u16 = audio_u16 - let s32_lsb = audio_s32lsb - let s32_msb = audio_s32msb - let s32_sys = audio_s32sys - let s32 = audio_s32 - let f32_lsb = audio_f32lsb - let f32_msb = audio_f32msb - let f32_sys = audio_f32sys - let f32 = audio_f32 - - type allow = int - let allow = int - let allow_frequency_change = sdl_audio_allow_frequency_change - let allow_format_change = sdl_audio_allow_format_change - let allow_channels_change = sdl_audio_allow_channels_change - let allow_any_change = sdl_audio_allow_any_change -end +module Audio = Types.Audio type audio_device_id = int32 let audio_device_id = int32_as_uint32_t @@ -5253,45 +3931,30 @@ let audio_callback kind f = f (bigarray_of_ptr array1 len kind p) let as_callback = - (ptr void @-> ptr uint8_t @-> int @-> returning void) - -type _audio_spec -let audio_spec : _audio_spec structure typ = structure "SDL_AudioSpec" -let as_freq = field audio_spec "freq" int -let as_format = field audio_spec "format" Audio.format -let as_channels = field audio_spec "channels" int_as_uint8_t -let as_silence = field audio_spec "silence" int_as_uint8_t -let as_samples = field audio_spec "samples" int_as_uint16_t -let _ = field audio_spec "padding" uint16_t -let as_size = field audio_spec "size" int32_as_uint32_t -let as_callback = - field audio_spec "callback" - (funptr_opt ~thread_registration:true ~runtime_lock:true as_callback) - -let as_userdata = field audio_spec "userdata" (ptr void) -let () = seal audio_spec + Foreign.funptr_opt ~thread_registration:true ~runtime_lock:true Types.as_callback_type let audio_spec_of_c c = - let as_freq = getf c as_freq in - let as_format = getf c as_format in - let as_channels = getf c as_channels in - let as_silence = getf c as_silence in - let as_samples = getf c as_samples in - let as_size = getf c as_size in + let as_freq = getf c Types.as_freq in + let as_format = Unsigned.UInt16.to_int (getf c Types.as_format) in + let as_channels = Unsigned.UInt8.to_int (getf c Types.as_channels) in + let as_silence = Unsigned.UInt8.to_int (getf c Types.as_silence) in + let as_samples = Unsigned.UInt16.to_int (getf c Types.as_samples) in + let as_size = Unsigned.UInt32.to_int32 (getf c Types.as_size) in let as_callback = None in { as_freq; as_format; as_channels; as_silence; as_samples; as_size; as_callback; } let audio_spec_to_c a = - let c = make audio_spec in - setf c as_freq a.as_freq; - setf c as_format a.as_format; - setf c as_channels a.as_channels; - setf c as_silence a.as_silence; (* irrelevant *) - setf c as_samples a.as_samples; - setf c as_size a.as_size; (* irrelevant *) - setf c as_callback a.as_callback; - setf c as_userdata null; + let c = make Types.audio_spec in + setf c Types.as_freq a.as_freq; + setf c Types.as_format (Unsigned.UInt16.of_int a.as_format); + setf c Types.as_channels (Unsigned.UInt8.of_int a.as_channels); + setf c Types.as_silence (Unsigned.UInt8.of_int a.as_silence); (* irrelevant *) + setf c Types.as_samples (Unsigned.UInt16.of_int a.as_samples); + setf c Types.as_size (Unsigned.UInt32.of_int32 a.as_size); (* irrelevant *) + setf c Types.as_callback + (coerce as_callback (static_funptr Types.as_callback_type) a.as_callback); + setf c Types.as_userdata null; c let close_audio_device = @@ -5317,8 +3980,8 @@ let get_num_audio_devices b = get_num_audio_devices b |> nat_to_ok let load_wav_rw = foreign ~release_runtime_lock:true "SDL_LoadWAV_RW" - (rw_ops @-> int @-> ptr audio_spec @-> ptr (ptr void) @-> ptr uint32_t @-> - returning (ptr_opt audio_spec)) + (Types.rw_ops @-> int @-> ptr Types.audio_spec @-> ptr (ptr void) @-> + ptr uint32_t @-> returning (ptr_opt Types.audio_spec)) let load_wav_rw ops spec kind = let d = allocate (ptr void) null in @@ -5342,12 +4005,12 @@ let lock_audio_device = let open_audio_device = foreign "SDL_OpenAudioDevice" - (string_opt @-> bool @-> ptr audio_spec @-> ptr audio_spec @-> - Audio.allow @-> returning int32_as_uint32_t) + (string_opt @-> bool @-> ptr Types.audio_spec @-> ptr Types.audio_spec @-> + int @-> returning int32_as_uint32_t) let open_audio_device dev capture desired allow = let desiredc = audio_spec_to_c desired in - let obtained = make audio_spec in + let obtained = make Types.audio_spec in match open_audio_device dev capture (addr desiredc) (addr obtained) allow with | id when id = Int32.zero -> error () @@ -5458,11 +4121,11 @@ type power_state = [ `Unknown | `On_battery | `No_battery | `Charging | `Charged ] let power_state = - [ sdl_powerstate_unknown, `Unknown; - sdl_powerstate_on_battery, `On_battery; - sdl_powerstate_no_battery, `No_battery; - sdl_powerstate_charging, `Charging; - sdl_powerstate_charged, `Charged; ] + Types.[ Powerstate.unknown, `Unknown; + Powerstate.on_battery, `On_battery; + Powerstate.no_battery, `No_battery; + Powerstate.charging, `Charging; + Powerstate.charged, `Charged; ] type power_info = { pi_state : power_state; diff --git a/src/tsdl.mllib b/src/tsdl.mllib index d5851c1..e3b2c87 100644 --- a/src/tsdl.mllib +++ b/src/tsdl.mllib @@ -1,2 +1,4 @@ Tsdl_consts +Type_description +Types_stubs Tsdl \ No newline at end of file diff --git a/src/type_description.ml b/src/type_description.ml new file mode 100644 index 0000000..717c66b --- /dev/null +++ b/src/type_description.ml @@ -0,0 +1,1799 @@ +module Types (F : Ctypes.TYPE) = struct + + module Init = struct + let timer = F.constant "SDL_INIT_TIMER" F.uint32_t + let audio = F.constant "SDL_INIT_AUDIO" F.uint32_t + let video = F.constant "SDL_INIT_VIDEO" F.uint32_t + let joystick = F.constant "SDL_INIT_JOYSTICK" F.uint32_t + let haptic = F.constant "SDL_INIT_HAPTIC" F.uint32_t + let gamecontroller = F.constant "SDL_INIT_GAMECONTROLLER" F.uint32_t + let events = F.constant "SDL_INIT_EVENTS" F.uint32_t + let everything = F.constant "SDL_INIT_EVERYTHING" F.uint32_t + let noparachute = F.constant "SDL_INIT_NOPARACHUTE" F.uint32_t + end + + module Hint = struct + let default = F.constant "SDL_HINT_DEFAULT" F.int + let normal = F.constant "SDL_HINT_NORMAL" F.int + let override = F.constant "SDL_HINT_OVERRIDE" F.int + end + + module Log = struct + let category_application = F.constant "SDL_LOG_CATEGORY_APPLICATION" F.int + let category_error = F.constant "SDL_LOG_CATEGORY_ERROR" F.int + let category_system = F.constant "SDL_LOG_CATEGORY_SYSTEM" F.int + let category_audio = F.constant "SDL_LOG_CATEGORY_AUDIO" F.int + let category_video = F.constant "SDL_LOG_CATEGORY_VIDEO" F.int + let category_render = F.constant "SDL_LOG_CATEGORY_RENDER" F.int + let category_input = F.constant "SDL_LOG_CATEGORY_INPUT" F.int + let category_custom = F.constant "SDL_LOG_CATEGORY_CUSTOM" F.int + + let priority_verbose = F.constant "SDL_LOG_PRIORITY_VERBOSE" F.int + let priority_debug = F.constant "SDL_LOG_PRIORITY_DEBUG" F.int + let priority_info = F.constant "SDL_LOG_PRIORITY_INFO" F.int + let priority_warn = F.constant "SDL_LOG_PRIORITY_WARN" F.int + let priority_error = F.constant "SDL_LOG_PRIORITY_ERROR" F.int + let priority_critical = F.constant "SDL_LOG_PRIORITY_CRITICAL" F.int + end + + type version + let version : version Ctypes_static.structure F.typ = F.structure "SDL_version" + let version_major = F.field version "major" F.uint8_t + let version_minor = F.field version "minor" F.uint8_t + let version_patch = F.field version "patch" F.uint8_t + let () = F.seal version + + (* IO absraction *) + + type _rw_ops + type rw_ops = _rw_ops Ctypes_static.structure Ctypes_static.ptr + let rw_ops_struct : _rw_ops Ctypes_static.structure F.typ = F.structure "SDL_RWops" + let rw_ops : rw_ops F.typ = F.ptr rw_ops_struct + let rw_ops_opt : rw_ops option F.typ = F.ptr_opt rw_ops_struct + + let _rw_ops_size = F.field rw_ops_struct "size" + F.(static_funptr (rw_ops @-> returning int64_t)) + let _rw_ops_seek = F.field rw_ops_struct "seek" + F.(static_funptr (rw_ops @-> int64_t @-> int @-> returning int64_t)) + let _rw_ops_read = F.field rw_ops_struct "read" + F.(static_funptr (rw_ops @-> ptr void @-> size_t @-> size_t @-> returning size_t)) + let _rw_ops_write = F.field rw_ops_struct "write" + F.(static_funptr (rw_ops @-> ptr void @-> size_t @-> size_t @-> returning size_t)) + let _rw_ops_close = F.field rw_ops_struct "close" + F.(static_funptr (rw_ops @-> returning int)) + let _ = F.field rw_ops_struct "type" F.uint32_t + (* ... #ifdef'd union follows, we don't care we don't use Ctypes.make *) + let () = F.seal rw_ops_struct + + module Color = struct + type _t + type t = _t Ctypes_static.structure + let t : t F.typ = F.structure "SDL_Color" + let r = F.field t "r" F.uint8_t + let g = F.field t "g" F.uint8_t + let b = F.field t "b" F.uint8_t + let a = F.field t "a" F.uint8_t + let () = F.seal t + end + + module Point = struct + type _t + type t = _t Ctypes_static.structure + let t : t F.typ = F.structure "SDL_Point" + let x = F.field t "x" F.int + let y = F.field t "y" F.int + let () = F.seal t + end + + module Fpoint = struct + type _t + type t = _t Ctypes_static.structure + let t : t F.typ = F.structure "SDL_FPoint" + let x = F.field t "x" F.float + let y = F.field t "y" F.float + let () = F.seal t + end + + module Vertex = struct + type _t + type t = _t Ctypes_static.structure + let t : t F.typ = F.structure "SDL_Vertex" + let position = F.field t "position" Fpoint.t + let color = F.field t "color" Color.t + let tex_coord = F.field t "tex_coord" Fpoint.t + let () = F.seal t + end + + module Rect = struct + type _t + type t = _t Ctypes_static.structure + let t : t F.typ = F.structure "SDL_Rect" + let x = F.field t "x" F.int + let y = F.field t "y" F.int + let w = F.field t "w" F.int + let h = F.field t "h" F.int + let () = F.seal t + end + + module Frect = struct + type _t + type t = _t Ctypes_static.structure + let t : t F.typ = F.structure "SDL_FRect" + let x = F.field t "x" F.float + let y = F.field t "y" F.float + let w = F.field t "w" F.float + let h = F.field t "h" F.float + let () = F.seal t + end + + type _palette + type palette = _palette Ctypes_static.structure + let palette : palette F.typ = F.structure "SDL_Palette" + let palette_ncolors = F.field palette "ncolors" F.int + let palette_colors = F.field palette "colors" (F.ptr Color.t) + let _ = F.field palette "version" F.uint32_t + let _ = F.field palette "refcount" F.int + let () = F.seal palette + + module Blend = struct + type mode = Unsigned.UInt.t + let mode_none = F.constant "SDL_BLENDMODE_NONE" F.uint + let mode_blend = F.constant "SDL_BLENDMODE_BLEND" F.uint + let mode_add = F.constant "SDL_BLENDMODE_ADD" F.uint + let mode_mod = F.constant "SDL_BLENDMODE_MOD" F.uint + let mode_mul = F.constant "SDL_BLENDMODE_MUL" F.uint + let mode_invalid = F.constant "SDL_BLENDMODE_INVALID" F.uint + let mode = F.uint + + let add = F.constant "SDL_BLENDOPERATION_ADD" F.int + let subtract = F.constant "SDL_BLENDOPERATION_SUBTRACT" F.int + let rev_subtract = F.constant "SDL_BLENDOPERATION_REV_SUBTRACT" F.int + let maximum = F.constant "SDL_BLENDOPERATION_MAXIMUM" F.int + let minimum = F.constant "SDL_BLENDOPERATION_MINIMUM" F.int + + let zero = F.constant "SDL_BLENDFACTOR_ZERO" F.int + let one = F.constant "SDL_BLENDFACTOR_ONE" F.int + let src_color = F.constant "SDL_BLENDFACTOR_SRC_COLOR" F.int + let one_minus_src_color = F.constant "SDL_BLENDFACTOR_ONE_MINUS_SRC_COLOR" F.int + let src_alpha = F.constant "SDL_BLENDFACTOR_SRC_ALPHA" F.int + let one_minus_src_alpha = F.constant "SDL_BLENDFACTOR_ONE_MINUS_SRC_ALPHA" F.int + let dst_color = F.constant "SDL_BLENDFACTOR_DST_COLOR" F.int + let one_minus_dst_color = F.constant "SDL_BLENDFACTOR_ONE_MINUS_DST_COLOR" F.int + let dst_alpha = F.constant "SDL_BLENDFACTOR_DST_ALPHA" F.int + let one_minus_dst_alpha = F.constant "SDL_BLENDFACTOR_ONE_MINUS_DST_ALPHA" F.int + end + + module Pixel = struct + let format_unknown = F.constant "SDL_PIXELFORMAT_UNKNOWN" F.uint32_t + let format_index1lsb = F.constant "SDL_PIXELFORMAT_INDEX1LSB" F.uint32_t + let format_index1msb = F.constant "SDL_PIXELFORMAT_INDEX1MSB" F.uint32_t + let format_index4lsb = F.constant "SDL_PIXELFORMAT_INDEX4LSB" F.uint32_t + let format_index4msb = F.constant "SDL_PIXELFORMAT_INDEX4MSB" F.uint32_t + let format_index8 = F.constant "SDL_PIXELFORMAT_INDEX8" F.uint32_t + let format_rgb332 = F.constant "SDL_PIXELFORMAT_RGB332" F.uint32_t + let format_rgb444 = F.constant "SDL_PIXELFORMAT_RGB444" F.uint32_t + let format_rgb555 = F.constant "SDL_PIXELFORMAT_RGB555" F.uint32_t + let format_bgr555 = F.constant "SDL_PIXELFORMAT_BGR555" F.uint32_t + let format_argb4444 = F.constant "SDL_PIXELFORMAT_ARGB4444" F.uint32_t + let format_rgba4444 = F.constant "SDL_PIXELFORMAT_RGBA4444" F.uint32_t + let format_abgr4444 = F.constant "SDL_PIXELFORMAT_ABGR4444" F.uint32_t + let format_bgra4444 = F.constant "SDL_PIXELFORMAT_BGRA4444" F.uint32_t + let format_argb1555 = F.constant "SDL_PIXELFORMAT_ARGB1555" F.uint32_t + let format_rgba5551 = F.constant "SDL_PIXELFORMAT_RGBA5551" F.uint32_t + let format_abgr1555 = F.constant "SDL_PIXELFORMAT_ABGR1555" F.uint32_t + let format_bgra5551 = F.constant "SDL_PIXELFORMAT_BGRA5551" F.uint32_t + let format_rgb565 = F.constant "SDL_PIXELFORMAT_RGB565" F.uint32_t + let format_bgr565 = F.constant "SDL_PIXELFORMAT_BGR565" F.uint32_t + let format_rgb24 = F.constant "SDL_PIXELFORMAT_RGB24" F.uint32_t + let format_bgr24 = F.constant "SDL_PIXELFORMAT_BGR24" F.uint32_t + let format_rgb888 = F.constant "SDL_PIXELFORMAT_RGB888" F.uint32_t + let format_rgbx8888 = F.constant "SDL_PIXELFORMAT_RGBX8888" F.uint32_t + let format_bgr888 = F.constant "SDL_PIXELFORMAT_BGR888" F.uint32_t + let format_bgrx8888 = F.constant "SDL_PIXELFORMAT_BGRX8888" F.uint32_t + let format_argb8888 = F.constant "SDL_PIXELFORMAT_ARGB8888" F.uint32_t + let format_rgba8888 = F.constant "SDL_PIXELFORMAT_RGBA8888" F.uint32_t + let format_abgr8888 = F.constant "SDL_PIXELFORMAT_ABGR8888" F.uint32_t + let format_bgra8888 = F.constant "SDL_PIXELFORMAT_BGRA8888" F.uint32_t + let format_argb2101010 = F.constant "SDL_PIXELFORMAT_ARGB2101010" F.uint32_t + let format_yv12 = F.constant "SDL_PIXELFORMAT_YV12" F.uint32_t + let format_iyuv = F.constant "SDL_PIXELFORMAT_IYUV" F.uint32_t + let format_yuy2 = F.constant "SDL_PIXELFORMAT_YUY2" F.uint32_t + let format_uyvy = F.constant "SDL_PIXELFORMAT_UYVY" F.uint32_t + let format_yvyu = F.constant "SDL_PIXELFORMAT_YVYU" F.uint32_t + end + + type _pixel_format + type pixel_format = _pixel_format Ctypes_static.structure + let pixel_format : pixel_format F.typ = F.structure "SDL_PixelFormat" + let pf_format = F.field pixel_format "format" F.uint32_t + let _pf_palette = F.field pixel_format "palette" (F.ptr palette) + let pf_bits_per_pixel = F.field pixel_format "BitsPerPixel" F.uint8_t + let pf_bytes_per_pixel = F.field pixel_format "BytesPerPixel" F.uint8_t + let _ = F.field pixel_format "padding" F.uint16_t + let _ = F.field pixel_format "Rmask" F.uint32_t + let _ = F.field pixel_format "Gmask" F.uint32_t + let _ = F.field pixel_format "Bmask" F.uint32_t + let _ = F.field pixel_format "Amask" F.uint32_t + let _ = F.field pixel_format "Rloss" F.uint8_t + let _ = F.field pixel_format "Gloss" F.uint8_t + let _ = F.field pixel_format "Bloss" F.uint8_t + let _ = F.field pixel_format "Aloss" F.uint8_t + let _ = F.field pixel_format "Rshift" F.uint8_t + let _ = F.field pixel_format "Gshift" F.uint8_t + let _ = F.field pixel_format "Bshift" F.uint8_t + let _ = F.field pixel_format "Ashift" F.uint8_t + let _ = F.field pixel_format "refcount" F.int + let _ = F.field pixel_format "next" (F.ptr pixel_format) + let () = F.seal pixel_format + + type _surface + type surface = _surface Ctypes_static.structure + let surface : surface F.typ = F.structure "SDL_Surface" + let _ = F.field surface "flags" F.uint32_t + let surface_format = F.field surface "format" (F.ptr pixel_format) + let surface_w = F.field surface "w" F.int + let surface_h = F.field surface "h" F.int + let surface_pitch = F.field surface "pitch" F.int + let surface_pixels = F.field surface "pixels" F.(ptr void) + let _ = F.field surface "userdata" F.(ptr void) + let _ = F.field surface "locked" F.int + let _ = F.field surface "list_blitmap" F.(ptr void) + let _ = F.field surface "clip_rect" Rect.t + let _ = F.field surface "map" F.(ptr void) + let _ = F.field surface "refcount" F.int + let () = F.seal surface + + module Flip = struct + let none = F.constant "SDL_FLIP_NONE" F.int + let horizontal = F.constant "SDL_FLIP_HORIZONTAL" F.int + let vertical = F.constant "SDL_FLIP_VERTICAL" F.int + end + + module Renderer = struct + let software = F.constant "SDL_RENDERER_SOFTWARE" F.uint32_t + let accelerated = F.constant "SDL_RENDERER_ACCELERATED" F.uint32_t + let presentvsync = F.constant "SDL_RENDERER_PRESENTVSYNC" F.uint32_t + let targettexture = F.constant "SDL_RENDERER_TARGETTEXTURE" F.uint32_t + + type _renderer + + type t = _renderer Ctypes_static.structure + let t : t F.typ = F.structure "SDL_Renderer" + end + + type renderer_info + let renderer_info : renderer_info Ctypes_static.structure F.typ = F.structure "SDL_RendererInfo" + let ri_name = F.field renderer_info "name" F.string + let ri_flags = F.field renderer_info "flags" F.uint32_t + let ri_num_tf = F.field renderer_info "num_texture_formats" F.uint32_t + let ri_tfs = F.field renderer_info "texture_formats" F.(array 16 uint32_t) + let ri_max_texture_width = F.field renderer_info "max_texture_width" F.int + let ri_max_texture_height = F.field renderer_info "max_texture_height" F.int + let () = F.seal renderer_info + + module Texture = struct + let access_static = F.constant "SDL_TEXTUREACCESS_STATIC" F.int + let access_streaming = F.constant "SDL_TEXTUREACCESS_STREAMING" F.int + let access_target = F.constant "SDL_TEXTUREACCESS_TARGET" F.int + + let modulate_none = F.constant "SDL_TEXTUREMODULATE_NONE" F.uint32_t + let modulate_color = F.constant "SDL_TEXTUREMODULATE_COLOR" F.uint32_t + let modulate_alpha = F.constant "SDL_TEXTUREMODULATE_ALPHA" F.uint32_t + + type _t + + type t = _t Ctypes_static.structure + let t : t F.typ = F.structure "SDL_Texture" + end + + type _display_mode + let display_mode : _display_mode Ctypes_static.structure F.typ = + F.typedef (F.structure "_display_mode") "SDL_DisplayMode" + let dm_format = F.field display_mode "format" F.uint32_t + let dm_w = F.field display_mode "w" F.int + let dm_h = F.field display_mode "h" F.int + let dm_refresh_rate = F.field display_mode "refresh_rate" F.int + let dm_driverdata = F.field display_mode "driverdata" F.(ptr_opt void) + let () = F.seal display_mode + + module Window = struct + type _t + type t = _t Ctypes_static.structure Ctypes_static.ptr + let raw : _t Ctypes_static.structure F.typ = F.structure "SDL_Window" + let t = F.ptr raw + let opt = F.ptr_opt raw + + let fullscreen = F.constant "SDL_WINDOW_FULLSCREEN" F.uint32_t + let fullscreen_desktop = F.constant "SDL_WINDOW_FULLSCREEN_DESKTOP" F.uint32_t + let opengl = F.constant "SDL_WINDOW_OPENGL" F.uint32_t + let shown = F.constant "SDL_WINDOW_SHOWN" F.uint32_t + let hidden = F.constant "SDL_WINDOW_HIDDEN" F.uint32_t + let borderless = F.constant "SDL_WINDOW_BORDERLESS" F.uint32_t + let resizable = F.constant "SDL_WINDOW_RESIZABLE" F.uint32_t + let minimized = F.constant "SDL_WINDOW_MINIMIZED" F.uint32_t + let maximized = F.constant "SDL_WINDOW_MAXIMIZED" F.uint32_t + let input_grabbed = F.constant "SDL_WINDOW_INPUT_GRABBED" F.uint32_t + let input_focus = F.constant "SDL_WINDOW_INPUT_FOCUS" F.uint32_t + let mouse_focus = F.constant "SDL_WINDOW_MOUSE_FOCUS" F.uint32_t + let foreign = F.constant "SDL_WINDOW_FOREIGN" F.uint32_t + let allow_highdpi = F.constant "SDL_WINDOW_ALLOW_HIGHDPI" F.uint32_t + let mouse_capture = F.constant "SDL_WINDOW_MOUSE_CAPTURE" F.uint32_t + let always_on_top = F.constant "SDL_WINDOW_ALWAYS_ON_TOP" F.uint32_t + let skip_taskbar = F.constant "SDL_WINDOW_SKIP_TASKBAR" F.uint32_t + let utility = F.constant "SDL_WINDOW_UTILITY" F.uint32_t + let popup_menu = F.constant "SDL_WINDOW_POPUP_MENU" F.uint32_t + let vulkan = F.constant "SDL_WINDOW_VULKAN" F.uint32_t + + let pos_centered = F.constant "SDL_WINDOWPOS_CENTERED" F.int + let pos_undefined = F.constant "SDL_WINDOWPOS_UNDEFINED" F.int + end + + module Gl = struct + + (* contextFlag *) + + let context_debug_flag = F.constant "SDL_GL_CONTEXT_DEBUG_FLAG" F.int + let context_forward_compatible_flag = F.constant "SDL_GL_CONTEXT_FORWARD_COMPATIBLE_FLAG" F.int + let context_robust_access_flag = F.constant "SDL_GL_CONTEXT_ROBUST_ACCESS_FLAG" F.int + let context_reset_isolation_flag = F.constant "SDL_GL_CONTEXT_RESET_ISOLATION_FLAG" F.int + let context_release_behavior = F.constant "SDL_GL_CONTEXT_RELEASE_BEHAVIOR" F.int + + (* profile *) + + let context_profile_core = F.constant "SDL_GL_CONTEXT_PROFILE_CORE" F.int + let context_profile_compatibility = F.constant "SDL_GL_CONTEXT_PROFILE_COMPATIBILITY" F.int + let context_profile_es = F.constant "SDL_GL_CONTEXT_PROFILE_ES" F.int + + (* attr *) + + let red_size = F.constant "SDL_GL_RED_SIZE" F.int + let green_size = F.constant "SDL_GL_GREEN_SIZE" F.int + let blue_size = F.constant "SDL_GL_BLUE_SIZE" F.int + let alpha_size = F.constant "SDL_GL_ALPHA_SIZE" F.int + let buffer_size = F.constant "SDL_GL_BUFFER_SIZE" F.int + let doublebuffer = F.constant "SDL_GL_DOUBLEBUFFER" F.int + let depth_size = F.constant "SDL_GL_DEPTH_SIZE" F.int + let stencil_size = F.constant "SDL_GL_STENCIL_SIZE" F.int + let accum_red_size = F.constant "SDL_GL_ACCUM_RED_SIZE" F.int + let accum_green_size = F.constant "SDL_GL_ACCUM_GREEN_SIZE" F.int + let accum_blue_size = F.constant "SDL_GL_ACCUM_BLUE_SIZE" F.int + let accum_alpha_size = F.constant "SDL_GL_ACCUM_ALPHA_SIZE" F.int + let stereo = F.constant "SDL_GL_STEREO" F.int + let multisamplebuffers = F.constant "SDL_GL_MULTISAMPLEBUFFERS" F.int + let multisamplesamples = F.constant "SDL_GL_MULTISAMPLESAMPLES" F.int + let accelerated_visual = F.constant "SDL_GL_ACCELERATED_VISUAL" F.int + let context_major_version = F.constant "SDL_GL_CONTEXT_MAJOR_VERSION" F.int + let context_minor_version = F.constant "SDL_GL_CONTEXT_MINOR_VERSION" F.int + let context_egl = F.constant "SDL_GL_CONTEXT_EGL" F.int + let context_flags = F.constant "SDL_GL_CONTEXT_FLAGS" F.int + let context_profile_mask = F.constant "SDL_GL_CONTEXT_PROFILE_MASK" F.int + let share_with_current_context = F.constant "SDL_GL_SHARE_WITH_CURRENT_CONTEXT" F.int + let framebuffer_srgb_capable = F.constant "SDL_GL_FRAMEBUFFER_SRGB_CAPABLE" F.int + + type _context + type context = _context Ctypes_static.structure + let context : context F.typ = F.structure "SDL_GLContext" + end + + module Vulkan = struct + type _surface + type surface = _surface Ctypes_static.structure Ctypes_static.ptr + + let raw_surface : _surface Ctypes_static.structure F.typ = + F.structure "VkSurfaceKHR_T" + let surface : surface F.typ = F.ptr raw_surface + end + + module Message_box = struct + let error = F.constant "SDL_MESSAGEBOX_ERROR" F.uint32_t + let warning = F.constant "SDL_MESSAGEBOX_WARNING" F.uint32_t + let information = F.constant "SDL_MESSAGEBOX_INFORMATION" F.uint32_t + + let button_returnkey_default = F.constant "SDL_MESSAGEBOX_BUTTON_RETURNKEY_DEFAULT" F.uint32_t + let button_escapekey_default = F.constant "SDL_MESSAGEBOX_BUTTON_ESCAPEKEY_DEFAULT" F.uint32_t + + let color_background = F.constant "SDL_MESSAGEBOX_COLOR_BACKGROUND" F.int + let color_text = F.constant "SDL_MESSAGEBOX_COLOR_TEXT" F.int + let color_button_border = F.constant "SDL_MESSAGEBOX_COLOR_BUTTON_BORDER" F.int + let color_button_background = F.constant "SDL_MESSAGEBOX_COLOR_BUTTON_BACKGROUND" F.int + let color_button_selected = F.constant "SDL_MESSAGEBOX_COLOR_BUTTON_SELECTED" F.int + let color_button_max = F.constant "SDL_MESSAGEBOX_COLOR_MAX" F.int + + type _button_data + let button_data : _button_data Ctypes_static.structure F.typ = + F.typedef (F.structure "_message_box_button_data") "SDL_MessageBoxButtonData" + let button_flags = F.field button_data "flags" F.uint32_t + let button_buttonid = F.field button_data "buttonid" F.int + let button_text = F.field button_data "text" F.string + let () = F.seal button_data + + type _color + let color : _color Ctypes_static.structure F.typ = + F.typedef (F.structure "_message_box_color") "SDL_MessageBoxColor" + let color_r = F.field color "r" F.uint8_t + let color_g = F.field color "g" F.uint8_t + let color_b = F.field color "b" F.uint8_t + let () = F.seal color + + type _color_scheme + let color_scheme : _color_scheme Ctypes_static.structure F.typ = + F.typedef (F.structure "_SDL_MessageBoxColorScheme") "SDL_MessageBoxColorScheme" + let colors = F.field color_scheme "colors" (F.array 5 color) + let () = F.seal color_scheme + + type _data + let data : _data Ctypes_static.structure F.typ = + F.typedef (F.structure "_SDL_MessageBoxData") "SDL_MessageBoxData" + let d_flags = F.field data "flags" F.uint32_t + let d_window = F.field data "window" Window.opt + let d_title = F.field data "title" F.string + let d_message = F.field data "message" F.string + let d_numbuttons = F.field data "numbuttons" F.int + let d_buttons = F.field data "buttons" (F.ptr button_data) + let d_color_scheme = F.field data "colorScheme" (F.ptr_opt color_scheme) + let () = F.seal data + end + + module Scancode = struct + let unknown = F.constant "SDL_SCANCODE_UNKNOWN" F.int + let a = F.constant "SDL_SCANCODE_A" F.int + let b = F.constant "SDL_SCANCODE_B" F.int + let c = F.constant "SDL_SCANCODE_C" F.int + let d = F.constant "SDL_SCANCODE_D" F.int + let e = F.constant "SDL_SCANCODE_E" F.int + let f = F.constant "SDL_SCANCODE_F" F.int + let g = F.constant "SDL_SCANCODE_G" F.int + let h = F.constant "SDL_SCANCODE_H" F.int + let i = F.constant "SDL_SCANCODE_I" F.int + let j = F.constant "SDL_SCANCODE_J" F.int + let k = F.constant "SDL_SCANCODE_K" F.int + let l = F.constant "SDL_SCANCODE_L" F.int + let m = F.constant "SDL_SCANCODE_M" F.int + let n = F.constant "SDL_SCANCODE_N" F.int + let o = F.constant "SDL_SCANCODE_O" F.int + let p = F.constant "SDL_SCANCODE_P" F.int + let q = F.constant "SDL_SCANCODE_Q" F.int + let r = F.constant "SDL_SCANCODE_R" F.int + let s = F.constant "SDL_SCANCODE_S" F.int + let t = F.constant "SDL_SCANCODE_T" F.int + let u = F.constant "SDL_SCANCODE_U" F.int + let v = F.constant "SDL_SCANCODE_V" F.int + let w = F.constant "SDL_SCANCODE_W" F.int + let x = F.constant "SDL_SCANCODE_X" F.int + let y = F.constant "SDL_SCANCODE_Y" F.int + let z = F.constant "SDL_SCANCODE_Z" F.int + let k1 = F.constant "SDL_SCANCODE_1" F.int + let k2 = F.constant "SDL_SCANCODE_2" F.int + let k3 = F.constant "SDL_SCANCODE_3" F.int + let k4 = F.constant "SDL_SCANCODE_4" F.int + let k5 = F.constant "SDL_SCANCODE_5" F.int + let k6 = F.constant "SDL_SCANCODE_6" F.int + let k7 = F.constant "SDL_SCANCODE_7" F.int + let k8 = F.constant "SDL_SCANCODE_8" F.int + let k9 = F.constant "SDL_SCANCODE_9" F.int + let k0 = F.constant "SDL_SCANCODE_0" F.int + let return = F.constant "SDL_SCANCODE_RETURN" F.int + let escape = F.constant "SDL_SCANCODE_ESCAPE" F.int + let backspace = F.constant "SDL_SCANCODE_BACKSPACE" F.int + let tab = F.constant "SDL_SCANCODE_TAB" F.int + let space = F.constant "SDL_SCANCODE_SPACE" F.int + let minus = F.constant "SDL_SCANCODE_MINUS" F.int + let equals = F.constant "SDL_SCANCODE_EQUALS" F.int + let leftbracket = F.constant "SDL_SCANCODE_LEFTBRACKET" F.int + let rightbracket = F.constant "SDL_SCANCODE_RIGHTBRACKET" F.int + let backslash = F.constant "SDL_SCANCODE_BACKSLASH" F.int + let nonushash = F.constant "SDL_SCANCODE_NONUSHASH" F.int + let semicolon = F.constant "SDL_SCANCODE_SEMICOLON" F.int + let apostrophe = F.constant "SDL_SCANCODE_APOSTROPHE" F.int + let grave = F.constant "SDL_SCANCODE_GRAVE" F.int + let comma = F.constant "SDL_SCANCODE_COMMA" F.int + let period = F.constant "SDL_SCANCODE_PERIOD" F.int + let slash = F.constant "SDL_SCANCODE_SLASH" F.int + let capslock = F.constant "SDL_SCANCODE_CAPSLOCK" F.int + let f1 = F.constant "SDL_SCANCODE_F1" F.int + let f2 = F.constant "SDL_SCANCODE_F2" F.int + let f3 = F.constant "SDL_SCANCODE_F3" F.int + let f4 = F.constant "SDL_SCANCODE_F4" F.int + let f5 = F.constant "SDL_SCANCODE_F5" F.int + let f6 = F.constant "SDL_SCANCODE_F6" F.int + let f7 = F.constant "SDL_SCANCODE_F7" F.int + let f8 = F.constant "SDL_SCANCODE_F8" F.int + let f9 = F.constant "SDL_SCANCODE_F9" F.int + let f10 = F.constant "SDL_SCANCODE_F10" F.int + let f11 = F.constant "SDL_SCANCODE_F11" F.int + let f12 = F.constant "SDL_SCANCODE_F12" F.int + let printscreen = F.constant "SDL_SCANCODE_PRINTSCREEN" F.int + let scrolllock = F.constant "SDL_SCANCODE_SCROLLLOCK" F.int + let pause = F.constant "SDL_SCANCODE_PAUSE" F.int + let insert = F.constant "SDL_SCANCODE_INSERT" F.int + let home = F.constant "SDL_SCANCODE_HOME" F.int + let pageup = F.constant "SDL_SCANCODE_PAGEUP" F.int + let delete = F.constant "SDL_SCANCODE_DELETE" F.int + let kend = F.constant "SDL_SCANCODE_END" F.int + let pagedown = F.constant "SDL_SCANCODE_PAGEDOWN" F.int + let right = F.constant "SDL_SCANCODE_RIGHT" F.int + let left = F.constant "SDL_SCANCODE_LEFT" F.int + let down = F.constant "SDL_SCANCODE_DOWN" F.int + let up = F.constant "SDL_SCANCODE_UP" F.int + let numlockclear = F.constant "SDL_SCANCODE_NUMLOCKCLEAR" F.int + let kp_divide = F.constant "SDL_SCANCODE_KP_DIVIDE" F.int + let kp_multiply = F.constant "SDL_SCANCODE_KP_MULTIPLY" F.int + let kp_minus = F.constant "SDL_SCANCODE_KP_MINUS" F.int + let kp_plus = F.constant "SDL_SCANCODE_KP_PLUS" F.int + let kp_enter = F.constant "SDL_SCANCODE_KP_ENTER" F.int + let kp_1 = F.constant "SDL_SCANCODE_KP_1" F.int + let kp_2 = F.constant "SDL_SCANCODE_KP_2" F.int + let kp_3 = F.constant "SDL_SCANCODE_KP_3" F.int + let kp_4 = F.constant "SDL_SCANCODE_KP_4" F.int + let kp_5 = F.constant "SDL_SCANCODE_KP_5" F.int + let kp_6 = F.constant "SDL_SCANCODE_KP_6" F.int + let kp_7 = F.constant "SDL_SCANCODE_KP_7" F.int + let kp_8 = F.constant "SDL_SCANCODE_KP_8" F.int + let kp_9 = F.constant "SDL_SCANCODE_KP_9" F.int + let kp_0 = F.constant "SDL_SCANCODE_KP_0" F.int + let kp_period = F.constant "SDL_SCANCODE_KP_PERIOD" F.int + let nonusbackslash = F.constant "SDL_SCANCODE_NONUSBACKSLASH" F.int + let application = F.constant "SDL_SCANCODE_APPLICATION" F.int + let kp_equals = F.constant "SDL_SCANCODE_KP_EQUALS" F.int + let f13 = F.constant "SDL_SCANCODE_F13" F.int + let f14 = F.constant "SDL_SCANCODE_F14" F.int + let f15 = F.constant "SDL_SCANCODE_F15" F.int + let f16 = F.constant "SDL_SCANCODE_F16" F.int + let f17 = F.constant "SDL_SCANCODE_F17" F.int + let f18 = F.constant "SDL_SCANCODE_F18" F.int + let f19 = F.constant "SDL_SCANCODE_F19" F.int + let f20 = F.constant "SDL_SCANCODE_F20" F.int + let f21 = F.constant "SDL_SCANCODE_F21" F.int + let f22 = F.constant "SDL_SCANCODE_F22" F.int + let f23 = F.constant "SDL_SCANCODE_F23" F.int + let f24 = F.constant "SDL_SCANCODE_F24" F.int + let execute = F.constant "SDL_SCANCODE_EXECUTE" F.int + let help = F.constant "SDL_SCANCODE_HELP" F.int + let menu = F.constant "SDL_SCANCODE_MENU" F.int + let select = F.constant "SDL_SCANCODE_SELECT" F.int + let stop = F.constant "SDL_SCANCODE_STOP" F.int + let again = F.constant "SDL_SCANCODE_AGAIN" F.int + let undo = F.constant "SDL_SCANCODE_UNDO" F.int + let cut = F.constant "SDL_SCANCODE_CUT" F.int + let copy = F.constant "SDL_SCANCODE_COPY" F.int + let paste = F.constant "SDL_SCANCODE_PASTE" F.int + let find = F.constant "SDL_SCANCODE_FIND" F.int + let mute = F.constant "SDL_SCANCODE_MUTE" F.int + let volumeup = F.constant "SDL_SCANCODE_VOLUMEUP" F.int + let volumedown = F.constant "SDL_SCANCODE_VOLUMEDOWN" F.int + let kp_comma = F.constant "SDL_SCANCODE_KP_COMMA" F.int + let kp_equalsas400 = F.constant "SDL_SCANCODE_KP_EQUALSAS400" F.int + let international1 = F.constant "SDL_SCANCODE_INTERNATIONAL1" F.int + let international2 = F.constant "SDL_SCANCODE_INTERNATIONAL2" F.int + let international3 = F.constant "SDL_SCANCODE_INTERNATIONAL3" F.int + let international4 = F.constant "SDL_SCANCODE_INTERNATIONAL4" F.int + let international5 = F.constant "SDL_SCANCODE_INTERNATIONAL5" F.int + let international6 = F.constant "SDL_SCANCODE_INTERNATIONAL6" F.int + let international7 = F.constant "SDL_SCANCODE_INTERNATIONAL7" F.int + let international8 = F.constant "SDL_SCANCODE_INTERNATIONAL8" F.int + let international9 = F.constant "SDL_SCANCODE_INTERNATIONAL9" F.int + let lang1 = F.constant "SDL_SCANCODE_LANG1" F.int + let lang2 = F.constant "SDL_SCANCODE_LANG2" F.int + let lang3 = F.constant "SDL_SCANCODE_LANG3" F.int + let lang4 = F.constant "SDL_SCANCODE_LANG4" F.int + let lang5 = F.constant "SDL_SCANCODE_LANG5" F.int + let lang6 = F.constant "SDL_SCANCODE_LANG6" F.int + let lang7 = F.constant "SDL_SCANCODE_LANG7" F.int + let lang8 = F.constant "SDL_SCANCODE_LANG8" F.int + let lang9 = F.constant "SDL_SCANCODE_LANG9" F.int + let alterase = F.constant "SDL_SCANCODE_ALTERASE" F.int + let sysreq = F.constant "SDL_SCANCODE_SYSREQ" F.int + let cancel = F.constant "SDL_SCANCODE_CANCEL" F.int + let clear = F.constant "SDL_SCANCODE_CLEAR" F.int + let prior = F.constant "SDL_SCANCODE_PRIOR" F.int + let return2 = F.constant "SDL_SCANCODE_RETURN2" F.int + let separator = F.constant "SDL_SCANCODE_SEPARATOR" F.int + let out = F.constant "SDL_SCANCODE_OUT" F.int + let oper = F.constant "SDL_SCANCODE_OPER" F.int + let clearagain = F.constant "SDL_SCANCODE_CLEARAGAIN" F.int + let crsel = F.constant "SDL_SCANCODE_CRSEL" F.int + let exsel = F.constant "SDL_SCANCODE_EXSEL" F.int + let kp_00 = F.constant "SDL_SCANCODE_KP_00" F.int + let kp_000 = F.constant "SDL_SCANCODE_KP_000" F.int + let thousandsseparator = F.constant "SDL_SCANCODE_THOUSANDSSEPARATOR" F.int + let decimalseparator = F.constant "SDL_SCANCODE_DECIMALSEPARATOR" F.int + let currencyunit = F.constant "SDL_SCANCODE_CURRENCYUNIT" F.int + let currencysubunit = F.constant "SDL_SCANCODE_CURRENCYSUBUNIT" F.int + let kp_leftparen = F.constant "SDL_SCANCODE_KP_LEFTPAREN" F.int + let kp_rightparen = F.constant "SDL_SCANCODE_KP_RIGHTPAREN" F.int + let kp_leftbrace = F.constant "SDL_SCANCODE_KP_LEFTBRACE" F.int + let kp_rightbrace = F.constant "SDL_SCANCODE_KP_RIGHTBRACE" F.int + let kp_tab = F.constant "SDL_SCANCODE_KP_TAB" F.int + let kp_backspace = F.constant "SDL_SCANCODE_KP_BACKSPACE" F.int + let kp_a = F.constant "SDL_SCANCODE_KP_A" F.int + let kp_b = F.constant "SDL_SCANCODE_KP_B" F.int + let kp_c = F.constant "SDL_SCANCODE_KP_C" F.int + let kp_d = F.constant "SDL_SCANCODE_KP_D" F.int + let kp_e = F.constant "SDL_SCANCODE_KP_E" F.int + let kp_f = F.constant "SDL_SCANCODE_KP_F" F.int + let kp_xor = F.constant "SDL_SCANCODE_KP_XOR" F.int + let kp_power = F.constant "SDL_SCANCODE_KP_POWER" F.int + let kp_percent = F.constant "SDL_SCANCODE_KP_PERCENT" F.int + let kp_less = F.constant "SDL_SCANCODE_KP_LESS" F.int + let kp_greater = F.constant "SDL_SCANCODE_KP_GREATER" F.int + let kp_ampersand = F.constant "SDL_SCANCODE_KP_AMPERSAND" F.int + let kp_dblampersand = F.constant "SDL_SCANCODE_KP_DBLAMPERSAND" F.int + let kp_verticalbar = F.constant "SDL_SCANCODE_KP_VERTICALBAR" F.int + let kp_dblverticalbar = F.constant "SDL_SCANCODE_KP_DBLVERTICALBAR" F.int + let kp_colon = F.constant "SDL_SCANCODE_KP_COLON" F.int + let kp_hash = F.constant "SDL_SCANCODE_KP_HASH" F.int + let kp_space = F.constant "SDL_SCANCODE_KP_SPACE" F.int + let kp_at = F.constant "SDL_SCANCODE_KP_AT" F.int + let kp_exclam = F.constant "SDL_SCANCODE_KP_EXCLAM" F.int + let kp_memstore = F.constant "SDL_SCANCODE_KP_MEMSTORE" F.int + let kp_memrecall = F.constant "SDL_SCANCODE_KP_MEMRECALL" F.int + let kp_memclear = F.constant "SDL_SCANCODE_KP_MEMCLEAR" F.int + let kp_memadd = F.constant "SDL_SCANCODE_KP_MEMADD" F.int + let kp_memsubtract = F.constant "SDL_SCANCODE_KP_MEMSUBTRACT" F.int + let kp_memmultiply = F.constant "SDL_SCANCODE_KP_MEMMULTIPLY" F.int + let kp_memdivide = F.constant "SDL_SCANCODE_KP_MEMDIVIDE" F.int + let kp_plusminus = F.constant "SDL_SCANCODE_KP_PLUSMINUS" F.int + let kp_clear = F.constant "SDL_SCANCODE_KP_CLEAR" F.int + let kp_clearentry = F.constant "SDL_SCANCODE_KP_CLEARENTRY" F.int + let kp_binary = F.constant "SDL_SCANCODE_KP_BINARY" F.int + let kp_octal = F.constant "SDL_SCANCODE_KP_OCTAL" F.int + let kp_decimal = F.constant "SDL_SCANCODE_KP_DECIMAL" F.int + let kp_hexadecimal = F.constant "SDL_SCANCODE_KP_HEXADECIMAL" F.int + let lctrl = F.constant "SDL_SCANCODE_LCTRL" F.int + let lshift = F.constant "SDL_SCANCODE_LSHIFT" F.int + let lalt = F.constant "SDL_SCANCODE_LALT" F.int + let lgui = F.constant "SDL_SCANCODE_LGUI" F.int + let rctrl = F.constant "SDL_SCANCODE_RCTRL" F.int + let rshift = F.constant "SDL_SCANCODE_RSHIFT" F.int + let ralt = F.constant "SDL_SCANCODE_RALT" F.int + let rgui = F.constant "SDL_SCANCODE_RGUI" F.int + let mode = F.constant "SDL_SCANCODE_MODE" F.int + let audionext = F.constant "SDL_SCANCODE_AUDIONEXT" F.int + let audioprev = F.constant "SDL_SCANCODE_AUDIOPREV" F.int + let audiostop = F.constant "SDL_SCANCODE_AUDIOSTOP" F.int + let audioplay = F.constant "SDL_SCANCODE_AUDIOPLAY" F.int + let audiomute = F.constant "SDL_SCANCODE_AUDIOMUTE" F.int + let mediaselect = F.constant "SDL_SCANCODE_MEDIASELECT" F.int + let www = F.constant "SDL_SCANCODE_WWW" F.int + let mail = F.constant "SDL_SCANCODE_MAIL" F.int + let calculator = F.constant "SDL_SCANCODE_CALCULATOR" F.int + let computer = F.constant "SDL_SCANCODE_COMPUTER" F.int + let ac_search = F.constant "SDL_SCANCODE_AC_SEARCH" F.int + let ac_home = F.constant "SDL_SCANCODE_AC_HOME" F.int + let ac_back = F.constant "SDL_SCANCODE_AC_BACK" F.int + let ac_forward = F.constant "SDL_SCANCODE_AC_FORWARD" F.int + let ac_stop = F.constant "SDL_SCANCODE_AC_STOP" F.int + let ac_refresh = F.constant "SDL_SCANCODE_AC_REFRESH" F.int + let ac_bookmarks = F.constant "SDL_SCANCODE_AC_BOOKMARKS" F.int + let brightnessdown = F.constant "SDL_SCANCODE_BRIGHTNESSDOWN" F.int + let brightnessup = F.constant "SDL_SCANCODE_BRIGHTNESSUP" F.int + let displayswitch = F.constant "SDL_SCANCODE_DISPLAYSWITCH" F.int + let kbdillumtoggle = F.constant "SDL_SCANCODE_KBDILLUMTOGGLE" F.int + let kbdillumdown = F.constant "SDL_SCANCODE_KBDILLUMDOWN" F.int + let kbdillumup = F.constant "SDL_SCANCODE_KBDILLUMUP" F.int + let eject = F.constant "SDL_SCANCODE_EJECT" F.int + let sleep = F.constant "SDL_SCANCODE_SLEEP" F.int + let app1 = F.constant "SDL_SCANCODE_APP1" F.int + let app2 = F.constant "SDL_SCANCODE_APP2" F.int + let num_scancodes = F.constant "SDL_NUM_SCANCODES" F.int + end + + module K = struct + let scancode_mask = F.constant "SDLK_SCANCODE_MASK" F.int + let unknown = F.constant "SDLK_UNKNOWN" F.int + let return = F.constant "SDLK_RETURN" F.int + let escape = F.constant "SDLK_ESCAPE" F.int + let backspace = F.constant "SDLK_BACKSPACE" F.int + let tab = F.constant "SDLK_TAB" F.int + let space = F.constant "SDLK_SPACE" F.int + let exclaim = F.constant "SDLK_EXCLAIM" F.int + let quotedbl = F.constant "SDLK_QUOTEDBL" F.int + let hash = F.constant "SDLK_HASH" F.int + let percent = F.constant "SDLK_PERCENT" F.int + let dollar = F.constant "SDLK_DOLLAR" F.int + let ampersand = F.constant "SDLK_AMPERSAND" F.int + let quote = F.constant "SDLK_QUOTE" F.int + let leftparen = F.constant "SDLK_LEFTPAREN" F.int + let rightparen = F.constant "SDLK_RIGHTPAREN" F.int + let asterisk = F.constant "SDLK_ASTERISK" F.int + let plus = F.constant "SDLK_PLUS" F.int + let comma = F.constant "SDLK_COMMA" F.int + let minus = F.constant "SDLK_MINUS" F.int + let period = F.constant "SDLK_PERIOD" F.int + let slash = F.constant "SDLK_SLASH" F.int + let k0 = F.constant "SDLK_0" F.int + let k1 = F.constant "SDLK_1" F.int + let k2 = F.constant "SDLK_2" F.int + let k3 = F.constant "SDLK_3" F.int + let k4 = F.constant "SDLK_4" F.int + let k5 = F.constant "SDLK_5" F.int + let k6 = F.constant "SDLK_6" F.int + let k7 = F.constant "SDLK_7" F.int + let k8 = F.constant "SDLK_8" F.int + let k9 = F.constant "SDLK_9" F.int + let colon = F.constant "SDLK_COLON" F.int + let semicolon = F.constant "SDLK_SEMICOLON" F.int + let less = F.constant "SDLK_LESS" F.int + let equals = F.constant "SDLK_EQUALS" F.int + let greater = F.constant "SDLK_GREATER" F.int + let question = F.constant "SDLK_QUESTION" F.int + let at = F.constant "SDLK_AT" F.int + let leftbracket = F.constant "SDLK_LEFTBRACKET" F.int + let backslash = F.constant "SDLK_BACKSLASH" F.int + let rightbracket = F.constant "SDLK_RIGHTBRACKET" F.int + let caret = F.constant "SDLK_CARET" F.int + let underscore = F.constant "SDLK_UNDERSCORE" F.int + let backquote = F.constant "SDLK_BACKQUOTE" F.int + let a = F.constant "SDLK_a" F.int + let b = F.constant "SDLK_b" F.int + let c = F.constant "SDLK_c" F.int + let d = F.constant "SDLK_d" F.int + let e = F.constant "SDLK_e" F.int + let f = F.constant "SDLK_f" F.int + let g = F.constant "SDLK_g" F.int + let h = F.constant "SDLK_h" F.int + let i = F.constant "SDLK_i" F.int + let j = F.constant "SDLK_j" F.int + let k = F.constant "SDLK_k" F.int + let l = F.constant "SDLK_l" F.int + let m = F.constant "SDLK_m" F.int + let n = F.constant "SDLK_n" F.int + let o = F.constant "SDLK_o" F.int + let p = F.constant "SDLK_p" F.int + let q = F.constant "SDLK_q" F.int + let r = F.constant "SDLK_r" F.int + let s = F.constant "SDLK_s" F.int + let t = F.constant "SDLK_t" F.int + let u = F.constant "SDLK_u" F.int + let v = F.constant "SDLK_v" F.int + let w = F.constant "SDLK_w" F.int + let x = F.constant "SDLK_x" F.int + let y = F.constant "SDLK_y" F.int + let z = F.constant "SDLK_z" F.int + let capslock = F.constant "SDLK_CAPSLOCK" F.int + let f1 = F.constant "SDLK_F1" F.int + let f2 = F.constant "SDLK_F2" F.int + let f3 = F.constant "SDLK_F3" F.int + let f4 = F.constant "SDLK_F4" F.int + let f5 = F.constant "SDLK_F5" F.int + let f6 = F.constant "SDLK_F6" F.int + let f7 = F.constant "SDLK_F7" F.int + let f8 = F.constant "SDLK_F8" F.int + let f9 = F.constant "SDLK_F9" F.int + let f10 = F.constant "SDLK_F10" F.int + let f11 = F.constant "SDLK_F11" F.int + let f12 = F.constant "SDLK_F12" F.int + let printscreen = F.constant "SDLK_PRINTSCREEN" F.int + let scrolllock = F.constant "SDLK_SCROLLLOCK" F.int + let pause = F.constant "SDLK_PAUSE" F.int + let insert = F.constant "SDLK_INSERT" F.int + let home = F.constant "SDLK_HOME" F.int + let pageup = F.constant "SDLK_PAGEUP" F.int + let delete = F.constant "SDLK_DELETE" F.int + let kend = F.constant "SDLK_END" F.int + let pagedown = F.constant "SDLK_PAGEDOWN" F.int + let right = F.constant "SDLK_RIGHT" F.int + let left = F.constant "SDLK_LEFT" F.int + let down = F.constant "SDLK_DOWN" F.int + let up = F.constant "SDLK_UP" F.int + let numlockclear = F.constant "SDLK_NUMLOCKCLEAR" F.int + let kp_divide = F.constant "SDLK_KP_DIVIDE" F.int + let kp_multiply = F.constant "SDLK_KP_MULTIPLY" F.int + let kp_minus = F.constant "SDLK_KP_MINUS" F.int + let kp_plus = F.constant "SDLK_KP_PLUS" F.int + let kp_enter = F.constant "SDLK_KP_ENTER" F.int + let kp_1 = F.constant "SDLK_KP_1" F.int + let kp_2 = F.constant "SDLK_KP_2" F.int + let kp_3 = F.constant "SDLK_KP_3" F.int + let kp_4 = F.constant "SDLK_KP_4" F.int + let kp_5 = F.constant "SDLK_KP_5" F.int + let kp_6 = F.constant "SDLK_KP_6" F.int + let kp_7 = F.constant "SDLK_KP_7" F.int + let kp_8 = F.constant "SDLK_KP_8" F.int + let kp_9 = F.constant "SDLK_KP_9" F.int + let kp_0 = F.constant "SDLK_KP_0" F.int + let kp_period = F.constant "SDLK_KP_PERIOD" F.int + let application = F.constant "SDLK_APPLICATION" F.int + let power = F.constant "SDLK_POWER" F.int + let kp_equals = F.constant "SDLK_KP_EQUALS" F.int + let f13 = F.constant "SDLK_F13" F.int + let f14 = F.constant "SDLK_F14" F.int + let f15 = F.constant "SDLK_F15" F.int + let f16 = F.constant "SDLK_F16" F.int + let f17 = F.constant "SDLK_F17" F.int + let f18 = F.constant "SDLK_F18" F.int + let f19 = F.constant "SDLK_F19" F.int + let f20 = F.constant "SDLK_F20" F.int + let f21 = F.constant "SDLK_F21" F.int + let f22 = F.constant "SDLK_F22" F.int + let f23 = F.constant "SDLK_F23" F.int + let f24 = F.constant "SDLK_F24" F.int + let execute = F.constant "SDLK_EXECUTE" F.int + let help = F.constant "SDLK_HELP" F.int + let menu = F.constant "SDLK_MENU" F.int + let select = F.constant "SDLK_SELECT" F.int + let stop = F.constant "SDLK_STOP" F.int + let again = F.constant "SDLK_AGAIN" F.int + let undo = F.constant "SDLK_UNDO" F.int + let cut = F.constant "SDLK_CUT" F.int + let copy = F.constant "SDLK_COPY" F.int + let paste = F.constant "SDLK_PASTE" F.int + let find = F.constant "SDLK_FIND" F.int + let mute = F.constant "SDLK_MUTE" F.int + let volumeup = F.constant "SDLK_VOLUMEUP" F.int + let volumedown = F.constant "SDLK_VOLUMEDOWN" F.int + let kp_comma = F.constant "SDLK_KP_COMMA" F.int + let kp_equalsas400 = F.constant "SDLK_KP_EQUALSAS400" F.int + let alterase = F.constant "SDLK_ALTERASE" F.int + let sysreq = F.constant "SDLK_SYSREQ" F.int + let cancel = F.constant "SDLK_CANCEL" F.int + let clear = F.constant "SDLK_CLEAR" F.int + let prior = F.constant "SDLK_PRIOR" F.int + let return2 = F.constant "SDLK_RETURN2" F.int + let separator = F.constant "SDLK_SEPARATOR" F.int + let out = F.constant "SDLK_OUT" F.int + let oper = F.constant "SDLK_OPER" F.int + let clearagain = F.constant "SDLK_CLEARAGAIN" F.int + let crsel = F.constant "SDLK_CRSEL" F.int + let exsel = F.constant "SDLK_EXSEL" F.int + let kp_00 = F.constant "SDLK_KP_00" F.int + let kp_000 = F.constant "SDLK_KP_000" F.int + let thousandsseparator = F.constant "SDLK_THOUSANDSSEPARATOR" F.int + let decimalseparator = F.constant "SDLK_DECIMALSEPARATOR" F.int + let currencyunit = F.constant "SDLK_CURRENCYUNIT" F.int + let currencysubunit = F.constant "SDLK_CURRENCYSUBUNIT" F.int + let kp_leftparen = F.constant "SDLK_KP_LEFTPAREN" F.int + let kp_rightparen = F.constant "SDLK_KP_RIGHTPAREN" F.int + let kp_leftbrace = F.constant "SDLK_KP_LEFTBRACE" F.int + let kp_rightbrace = F.constant "SDLK_KP_RIGHTBRACE" F.int + let kp_tab = F.constant "SDLK_KP_TAB" F.int + let kp_backspace = F.constant "SDLK_KP_BACKSPACE" F.int + let kp_a = F.constant "SDLK_KP_A" F.int + let kp_b = F.constant "SDLK_KP_B" F.int + let kp_c = F.constant "SDLK_KP_C" F.int + let kp_d = F.constant "SDLK_KP_D" F.int + let kp_e = F.constant "SDLK_KP_E" F.int + let kp_f = F.constant "SDLK_KP_F" F.int + let kp_xor = F.constant "SDLK_KP_XOR" F.int + let kp_power = F.constant "SDLK_KP_POWER" F.int + let kp_percent = F.constant "SDLK_KP_PERCENT" F.int + let kp_less = F.constant "SDLK_KP_LESS" F.int + let kp_greater = F.constant "SDLK_KP_GREATER" F.int + let kp_ampersand = F.constant "SDLK_KP_AMPERSAND" F.int + let kp_dblampersand = F.constant "SDLK_KP_DBLAMPERSAND" F.int + let kp_verticalbar = F.constant "SDLK_KP_VERTICALBAR" F.int + let kp_dblverticalbar = F.constant "SDLK_KP_DBLVERTICALBAR" F.int + let kp_colon = F.constant "SDLK_KP_COLON" F.int + let kp_hash = F.constant "SDLK_KP_HASH" F.int + let kp_space = F.constant "SDLK_KP_SPACE" F.int + let kp_at = F.constant "SDLK_KP_AT" F.int + let kp_exclam = F.constant "SDLK_KP_EXCLAM" F.int + let kp_memstore = F.constant "SDLK_KP_MEMSTORE" F.int + let kp_memrecall = F.constant "SDLK_KP_MEMRECALL" F.int + let kp_memclear = F.constant "SDLK_KP_MEMCLEAR" F.int + let kp_memadd = F.constant "SDLK_KP_MEMADD" F.int + let kp_memsubtract = F.constant "SDLK_KP_MEMSUBTRACT" F.int + let kp_memmultiply = F.constant "SDLK_KP_MEMMULTIPLY" F.int + let kp_memdivide = F.constant "SDLK_KP_MEMDIVIDE" F.int + let kp_plusminus = F.constant "SDLK_KP_PLUSMINUS" F.int + let kp_clear = F.constant "SDLK_KP_CLEAR" F.int + let kp_clearentry = F.constant "SDLK_KP_CLEARENTRY" F.int + let kp_binary = F.constant "SDLK_KP_BINARY" F.int + let kp_octal = F.constant "SDLK_KP_OCTAL" F.int + let kp_decimal = F.constant "SDLK_KP_DECIMAL" F.int + let kp_hexadecimal = F.constant "SDLK_KP_HEXADECIMAL" F.int + let lctrl = F.constant "SDLK_LCTRL" F.int + let lshift = F.constant "SDLK_LSHIFT" F.int + let lalt = F.constant "SDLK_LALT" F.int + let lgui = F.constant "SDLK_LGUI" F.int + let rctrl = F.constant "SDLK_RCTRL" F.int + let rshift = F.constant "SDLK_RSHIFT" F.int + let ralt = F.constant "SDLK_RALT" F.int + let rgui = F.constant "SDLK_RGUI" F.int + let mode = F.constant "SDLK_MODE" F.int + let audionext = F.constant "SDLK_AUDIONEXT" F.int + let audioprev = F.constant "SDLK_AUDIOPREV" F.int + let audiostop = F.constant "SDLK_AUDIOSTOP" F.int + let audioplay = F.constant "SDLK_AUDIOPLAY" F.int + let audiomute = F.constant "SDLK_AUDIOMUTE" F.int + let mediaselect = F.constant "SDLK_MEDIASELECT" F.int + let www = F.constant "SDLK_WWW" F.int + let mail = F.constant "SDLK_MAIL" F.int + let calculator = F.constant "SDLK_CALCULATOR" F.int + let computer = F.constant "SDLK_COMPUTER" F.int + let ac_search = F.constant "SDLK_AC_SEARCH" F.int + let ac_home = F.constant "SDLK_AC_HOME" F.int + let ac_back = F.constant "SDLK_AC_BACK" F.int + let ac_forward = F.constant "SDLK_AC_FORWARD" F.int + let ac_stop = F.constant "SDLK_AC_STOP" F.int + let ac_refresh = F.constant "SDLK_AC_REFRESH" F.int + let ac_bookmarks = F.constant "SDLK_AC_BOOKMARKS" F.int + let brightnessdown = F.constant "SDLK_BRIGHTNESSDOWN" F.int + let brightnessup = F.constant "SDLK_BRIGHTNESSUP" F.int + let displayswitch = F.constant "SDLK_DISPLAYSWITCH" F.int + let kbdillumtoggle = F.constant "SDLK_KBDILLUMTOGGLE" F.int + let kbdillumdown = F.constant "SDLK_KBDILLUMDOWN" F.int + let kbdillumup = F.constant "SDLK_KBDILLUMUP" F.int + let eject = F.constant "SDLK_EJECT" F.int + let sleep = F.constant "SDLK_SLEEP" F.int + end + + module Kmod = struct + let none = F.constant "KMOD_NONE" F.int (* F.uint16_t *) + let lshift = F.constant "KMOD_LSHIFT" F.int (* F.uint16_t *) + let rshift = F.constant "KMOD_RSHIFT" F.int (* F.uint16_t *) + let lctrl = F.constant "KMOD_LCTRL" F.int (* F.uint16_t *) + let rctrl = F.constant "KMOD_RCTRL" F.int (* F.uint16_t *) + let lalt = F.constant "KMOD_LALT" F.int (* F.uint16_t *) + let ralt = F.constant "KMOD_RALT" F.int (* F.uint16_t *) + let lgui = F.constant "KMOD_LGUI" F.int (* F.uint16_t *) + let rgui = F.constant "KMOD_RGUI" F.int (* F.uint16_t *) + let num = F.constant "KMOD_NUM" F.int (* F.uint16_t *) + let caps = F.constant "KMOD_CAPS" F.int (* F.uint16_t *) + let mode = F.constant "KMOD_MODE" F.int (* F.uint16_t *) + let reserved = F.constant "KMOD_RESERVED" F.int (* F.uint16_t *) + let ctrl = F.constant "KMOD_CTRL" F.int (* F.uint16_t *) + let shift = F.constant "KMOD_SHIFT" F.int (* F.uint16_t *) + let alt = F.constant "KMOD_ALT" F.int (* F.uint16_t *) + let gui = F.constant "KMOD_GUI" F.int (* F.uint16_t *) + end + + type _cursor + type cursor = _cursor Ctypes_static.structure + let cursor : cursor F.typ = F.structure "SDL_Cursor" + + module System_cursor = struct + let arrow = F.constant "SDL_SYSTEM_CURSOR_ARROW" F.int + let ibeam = F.constant "SDL_SYSTEM_CURSOR_IBEAM" F.int + let wait = F.constant "SDL_SYSTEM_CURSOR_WAIT" F.int + let crosshair = F.constant "SDL_SYSTEM_CURSOR_CROSSHAIR" F.int + let waitarrow = F.constant "SDL_SYSTEM_CURSOR_WAITARROW" F.int + let size_nw_se = F.constant "SDL_SYSTEM_CURSOR_SIZENWSE" F.int + let size_ne_sw = F.constant "SDL_SYSTEM_CURSOR_SIZENESW" F.int + let size_we = F.constant "SDL_SYSTEM_CURSOR_SIZEWE" F.int + let size_ns = F.constant "SDL_SYSTEM_CURSOR_SIZENS" F.int + let size_all = F.constant "SDL_SYSTEM_CURSOR_SIZEALL" F.int + let no = F.constant "SDL_SYSTEM_CURSOR_NO" F.int + let hand = F.constant "SDL_SYSTEM_CURSOR_HAND" F.int + end + + module Button = struct + let left = F.constant "SDL_BUTTON_LEFT" F.int + let middle = F.constant "SDL_BUTTON_MIDDLE" F.int + let right = F.constant "SDL_BUTTON_RIGHT" F.int + let x1 = F.constant "SDL_BUTTON_X1" F.int + let x2 = F.constant "SDL_BUTTON_X2" F.int + + let lmask = F.constant "SDL_BUTTON_LMASK" F.int32_t + let mmask = F.constant "SDL_BUTTON_MMASK" F.int32_t + let rmask = F.constant "SDL_BUTTON_RMASK" F.int32_t + let x1mask = F.constant "SDL_BUTTON_X1MASK" F.int32_t + let x2mask = F.constant "SDL_BUTTON_X2MASK" F.int32_t + end + + (* Touch *) + let touch_mouseid = F.constant "SDL_TOUCH_MOUSEID" F.int64_t + + module Finger = struct + type _t + type t = _t Ctypes_static.structure + let t : t F.typ = F.structure "SDL_Finger" + let id = F.field t "id" F.int64_t + let x = F.field t "x" F.float + let y = F.field t "y" F.float + let pressure = F.field t "pressure" F.float + let () = F.seal t + end + + (*type guid = _guid Ctypes_static.structure + let guid : guid F.typ = F.typedef (F.structure "_guid") "SDL_GUID" + let _= F.field guid "data" F.(array 16 uint8_t) + let () = F.seal guid + + let joystick_guid = F.typedef guid "SDL_JoystickGUID"*) + + type _joystick + type joystick = _joystick Ctypes_static.structure + let joystick : joystick F.typ = + F.typedef (F.structure "_SDL_Joystick") "SDL_Joystick" + + module Hat = struct + type t = int + let centered = F.constant "SDL_HAT_CENTERED" F.int + let up = F.constant "SDL_HAT_UP" F.int + let right = F.constant "SDL_HAT_RIGHT" F.int + let down = F.constant "SDL_HAT_DOWN" F.int + let left = F.constant "SDL_HAT_LEFT" F.int + let rightup = F.constant "SDL_HAT_RIGHTUP" F.int + let rightdown = F.constant "SDL_HAT_RIGHTDOWN" F.int + let leftup = F.constant "SDL_HAT_LEFTUP" F.int + let leftdown = F.constant "SDL_HAT_LEFTDOWN" F.int + end + + module Joystick_power_level = struct + type t = int + let unknown = F.constant "SDL_JOYSTICK_POWER_UNKNOWN" F.int + let low = F.constant "SDL_JOYSTICK_POWER_LOW" F.int + let medium = F.constant "SDL_JOYSTICK_POWER_MEDIUM" F.int + let full = F.constant "SDL_JOYSTICK_POWER_FULL" F.int + let max = F.constant "SDL_JOYSTICK_POWER_MAX" F.int + let wired = F.constant "SDL_JOYSTICK_POWER_WIRED" F.int + end + + module Joystick_type = struct + type t = int + let unknown = F.constant "SDL_JOYSTICK_TYPE_UNKNOWN" F.int + let gamecontroller = F.constant "SDL_JOYSTICK_TYPE_GAMECONTROLLER" F.int + let wheel = F.constant "SDL_JOYSTICK_TYPE_WHEEL" F.int + let arcade_stick = F.constant "SDL_JOYSTICK_TYPE_ARCADE_STICK" F.int + let flight_stick = F.constant "SDL_JOYSTICK_TYPE_FLIGHT_STICK" F.int + let dance_pad = F.constant "SDL_JOYSTICK_TYPE_DANCE_PAD" F.int + let guitar = F.constant "SDL_JOYSTICK_TYPE_GUITAR" F.int + let drum_kit = F.constant "SDL_JOYSTICK_TYPE_DRUM_KIT" F.int + let arcade_pad = F.constant "SDL_JOYSTICK_TYPE_ARCADE_PAD" F.int + let throttle = F.constant "SDL_JOYSTICK_TYPE_THROTTLE" F.int + end + + module Controller = struct + type bind_type = int + let bind_type_none = F.constant "SDL_CONTROLLER_BINDTYPE_NONE" F.int + let bind_type_button = F.constant "SDL_CONTROLLER_BINDTYPE_BUTTON" F.int + let bind_type_axis = F.constant "SDL_CONTROLLER_BINDTYPE_AXIS" F.int + let bind_type_hat = F.constant "SDL_CONTROLLER_BINDTYPE_HAT" F.int + + type axis = int + let axis_invalid = F.constant "SDL_CONTROLLER_AXIS_INVALID" F.int + let axis_left_x = F.constant "SDL_CONTROLLER_AXIS_LEFTX" F.int + let axis_left_y = F.constant "SDL_CONTROLLER_AXIS_LEFTY" F.int + let axis_right_x = F.constant "SDL_CONTROLLER_AXIS_RIGHTX" F.int + let axis_right_y = F.constant "SDL_CONTROLLER_AXIS_RIGHTY" F.int + let axis_trigger_left = F.constant "SDL_CONTROLLER_AXIS_TRIGGERLEFT" F.int + let axis_trigger_right = F.constant "SDL_CONTROLLER_AXIS_TRIGGERRIGHT" F.int + let axis_max = F.constant "SDL_CONTROLLER_AXIS_MAX" F.int + + type button = int + let button_invalid = F.constant "SDL_CONTROLLER_BUTTON_INVALID" F.int + let button_a = F.constant "SDL_CONTROLLER_BUTTON_A" F.int + let button_b = F.constant "SDL_CONTROLLER_BUTTON_B" F.int + let button_x = F.constant "SDL_CONTROLLER_BUTTON_X" F.int + let button_y = F.constant "SDL_CONTROLLER_BUTTON_Y" F.int + let button_back = F.constant "SDL_CONTROLLER_BUTTON_BACK" F.int + let button_guide = F.constant "SDL_CONTROLLER_BUTTON_GUIDE" F.int + let button_start = F.constant "SDL_CONTROLLER_BUTTON_START" F.int + let button_left_stick = F.constant "SDL_CONTROLLER_BUTTON_LEFTSTICK" F.int + let button_right_stick = F.constant "SDL_CONTROLLER_BUTTON_RIGHTSTICK" F.int + let button_left_shoulder = F.constant "SDL_CONTROLLER_BUTTON_LEFTSHOULDER" F.int + let button_right_shoulder = F.constant "SDL_CONTROLLER_BUTTON_RIGHTSHOULDER" F.int + let button_dpad_up = F.constant "SDL_CONTROLLER_BUTTON_DPAD_UP" F.int + let button_dpad_down = F.constant "SDL_CONTROLLER_BUTTON_DPAD_DOWN" F.int + let button_dpad_left = F.constant "SDL_CONTROLLER_BUTTON_DPAD_LEFT" F.int + let button_dpad_right = F.constant "SDL_CONTROLLER_BUTTON_DPAD_RIGHT" F.int + let button_max = F.constant "SDL_CONTROLLER_BUTTON_MAX" F.int + end + + type _game_controller + + let game_controller : + _game_controller Ctypes_static.structure F.typ = + F.typedef (F.structure "_SDL_GameController") "SDL_GameController" + + let sdl_query = F.constant "SDL_QUERY" F.int + + let disable = F.constant "SDL_DISABLE" F.uint8_t + let enable = F.constant "SDL_ENABLE" F.uint8_t + + let pressed = F.constant "SDL_PRESSED" F.uint8_t + let released = F.constant "SDL_RELEASED" F.uint8_t + + + module Event = struct + let first_event = F.constant "SDL_FIRSTEVENT" F.int (* F.uint32_t *) + let last_event = F.constant "SDL_LASTEVENT" F.int (* F.uint32_t *) + + let quit = F.constant "SDL_QUIT" F.int (* F.uint32_t *) + + let app_terminating = F.constant "SDL_APP_TERMINATING" F.int (* F.uint32_t *) + let app_low_memory = F.constant "SDL_APP_LOWMEMORY" F.int (* F.uint32_t *) + let app_will_enter_background = F.constant "SDL_APP_WILLENTERBACKGROUND" F.int (* F.uint32_t *) + let app_did_enter_background = F.constant "SDL_APP_DIDENTERBACKGROUND" F.int (* F.uint32_t *) + let app_will_enter_foreground = F.constant "SDL_APP_WILLENTERFOREGROUND" F.int (* F.uint32_t *) + let app_did_enter_foreground = F.constant "SDL_APP_DIDENTERFOREGROUND" F.int (* F.uint32_t *) + + let display_event = F.constant "SDL_DISPLAYEVENT" F.int (* F.uint32_t *) + let window_event = F.constant "SDL_WINDOWEVENT" F.int (* F.uint32_t *) + let sys_wm_event = F.constant "SDL_SYSWMEVENT" F.int (* F.uint32_t *) + let sensor_update = F.constant "SDL_SENSORUPDATE" F.int (* F.uint32_t *) + let user_event = F.constant "SDL_USEREVENT" F.int (* F.uint32_t *) + + let key_down = F.constant "SDL_KEYDOWN" F.int (* F.uint32_t *) + let key_up = F.constant "SDL_KEYUP" F.int (* F.uint32_t *) + let keymap_changed = F.constant "SDL_KEYMAPCHANGED" F.int (* F.uint32_t *) + + let text_editing = F.constant "SDL_TEXTEDITING" F.int (* F.uint32_t *) + let text_input = F.constant "SDL_TEXTINPUT" F.int (* F.uint32_t *) + + let mouse_motion = F.constant "SDL_MOUSEMOTION" F.int (* F.uint32_t *) + let mouse_button_down = F.constant "SDL_MOUSEBUTTONDOWN" F.int (* F.uint32_t *) + let mouse_button_up = F.constant "SDL_MOUSEBUTTONUP" F.int (* F.uint32_t *) + let mouse_wheel = F.constant "SDL_MOUSEWHEEL" F.int (* F.uint32_t *) + + type mouse_wheel_direction = int + let mouse_wheel_normal = F.constant "SDL_MOUSEWHEEL_NORMAL" F.int + let mouse_wheel_flipped = F.constant "SDL_MOUSEWHEEL_FLIPPED" F.int + + let joy_axis_motion = F.constant "SDL_JOYAXISMOTION" F.int (* F.uint32_t *) + let joy_ball_motion = F.constant "SDL_JOYBALLMOTION" F.int (* F.uint32_t *) + let joy_hat_motion = F.constant "SDL_JOYHATMOTION" F.int (* F.uint32_t *) + let joy_button_down = F.constant "SDL_JOYBUTTONDOWN" F.int (* F.uint32_t *) + let joy_button_up = F.constant "SDL_JOYBUTTONUP" F.int (* F.uint32_t *) + let joy_device_added = F.constant "SDL_JOYDEVICEADDED" F.int (* F.uint32_t *) + let joy_device_removed = F.constant "SDL_JOYDEVICEREMOVED" F.int (* F.uint32_t *) + + let controller_axis_motion = F.constant "SDL_CONTROLLERAXISMOTION" F.int (* F.uint32_t *) + let controller_button_down = F.constant "SDL_CONTROLLERBUTTONDOWN" F.int (* F.uint32_t *) + let controller_button_up = F.constant "SDL_CONTROLLERBUTTONUP" F.int (* F.uint32_t *) + let controller_device_added = F.constant "SDL_CONTROLLERDEVICEADDED" F.int (* F.uint32_t *) + let controller_device_removed = F.constant "SDL_CONTROLLERDEVICEREMOVED" F.int (* F.uint32_t *) + let controller_device_remapped = F.constant "SDL_CONTROLLERDEVICEREMAPPED" F.int (* F.uint32_t *) + + let finger_down = F.constant "SDL_FINGERDOWN" F.int (* F.uint32_t *) + let finger_up = F.constant "SDL_FINGERUP" F.int (* F.uint32_t *) + let finger_motion = F.constant "SDL_FINGERMOTION" F.int (* F.uint32_t *) + + let dollar_gesture = F.constant "SDL_DOLLARGESTURE" F.int (* F.uint32_t *) + let dollar_record = F.constant "SDL_DOLLARRECORD" F.int (* F.uint32_t *) + + let multi_gesture = F.constant "SDL_MULTIGESTURE" F.int (* F.uint32_t *) + + let clipboard_update = F.constant "SDL_CLIPBOARDUPDATE" F.int (* F.uint32_t *) + + let drop_file = F.constant "SDL_DROPFILE" F.int (* F.uint32_t *) + let drop_text = F.constant "SDL_DROPTEXT" F.int (* F.uint32_t *) + let drop_begin = F.constant "SDL_DROPBEGIN" F.int (* F.uint32_t *) + let drop_complete = F.constant "SDL_DROPCOMPLETE" F.int (* F.uint32_t *) + + let audio_device_added = F.constant "SDL_AUDIODEVICEADDED" F.int (* F.uint32_t *) + let audio_device_removed = F.constant "SDL_AUDIODEVICEREMOVED" F.int (* F.uint32_t *) + + let render_targets_reset = F.constant "SDL_RENDER_TARGETS_RESET" F.int (* F.uint32_t *) + let render_device_reset = F.constant "SDL_RENDER_DEVICE_RESET" F.int (* F.uint32_t *) + + let texteditingevent_text_size = F.constant "SDL_TEXTEDITINGEVENT_TEXT_SIZE" F.int + let textinputevent_text_size = F.constant "SDL_TEXTINPUTEVENT_TEXT_SIZE" F.int + + (* SDL_WindowEventID *) + type window_event_id = int + let window_event_shown = F.constant "SDL_WINDOWEVENT_SHOWN" F.int + let window_event_hidden = F.constant "SDL_WINDOWEVENT_HIDDEN" F.int + let window_event_exposed = F.constant "SDL_WINDOWEVENT_EXPOSED" F.int + let window_event_moved = F.constant "SDL_WINDOWEVENT_MOVED" F.int + let window_event_resized = F.constant "SDL_WINDOWEVENT_RESIZED" F.int + let window_event_size_changed = F.constant "SDL_WINDOWEVENT_SIZE_CHANGED" F.int + let window_event_minimized = F.constant "SDL_WINDOWEVENT_MINIMIZED" F.int + let window_event_maximized = F.constant "SDL_WINDOWEVENT_MAXIMIZED" F.int + let window_event_restored = F.constant "SDL_WINDOWEVENT_RESTORED" F.int + let window_event_enter = F.constant "SDL_WINDOWEVENT_ENTER" F.int + let window_event_leave = F.constant "SDL_WINDOWEVENT_LEAVE" F.int + let window_event_focus_gained = F.constant "SDL_WINDOWEVENT_FOCUS_GAINED" F.int + let window_event_focus_lost = F.constant "SDL_WINDOWEVENT_FOCUS_LOST" F.int + let window_event_close = F.constant "SDL_WINDOWEVENT_CLOSE" F.int + let window_event_take_focus = F.constant "SDL_WINDOWEVENT_TAKE_FOCUS" F.int + let window_event_hit_test = F.constant "SDL_WINDOWEVENT_HIT_TEST" F.int + + module Common = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_CommonEvent" + let typ = F.field t "type" F.uint32_t + let timestamp = F.field t "timestamp" F.uint32_t + let () = F.seal t + end + + module Controller_axis_event = struct + type t + let t : t Ctypes_static.structure F.typ = + F.structure "SDL_ControllerAxisEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let which = F.field t "which" F.int32_t + let axis = F.field t "axis" F.uint8_t + let _ = F.field t "padding1" F.uint8_t + let _ = F.field t "padding2" F.uint8_t + let _ = F.field t "padding3" F.uint8_t + let value = F.field t "value" F.int16_t + let _ = F.field t "padding4" F.uint16_t + let () = F.seal t + end + + module Controller_button_event = struct + type t + let t : t Ctypes_static.structure F.typ = + F.structure "SDL_ControllerButtonEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let which = F.field t "which" F.int32_t + let button = F.field t "button" F.uint8_t + let state = F.field t "state" F.uint8_t + let _ = F.field t "padding1" F.uint8_t + let _ = F.field t "padding2" F.uint8_t + let () = F.seal t + end + + module Controller_device_event = struct + type t + let t : t Ctypes_static.structure F.typ = + F.structure "SDL_ControllerDeviceEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let which = F.field t "which" F.int32_t + let () = F.seal t + end + + module Dollar_gesture_event = struct + type t + let t : t Ctypes_static.structure F.typ = + F.structure "SDL_DollarGestureEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let touch_id = F.field t "touchId" F.int64_t + let gesture_id = F.field t "gestureId" F.int64_t + let num_fingers = F.field t "numFingers" F.uint32_t + let error = F.field t "error" F.float + let x = F.field t "x" F.float + let y = F.field t "y" F.float + let () = F.seal t + end + + module Drop_event = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_DropEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let file = F.field t "file" F.(ptr char) + let window_id = F.field t "windowID" F.uint32_t + let () = F.seal t + end + + module Keyboard_event = struct + type keysym + let keysym: keysym Ctypes_static.structure F.typ = F.structure "SDL_Keysym" + let scancode = F.field keysym "scancode" F.int + let keycode = F.field keysym "sym" F.int + let keymod = F.field keysym "mod" F.uint16_t + let _unused = F.field keysym "unused" F.uint32_t + let () = F.seal keysym + + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_KeyboardEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let window_id = F.field t "windowID" F.uint32_t + let state = F.field t "state" F.uint8_t + let repeat = F.field t "repeat" F.uint8_t + let _padding2 = F.field t "padding2" F.uint8_t + let _padding3 = F.field t "padding3" F.uint8_t + let keysym = F.field t "keysym" keysym + let () = F.seal t + end + + module Joy_axis_event = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_JoyAxisEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let which = F.field t "which" F.int32_t + let axis = F.field t "axis" F.uint8_t + let _ = F.field t "padding1" F.uint8_t + let _ = F.field t "padding2" F.uint8_t + let _ = F.field t "padding3" F.uint8_t + let value = F.field t "value" F.int16_t + let _ = F.field t "padding4" F.uint16_t + let () = F.seal t + end + + module Joy_ball_event = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_JoyBallEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let which = F.field t "which" F.int32_t + let ball = F.field t "ball" F.uint8_t + let _ = F.field t "padding1" F.uint8_t + let _ = F.field t "padding2" F.uint8_t + let _ = F.field t "padding3" F.uint8_t + let xrel = F.field t "xrel" F.int16_t + let yrel = F.field t "yrel" F.int16_t + let () = F.seal t + end + + module Joy_button_event = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_JoyButtonEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let which = F.field t "which" F.int32_t + let button = F.field t "button" F.uint8_t + let state = F.field t "state" F.uint8_t + let _ = F.field t "padding1" F.uint8_t + let _ = F.field t "padding2" F.uint8_t + let () = F.seal t + end + + module Joy_device_event = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_JoyDeviceEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let which = F.field t "which" F.int32_t + let () = F.seal t + end + + module Joy_hat_event = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_JoyHatEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let which = F.field t "which" F.int32_t + let hat = F.field t "hat" F.uint8_t + let value = F.field t "value" F.uint8_t + let _ = F.field t "padding1" F.uint8_t + let _ = F.field t "padding2" F.uint8_t + let () = F.seal t + end + + module Mouse_button_event = struct + type t + let t : t Ctypes_static.structure F.typ = + F.structure "SDL_MouseButtonEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let window_id = F.field t "windowID" F.uint32_t + let which = F.field t "which" F.uint32_t + let button = F.field t "button" F.uint8_t + let state = F.field t "state" F.uint8_t + let clicks = F.field t "clicks" F.uint8_t + let _ = F.field t "padding1" F.uint8_t + let x = F.field t "x" F.int32_t + let y = F.field t "y" F.int32_t + let () = F.seal t + end + + module Mouse_motion_event = struct + type t + let t : t Ctypes_static.structure F.typ = + F.structure "SDL_MouseMotionEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let window_id = F.field t "windowID" F.uint32_t + let which = F.field t "which" F.uint32_t + let state = F.field t "state" F.uint32_t + let x = F.field t "x" F.int32_t + let y = F.field t "y" F.int32_t + let xrel = F.field t "xrel" F.int32_t + let yrel = F.field t "yrel" F.int32_t + let () = F.seal t + end + + module Mouse_wheel_event = struct + type t + let t : t Ctypes_static.structure F.typ = + F.structure "SDL_MouseWheelEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let window_id = F.field t "windowID" F.uint32_t + let which = F.field t "which" F.uint32_t + let x = F.field t "x" F.int32_t + let y = F.field t "y" F.int32_t + let direction = F.field t "direction" F.uint32_t + let () = F.seal t + end + + module Multi_gesture_event = struct + type t + let t : t Ctypes_static.structure F.typ = + F.structure "SDL_MultiGestureEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let touch_id = F.field t "touchId" F.int64_t + let dtheta = F.field t "dTheta" F.float + let ddist = F.field t "dDist" F.float + let x = F.field t "x" F.float + let y = F.field t "y" F.float + let num_fingers = F.field t "numFingers" F.uint16_t + let _ = F.field t "padding" F.uint16_t + let () = F.seal t + end + + module Sensor_event = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_SensorEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let which = F.field t "which" F.uint32_t + let data = F.field t "data" F.(array 6 float) + let () = F.seal t + end + + module Quit_event = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_QuitEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let () = F.seal t + end + + module Sys_wm_event = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_SysWMEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let _ = F.field t "msg" F.(ptr void) + let () = F.seal t + end + + module Text_editing_event = struct + type t + let t : t Ctypes_static.structure F.typ = + F.structure "SDL_TextEditingEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let window_id = F.field t "windowID" F.uint32_t + let text = F.field t "text" F.(array 32 char (* FIXME *)) + let start = F.field t "start" F.int32_t + let length = F.field t "length" F.int32_t + let () = F.seal t + end + + module Text_input_event = struct + type t + let t : t Ctypes_static.structure F.typ = + F.structure "SDL_TextInputEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let window_id = F.field t "windowID" F.uint32_t + let text = F.field t "text" F.(array 32 char (* FIXME *)) + let () = F.seal t + end + + module Touch_finger_event = struct + type t + let t : t Ctypes_static.structure F.typ = + F.structure "SDL_TouchFingerEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let touch_id = F.field t "touchId" F.int64_t + let finger_id = F.field t "fingerId" F.int64_t + let x = F.field t "x" F.float + let y = F.field t "y" F.float + let dx = F.field t "dx" F.float + let dy = F.field t "dy" F.float + let pressure = F.field t "pressure" F.float + let () = F.seal t + end + + module User_event = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_UserEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let window_id = F.field t "windowID" F.uint32_t + let code = F.field t "code" F.int32_t + let _ = F.field t "data1" F.(ptr void) + let _ = F.field t "data2" F.(ptr void) + let () = F.seal t + end + + module Window_event = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_WindowEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let window_id = F.field t "windowID" F.uint32_t + let event = F.field t "event" F.uint8_t + let _padding1 = F.field t "padding1" F.uint8_t + let _padding2 = F.field t "padding2" F.uint8_t + let _padding3 = F.field t "padding3" F.uint8_t + let data1 = F.field t "data1" F.int32_t + let data2 = F.field t "data2" F.int32_t + let () = F.seal t + end + + module Display_event = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_DisplayEvent" + let _ = F.field t "type" F.uint32_t + let _ = F.field t "timestamp" F.uint32_t + let display = F.field t "display" F.uint32_t + let event = F.field t "event" F.uint8_t + let _padding1 = F.field t "padding1" F.uint8_t + let _padding2 = F.field t "padding2" F.uint8_t + let _padding3 = F.field t "padding3" F.uint8_t + let data1 = F.field t "data1" F.int32_t + let () = F.seal t + end + + module Audio_device_event = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_AudioDeviceEvent" + let _ = F.field t "type" F.uint32_t + let timestamp = F.field t "timestamp" F.uint32_t + let which = F.field t "which" F.uint32_t + let iscapture = F.field t "iscapture" F.uint8_t + let () = F.seal t + end + + type t + let t : t Ctypes_static.union F.typ = F.union "SDL_Event" + let _typ = F.field t "type" F.uint32_t + let audio_device_event = F.field t "adevice" Audio_device_event.t + let common = F.field t "common" Common.t + let controller_axis_event = F.field t "caxis" Controller_axis_event.t + let controller_button_event = F.field t "cbutton" Controller_button_event.t + let controller_device_event = F.field t "cdevice" Controller_device_event.t + let dollar_gesture_event = F.field t "dgesture" Dollar_gesture_event.t + let drop_event = F.field t "drop" Drop_event.t + let joy_axis_event = F.field t "jaxis" Joy_axis_event.t + let joy_ball_event = F.field t "jball" Joy_ball_event.t + let joy_button_event = F.field t "jbutton" Joy_button_event.t + let joy_device_event = F.field t "jdevice" Joy_device_event.t + let joy_hat_event = F.field t "jhat" Joy_hat_event.t + let keyboard_event = F.field t "key" Keyboard_event.t + let mouse_button_event = F.field t "button" Mouse_button_event.t + let mouse_motion_event = F.field t "motion" Mouse_motion_event.t + let mouse_wheel_event = F.field t "wheel" Mouse_wheel_event.t + let multi_gesture_event = F.field t "mgesture" Multi_gesture_event.t + let _quit_event = F.field t "quit" Quit_event.t + let _sys_wm_event = F.field t "syswm" Sys_wm_event.t + let text_editing_event = F.field t "edit" Text_editing_event.t + let text_input_event = F.field t "text" Text_input_event.t + let touch_finger_event = F.field t "tfinger" Touch_finger_event.t + let _user_event = F.field t "user" User_event.t + let _window_event = F.field t "window" Window_event.t + let _display_event = F.field t "display" Display_event.t + let sensor_event = F.field t "sensor" Sensor_event.t + let _padding = F.field t "padding" F.(ptr uint8_t) + let () = F.seal t + end + + module Haptic = struct + type _t + type t = _t Ctypes_static.structure + let t : t F.typ = F.typedef (F.structure "_SDL_Haptic") "SDL_Haptic" + + let constant = F.constant "SDL_HAPTIC_CONSTANT" F.int + + let sine = F.constant "SDL_HAPTIC_SINE" F.int + let left_right = F.constant "SDL_HAPTIC_LEFTRIGHT" F.int + let triangle = F.constant "SDL_HAPTIC_TRIANGLE" F.int + let sawtooth_up = F.constant "SDL_HAPTIC_SAWTOOTHUP" F.int + let sawtooth_down = F.constant "SDL_HAPTIC_SAWTOOTHDOWN" F.int + + let ramp = F.constant "SDL_HAPTIC_RAMP" F.int + + let spring = F.constant "SDL_HAPTIC_SPRING" F.int + let damper = F.constant "SDL_HAPTIC_DAMPER" F.int + let inertia = F.constant "SDL_HAPTIC_INERTIA" F.int + let friction = F.constant "SDL_HAPTIC_FRICTION" F.int + + let custom = F.constant "SDL_HAPTIC_CUSTOM" F.int + + let infinity = F.constant "SDL_HAPTIC_INFINITY" F.int32_t + + type feature = int + let gain = F.constant "SDL_HAPTIC_GAIN" F.int + let autocenter = F.constant "SDL_HAPTIC_AUTOCENTER" F.int + let status = F.constant "SDL_HAPTIC_STATUS" F.int + let pause = F.constant "SDL_HAPTIC_PAUSE" F.int + + type direction_type = int + let polar = F.constant "SDL_HAPTIC_POLAR" F.int + let cartesian = F.constant "SDL_HAPTIC_CARTESIAN" F.int + let spherical = F.constant "SDL_HAPTIC_SPHERICAL" F.int + + module Direction = struct + type _t + type t = _t Ctypes_static.structure + let t : t F.typ = F.structure "SDL_HapticDirection" + let typ = F.field t "type" F.uint8_t + let dir = F.field t "dir" F.(array 3 int32_t) + let () = F.seal t + end + + (* Effects *) + + module Constant = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_HapticConstant" + let typ = F.field t "type" F.uint16_t + let direction = F.field t "direction" Direction.t + let length = F.field t "length" F.uint32_t + let delay = F.field t "delay" F.uint16_t + let button = F.field t "button" F.uint16_t + let interval = F.field t "interval" F.uint16_t + + let level = F.field t "level" F.int16_t + let attack_length = F.field t "attack_length" F.uint16_t + let attack_level = F.field t "attack_level" F.uint16_t + let fade_length = F.field t "fade_length" F.uint16_t + let fade_level = F.field t "fade_level" F.uint16_t + let () = F.seal t + end + + module Periodic = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_HapticPeriodic" + let typ = F.field t "type" F.uint16_t + let direction = F.field t "direction" Direction.t + let length = F.field t "length" F.uint32_t + let delay = F.field t "delay" F.uint16_t + let button = F.field t "button" F.uint16_t + let interval = F.field t "interval" F.uint16_t + + let period = F.field t "period" F.uint16_t + let magnitude = F.field t "magnitude" F.int16_t + let offset = F.field t "offset" F.int16_t + let phase = F.field t "phase" F.uint16_t + let attack_length = F.field t "attack_length" F.uint16_t + let attack_level = F.field t "attack_level" F.uint16_t + let fade_length = F.field t "fade_length" F.uint16_t + let fade_level = F.field t "fade_level" F.uint16_t + let () = F.seal t + end + + module Condition = struct + type t + let t : t Ctypes_static.structure F.typ = + F.structure "SDL_HapticCondition" + let typ = F.field t "type" F.uint16_t + let direction = F.field t "direction" Direction.t + let length = F.field t "length" F.uint32_t + let delay = F.field t "delay" F.uint16_t + let button = F.field t "button" F.uint16_t + let interval = F.field t "interval" F.uint16_t + + let right_sat_0 = F.field t "right_sat[0]" F.uint16_t + let right_sat_1 = F.field t "right_sat[1]" F.uint16_t + let right_sat_2 = F.field t "right_sat[2]" F.uint16_t + let left_sat_0 = F.field t "left_sat[0]" F.uint16_t + let left_sat_1 = F.field t "left_sat[1]" F.uint16_t + let left_sat_2 = F.field t "left_sat[2]" F.uint16_t + let right_coeff_0 = F.field t "right_coeff[0]" F.int16_t + let right_coeff_1 = F.field t "right_coeff[1]" F.int16_t + let right_coeff_2 = F.field t "right_coeff[2]" F.int16_t + let left_coeff_0 = F.field t "left_coeff[0]" F.int16_t + let left_coeff_1 = F.field t "left_coeff[1]" F.int16_t + let left_coeff_2 = F.field t "left_coeff[2]" F.int16_t + let deadband_0 = F.field t "deadband[0]" F.uint16_t + let deadband_1 = F.field t "deadband[1]" F.uint16_t + let deadband_2 = F.field t "deadband[2]" F.uint16_t + let center_0 = F.field t "center[0]" F.int16_t + let center_1 = F.field t "center[1]" F.int16_t + let center_2 = F.field t "center[2]" F.int16_t + let () = F.seal t + end + + module Ramp = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_HapticRamp" + let typ = F.field t "type" F.uint16_t + let direction = F.field t "direction" Direction.t + let length = F.field t "length" F.uint32_t + let delay = F.field t "delay" F.uint16_t + let button = F.field t "button" F.uint16_t + let interval = F.field t "interval" F.uint16_t + + let start = F.field t "start" F.int16_t + let end_ = F.field t "end" F.int16_t + let attack_length = F.field t "attack_length" F.uint16_t + let attack_level = F.field t "attack_level" F.uint16_t + let fade_length = F.field t "fade_length" F.uint16_t + let fade_level = F.field t "fade_level" F.uint16_t + let () = F.seal t + end + + module Left_right = struct + type t + let t : t Ctypes_static.structure F.typ = + F.structure "SDL_HapticLeftRight" + let typ = F.field t "type" F.uint16_t + let length = F.field t "length" F.uint32_t + + let large_magnitude = F.field t "large_magnitude" F.uint16_t + let small_magnitude = F.field t "small_magnitude" F.uint16_t + let () = F.seal t + end + + module Custom = struct + type t + let t : t Ctypes_static.structure F.typ = F.structure "SDL_HapticCustom" + let typ = F.field t "type" F.uint16_t + let direction = F.field t "direction" Direction.t + let length = F.field t "length" F.uint32_t + let delay = F.field t "delay" F.uint16_t + let button = F.field t "button" F.uint16_t + let interval = F.field t "interval" F.uint16_t + + let channels = F.field t "channels" F.uint8_t + let period = F.field t "period" F.uint16_t + let samples = F.field t "samples" F.uint16_t + let data = F.field t "data" (F.ptr F.uint16_t) + let attack_length = F.field t "attack_length" F.uint16_t + let attack_level = F.field t "attack_level" F.uint16_t + let fade_length = F.field t "fade_length" F.uint16_t + let fade_level = F.field t "fade_level" F.uint16_t + let () = F.seal t + end + + module Effect = struct + type t + let t : t Ctypes_static.union F.typ = F.union "SDL_HapticEffect" + let _typ = F.field t "type" F.uint16_t + let constant = F.field t "constant" Constant.t + let periodic = F.field t "periodic" Periodic.t + let condition = F.field t "condition" Condition.t + let ramp = F.field t "ramp" Ramp.t + let left_right = F.field t "leftright" Left_right.t + let custom = F.field t "custom" Custom.t + let () = F.seal t + end + end + + module Audio = struct + type status = int + let stopped = F.constant "SDL_AUDIO_STOPPED" F.int + let playing = F.constant "SDL_AUDIO_PLAYING" F.int + let paused = F.constant "SDL_AUDIO_PAUSED" F.int + + type format = int + let s8 = F.constant "AUDIO_S8" F.int + let u8 = F.constant "AUDIO_U8" F.int + let s16_lsb = F.constant "AUDIO_S16LSB" F.int + let s16_msb = F.constant "AUDIO_S16MSB" F.int + let s16_sys = F.constant "AUDIO_S16SYS" F.int + let s16 = F.constant "AUDIO_S16" F.int + let u16_lsb = F.constant "AUDIO_U16LSB" F.int + let u16_msb = F.constant "AUDIO_U16MSB" F.int + let u16_sys = F.constant "AUDIO_U16SYS" F.int + let u16 = F.constant "AUDIO_U16" F.int + let s32_lsb = F.constant "AUDIO_S32LSB" F.int + let s32_msb = F.constant "AUDIO_S32MSB" F.int + let s32_sys = F.constant "AUDIO_S32SYS" F.int + let s32 = F.constant "AUDIO_S32" F.int + let f32_lsb = F.constant "AUDIO_F32LSB" F.int + let f32_msb = F.constant "AUDIO_F32MSB" F.int + let f32_sys = F.constant "AUDIO_F32SYS" F.int + let f32 = F.constant "AUDIO_F32" F.int + + type allow = int + let allow_frequency_change = F.constant "SDL_AUDIO_ALLOW_FREQUENCY_CHANGE" F.int + let allow_format_change = F.constant "SDL_AUDIO_ALLOW_FORMAT_CHANGE" F.int + let allow_channels_change = F.constant "SDL_AUDIO_ALLOW_CHANNELS_CHANGE" F.int + let allow_any_change = F.constant "SDL_AUDIO_ALLOW_ANY_CHANGE" F.int + end + + let as_callback_type = + F.(ptr void @-> ptr uint8_t @-> int @-> returning void) + + type _audio_spec + let audio_spec : _audio_spec Ctypes_static.structure F.typ = + F.structure "SDL_AudioSpec" + let as_freq = F.field audio_spec "freq" F.int + let as_format = F.field audio_spec "format" F.uint16_t + let as_channels = F.field audio_spec "channels" F.uint8_t + let as_silence = F.field audio_spec "silence" F.uint8_t + let as_samples = F.field audio_spec "samples" F.uint16_t + let _ = F.field audio_spec "padding" F.uint16_t + let as_size = F.field audio_spec "size" F.uint32_t + let as_callback = + F.field audio_spec "callback" (F.static_funptr as_callback_type) + let as_userdata = F.field audio_spec "userdata" F.(ptr void) + let () = F.seal audio_spec + + + module Powerstate = struct + let unknown = F.constant "SDL_POWERSTATE_UNKNOWN" F.int + let on_battery = F.constant "SDL_POWERSTATE_ON_BATTERY" F.int + let no_battery = F.constant "SDL_POWERSTATE_NO_BATTERY" F.int + let charging = F.constant "SDL_POWERSTATE_CHARGING" F.int + let charged = F.constant "SDL_POWERSTATE_CHARGED" F.int + end +end diff --git a/support/consts_stub.c b/support/consts_stub.c index 7e49f9b..e661f43 100644 --- a/support/consts_stub.c +++ b/support/consts_stub.c @@ -43,20 +43,6 @@ void consts (FILE *fd) assert(sizeof(int) == 4); - /* Init */ - - int_v (SDL_INIT_TIMER); - int_v (SDL_INIT_AUDIO); - int_v (SDL_INIT_VIDEO); - int_v (SDL_INIT_JOYSTICK); - int_v (SDL_INIT_HAPTIC); - int_v (SDL_INIT_GAMECONTROLLER); - int_v (SDL_INIT_EVENTS); - int_v (SDL_INIT_EVERYTHING); - int_v (SDL_INIT_NOPARACHUTE); - - /* Hint */ - str_v (SDL_HINT_FRAMEBUFFER_ACCELERATION); str_v (SDL_HINT_IDLE_TIMER_DISABLED); str_v (SDL_HINT_MOUSE_FOCUS_CLICKTHROUGH); @@ -67,10 +53,6 @@ void consts (FILE *fd) str_v (SDL_HINT_RENDER_SCALE_QUALITY); str_v (SDL_HINT_RENDER_VSYNC); - int_v (SDL_HINT_DEFAULT); - int_v (SDL_HINT_NORMAL); - int_v (SDL_HINT_OVERRIDE); - str_v (SDL_HINT_NO_SIGNAL_HANDLERS); str_v (SDL_HINT_THREAD_STACK_SIZE); str_v (SDL_HINT_WINDOW_FRAME_USABLE_WHILE_CURSOR_HIDDEN); @@ -81,948 +63,6 @@ void consts (FILE *fd) str_v (SDL_HINT_TOUCH_MOUSE_EVENTS); str_v (SDL_HINT_MOUSE_TOUCH_EVENTS); - /* Log */ - - int_v (SDL_LOG_CATEGORY_APPLICATION); - int_v (SDL_LOG_CATEGORY_ERROR); - int_v (SDL_LOG_CATEGORY_SYSTEM); - int_v (SDL_LOG_CATEGORY_AUDIO); - int_v (SDL_LOG_CATEGORY_VIDEO); - int_v (SDL_LOG_CATEGORY_RENDER); - int_v (SDL_LOG_CATEGORY_INPUT); - int_v (SDL_LOG_CATEGORY_CUSTOM); - - int_v (SDL_LOG_PRIORITY_VERBOSE); - int_v (SDL_LOG_PRIORITY_DEBUG); - int_v (SDL_LOG_PRIORITY_INFO); - int_v (SDL_LOG_PRIORITY_WARN); - int_v (SDL_LOG_PRIORITY_ERROR); - int_v (SDL_LOG_PRIORITY_CRITICAL); - - /* Pixel format */ - - int_v (SDL_BLENDMODE_NONE); - int_v (SDL_BLENDMODE_BLEND); - int_v (SDL_BLENDMODE_ADD); - int_v (SDL_BLENDMODE_MOD); - - int_v (SDL_BLENDOPERATION_ADD); - int_v (SDL_BLENDOPERATION_SUBTRACT); - int_v (SDL_BLENDOPERATION_REV_SUBTRACT); - int_v (SDL_BLENDOPERATION_MAXIMUM); - int_v (SDL_BLENDOPERATION_MINIMUM); - - int_v (SDL_BLENDFACTOR_ZERO); - int_v (SDL_BLENDFACTOR_ONE); - int_v (SDL_BLENDFACTOR_SRC_COLOR); - int_v (SDL_BLENDFACTOR_ONE_MINUS_SRC_COLOR); - int_v (SDL_BLENDFACTOR_SRC_ALPHA); - int_v (SDL_BLENDFACTOR_ONE_MINUS_SRC_ALPHA); - int_v (SDL_BLENDFACTOR_DST_COLOR); - int_v (SDL_BLENDFACTOR_ONE_MINUS_DST_COLOR); - int_v (SDL_BLENDFACTOR_DST_ALPHA); - int_v (SDL_BLENDFACTOR_ONE_MINUS_DST_ALPHA); - - int32_v (SDL_PIXELFORMAT_UNKNOWN); - int32_v (SDL_PIXELFORMAT_INDEX1LSB); - int32_v (SDL_PIXELFORMAT_INDEX1MSB); - int32_v (SDL_PIXELFORMAT_INDEX4LSB); - int32_v (SDL_PIXELFORMAT_INDEX4MSB); - int32_v (SDL_PIXELFORMAT_INDEX8); - int32_v (SDL_PIXELFORMAT_RGB332); - int32_v (SDL_PIXELFORMAT_RGB444); - int32_v (SDL_PIXELFORMAT_RGB555); - int32_v (SDL_PIXELFORMAT_BGR555); - int32_v (SDL_PIXELFORMAT_ARGB4444); - int32_v (SDL_PIXELFORMAT_RGBA4444); - int32_v (SDL_PIXELFORMAT_ABGR4444); - int32_v (SDL_PIXELFORMAT_BGRA4444); - int32_v (SDL_PIXELFORMAT_ARGB1555); - int32_v (SDL_PIXELFORMAT_RGBA5551); - int32_v (SDL_PIXELFORMAT_ABGR1555); - int32_v (SDL_PIXELFORMAT_BGRA5551); - int32_v (SDL_PIXELFORMAT_RGB565); - int32_v (SDL_PIXELFORMAT_BGR565); - int32_v (SDL_PIXELFORMAT_RGB24); - int32_v (SDL_PIXELFORMAT_BGR24); - int32_v (SDL_PIXELFORMAT_RGB888); - int32_v (SDL_PIXELFORMAT_RGBX8888); - int32_v (SDL_PIXELFORMAT_BGR888); - int32_v (SDL_PIXELFORMAT_BGRX8888); - int32_v (SDL_PIXELFORMAT_ARGB8888); - int32_v (SDL_PIXELFORMAT_RGBA8888); - int32_v (SDL_PIXELFORMAT_ABGR8888); - int32_v (SDL_PIXELFORMAT_BGRA8888); - int32_v (SDL_PIXELFORMAT_ARGB2101010); - int32_v (SDL_PIXELFORMAT_YV12); - int32_v (SDL_PIXELFORMAT_IYUV); - int32_v (SDL_PIXELFORMAT_YUY2); - int32_v (SDL_PIXELFORMAT_UYVY); - int32_v (SDL_PIXELFORMAT_YVYU); - - /* Renderer */ - - int_v (SDL_FLIP_NONE); - int_v (SDL_FLIP_HORIZONTAL); - int_v (SDL_FLIP_VERTICAL); - - int_v (SDL_RENDERER_SOFTWARE); - int_v (SDL_RENDERER_ACCELERATED); - int_v (SDL_RENDERER_PRESENTVSYNC); - int_v (SDL_RENDERER_TARGETTEXTURE); - - int_v (SDL_TEXTUREACCESS_STATIC); - int_v (SDL_TEXTUREACCESS_STREAMING); - int_v (SDL_TEXTUREACCESS_TARGET); - - int_v (SDL_TEXTUREMODULATE_NONE); - int_v (SDL_TEXTUREMODULATE_COLOR); - int_v (SDL_TEXTUREMODULATE_ALPHA); - - /* Windows and displays */ - - int_v (SDL_WINDOW_FULLSCREEN); - int_v (SDL_WINDOW_FULLSCREEN_DESKTOP); - int_v (SDL_WINDOW_OPENGL); - int_v (SDL_WINDOW_SHOWN); - int_v (SDL_WINDOW_HIDDEN); - int_v (SDL_WINDOW_BORDERLESS); - int_v (SDL_WINDOW_RESIZABLE); - int_v (SDL_WINDOW_MINIMIZED); - int_v (SDL_WINDOW_MAXIMIZED); - int_v (SDL_WINDOW_INPUT_GRABBED); - int_v (SDL_WINDOW_INPUT_FOCUS); - int_v (SDL_WINDOW_MOUSE_FOCUS); - int_v (SDL_WINDOW_FOREIGN); - int_v (SDL_WINDOW_ALLOW_HIGHDPI); - int_v (SDL_WINDOW_MOUSE_CAPTURE); - int_v (SDL_WINDOW_ALWAYS_ON_TOP); - int_v (SDL_WINDOW_SKIP_TASKBAR); - int_v (SDL_WINDOW_UTILITY); - int_v (SDL_WINDOW_POPUP_MENU); - int_v (SDL_WINDOW_VULKAN); - - int_v (SDL_WINDOWPOS_CENTERED); - int_v (SDL_WINDOWPOS_UNDEFINED); - - /* Hit test */ - int_v (SDL_HITTEST_NORMAL); - int_v (SDL_HITTEST_DRAGGABLE); - int_v (SDL_HITTEST_RESIZE_TOPLEFT); - int_v (SDL_HITTEST_RESIZE_TOP); - int_v (SDL_HITTEST_RESIZE_TOPRIGHT); - int_v (SDL_HITTEST_RESIZE_LEFT); - int_v (SDL_HITTEST_RESIZE_RIGHT); - int_v (SDL_HITTEST_RESIZE_BOTTOMLEFT); - int_v (SDL_HITTEST_RESIZE_BOTTOM); - int_v (SDL_HITTEST_RESIZE_BOTTOMRIGHT); - - /* SDL_GLcontextFlag */ - - int_v (SDL_GL_CONTEXT_DEBUG_FLAG); - int_v (SDL_GL_CONTEXT_FORWARD_COMPATIBLE_FLAG); - int_v (SDL_GL_CONTEXT_ROBUST_ACCESS_FLAG); - int_v (SDL_GL_CONTEXT_RESET_ISOLATION_FLAG); - int_v (SDL_GL_CONTEXT_RELEASE_BEHAVIOR); - - /* SDL_GLprofile */ - - int_v (SDL_GL_CONTEXT_PROFILE_CORE); - int_v (SDL_GL_CONTEXT_PROFILE_COMPATIBILITY); - int_v (SDL_GL_CONTEXT_PROFILE_ES); - - /* SDL_GLattr */ - - int_v (SDL_GL_RED_SIZE); - int_v (SDL_GL_GREEN_SIZE); - int_v (SDL_GL_BLUE_SIZE); - int_v (SDL_GL_ALPHA_SIZE); - int_v (SDL_GL_BUFFER_SIZE); - int_v (SDL_GL_DOUBLEBUFFER); - int_v (SDL_GL_DEPTH_SIZE); - int_v (SDL_GL_STENCIL_SIZE); - int_v (SDL_GL_ACCUM_RED_SIZE); - int_v (SDL_GL_ACCUM_GREEN_SIZE); - int_v (SDL_GL_ACCUM_BLUE_SIZE); - int_v (SDL_GL_ACCUM_ALPHA_SIZE); - int_v (SDL_GL_STEREO); - int_v (SDL_GL_MULTISAMPLEBUFFERS); - int_v (SDL_GL_MULTISAMPLESAMPLES); - int_v (SDL_GL_ACCELERATED_VISUAL); - int_v (SDL_GL_CONTEXT_MAJOR_VERSION); - int_v (SDL_GL_CONTEXT_MINOR_VERSION); - int_v (SDL_GL_CONTEXT_EGL); - int_v (SDL_GL_CONTEXT_FLAGS); - int_v (SDL_GL_CONTEXT_PROFILE_MASK); - int_v (SDL_GL_SHARE_WITH_CURRENT_CONTEXT); - int_v (SDL_GL_FRAMEBUFFER_SRGB_CAPABLE); - - /* Message box */ - - int_v (SDL_MESSAGEBOX_ERROR); - int_v (SDL_MESSAGEBOX_WARNING); - int_v (SDL_MESSAGEBOX_INFORMATION); - - int_v (SDL_MESSAGEBOX_BUTTON_RETURNKEY_DEFAULT); - int_v (SDL_MESSAGEBOX_BUTTON_ESCAPEKEY_DEFAULT); - - int_v (SDL_MESSAGEBOX_COLOR_BACKGROUND); - int_v (SDL_MESSAGEBOX_COLOR_TEXT); - int_v (SDL_MESSAGEBOX_COLOR_BUTTON_BORDER); - int_v (SDL_MESSAGEBOX_COLOR_BUTTON_BACKGROUND); - int_v (SDL_MESSAGEBOX_COLOR_BUTTON_SELECTED); - int_v (SDL_MESSAGEBOX_COLOR_MAX); - - /* Keyboard */ - - assert(sizeof (SDL_Keycode) == 4); - assert(sizeof (SDL_Scancode) == 4); - - int_v (SDL_SCANCODE_UNKNOWN); - int_v (SDL_SCANCODE_A); - int_v (SDL_SCANCODE_B); - int_v (SDL_SCANCODE_C); - int_v (SDL_SCANCODE_D); - int_v (SDL_SCANCODE_E); - int_v (SDL_SCANCODE_F); - int_v (SDL_SCANCODE_G); - int_v (SDL_SCANCODE_H); - int_v (SDL_SCANCODE_I); - int_v (SDL_SCANCODE_J); - int_v (SDL_SCANCODE_K); - int_v (SDL_SCANCODE_L); - int_v (SDL_SCANCODE_M); - int_v (SDL_SCANCODE_N); - int_v (SDL_SCANCODE_O); - int_v (SDL_SCANCODE_P); - int_v (SDL_SCANCODE_Q); - int_v (SDL_SCANCODE_R); - int_v (SDL_SCANCODE_S); - int_v (SDL_SCANCODE_T); - int_v (SDL_SCANCODE_U); - int_v (SDL_SCANCODE_V); - int_v (SDL_SCANCODE_W); - int_v (SDL_SCANCODE_X); - int_v (SDL_SCANCODE_Y); - int_v (SDL_SCANCODE_Z); - int_v (SDL_SCANCODE_1); - int_v (SDL_SCANCODE_2); - int_v (SDL_SCANCODE_3); - int_v (SDL_SCANCODE_4); - int_v (SDL_SCANCODE_5); - int_v (SDL_SCANCODE_6); - int_v (SDL_SCANCODE_7); - int_v (SDL_SCANCODE_8); - int_v (SDL_SCANCODE_9); - int_v (SDL_SCANCODE_0); - int_v (SDL_SCANCODE_RETURN); - int_v (SDL_SCANCODE_ESCAPE); - int_v (SDL_SCANCODE_BACKSPACE); - int_v (SDL_SCANCODE_TAB); - int_v (SDL_SCANCODE_SPACE); - int_v (SDL_SCANCODE_MINUS); - int_v (SDL_SCANCODE_EQUALS); - int_v (SDL_SCANCODE_LEFTBRACKET); - int_v (SDL_SCANCODE_RIGHTBRACKET); - int_v (SDL_SCANCODE_BACKSLASH); - int_v (SDL_SCANCODE_NONUSHASH); - int_v (SDL_SCANCODE_SEMICOLON); - int_v (SDL_SCANCODE_APOSTROPHE); - int_v (SDL_SCANCODE_GRAVE); - int_v (SDL_SCANCODE_COMMA); - int_v (SDL_SCANCODE_PERIOD); - int_v (SDL_SCANCODE_SLASH); - int_v (SDL_SCANCODE_CAPSLOCK); - int_v (SDL_SCANCODE_F1); - int_v (SDL_SCANCODE_F2); - int_v (SDL_SCANCODE_F3); - int_v (SDL_SCANCODE_F4); - int_v (SDL_SCANCODE_F5); - int_v (SDL_SCANCODE_F6); - int_v (SDL_SCANCODE_F7); - int_v (SDL_SCANCODE_F8); - int_v (SDL_SCANCODE_F9); - int_v (SDL_SCANCODE_F10); - int_v (SDL_SCANCODE_F11); - int_v (SDL_SCANCODE_F12); - int_v (SDL_SCANCODE_PRINTSCREEN); - int_v (SDL_SCANCODE_SCROLLLOCK); - int_v (SDL_SCANCODE_PAUSE); - int_v (SDL_SCANCODE_INSERT); - int_v (SDL_SCANCODE_HOME); - int_v (SDL_SCANCODE_PAGEUP); - int_v (SDL_SCANCODE_DELETE); - int_v (SDL_SCANCODE_END); - int_v (SDL_SCANCODE_PAGEDOWN); - int_v (SDL_SCANCODE_RIGHT); - int_v (SDL_SCANCODE_LEFT); - int_v (SDL_SCANCODE_DOWN); - int_v (SDL_SCANCODE_UP); - int_v (SDL_SCANCODE_NUMLOCKCLEAR); - int_v (SDL_SCANCODE_KP_DIVIDE); - int_v (SDL_SCANCODE_KP_MULTIPLY); - int_v (SDL_SCANCODE_KP_MINUS); - int_v (SDL_SCANCODE_KP_PLUS); - int_v (SDL_SCANCODE_KP_ENTER); - int_v (SDL_SCANCODE_KP_1); - int_v (SDL_SCANCODE_KP_2); - int_v (SDL_SCANCODE_KP_3); - int_v (SDL_SCANCODE_KP_4); - int_v (SDL_SCANCODE_KP_5); - int_v (SDL_SCANCODE_KP_6); - int_v (SDL_SCANCODE_KP_7); - int_v (SDL_SCANCODE_KP_8); - int_v (SDL_SCANCODE_KP_9); - int_v (SDL_SCANCODE_KP_0); - int_v (SDL_SCANCODE_KP_PERIOD); - int_v (SDL_SCANCODE_NONUSBACKSLASH); - int_v (SDL_SCANCODE_APPLICATION); - int_v (SDL_SCANCODE_KP_EQUALS); - int_v (SDL_SCANCODE_F13); - int_v (SDL_SCANCODE_F14); - int_v (SDL_SCANCODE_F15); - int_v (SDL_SCANCODE_F16); - int_v (SDL_SCANCODE_F17); - int_v (SDL_SCANCODE_F18); - int_v (SDL_SCANCODE_F19); - int_v (SDL_SCANCODE_F20); - int_v (SDL_SCANCODE_F21); - int_v (SDL_SCANCODE_F22); - int_v (SDL_SCANCODE_F23); - int_v (SDL_SCANCODE_F24); - int_v (SDL_SCANCODE_EXECUTE); - int_v (SDL_SCANCODE_HELP); - int_v (SDL_SCANCODE_MENU); - int_v (SDL_SCANCODE_SELECT); - int_v (SDL_SCANCODE_STOP); - int_v (SDL_SCANCODE_AGAIN); - int_v (SDL_SCANCODE_UNDO); - int_v (SDL_SCANCODE_CUT); - int_v (SDL_SCANCODE_COPY); - int_v (SDL_SCANCODE_PASTE); - int_v (SDL_SCANCODE_FIND); - int_v (SDL_SCANCODE_MUTE); - int_v (SDL_SCANCODE_VOLUMEUP); - int_v (SDL_SCANCODE_VOLUMEDOWN); - int_v (SDL_SCANCODE_KP_COMMA); - int_v (SDL_SCANCODE_KP_EQUALSAS400); - int_v (SDL_SCANCODE_INTERNATIONAL1); - int_v (SDL_SCANCODE_INTERNATIONAL2); - int_v (SDL_SCANCODE_INTERNATIONAL3); - int_v (SDL_SCANCODE_INTERNATIONAL4); - int_v (SDL_SCANCODE_INTERNATIONAL5); - int_v (SDL_SCANCODE_INTERNATIONAL6); - int_v (SDL_SCANCODE_INTERNATIONAL7); - int_v (SDL_SCANCODE_INTERNATIONAL8); - int_v (SDL_SCANCODE_INTERNATIONAL9); - int_v (SDL_SCANCODE_LANG1); - int_v (SDL_SCANCODE_LANG2); - int_v (SDL_SCANCODE_LANG3); - int_v (SDL_SCANCODE_LANG4); - int_v (SDL_SCANCODE_LANG5); - int_v (SDL_SCANCODE_LANG6); - int_v (SDL_SCANCODE_LANG7); - int_v (SDL_SCANCODE_LANG8); - int_v (SDL_SCANCODE_LANG9); - int_v (SDL_SCANCODE_ALTERASE); - int_v (SDL_SCANCODE_SYSREQ); - int_v (SDL_SCANCODE_CANCEL); - int_v (SDL_SCANCODE_CLEAR); - int_v (SDL_SCANCODE_PRIOR); - int_v (SDL_SCANCODE_RETURN2); - int_v (SDL_SCANCODE_SEPARATOR); - int_v (SDL_SCANCODE_OUT); - int_v (SDL_SCANCODE_OPER); - int_v (SDL_SCANCODE_CLEARAGAIN); - int_v (SDL_SCANCODE_CRSEL); - int_v (SDL_SCANCODE_EXSEL); - int_v (SDL_SCANCODE_KP_00); - int_v (SDL_SCANCODE_KP_000); - int_v (SDL_SCANCODE_THOUSANDSSEPARATOR); - int_v (SDL_SCANCODE_DECIMALSEPARATOR); - int_v (SDL_SCANCODE_CURRENCYUNIT); - int_v (SDL_SCANCODE_CURRENCYSUBUNIT); - int_v (SDL_SCANCODE_KP_LEFTPAREN); - int_v (SDL_SCANCODE_KP_RIGHTPAREN); - int_v (SDL_SCANCODE_KP_LEFTBRACE); - int_v (SDL_SCANCODE_KP_RIGHTBRACE); - int_v (SDL_SCANCODE_KP_TAB); - int_v (SDL_SCANCODE_KP_BACKSPACE); - int_v (SDL_SCANCODE_KP_A); - int_v (SDL_SCANCODE_KP_B); - int_v (SDL_SCANCODE_KP_C); - int_v (SDL_SCANCODE_KP_D); - int_v (SDL_SCANCODE_KP_E); - int_v (SDL_SCANCODE_KP_F); - int_v (SDL_SCANCODE_KP_XOR); - int_v (SDL_SCANCODE_KP_POWER); - int_v (SDL_SCANCODE_KP_PERCENT); - int_v (SDL_SCANCODE_KP_LESS); - int_v (SDL_SCANCODE_KP_GREATER); - int_v (SDL_SCANCODE_KP_AMPERSAND); - int_v (SDL_SCANCODE_KP_DBLAMPERSAND); - int_v (SDL_SCANCODE_KP_VERTICALBAR); - int_v (SDL_SCANCODE_KP_DBLVERTICALBAR); - int_v (SDL_SCANCODE_KP_COLON); - int_v (SDL_SCANCODE_KP_HASH); - int_v (SDL_SCANCODE_KP_SPACE); - int_v (SDL_SCANCODE_KP_AT); - int_v (SDL_SCANCODE_KP_EXCLAM); - int_v (SDL_SCANCODE_KP_MEMSTORE); - int_v (SDL_SCANCODE_KP_MEMRECALL); - int_v (SDL_SCANCODE_KP_MEMCLEAR); - int_v (SDL_SCANCODE_KP_MEMADD); - int_v (SDL_SCANCODE_KP_MEMSUBTRACT); - int_v (SDL_SCANCODE_KP_MEMMULTIPLY); - int_v (SDL_SCANCODE_KP_MEMDIVIDE); - int_v (SDL_SCANCODE_KP_PLUSMINUS); - int_v (SDL_SCANCODE_KP_CLEAR); - int_v (SDL_SCANCODE_KP_CLEARENTRY); - int_v (SDL_SCANCODE_KP_BINARY); - int_v (SDL_SCANCODE_KP_OCTAL); - int_v (SDL_SCANCODE_KP_DECIMAL); - int_v (SDL_SCANCODE_KP_HEXADECIMAL); - int_v (SDL_SCANCODE_LCTRL); - int_v (SDL_SCANCODE_LSHIFT); - int_v (SDL_SCANCODE_LALT); - int_v (SDL_SCANCODE_LGUI); - int_v (SDL_SCANCODE_RCTRL); - int_v (SDL_SCANCODE_RSHIFT); - int_v (SDL_SCANCODE_RALT); - int_v (SDL_SCANCODE_RGUI); - int_v (SDL_SCANCODE_MODE); - int_v (SDL_SCANCODE_AUDIONEXT); - int_v (SDL_SCANCODE_AUDIOPREV); - int_v (SDL_SCANCODE_AUDIOSTOP); - int_v (SDL_SCANCODE_AUDIOPLAY); - int_v (SDL_SCANCODE_AUDIOMUTE); - int_v (SDL_SCANCODE_MEDIASELECT); - int_v (SDL_SCANCODE_WWW); - int_v (SDL_SCANCODE_MAIL); - int_v (SDL_SCANCODE_CALCULATOR); - int_v (SDL_SCANCODE_COMPUTER); - int_v (SDL_SCANCODE_AC_SEARCH); - int_v (SDL_SCANCODE_AC_HOME); - int_v (SDL_SCANCODE_AC_BACK); - int_v (SDL_SCANCODE_AC_FORWARD); - int_v (SDL_SCANCODE_AC_STOP); - int_v (SDL_SCANCODE_AC_REFRESH); - int_v (SDL_SCANCODE_AC_BOOKMARKS); - int_v (SDL_SCANCODE_BRIGHTNESSDOWN); - int_v (SDL_SCANCODE_BRIGHTNESSUP); - int_v (SDL_SCANCODE_DISPLAYSWITCH); - int_v (SDL_SCANCODE_KBDILLUMTOGGLE); - int_v (SDL_SCANCODE_KBDILLUMDOWN); - int_v (SDL_SCANCODE_KBDILLUMUP); - int_v (SDL_SCANCODE_EJECT); - int_v (SDL_SCANCODE_SLEEP); - int_v (SDL_SCANCODE_APP1); - int_v (SDL_SCANCODE_APP2); - int_v (SDL_NUM_SCANCODES); - - int_vx (SDLK_SCANCODE_MASK); - int_vx (SDLK_UNKNOWN); - int_vx (SDLK_RETURN); - int_vx (SDLK_ESCAPE); - int_vx (SDLK_BACKSPACE); - int_vx (SDLK_TAB); - int_vx (SDLK_SPACE); - int_vx (SDLK_EXCLAIM); - int_vx (SDLK_QUOTEDBL); - int_vx (SDLK_HASH); - int_vx (SDLK_PERCENT); - int_vx (SDLK_DOLLAR); - int_vx (SDLK_AMPERSAND); - int_vx (SDLK_QUOTE); - int_vx (SDLK_LEFTPAREN); - int_vx (SDLK_RIGHTPAREN); - int_vx (SDLK_ASTERISK); - int_vx (SDLK_PLUS); - int_vx (SDLK_COMMA); - int_vx (SDLK_MINUS); - int_vx (SDLK_PERIOD); - int_vx (SDLK_SLASH); - int_vx (SDLK_0); - int_vx (SDLK_1); - int_vx (SDLK_2); - int_vx (SDLK_3); - int_vx (SDLK_4); - int_vx (SDLK_5); - int_vx (SDLK_6); - int_vx (SDLK_7); - int_vx (SDLK_8); - int_vx (SDLK_9); - int_vx (SDLK_COLON); - int_vx (SDLK_SEMICOLON); - int_vx (SDLK_LESS); - int_vx (SDLK_EQUALS); - int_vx (SDLK_GREATER); - int_vx (SDLK_QUESTION); - int_vx (SDLK_AT); - int_vx (SDLK_LEFTBRACKET); - int_vx (SDLK_BACKSLASH); - int_vx (SDLK_RIGHTBRACKET); - int_vx (SDLK_CARET); - int_vx (SDLK_UNDERSCORE); - int_vx (SDLK_BACKQUOTE); - int_vx (SDLK_a); - int_vx (SDLK_b); - int_vx (SDLK_c); - int_vx (SDLK_d); - int_vx (SDLK_e); - int_vx (SDLK_f); - int_vx (SDLK_g); - int_vx (SDLK_h); - int_vx (SDLK_i); - int_vx (SDLK_j); - int_vx (SDLK_k); - int_vx (SDLK_l); - int_vx (SDLK_m); - int_vx (SDLK_n); - int_vx (SDLK_o); - int_vx (SDLK_p); - int_vx (SDLK_q); - int_vx (SDLK_r); - int_vx (SDLK_s); - int_vx (SDLK_t); - int_vx (SDLK_u); - int_vx (SDLK_v); - int_vx (SDLK_w); - int_vx (SDLK_x); - int_vx (SDLK_y); - int_vx (SDLK_z); - int_vx (SDLK_CAPSLOCK); - int_vx (SDLK_F1); - int_vx (SDLK_F2); - int_vx (SDLK_F3); - int_vx (SDLK_F4); - int_vx (SDLK_F5); - int_vx (SDLK_F6); - int_vx (SDLK_F7); - int_vx (SDLK_F8); - int_vx (SDLK_F9); - int_vx (SDLK_F10); - int_vx (SDLK_F11); - int_vx (SDLK_F12); - int_vx (SDLK_PRINTSCREEN); - int_vx (SDLK_SCROLLLOCK); - int_vx (SDLK_PAUSE); - int_vx (SDLK_INSERT); - int_vx (SDLK_HOME); - int_vx (SDLK_PAGEUP); - int_vx (SDLK_DELETE); - int_vx (SDLK_END); - int_vx (SDLK_PAGEDOWN); - int_vx (SDLK_RIGHT); - int_vx (SDLK_LEFT); - int_vx (SDLK_DOWN); - int_vx (SDLK_UP); - int_vx (SDLK_NUMLOCKCLEAR); - int_vx (SDLK_KP_DIVIDE); - int_vx (SDLK_KP_MULTIPLY); - int_vx (SDLK_KP_MINUS); - int_vx (SDLK_KP_PLUS); - int_vx (SDLK_KP_ENTER); - int_vx (SDLK_KP_1); - int_vx (SDLK_KP_2); - int_vx (SDLK_KP_3); - int_vx (SDLK_KP_4); - int_vx (SDLK_KP_5); - int_vx (SDLK_KP_6); - int_vx (SDLK_KP_7); - int_vx (SDLK_KP_8); - int_vx (SDLK_KP_9); - int_vx (SDLK_KP_0); - int_vx (SDLK_KP_PERIOD); - int_vx (SDLK_APPLICATION); - int_vx (SDLK_POWER); - int_vx (SDLK_KP_EQUALS); - int_vx (SDLK_F13); - int_vx (SDLK_F14); - int_vx (SDLK_F15); - int_vx (SDLK_F16); - int_vx (SDLK_F17); - int_vx (SDLK_F18); - int_vx (SDLK_F19); - int_vx (SDLK_F20); - int_vx (SDLK_F21); - int_vx (SDLK_F22); - int_vx (SDLK_F23); - int_vx (SDLK_F24); - int_vx (SDLK_EXECUTE); - int_vx (SDLK_HELP); - int_vx (SDLK_MENU); - int_vx (SDLK_SELECT); - int_vx (SDLK_STOP); - int_vx (SDLK_AGAIN); - int_vx (SDLK_UNDO); - int_vx (SDLK_CUT); - int_vx (SDLK_COPY); - int_vx (SDLK_PASTE); - int_vx (SDLK_FIND); - int_vx (SDLK_MUTE); - int_vx (SDLK_VOLUMEUP); - int_vx (SDLK_VOLUMEDOWN); - int_vx (SDLK_KP_COMMA); - int_vx (SDLK_KP_EQUALSAS400); - int_vx (SDLK_ALTERASE); - int_vx (SDLK_SYSREQ); - int_vx (SDLK_CANCEL); - int_vx (SDLK_CLEAR); - int_vx (SDLK_PRIOR); - int_vx (SDLK_RETURN2); - int_vx (SDLK_SEPARATOR); - int_vx (SDLK_OUT); - int_vx (SDLK_OPER); - int_vx (SDLK_CLEARAGAIN); - int_vx (SDLK_CRSEL); - int_vx (SDLK_EXSEL); - int_vx (SDLK_KP_00); - int_vx (SDLK_KP_000); - int_vx (SDLK_THOUSANDSSEPARATOR); - int_vx (SDLK_DECIMALSEPARATOR); - int_vx (SDLK_CURRENCYUNIT); - int_vx (SDLK_CURRENCYSUBUNIT); - int_vx (SDLK_KP_LEFTPAREN); - int_vx (SDLK_KP_RIGHTPAREN); - int_vx (SDLK_KP_LEFTBRACE); - int_vx (SDLK_KP_RIGHTBRACE); - int_vx (SDLK_KP_TAB); - int_vx (SDLK_KP_BACKSPACE); - int_vx (SDLK_KP_A); - int_vx (SDLK_KP_B); - int_vx (SDLK_KP_C); - int_vx (SDLK_KP_D); - int_vx (SDLK_KP_E); - int_vx (SDLK_KP_F); - int_vx (SDLK_KP_XOR); - int_vx (SDLK_KP_POWER); - int_vx (SDLK_KP_PERCENT); - int_vx (SDLK_KP_LESS); - int_vx (SDLK_KP_GREATER); - int_vx (SDLK_KP_AMPERSAND); - int_vx (SDLK_KP_DBLAMPERSAND); - int_vx (SDLK_KP_VERTICALBAR); - int_vx (SDLK_KP_DBLVERTICALBAR); - int_vx (SDLK_KP_COLON); - int_vx (SDLK_KP_HASH); - int_vx (SDLK_KP_SPACE); - int_vx (SDLK_KP_AT); - int_vx (SDLK_KP_EXCLAM); - int_vx (SDLK_KP_MEMSTORE); - int_vx (SDLK_KP_MEMRECALL); - int_vx (SDLK_KP_MEMCLEAR); - int_vx (SDLK_KP_MEMADD); - int_vx (SDLK_KP_MEMSUBTRACT); - int_vx (SDLK_KP_MEMMULTIPLY); - int_vx (SDLK_KP_MEMDIVIDE); - int_vx (SDLK_KP_PLUSMINUS); - int_vx (SDLK_KP_CLEAR); - int_vx (SDLK_KP_CLEARENTRY); - int_vx (SDLK_KP_BINARY); - int_vx (SDLK_KP_OCTAL); - int_vx (SDLK_KP_DECIMAL); - int_vx (SDLK_KP_HEXADECIMAL); - int_vx (SDLK_LCTRL); - int_vx (SDLK_LSHIFT); - int_vx (SDLK_LALT); - int_vx (SDLK_LGUI); - int_vx (SDLK_RCTRL); - int_vx (SDLK_RSHIFT); - int_vx (SDLK_RALT); - int_vx (SDLK_RGUI); - int_vx (SDLK_MODE); - int_vx (SDLK_AUDIONEXT); - int_vx (SDLK_AUDIOPREV); - int_vx (SDLK_AUDIOSTOP); - int_vx (SDLK_AUDIOPLAY); - int_vx (SDLK_AUDIOMUTE); - int_vx (SDLK_MEDIASELECT); - int_vx (SDLK_WWW); - int_vx (SDLK_MAIL); - int_vx (SDLK_CALCULATOR); - int_vx (SDLK_COMPUTER); - int_vx (SDLK_AC_SEARCH); - int_vx (SDLK_AC_HOME); - int_vx (SDLK_AC_BACK); - int_vx (SDLK_AC_FORWARD); - int_vx (SDLK_AC_STOP); - int_vx (SDLK_AC_REFRESH); - int_vx (SDLK_AC_BOOKMARKS); - int_vx (SDLK_BRIGHTNESSDOWN); - int_vx (SDLK_BRIGHTNESSUP); - int_vx (SDLK_DISPLAYSWITCH); - int_vx (SDLK_KBDILLUMTOGGLE); - int_vx (SDLK_KBDILLUMDOWN); - int_vx (SDLK_KBDILLUMUP); - int_vx (SDLK_EJECT); - int_vx (SDLK_SLEEP); - - int_vx (KMOD_NONE); - int_vx (KMOD_LSHIFT); - int_vx (KMOD_RSHIFT); - int_vx (KMOD_LCTRL); - int_vx (KMOD_RCTRL); - int_vx (KMOD_LALT); - int_vx (KMOD_RALT); - int_vx (KMOD_LGUI); - int_vx (KMOD_RGUI); - int_vx (KMOD_NUM); - int_vx (KMOD_CAPS); - int_vx (KMOD_MODE); - int_vx (KMOD_RESERVED); - int_vx (KMOD_CTRL); - int_vx (KMOD_SHIFT); - int_vx (KMOD_ALT); - int_vx (KMOD_GUI); - - /* Mouse */ - - int_v (SDL_SYSTEM_CURSOR_ARROW); - int_v (SDL_SYSTEM_CURSOR_IBEAM); - int_v (SDL_SYSTEM_CURSOR_WAIT); - int_v (SDL_SYSTEM_CURSOR_CROSSHAIR); - int_v (SDL_SYSTEM_CURSOR_WAITARROW); - int_v (SDL_SYSTEM_CURSOR_SIZENWSE); - int_v (SDL_SYSTEM_CURSOR_SIZENESW); - int_v (SDL_SYSTEM_CURSOR_SIZEWE); - int_v (SDL_SYSTEM_CURSOR_SIZENS); - int_v (SDL_SYSTEM_CURSOR_SIZEALL); - int_v (SDL_SYSTEM_CURSOR_NO); - int_v (SDL_SYSTEM_CURSOR_HAND); - - int_v (SDL_BUTTON_LEFT); - int_v (SDL_BUTTON_MIDDLE); - int_v (SDL_BUTTON_RIGHT); - int_v (SDL_BUTTON_X1); - int_v (SDL_BUTTON_X2); - - int_v (SDL_BUTTON_LMASK); - int_v (SDL_BUTTON_MMASK); - int_v (SDL_BUTTON_RMASK); - int_v (SDL_BUTTON_X1MASK); - int_v (SDL_BUTTON_X2MASK); - - /* Touch */ - - int32_v (SDL_TOUCH_MOUSEID); - - /* Joystick */ - - int_v (SDL_HAT_CENTERED); - int_v (SDL_HAT_UP); - int_v (SDL_HAT_RIGHT); - int_v (SDL_HAT_DOWN); - int_v (SDL_HAT_LEFT); - int_v (SDL_HAT_RIGHTUP); - int_v (SDL_HAT_RIGHTDOWN); - int_v (SDL_HAT_LEFTUP); - int_v (SDL_HAT_LEFTDOWN); - - int_v (SDL_JOYSTICK_POWER_UNKNOWN); - int_v (SDL_JOYSTICK_POWER_LOW); - int_v (SDL_JOYSTICK_POWER_MEDIUM); - int_v (SDL_JOYSTICK_POWER_FULL); - int_v (SDL_JOYSTICK_POWER_MAX); - int_v (SDL_JOYSTICK_POWER_WIRED); - - int_v (SDL_JOYSTICK_TYPE_UNKNOWN); - int_v (SDL_JOYSTICK_TYPE_GAMECONTROLLER); - int_v (SDL_JOYSTICK_TYPE_WHEEL); - int_v (SDL_JOYSTICK_TYPE_ARCADE_STICK); - int_v (SDL_JOYSTICK_TYPE_FLIGHT_STICK); - int_v (SDL_JOYSTICK_TYPE_DANCE_PAD); - int_v (SDL_JOYSTICK_TYPE_GUITAR); - int_v (SDL_JOYSTICK_TYPE_DRUM_KIT); - int_v (SDL_JOYSTICK_TYPE_ARCADE_PAD); - int_v (SDL_JOYSTICK_TYPE_THROTTLE); - /* Game controller */ - - int_v (SDL_CONTROLLER_BINDTYPE_NONE); - int_v (SDL_CONTROLLER_BINDTYPE_BUTTON); - int_v (SDL_CONTROLLER_BINDTYPE_AXIS); - int_v (SDL_CONTROLLER_BINDTYPE_HAT); - - int_v (SDL_CONTROLLER_AXIS_INVALID); - int_v (SDL_CONTROLLER_AXIS_LEFTX); - int_v (SDL_CONTROLLER_AXIS_LEFTY); - int_v (SDL_CONTROLLER_AXIS_RIGHTX); - int_v (SDL_CONTROLLER_AXIS_RIGHTY); - int_v (SDL_CONTROLLER_AXIS_TRIGGERLEFT); - int_v (SDL_CONTROLLER_AXIS_TRIGGERRIGHT); - int_v (SDL_CONTROLLER_AXIS_MAX); - - int_v (SDL_CONTROLLER_BUTTON_INVALID); - int_v (SDL_CONTROLLER_BUTTON_A); - int_v (SDL_CONTROLLER_BUTTON_B); - int_v (SDL_CONTROLLER_BUTTON_X); - int_v (SDL_CONTROLLER_BUTTON_Y); - int_v (SDL_CONTROLLER_BUTTON_BACK); - int_v (SDL_CONTROLLER_BUTTON_GUIDE); - int_v (SDL_CONTROLLER_BUTTON_START); - int_v (SDL_CONTROLLER_BUTTON_LEFTSTICK); - int_v (SDL_CONTROLLER_BUTTON_RIGHTSTICK); - int_v (SDL_CONTROLLER_BUTTON_LEFTSHOULDER); - int_v (SDL_CONTROLLER_BUTTON_RIGHTSHOULDER); - int_v (SDL_CONTROLLER_BUTTON_DPAD_UP); - int_v (SDL_CONTROLLER_BUTTON_DPAD_DOWN); - int_v (SDL_CONTROLLER_BUTTON_DPAD_LEFT); - int_v (SDL_CONTROLLER_BUTTON_DPAD_RIGHT); - int_v (SDL_CONTROLLER_BUTTON_MAX); - - assert (sizeof(SDL_GameControllerButtonBind) == 12); - - /* Event */ - - int_v (SDL_QUERY); - int_v (SDL_DISABLE); - int_v (SDL_ENABLE); - int_v (SDL_PRESSED); - int_v (SDL_RELEASED); - - int_v (SDL_FIRSTEVENT); - int_v (SDL_QUIT); - int_v (SDL_APP_TERMINATING); - int_v (SDL_APP_LOWMEMORY); - int_v (SDL_APP_WILLENTERBACKGROUND); - int_v (SDL_APP_DIDENTERBACKGROUND); - int_v (SDL_APP_WILLENTERFOREGROUND); - int_v (SDL_APP_DIDENTERFOREGROUND); - int_v (SDL_DISPLAYEVENT); - int_v (SDL_WINDOWEVENT); - int_v (SDL_SYSWMEVENT); - int_v (SDL_KEYDOWN); - int_v (SDL_KEYUP); - int_v (SDL_TEXTEDITING); - int_v (SDL_TEXTINPUT); - int_v (SDL_KEYMAPCHANGED); - int_v (SDL_MOUSEMOTION); - int_v (SDL_MOUSEBUTTONDOWN); - int_v (SDL_MOUSEBUTTONUP); - int_v (SDL_MOUSEWHEEL); - int_v (SDL_MOUSEWHEEL_NORMAL); - int_v (SDL_MOUSEWHEEL_FLIPPED); - int_v (SDL_JOYAXISMOTION); - int_v (SDL_JOYBALLMOTION); - int_v (SDL_JOYHATMOTION); - int_v (SDL_JOYBUTTONDOWN); - int_v (SDL_JOYBUTTONUP); - int_v (SDL_JOYDEVICEADDED); - int_v (SDL_JOYDEVICEREMOVED); - int_v (SDL_CONTROLLERAXISMOTION); - int_v (SDL_CONTROLLERBUTTONDOWN); - int_v (SDL_CONTROLLERBUTTONUP); - int_v (SDL_CONTROLLERDEVICEADDED); - int_v (SDL_CONTROLLERDEVICEREMOVED); - int_v (SDL_CONTROLLERDEVICEREMAPPED); - int_v (SDL_FINGERDOWN); - int_v (SDL_FINGERUP); - int_v (SDL_FINGERMOTION); - int_v (SDL_DOLLARGESTURE); - int_v (SDL_DOLLARRECORD); - int_v (SDL_MULTIGESTURE); - int_v (SDL_CLIPBOARDUPDATE); - int_v (SDL_DROPFILE); - int_v (SDL_DROPTEXT); - int_v (SDL_DROPBEGIN); - int_v (SDL_DROPCOMPLETE); - int_v (SDL_AUDIODEVICEADDED); - int_v (SDL_AUDIODEVICEREMOVED); - int_v (SDL_SENSORUPDATE); - int_v (SDL_RENDER_TARGETS_RESET); - int_v (SDL_RENDER_DEVICE_RESET); - int_v (SDL_USEREVENT); - int_v (SDL_LASTEVENT); - - int tsdl_sdl_event_size = sizeof (SDL_Event); - int_v (tsdl_sdl_event_size); - - int_v (SDL_TEXTEDITINGEVENT_TEXT_SIZE); - int_v (SDL_TEXTINPUTEVENT_TEXT_SIZE); - - /* SDL_WindowEventID */ - - int_v (SDL_WINDOWEVENT_SHOWN); - int_v (SDL_WINDOWEVENT_HIDDEN); - int_v (SDL_WINDOWEVENT_EXPOSED); - int_v (SDL_WINDOWEVENT_MOVED); - int_v (SDL_WINDOWEVENT_RESIZED); - int_v (SDL_WINDOWEVENT_SIZE_CHANGED); - int_v (SDL_WINDOWEVENT_MINIMIZED); - int_v (SDL_WINDOWEVENT_MAXIMIZED); - int_v (SDL_WINDOWEVENT_RESTORED); - int_v (SDL_WINDOWEVENT_ENTER); - int_v (SDL_WINDOWEVENT_LEAVE); - int_v (SDL_WINDOWEVENT_FOCUS_GAINED); - int_v (SDL_WINDOWEVENT_FOCUS_LOST); - int_v (SDL_WINDOWEVENT_CLOSE); - int_v (SDL_WINDOWEVENT_TAKE_FOCUS); - int_v (SDL_WINDOWEVENT_HIT_TEST); - - /* Haptic */ - - assert (SDL_HAPTIC_INFINITY == 4294967295U); - - int_v (SDL_HAPTIC_CONSTANT); - int_v (SDL_HAPTIC_SINE); - int_v (SDL_HAPTIC_LEFTRIGHT); - int_v (SDL_HAPTIC_TRIANGLE); - int_v (SDL_HAPTIC_SAWTOOTHUP); - int_v (SDL_HAPTIC_SAWTOOTHDOWN); - int_v (SDL_HAPTIC_RAMP); - int_v (SDL_HAPTIC_SPRING); - int_v (SDL_HAPTIC_DAMPER); - int_v (SDL_HAPTIC_INERTIA); - int_v (SDL_HAPTIC_FRICTION); - int_v (SDL_HAPTIC_CUSTOM); - int_v (SDL_HAPTIC_GAIN); - int_v (SDL_HAPTIC_AUTOCENTER); - int_v (SDL_HAPTIC_STATUS); - int_v (SDL_HAPTIC_PAUSE); - - int_v (SDL_HAPTIC_POLAR); - int_v (SDL_HAPTIC_CARTESIAN); - int_v (SDL_HAPTIC_SPHERICAL); - - /* Audio */ - - int_v (SDL_AUDIO_STOPPED); - int_v (SDL_AUDIO_PLAYING); - int_v (SDL_AUDIO_PAUSED); - - assert (sizeof (SDL_AudioFormat) == 2); - - int_v (AUDIO_S8); - int_v (AUDIO_U8); - int_v (AUDIO_S16LSB); - int_v (AUDIO_S16MSB); - int_v (AUDIO_S16SYS); - int_v (AUDIO_S16); - int_v (AUDIO_U16LSB); - int_v (AUDIO_U16MSB); - int_v (AUDIO_U16SYS); - int_v (AUDIO_U16); - int_v (AUDIO_S32LSB); - int_v (AUDIO_S32MSB); - int_v (AUDIO_S32SYS); - int_v (AUDIO_S32); - int_v (AUDIO_F32LSB); - int_v (AUDIO_F32MSB); - int_v (AUDIO_F32SYS); - int_v (AUDIO_F32); - - int_v (SDL_AUDIO_ALLOW_FREQUENCY_CHANGE); - int_v (SDL_AUDIO_ALLOW_FORMAT_CHANGE); - int_v (SDL_AUDIO_ALLOW_CHANNELS_CHANGE); - int_v (SDL_AUDIO_ALLOW_ANY_CHANGE); - - /* Power management */ - - int_v (SDL_POWERSTATE_UNKNOWN); - int_v (SDL_POWERSTATE_ON_BATTERY); - int_v (SDL_POWERSTATE_NO_BATTERY); - int_v (SDL_POWERSTATE_CHARGING); - int_v (SDL_POWERSTATE_CHARGED); } CAMLprim value output_consts (value fname) diff --git a/support/types_c_gen.ml b/support/types_c_gen.ml new file mode 100644 index 0000000..7e02fa4 --- /dev/null +++ b/support/types_c_gen.ml @@ -0,0 +1,11 @@ +let c_headers = "#include " + +let main () = + let stubs_out = open_out "support/types_stubs_gen.c" in + let stubs_fmt = Format.formatter_of_out_channel stubs_out in + Format.fprintf stubs_fmt "%s@\n" c_headers; + Cstubs.Types.write_c stubs_fmt (module Type_description.Types); + Format.pp_print_flush stubs_fmt (); + close_out stubs_out + +let () = main () From 8eeba5c9a0267ce71e8a527a19455e8d6f721da1 Mon Sep 17 00:00:00 2001 From: Pierre Boutillier Date: Wed, 5 Mar 2025 11:14:16 +0100 Subject: [PATCH 5/8] Fix compilation with OCaml 4.14 --- support/types_c_gen.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/support/types_c_gen.ml b/support/types_c_gen.ml index 7e02fa4..a121626 100644 --- a/support/types_c_gen.ml +++ b/support/types_c_gen.ml @@ -1,4 +1,5 @@ -let c_headers = "#include " +let c_headers = "#include \n\ + #define CAML_NAME_SPACE" let main () = let stubs_out = open_out "support/types_stubs_gen.c" in From 975e7e3e3aab4333dc7d3393e9eec4952a47486a Mon Sep 17 00:00:00 2001 From: Pierre Boutillier Date: Wed, 26 Feb 2025 13:58:04 +0100 Subject: [PATCH 6/8] Functions stubs generator --- .merlin | 1 + _tags | 10 +++--- myocamlbuild.ml | 12 +++++++ src/async_function_description.ml | 23 ++++++++++++ src/libtsdl_stubs.clib | 3 +- src/tsdl.ml | 53 ++++++++++------------------ src/tsdl.mllib | 3 ++ src/types_generated.ml | 1 + support/async_functions_generator.ml | 27 ++++++++++++++ 9 files changed, 94 insertions(+), 39 deletions(-) create mode 100644 src/async_function_description.ml create mode 100644 src/types_generated.ml create mode 100644 support/async_functions_generator.ml diff --git a/.merlin b/.merlin index 7afba6e..19f186a 100644 --- a/.merlin +++ b/.merlin @@ -1,4 +1,5 @@ PKG b0.kit ctypes ctypes-foreign S src +S support S test B _build/** diff --git a/_tags b/_tags index b188bb8..e159cc4 100644 --- a/_tags +++ b/_tags @@ -3,15 +3,17 @@ true: bin_annot, safe_string, thread : include : include - : use_sdl2 +<*/*_stub*.c> : use_sdl2, package(ctypes) + : custom, link_consts_stub : package(ctypes.stubs) - : package(ctypes) + : package(ctypes.stubs) : package(ctypes ctypes-foreign) - : package(ctypes) + : package(ctypes) + : package(ctypes) : sdl_consts - : use_sdl2 + : package(ctypes) : use_sdl2 : record_tsdl_stubs : link_tsdl_stubs_archive diff --git a/myocamlbuild.ml b/myocamlbuild.ml index cfc60a1..5b4447e 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -88,6 +88,7 @@ let sdl_consts_build () = ;; let ctypes_stub_gen () = + (* Types stubs generators *) (* 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" @@ -109,6 +110,17 @@ let ctypes_stub_gen () = ~prod:"src/%_stubs.ml" (fun env _build -> Cmd (S[A (env "support/%_stubs_gen"); Sh">"; A (env "src/%_stubs.ml")])); + (* Functions stubs generators *) + rule "cstubs functions: x_generator.native -> x_stubs.c" + ~dep:"support/%_generator.native" + ~prod:"src/%_stubs.c" + (fun env _build -> Cmd (S[A (env "./support/%_generator.native"); A "c"])); + + rule "mlstubs functions: x_generator.native -> x_generated.ml" + ~dep:"support/%_generator.native" + ~prod:"src/%_generated.ml" + (fun env _build -> Cmd (S[A (env "./support/%_generator.native"); A "ml"])) + let () = dispatch begin function | After_rules -> diff --git a/src/async_function_description.ml b/src/async_function_description.ml new file mode 100644 index 0000000..92b7d08 --- /dev/null +++ b/src/async_function_description.ml @@ -0,0 +1,23 @@ +open Ctypes + +module Types = Types_generated + +module Functions (F : FOREIGN) = struct + let delay = + F.(foreign "SDL_Delay" (int32_t @-> returning void)) + + let render_present = + F.(foreign "SDL_RenderPresent" (ptr Types.Renderer.t @-> returning void)) + + let wait_event = + F.(foreign "SDL_WaitEvent" (ptr Types.Event.t @-> returning int)) + + let wait_event_timeout = + F.(foreign "SDL_WaitEventTimeout" + (ptr Types.Event.t @-> int @-> returning bool)) + + let load_wav_rw = + F.(foreign "SDL_LoadWAV_RW" + (Types.rw_ops @-> int @-> ptr Types.audio_spec @-> ptr (ptr uint8_t) @-> + ptr uint32_t @-> returning (ptr_opt Types.audio_spec))) +end diff --git a/src/libtsdl_stubs.clib b/src/libtsdl_stubs.clib index 4cb29a9..2896fab 100644 --- a/src/libtsdl_stubs.clib +++ b/src/libtsdl_stubs.clib @@ -1 +1,2 @@ -tsdl_stubs.o \ No newline at end of file +tsdl_stubs.o +async_functions_stubs.o diff --git a/src/tsdl.ml b/src/tsdl.ml index 79433b0..32fd172 100644 --- a/src/tsdl.ml +++ b/src/tsdl.ml @@ -10,7 +10,8 @@ open Foreign module Sdl = struct -module Types = Type_description.Types(Types_stubs) +module Types = Types_generated +module Async_functions = Async_function_description.Functions (Async_functions_generated) (* Formatting with continuation. *) @@ -1049,15 +1050,6 @@ let unsafe_texture_of_ptr addr : texture = let unsafe_ptr_of_texture texture = raw_address_of_ptr (to_voidp texture) -type renderer = unit ptr -let renderer : renderer typ = ptr void -let renderer_opt : renderer option typ = ptr_opt void - -let unsafe_renderer_of_ptr addr : renderer = - ptr_of_raw_address addr -let unsafe_ptr_of_renderer renderer = - raw_address_of_ptr (to_voidp renderer) - module Renderer = struct type flags = Unsigned.uint32 let i = Unsigned.UInt32.of_int @@ -1068,6 +1060,15 @@ module Renderer = struct include Types.Renderer end +type renderer = Renderer.t ptr +let renderer : renderer typ = ptr Renderer.t +let renderer_opt : renderer option typ = ptr_opt Renderer.t + +let unsafe_renderer_of_ptr addr : renderer = + from_voidp Renderer.t (Ctypes.ptr_of_raw_address addr) +let unsafe_ptr_of_renderer renderer = + raw_address_of_ptr (to_voidp renderer) + type renderer_info = { ri_name : string; ri_flags : Renderer.flags; @@ -1409,9 +1410,7 @@ let render_get_viewport rend = render_get_viewport rend (addr r); r -let render_present = - foreign ~release_runtime_lock:true "SDL_RenderPresent" - (renderer @-> returning void) +let render_present = Async_functions.render_present let render_read_pixels = foreign "SDL_RenderReadPixels" @@ -1774,7 +1773,7 @@ let create_window_and_renderer = let create_window_and_renderer ~w ~h flags = let win = allocate Window.t (from_voidp Window.raw null) in - let r = allocate renderer null in + let r = allocate renderer (from_voidp Renderer.t null) in match create_window_and_renderer w h flags win r with | 0 -> Ok (!@ win, !@ r) | _ -> error () @@ -3435,19 +3434,11 @@ let register_events = let register_event () = match Unsigned.UInt32.to_int32 (register_events 1) with | -1l -> None | t -> Some (Int32.to_int t) -let wait_event = - foreign ~release_runtime_lock:true - "SDL_WaitEvent" (ptr Event.t @-> returning int) - -let wait_event e = match wait_event (Event.opt_addr e) with +let wait_event e = match Async_functions.wait_event (Event.opt_addr e) with | 1 -> Ok () | _ -> error () -let wait_event_timeout = - foreign "SDL_WaitEventTimeout" ~release_runtime_lock:true - (ptr Event.t @-> int @-> returning bool) - let wait_event_timeout e t = - wait_event_timeout (Event.opt_addr e) t + Async_functions.wait_event_timeout (Event.opt_addr e) t (* Force feedback *) @@ -3978,15 +3969,10 @@ let get_num_audio_devices = foreign "SDL_GetNumAudioDevices" (bool @-> returning int) let get_num_audio_devices b = get_num_audio_devices b |> nat_to_ok -let load_wav_rw = - foreign ~release_runtime_lock:true "SDL_LoadWAV_RW" - (Types.rw_ops @-> int @-> ptr Types.audio_spec @-> ptr (ptr void) @-> - ptr uint32_t @-> returning (ptr_opt Types.audio_spec)) - let load_wav_rw ops spec kind = - let d = allocate (ptr void) null in + let d = allocate (ptr uint8_t) (from_voidp uint8_t null) in let len = allocate uint32_t Unsigned.UInt32.zero in - match load_wav_rw ops 0 (addr (audio_spec_to_c spec)) d len with + match Async_functions.load_wav_rw ops 0 (addr (audio_spec_to_c spec)) d len with | None -> error () | Some r -> let rspec = audio_spec_of_c (!@ r) in @@ -3997,7 +3983,7 @@ let load_wav_rw ops spec kind = else let ba_size = len / kind_size in let ba_ptr = access_ptr_typ_of_ba_kind kind in - let d = coerce (ptr void) ba_ptr (!@ d) in + let d = coerce (ptr uint8_t) ba_ptr (!@ d) in Ok (rspec, bigarray_of_ptr array1 ba_size kind d) let lock_audio_device = @@ -4049,8 +4035,7 @@ let clear_queued_audio = (* Timer *) -let delay = - foreign ~release_runtime_lock:true "SDL_Delay" (int32_t @-> returning void) +let delay = Async_functions.delay let get_ticks = foreign "SDL_GetTicks" (void @-> returning int32_t) diff --git a/src/tsdl.mllib b/src/tsdl.mllib index e3b2c87..26bfff5 100644 --- a/src/tsdl.mllib +++ b/src/tsdl.mllib @@ -1,4 +1,7 @@ Tsdl_consts Type_description Types_stubs +Types_generated +Async_function_description +Async_functions_generated Tsdl \ No newline at end of file diff --git a/src/types_generated.ml b/src/types_generated.ml new file mode 100644 index 0000000..a52a7f2 --- /dev/null +++ b/src/types_generated.ml @@ -0,0 +1 @@ +include Type_description.Types(Types_stubs) diff --git a/support/async_functions_generator.ml b/support/async_functions_generator.ml new file mode 100644 index 0000000..b35ed07 --- /dev/null +++ b/support/async_functions_generator.ml @@ -0,0 +1,27 @@ +let c_headers = "#define SDL_MAIN_HANDLED 1\n\ + #include \"SDL.h\"\n\ + #include \"SDL_vulkan.h\"\n\ + #undef main" + +let concurrency = Cstubs.unlocked +let errno = Cstubs.ignore_errno +let prefix = "sdl2_stubs" + +let main () = + match Sys.argv.(1) with + | "ml" -> + let ml_out = open_out "src/async_functions_generated.ml" in + let ml_fmt = Format.formatter_of_out_channel ml_out in + Cstubs.write_ml ~concurrency ml_fmt ~prefix (module Async_function_description.Functions); + Format.pp_print_flush ml_fmt (); + close_out ml_out + | "c" -> + let c_out = open_out "src/async_functions_stubs.c" in + let c_fmt = Format.formatter_of_out_channel c_out in + Format.fprintf c_fmt "%s@\n" c_headers; + Cstubs.write_c ~concurrency c_fmt ~prefix (module Async_function_description.Functions); + Format.pp_print_flush c_fmt (); + close_out c_out + | _ -> () + +let () = main () From 1109b746238fca78db466c5b110bfccfc8617a39 Mon Sep 17 00:00:00 2001 From: Pierre Boutillier Date: Wed, 26 Feb 2025 14:58:43 +0100 Subject: [PATCH 7/8] Full stubs generated --- _tags | 2 - myocamlbuild.ml | 20 - src/function_description.ml | 1571 ++++++++++++++++++ src/libtsdl_stubs.clib | 1 + src/tsdl.ml | 2824 +++++++++++--------------------- src/tsdl.mllib | 3 +- src/type_description.ml | 5 +- support/consts.ml | 19 - support/consts_stub.c | 83 - support/functions_generator.ml | 27 + 10 files changed, 2556 insertions(+), 1999 deletions(-) create mode 100644 src/function_description.ml delete mode 100644 support/consts.ml delete mode 100644 support/consts_stub.c create mode 100644 support/functions_generator.ml diff --git a/_tags b/_tags index e159cc4..0073bfd 100644 --- a/_tags +++ b/_tags @@ -5,14 +5,12 @@ true: bin_annot, safe_string, thread <*/*_stub*.c> : use_sdl2, package(ctypes) - : custom, link_consts_stub : package(ctypes.stubs) : package(ctypes.stubs) : package(ctypes ctypes-foreign) : package(ctypes) : package(ctypes) - : sdl_consts : package(ctypes) : use_sdl2 : record_tsdl_stubs diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 5b4447e..0105f82 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -68,25 +68,6 @@ let lib_with_clib ~lib ~clib ~has_lib ~src_dir ~stublib = ocaml_lib ~tag_name:use_lib ~dir:src_dir (strf "%s/%s" src_dir lib) end -(* tsdl_const.ml generation. *) - -let sdl_consts_build () = - let obj s = match !Ocamlbuild_plugin.Options.ext_obj with - | "" -> s ^ ".o" - | x -> s ^ "." ^ x - in - dep [ "link"; "ocaml"; "link_consts_stub" ] [ obj "support/consts_stub" ]; - dep [ "sdl_consts" ] [ "src/tsdl_consts.ml" ]; - rule "sdl_consts: consts.byte -> tsdl_consts.ml" - ~dep:"support/consts.byte" - ~prod:"src/tsdl_consts.ml" - begin fun env build -> - let enums = env "support/consts.byte" in - let prod = env "src/tsdl_consts.ml" in - Cmd (S [A enums; A prod]) - end; -;; - let ctypes_stub_gen () = (* Types stubs generators *) (* Generate stubs. Steps 1, 2, & 3 of Makefile (1 & 2 via built-in rules). @@ -126,7 +107,6 @@ let () = | After_rules -> lib_with_clib ~lib:"tsdl" ~clib:"sdl2" ~has_lib:"-DHAS_SDL2" ~src_dir:"src" ~stublib:"tsdl_stubs"; - sdl_consts_build (); ctypes_stub_gen () | _ -> () end diff --git a/src/function_description.ml b/src/function_description.ml new file mode 100644 index 0000000..09dcff1 --- /dev/null +++ b/src/function_description.ml @@ -0,0 +1,1571 @@ +open Ctypes + +module Types = Types_generated + +let const_string_opt = + Ctypes_std_views.nullable_view string Ctypes_static.(const char) + +module Functions (F : FOREIGN) = struct + let get_error = + F.(foreign "SDL_GetError" (void @-> returning string)) + let sdl_free = F.(foreign "SDL_free" (ptr void @-> returning void)) + let set_main_ready = F.(foreign "SDL_SetMainReady" (void @-> returning void)) + let init = + F.(foreign "SDL_Init" (uint32_t @-> returning int)) + let init_sub_system = + F.(foreign "SDL_InitSubSystem" (uint32_t @-> returning int)) + let was_init = + F.(foreign "SDL_WasInit" (uint32_t @-> returning uint32_t)) + let quit = + F.(foreign "SDL_Quit" (void @-> returning void)) + let quit_sub_system = + F.(foreign "SDL_QuitSubSystem" (uint32_t @-> returning void)) + + module Hint = struct + let framebuffer_acceleration = + F.foreign_value "SDL_HINT_FRAMEBUFFER_ACCELERATION" (array 29 char) + let idle_timer_disabled = + F.foreign_value "SDL_HINT_IDLE_TIMER_DISABLED" (array 28 char) + let mouse_focus_clickthrough = + F.foreign_value "SDL_HINT_MOUSE_FOCUS_CLICKTHROUGH" (array 29 char) + let orientations = + F.foreign_value "SDL_HINT_ORIENTATIONS" (array 21 char) + let render_driver = + F.foreign_value "SDL_HINT_RENDER_DRIVER" (array 18 char) + let render_opengl_shaders = + F.foreign_value "SDL_HINT_RENDER_OPENGL_SHADERS" (array 26 char) + let render_logical_size_mode = + F.foreign_value "SDL_HINT_RENDER_LOGICAL_SIZE_MODE" (array 29 char) + let render_scale_quality = + F.foreign_value "SDL_HINT_RENDER_SCALE_QUALITY" (array 25 char) + let render_vsync = + F.foreign_value "SDL_HINT_RENDER_VSYNC" (array 17 char) + + let no_signal_handlers = + F.foreign_value "SDL_HINT_NO_SIGNAL_HANDLERS" (array 23 char) + let thread_stack_size = + F.foreign_value "SDL_HINT_THREAD_STACK_SIZE" (array 22 char) + let window_frame_usable_while_cursor_hidden = + F.foreign_value + "SDL_HINT_WINDOW_FRAME_USABLE_WHILE_CURSOR_HIDDEN" (array 44 char) + + let audio_resampling_mode = + F.foreign_value "SDL_HINT_AUDIO_RESAMPLING_MODE" (array 26 char) + let mouse_normal_speed_scale = + F.foreign_value "SDL_HINT_MOUSE_NORMAL_SPEED_SCALE" (array 29 char) + let mouse_relative_speed_scale = + F.foreign_value "SDL_HINT_MOUSE_RELATIVE_SPEED_SCALE" (array 31 char) + let touch_mouse_events = + F.foreign_value "SDL_HINT_TOUCH_MOUSE_EVENTS" (array 23 char) + let mouse_touch_events = + F.foreign_value "SDL_HINT_MOUSE_TOUCH_EVENTS" (array 23 char) + end + + let clear_hints = + F.(foreign "SDL_ClearHints" (void @-> returning void)) + + let get_hint = + F.(foreign "SDL_GetHint" (string @-> returning const_string_opt)) + + let get_hint_boolean = + F.(foreign "SDL_GetHintBoolean" (string @-> bool @-> returning bool)) + + let set_hint = + F.(foreign "SDL_SetHint" (string @-> string @-> returning bool)) + + let set_hint_with_priority = + F.(foreign "SDL_SetHintWithPriority" + (string @-> string @-> int @-> returning bool)) + + (* Errors *) + + let clear_error = + F.(foreign "SDL_ClearError" (void @-> returning void)) + + let set_error = + F.(foreign "SDL_SetError" (string @-> returning int)) + + (* Log *) + + let log_get_priority = + F.(foreign "SDL_LogGetPriority" (int @-> returning int)) + + let log_reset_priorities = + F.(foreign "SDL_LogResetPriorities" (void @-> returning void)) + + let log_set_all_priority = + F.(foreign "SDL_LogSetAllPriority" (int @-> returning void)) + + let log_set_priority = + F.(foreign "SDL_LogSetPriority" (int @-> int @-> returning void)) + + (* Version *) + + let get_version = + F.(foreign "SDL_GetVersion" (ptr Types.version @-> returning void)) + + let get_revision = + F.(foreign "SDL_GetRevision" (void @-> returning string)) + + (* IO absraction *) + + let load_file_rw = + F.(foreign "SDL_LoadFile_RW" + (Types.rw_ops @-> ptr size_t @-> bool @-> returning string_opt)) + + let rw_close = + F.(foreign "SDL_RWclose" (Types.rw_ops @-> returning int)) + + let rw_from_file = + F.(foreign "SDL_RWFromFile" + (string @-> string @-> returning Types.rw_ops_opt)) + + let rw_from_const_mem = + F.(foreign "SDL_RWFromConstMem" + (ocaml_string @-> int @-> returning Types.rw_ops_opt)) + + let rw_from_mem = + F.(foreign "SDL_RWFromMem" + (ocaml_bytes @-> int @-> returning Types.rw_ops_opt)) + + (* File system paths *) + + let get_base_path = + F.(foreign "SDL_GetBasePath" (void @-> returning (ptr char))) + + let get_pref_path = + F.(foreign "SDL_GetPrefPath" (string @-> string @-> returning (ptr char))) + + (* Rectangles *) + + let enclose_points = + F.(foreign "SDL_EnclosePoints" + (ptr void @-> int @-> ptr Types.Rect.t @-> ptr Types.Rect.t @-> + returning bool)) + + let has_intersection = + F.(foreign "SDL_HasIntersection" + (ptr Types.Rect.t @-> ptr Types.Rect.t @-> returning bool)) + + let intersect_rect = + F.(foreign "SDL_IntersectRect" + (ptr Types.Rect.t @-> ptr Types.Rect.t @-> ptr Types.Rect.t @-> + returning bool)) + + let intersect_rect_and_line = + F.(foreign "SDL_IntersectRectAndLine" + (ptr Types.Rect.t @-> ptr int @-> ptr int @-> ptr int @-> ptr int @-> + returning bool)) + + let point_in_rect = + F.(foreign "SDL_PointInRect" + (ptr Types.Point.t @-> ptr Types.Rect.t @-> returning bool)) + + let rect_empty = + F.(foreign "SDL_RectEmpty" (ptr Types.Rect.t @-> returning bool)) + + let rect_equals = + F.(foreign "SDL_RectEquals" + (ptr Types.Rect.t @-> ptr Types.Rect.t @-> returning bool)) + + let union_rect = + F.(foreign "SDL_UnionRect" + (ptr Types.Rect.t @-> ptr Types.Rect.t @-> ptr Types.Rect.t @-> + returning void)) + + let alloc_palette = + F.(foreign "SDL_AllocPalette" (int @-> returning (ptr_opt Types.palette))) + + let free_palette = + F.(foreign "SDL_FreePalette" (ptr Types.palette @-> returning void)) + + let set_palette_colors = + F.(foreign "SDL_SetPaletteColors" + (ptr Types.palette @-> ptr void(*Types.Color.t*) @-> int @-> int @-> returning int)) + + (* See https://github.com/yallop/ocaml-ctypes/issues/109 for why (*u*) *) + let calculate_gamma_ramp = + F.(foreign "SDL_CalculateGammaRamp" (float @-> ptr (*u*)int16_t @-> returning void)) + + let compose_custom_blend_mode = + F.(foreign "SDL_ComposeCustomBlendMode" + (int @-> int @-> int @-> int @-> int @-> int @-> returning Types.Blend.mode)) + + let alloc_format = + F.(foreign "SDL_AllocFormat" + (uint32_t @-> returning (ptr_opt Types.pixel_format))) + + let free_format = + F.(foreign "SDL_FreeFormat" (ptr Types.pixel_format @-> returning void)) + + let get_pixel_format_name = + F.(foreign "SDL_GetPixelFormatName" (uint32_t @-> returning string)) + + let get_rgb = + F.(foreign "SDL_GetRGB" + (uint32_t @-> ptr Types.pixel_format @-> ptr uint8_t @-> + ptr uint8_t @-> ptr uint8_t @-> returning void)) + + let get_rgba = + F.(foreign "SDL_GetRGBA" + (uint32_t @-> ptr Types.pixel_format @-> ptr uint8_t @-> + ptr uint8_t @-> ptr uint8_t @-> ptr uint8_t @-> returning void)) + + let map_rgb = + F.(foreign "SDL_MapRGB" + (ptr Types.pixel_format @-> uint8_t @-> uint8_t @-> uint8_t @-> + returning uint32_t)) + + let map_rgba = + F.(foreign "SDL_MapRGBA" + (ptr Types.pixel_format @-> uint8_t @-> uint8_t @-> uint8_t @-> + uint8_t @-> returning uint32_t)) + + let masks_to_pixel_format_enum = + F.(foreign "SDL_MasksToPixelFormatEnum" + (int @-> uint32_t @-> uint32_t @-> uint32_t @-> uint32_t @-> + returning uint32_t)) + + let pixel_format_enum_to_masks = + F.(foreign "SDL_PixelFormatEnumToMasks" + (uint32_t @-> ptr int @-> + ptr uint32_t @-> ptr uint32_t @-> ptr uint32_t @-> ptr uint32_t @-> + returning bool)) + + let set_pixel_format_palette = + F.(foreign "SDL_SetPixelFormatPalette" + (ptr Types.pixel_format @-> ptr Types.palette @-> returning int)) + + let blit_scaled = + (* SDL_BlitScaled is #ifdef'd to SDL_UpperBlitScaled *) + F.(foreign "SDL_UpperBlitScaled" + (ptr Types.surface @-> ptr Types.Rect.t @-> ptr Types.surface @-> + ptr Types.Rect.t @-> returning int)) + + let blit_surface = + (* SDL_BlitSurface is #ifdef'd to SDL_UpperBlit *) + F.(foreign "SDL_UpperBlit" + (ptr Types.surface @-> ptr Types.Rect.t @-> ptr Types.surface @-> + ptr Types.Rect.t @-> returning int)) + + let convert_pixels = + F.(foreign "SDL_ConvertPixels" + (int @-> int @-> uint32_t @-> ptr void @-> int @-> uint32_t @-> + ptr void @-> int @-> returning int)) + + let convert_surface = + F.(foreign "SDL_ConvertSurface" + (ptr Types.surface @-> ptr Types.pixel_format @-> uint32_t @-> + returning (ptr_opt Types.surface))) + + let convert_surface_format = + F.(foreign "SDL_ConvertSurfaceFormat" + (ptr Types.surface @-> uint32_t @-> uint32_t @-> + returning (ptr_opt Types.surface))) + + let create_rgb_surface = + F.(foreign "SDL_CreateRGBSurface" + (uint32_t @-> int @-> int @-> int @-> uint32_t @-> uint32_t @-> + uint32_t @-> uint32_t @-> returning (ptr_opt Types.surface))) + + let create_rgb_surface_from = + F.(foreign "SDL_CreateRGBSurfaceFrom" + (ptr void @-> int @-> int @-> int @-> int @-> uint32_t @-> + uint32_t @-> uint32_t @-> uint32_t @-> + returning (ptr_opt Types.surface))) + + let create_rgb_surface_with_format = + F.(foreign "SDL_CreateRGBSurfaceWithFormat" + (uint32_t @-> int @-> int @-> int @-> uint32_t @-> + returning (ptr_opt Types.surface))) + + let create_rgb_surface_with_format_from = + F.(foreign "SDL_CreateRGBSurfaceWithFormatFrom" + (ptr void @-> int @-> int @-> int @-> int @-> uint32_t @-> + returning (ptr_opt Types.surface))) + + let duplicate_surface = + F.(foreign "SDL_DuplicateSurface" + (ptr Types.surface @-> returning (ptr Types.surface))) + + let fill_rect = + F.(foreign "SDL_FillRect" + (ptr Types.surface @-> ptr Types.Rect.t @-> uint32_t @-> + returning int)) + + let fill_rects = + F.(foreign "SDL_FillRects" + (ptr Types.surface @-> ptr void (* Types.Rect.t *) @-> int @-> + uint32_t @-> returning int)) + + let free_surface = + F.(foreign "SDL_FreeSurface" (ptr Types.surface @-> returning void)) + + let get_clip_rect = + F.(foreign "SDL_GetClipRect" + (ptr Types.surface @-> ptr Types.Rect.t @-> returning void)) + + let get_color_key = + F.(foreign "SDL_GetColorKey" + (ptr Types.surface @-> ptr uint32_t @-> returning int)) + + let get_surface_alpha_mod = + F.(foreign "SDL_GetSurfaceAlphaMod" + (ptr Types.surface @-> ptr uint8_t @-> returning int)) + + let get_surface_blend_mode = + F.(foreign "SDL_GetSurfaceBlendMode" + (ptr Types.surface @-> ptr Types.Blend.mode @-> returning int)) + + let get_surface_color_mod = + F.(foreign "SDL_GetSurfaceColorMod" + (ptr Types.surface @-> ptr uint8_t @-> ptr uint8_t @-> ptr uint8_t @-> + returning int)) + + let load_bmp_rw = + F.(foreign "SDL_LoadBMP_RW" + (Types.rw_ops @-> bool @-> returning (ptr_opt Types.surface))) + + let lock_surface = + F.(foreign "SDL_LockSurface" (ptr Types.surface @-> returning int)) + + let lower_blit = + F.(foreign "SDL_LowerBlit" + (ptr Types.surface @-> ptr Types.Rect.t @-> ptr Types.surface @-> + ptr Types.Rect.t @-> returning int)) + + let lower_blit_scaled = + F.(foreign "SDL_LowerBlitScaled" + (ptr Types.surface @-> ptr Types.Rect.t @-> ptr Types.surface @-> + ptr Types.Rect.t @-> returning int)) + + let save_bmp_rw = + F.(foreign "SDL_SaveBMP_RW" + (ptr Types.surface @-> Types.rw_ops @-> bool @-> returning int)) + + let set_clip_rect = + F.(foreign "SDL_SetClipRect" + (ptr Types.surface @-> ptr Types.Rect.t @-> returning bool)) + + let set_color_key = + F.(foreign "SDL_SetColorKey" + (ptr Types.surface @-> bool @-> uint32_t @-> returning int)) + + let set_surface_alpha_mod = + F.(foreign "SDL_SetSurfaceAlphaMod" + (ptr Types.surface @-> uint8_t @-> returning int)) + + let set_surface_blend_mode = + F.(foreign "SDL_SetSurfaceBlendMode" + (ptr Types.surface @-> Types.Blend.mode @-> returning int)) + + let set_surface_color_mod = + F.(foreign "SDL_SetSurfaceColorMod" + (ptr Types.surface @-> uint8_t @-> uint8_t @-> uint8_t @-> + returning int)) + + let set_surface_palette = + F.(foreign "SDL_SetSurfacePalette" + (ptr Types.surface @-> ptr Types.palette @-> returning int)) + + let set_surface_rle = + F.(foreign "SDL_SetSurfaceRLE" + (ptr Types.surface @-> bool @-> returning int)) + + let unlock_surface = + F.(foreign "SDL_UnlockSurface" (ptr Types.surface @-> returning void)) + + let create_renderer = + F.(foreign "SDL_CreateRenderer" + (Types.Window.t @-> int @-> uint32_t @-> + returning (ptr_opt Types.Renderer.t))) + + let create_software_renderer = + F.(foreign "SDL_CreateSoftwareRenderer" + (ptr Types.surface @-> returning (ptr_opt Types.Renderer.t))) + + let destroy_renderer = + F.(foreign "SDL_DestroyRenderer" (ptr Types.Renderer.t @-> returning void)) + + let get_num_render_drivers = + F.(foreign "SDL_GetNumRenderDrivers" (void @-> returning int)) + + let get_render_draw_blend_mode = + F.(foreign "SDL_GetRenderDrawBlendMode" + (ptr Types.Renderer.t @-> ptr Types.Blend.mode @-> returning int)) + + let get_render_draw_color = + F.(foreign "SDL_GetRenderDrawColor" + (ptr Types.Renderer.t @-> ptr uint8_t @-> ptr uint8_t @-> + ptr uint8_t @-> ptr uint8_t @-> returning int)) + + let get_render_driver_info = + F.(foreign "SDL_GetRenderDriverInfo" + (int @-> ptr Types.renderer_info @-> returning int)) + + let get_render_target = + F.(foreign "SDL_GetRenderTarget" + (ptr Types.Renderer.t @-> returning (ptr_opt Types.Texture.t))) + + let get_renderer = + F.(foreign "SDL_GetRenderer" + (Types.Window.t @-> returning (ptr_opt Types.Renderer.t))) + + let get_renderer_info = + F.(foreign "SDL_GetRendererInfo" + (ptr Types.Renderer.t @-> ptr Types.renderer_info @-> returning int)) + + let get_renderer_output_size = + F.(foreign "SDL_GetRendererOutputSize" + (ptr Types.Renderer.t @-> ptr int @-> ptr int @-> returning int)) + + let render_clear = + F.(foreign "SDL_RenderClear" (ptr Types.Renderer.t @-> returning int)) + + let render_copy = + F.(foreign "SDL_RenderCopy" + (ptr Types.Renderer.t @-> ptr Types.Texture.t @-> ptr Types.Rect.t @-> + ptr Types.Rect.t @-> returning int)) + + let render_copy_ex = + F.(foreign "SDL_RenderCopyEx" + (ptr Types.Renderer.t @-> ptr Types.Texture.t @-> ptr Types.Rect.t @-> + ptr Types.Rect.t @-> double @-> ptr Types.Point.t @-> int @-> + returning int)) + + let render_draw_line = + F.(foreign "SDL_RenderDrawLine" + (ptr Types.Renderer.t @-> int @-> int @-> int @-> int @-> + returning int)) + + let render_draw_line_f = + F.(foreign "SDL_RenderDrawLineF" + (ptr Types.Renderer.t @-> float @-> float @-> float @-> float @-> + returning int)) + + let render_draw_lines = + F.(foreign "SDL_RenderDrawLines" + (ptr Types.Renderer.t @-> ptr void @-> int @-> returning int)) + + let render_draw_point = + F.(foreign "SDL_RenderDrawPoint" + (ptr Types.Renderer.t @-> int @-> int @-> returning int)) + + let render_draw_points = + F.(foreign "SDL_RenderDrawPoints" + (ptr Types.Renderer.t @-> ptr void @-> int @-> returning int)) + + let render_draw_point_f = + F.(foreign "SDL_RenderDrawPointF" + (ptr Types.Renderer.t @-> float @-> float @-> returning int)) + + let render_draw_points_f = + F.(foreign "SDL_RenderDrawPointsF" + (ptr Types.Renderer.t @-> ptr void @-> int @-> returning int)) + + let render_draw_rect = + F.(foreign "SDL_RenderDrawRect" + (ptr Types.Renderer.t @-> ptr Types.Rect.t @-> returning int)) + + let render_draw_rects = + F.(foreign "SDL_RenderDrawRects" + (ptr Types.Renderer.t @-> ptr void @-> int @-> returning int)) + + let render_fill_rect = + F.(foreign "SDL_RenderFillRect" + (ptr Types.Renderer.t @-> ptr Types.Rect.t @-> returning int)) + + let render_fill_rects = + F.(foreign "SDL_RenderFillRects" + (ptr Types.Renderer.t @-> ptr void @-> int @-> returning int)) + + let render_geometry = + F.(foreign "SDL_RenderGeometry" + (ptr Types.Renderer.t @-> ptr_opt Types.Texture.t @-> + ptr Types.Vertex.t @-> int @-> ptr_opt int @-> int @-> returning int)) + + let render_geometry_raw = + F.(foreign "SDL_RenderGeometryRaw" + (ptr Types.Renderer.t @-> ptr_opt Types.Texture.t @-> + ptr float @-> int @-> + ptr void (*Types.Color.t*) @-> int @-> + ptr float @-> int @-> + int @-> ptr void @-> int @-> int @-> returning int)) + + let render_get_clip_rect = + F.(foreign "SDL_RenderGetClipRect" + (ptr Types.Renderer.t @-> ptr Types.Rect.t @-> returning void)) + + let render_is_clip_enabled = + F.(foreign "SDL_RenderIsClipEnabled" + (ptr Types.Renderer.t @-> returning bool)) + + let render_get_integer_scale = + F.(foreign "SDL_RenderGetIntegerScale" + (ptr Types.Renderer.t @-> returning bool)) + + let render_get_logical_size = + F.(foreign "SDL_RenderGetLogicalSize" + (ptr Types.Renderer.t @-> ptr int @-> ptr int @-> returning void)) + + let render_get_scale = + F.(foreign "SDL_RenderGetScale" + (ptr Types.Renderer.t @-> ptr float @-> ptr float @-> returning void)) + + let render_get_viewport = + F.(foreign "SDL_RenderGetViewport" + (ptr Types.Renderer.t @-> ptr Types.Rect.t @-> returning void)) + + let render_read_pixels = + F.(foreign "SDL_RenderReadPixels" + (ptr Types.Renderer.t @-> ptr Types.Rect.t @-> uint32_t @-> + ptr void @-> int @-> returning int)) + + let render_set_clip_rect = + F.(foreign "SDL_RenderSetClipRect" + (ptr Types.Renderer.t @-> ptr Types.Rect.t @-> returning int)) + + let render_set_integer_scale = + F.(foreign "SDL_RenderSetIntegerScale" + (ptr Types.Renderer.t @-> bool @-> returning int)) + + let render_set_logical_size = + F.(foreign "SDL_RenderSetLogicalSize" + (ptr Types.Renderer.t @-> int @-> int @-> returning int)) + + let render_set_scale = + F.(foreign "SDL_RenderSetScale" + (ptr Types.Renderer.t @-> float @-> float @-> returning int)) + + let render_set_viewport = + F.(foreign "SDL_RenderSetViewport" + (ptr Types.Renderer.t @-> ptr Types.Rect.t @-> returning int)) + + let render_target_supported = + F.(foreign "SDL_RenderTargetSupported" + (ptr Types.Renderer.t @-> returning bool)) + + let set_render_draw_blend_mode = + F.(foreign "SDL_SetRenderDrawBlendMode" + (ptr Types.Renderer.t @-> Types.Blend.mode @-> returning int)) + + let set_render_draw_color = + F.(foreign "SDL_SetRenderDrawColor" + (ptr Types.Renderer.t @-> uint8_t @-> uint8_t @-> uint8_t @-> + uint8_t @-> returning int)) + + let set_render_target = + F.(foreign "SDL_SetRenderTarget" + (ptr Types.Renderer.t @-> ptr_opt Types.Texture.t @-> returning int)) + + let create_texture = + F.(foreign "SDL_CreateTexture" + (ptr Types.Renderer.t @-> uint32_t @-> int @-> int @-> int @-> + returning (ptr_opt Types.Texture.t))) + + let create_texture_from_surface = + F.(foreign "SDL_CreateTextureFromSurface" + (ptr Types.Renderer.t @-> ptr Types.surface @-> + returning (ptr_opt Types.Texture.t))) + + let destroy_texture = + F.(foreign "SDL_DestroyTexture" (ptr Types.Texture.t @-> returning void)) + + let get_texture_alpha_mod = + F.(foreign "SDL_GetTextureAlphaMod" + (ptr Types.Texture.t @-> ptr uint8_t @-> returning int)) + + let get_texture_blend_mode = + F.(foreign "SDL_GetTextureBlendMode" + (ptr Types.Texture.t @-> ptr Types.Blend.mode @-> returning int)) + + let get_texture_color_mod = + F.(foreign "SDL_GetTextureColorMod" + (ptr Types.Texture.t @-> ptr uint8_t @-> ptr uint8_t @-> + ptr uint8_t @-> returning int)) + + let query_texture = + F.(foreign "SDL_QueryTexture" + (ptr Types.Texture.t @-> ptr uint32_t @-> ptr int @-> ptr int @-> + ptr int @-> returning int)) + + let lock_texture = + F.(foreign "SDL_LockTexture" + (ptr Types.Texture.t @-> ptr Types.Rect.t @-> ptr (ptr void) @-> + ptr int @-> returning int)) + + let set_texture_alpha_mod = + F.(foreign "SDL_SetTextureAlphaMod" + (ptr Types.Texture.t @-> uint8_t @-> returning int)) + + let set_texture_blend_mode = + F.(foreign "SDL_SetTextureBlendMode" + (ptr Types.Texture.t @-> Types.Blend.mode @-> returning int)) + + let set_texture_color_mod = + F.(foreign "SDL_SetTextureColorMod" + (ptr Types.Texture.t @-> uint8_t @-> uint8_t @-> uint8_t @-> returning int)) + + let unlock_texture = + F.(foreign "SDL_UnlockTexture" (ptr Types.Texture.t @-> returning void)) + + let update_texture = + F.(foreign "SDL_UpdateTexture" + (ptr Types.Texture.t @-> ptr Types.Rect.t @-> ptr void @-> int @-> + returning int)) + + let update_yuv_texture = + F.(foreign "SDL_UpdateYUVTexture" + (ptr Types.Texture.t @-> ptr Types.Rect.t @-> + ptr (*u*)int8_t @-> int @-> ptr (*u*)int8_t @-> int @-> + ptr (*u*)int8_t @-> int @-> returning int)) + + (* Video drivers *) + + let get_current_video_driver = + F.(foreign "SDL_GetCurrentVideoDriver" (void @-> returning const_string_opt)) + + let get_num_video_drivers = + F.(foreign "SDL_GetNumVideoDrivers" (void @-> returning int)) + + let get_video_driver = + F.(foreign "SDL_GetVideoDriver" (int @-> returning const_string_opt)) + + let video_init = + F.(foreign "SDL_VideoInit" (string_opt @-> returning int)) + + let video_quit = + F.(foreign "SDL_VideoQuit" (void @-> returning void)) + + (* Displays *) + + let get_closest_display_mode = + F.(foreign "SDL_GetClosestDisplayMode" + (int @-> ptr Types.display_mode @-> ptr Types.display_mode @-> + returning (ptr_opt void))) + + let get_current_display_mode = + F.(foreign "SDL_GetCurrentDisplayMode" + (int @-> ptr Types.display_mode @-> returning int)) + + let get_desktop_display_mode = + F.(foreign "SDL_GetDesktopDisplayMode" + (int @-> ptr Types.display_mode @-> returning int)) + + let get_display_bounds = + F.(foreign "SDL_GetDisplayBounds" + (int @-> ptr Types.Rect.t @-> returning int)) + + let get_display_dpi = + F.(foreign "SDL_GetDisplayDPI" + (int @-> ptr float @-> ptr float @-> ptr float @-> returning int)) + + let get_display_mode = + F.(foreign "SDL_GetDisplayMode" + (int @-> int @-> ptr Types.display_mode @-> returning int)) + + let get_display_usable_bounds = + F.(foreign "SDL_GetDisplayUsableBounds" + (int @-> ptr Types.Rect.t @-> returning int)) + + let get_num_display_modes = + F.(foreign "SDL_GetNumDisplayModes" (int @-> returning int)) + + let get_display_name = + F.(foreign "SDL_GetDisplayName" (int @-> returning const_string_opt)) + + let get_num_video_displays = + F.(foreign "SDL_GetNumVideoDisplays" (void @-> returning int)) + + let create_window = + F.(foreign "SDL_CreateWindow" + (string @-> int @-> int @-> int @-> int @-> uint32_t @-> + returning Types.Window.opt)) + + let create_window_and_renderer = + F.(foreign "SDL_CreateWindowAndRenderer" + (int @-> int @-> uint32_t @-> ptr Types.Window.t @-> + ptr (ptr Types.Renderer.t) @-> (returning int))) + + let destroy_window = + F.(foreign "SDL_DestroyWindow" (Types.Window.t @-> returning void)) + + let get_window_brightness = + F.(foreign "SDL_GetWindowBrightness" (Types.Window.t @-> returning float)) + + let get_window_borders_size = + F.(foreign "SDL_GetWindowBordersSize" + (Types.Window.t @-> ptr int @-> ptr int @-> ptr int @-> ptr int @-> + returning int)) + + let get_window_display_index = + F.(foreign "SDL_GetWindowDisplayIndex" (Types.Window.t @-> returning int)) + + let get_window_display_mode = + F.(foreign "SDL_GetWindowDisplayMode" + (Types.Window.t @-> (ptr Types.display_mode) @-> returning int)) + + let get_window_flags = + F.(foreign "SDL_GetWindowFlags" (Types.Window.t @-> returning uint32_t)) + + let get_window_from_id = + F.(foreign "SDL_GetWindowFromID" + (uint32_t @-> returning Types.Window.opt)) + + let get_window_gamma_ramp = + F.(foreign "SDL_GetWindowGammaRamp" + (Types.Window.t @-> ptr (*u*)int16_t @-> ptr (*u*)int16_t @-> + ptr (*u*)int16_t @-> returning int)) + + let get_window_grab = + F.(foreign "SDL_GetWindowGrab" (Types.Window.t @-> returning bool)) + + let get_grabbed_window = + F.(foreign "SDL_GetGrabbedWindow" (void @-> returning Types.Window.t)) + + let get_window_id = + F.(foreign "SDL_GetWindowID" (Types.Window.t @-> returning uint32_t)) + + let get_window_maximum_size = + F.(foreign "SDL_GetWindowMaximumSize" + (Types.Window.t @-> (ptr int) @-> (ptr int) @-> returning void)) + + let get_window_minimum_size = + F.(foreign "SDL_GetWindowMinimumSize" + (Types.Window.t @-> (ptr int) @-> (ptr int) @-> returning void)) + + let get_window_opacity = + F.(foreign "SDL_GetWindowOpacity" + (Types.Window.t @-> (ptr float) @-> returning int)) + + let get_window_pixel_format = + F.(foreign "SDL_GetWindowPixelFormat" + (Types.Window.t @-> returning uint32_t)) + + let get_window_position = + F.(foreign "SDL_GetWindowPosition" + (Types.Window.t @-> (ptr int) @-> (ptr int) @-> returning void)) + + let get_window_size = + F.(foreign "SDL_GetWindowSize" + (Types.Window.t @-> (ptr int) @-> (ptr int) @-> returning void)) + + let get_window_surface = + F.(foreign "SDL_GetWindowSurface" + (Types.Window.t @-> returning (ptr_opt Types.surface))) + + let get_window_title = + F.(foreign "SDL_GetWindowTitle" (Types.Window.t @-> returning string)) + + let hide_window = + F.(foreign "SDL_HideWindow" (Types.Window.t @-> returning void)) + + let maximize_window = + F.(foreign "SDL_MaximizeWindow" (Types.Window.t @-> returning void)) + + let minimize_window = + F.(foreign "SDL_MinimizeWindow" (Types.Window.t @-> returning void)) + + let raise_window = + F.(foreign "SDL_RaiseWindow" (Types.Window.t @-> returning void)) + + let restore_window = + F.(foreign "SDL_RestoreWindow" (Types.Window.t @-> returning void)) + + let set_window_bordered = + F.(foreign "SDL_SetWindowBordered" + (Types.Window.t @-> bool @-> returning void)) + + let set_window_brightness = + F.(foreign "SDL_SetWindowBrightness" + (Types.Window.t @-> float @-> returning int)) + + let set_window_display_mode = + F.(foreign "SDL_SetWindowDisplayMode" + (Types.Window.t @-> (ptr Types.display_mode) @-> returning int)) + + let set_window_fullscreen = + F.(foreign "SDL_SetWindowFullscreen" + (Types.Window.t @-> uint32_t @-> returning int)) + + let set_window_gamma_ramp = + F.(foreign "SDL_SetWindowGammaRamp" + (Types.Window.t @-> ptr (*u*)int16_t @-> ptr (*u*)int16_t @-> + ptr (*u*)int16_t @-> returning int)) + + let set_window_grab = + F.(foreign "SDL_SetWindowGrab" (Types.Window.t @-> bool @-> returning void)) + + let set_window_icon = + F.(foreign "SDL_SetWindowIcon" + (Types.Window.t @-> ptr Types.surface @-> returning void)) + + let set_window_input_focus = + F.(foreign "SDL_SetWindowInputFocus" (Types.Window.t @-> returning int)) + + let set_window_maximum_size = + F.(foreign "SDL_SetWindowMaximumSize" + (Types.Window.t @-> int @-> int @-> returning void)) + + let set_window_minimum_size = + F.(foreign "SDL_SetWindowMinimumSize" + (Types.Window.t @-> int @-> int @-> returning void)) + + let set_window_modal_for = + F.(foreign "SDL_SetWindowModalFor" + (Types.Window.t @-> Types.Window.t @-> returning int)) + + let set_window_opacity = + F.(foreign "SDL_SetWindowOpacity" + (Types.Window.t @-> float @-> returning int)) + + let set_window_position = + F.(foreign "SDL_SetWindowPosition" + (Types.Window.t @-> int @-> int @-> returning void)) + + let set_window_resizable = + F.(foreign "SDL_SetWindowResizable" + (Types.Window.t @-> bool @-> returning void)) + + let set_window_size = + F.(foreign "SDL_SetWindowSize" + (Types.Window.t @-> int @-> int @-> returning void)) + + let set_window_title = + F.(foreign "SDL_SetWindowTitle" + (Types.Window.t @-> string @-> returning void)) + + let show_window = + F.(foreign "SDL_ShowWindow" (Types.Window.t @-> returning void)) + + let update_window_surface = + F.(foreign "SDL_UpdateWindowSurface" + (Types.Window.t @-> returning int)) + + let update_window_surface_rects = + F.(foreign "SDL_UpdateWindowSurfaceRects" + (Types.Window.t @-> ptr void @-> int @-> returning int)) + + let gl_bind_texture = + F.(foreign "SDL_GL_BindTexture" + (ptr Types.Texture.t @-> ptr float @-> ptr float @-> returning int)) + + let gl_create_context = + F.(foreign "SDL_GL_CreateContext" + (Types.Window.t @-> returning (ptr_opt Types.Gl.context))) + + let gl_delete_context = + F.(foreign "SDL_GL_DeleteContext" (ptr Types.Gl.context @-> returning void)) + + let gl_extension_supported = + F.(foreign "SDL_GL_ExtensionSupported" (string @-> returning bool)) + + let gl_get_attribute = + F.(foreign "SDL_GL_GetAttribute" (int @-> (ptr int) @-> returning int)) + + let gl_get_current_context = + F.(foreign "SDL_GL_GetCurrentContext" + (void @-> returning (ptr_opt Types.Gl.context))) + + let gl_get_drawable_size = + F.(foreign "SDL_GL_GetDrawableSize" + (Types.Window.t @-> ptr int @-> ptr int @-> returning void)) + + let gl_get_swap_interval = + F.(foreign "SDL_GL_GetSwapInterval" (void @-> returning int)) + + let gl_make_current = + F.(foreign "SDL_GL_MakeCurrent" + (Types.Window.t @-> ptr Types.Gl.context @-> returning int)) + + let gl_reset_attributes = + F.(foreign "SDL_GL_ResetAttributes" (void @-> returning void)) + + let gl_set_attribute = + F.(foreign "SDL_GL_SetAttribute" (int @-> int @-> returning int)) + + let gl_set_swap_interval = + F.(foreign "SDL_GL_SetSwapInterval" (int @-> returning int)) + + let gl_swap_window = + F.(foreign "SDL_GL_SwapWindow" (Types.Window.t @-> returning void)) + + let gl_unbind_texture = + F.(foreign "SDL_GL_UnbindTexture" (ptr Types.Texture.t @-> returning int)) + + module Vulkan = struct + let load_library = + F.(foreign "SDL_Vulkan_LoadLibrary" (const_string_opt @-> returning int)) + + let unload_library = + F.(foreign "SDL_Vulkan_UnloadLibrary" (void @-> returning void)) + + let get_instance_extensions = + F.(foreign "SDL_Vulkan_GetInstanceExtensions" + (Types.Window.t @-> ptr int @-> ptr string @-> returning bool)) + + let create_surface = + F.(foreign "SDL_Vulkan_CreateSurface" + (Types.Window.t @-> ptr void @-> ptr Types.Vulkan.surface @-> + returning bool)) + + let get_drawable_size = + F.(foreign "SDL_Vulkan_GetDrawableSize" + (Types.Window.t @-> ptr int @-> ptr int @-> returning void)) + end + + let disable_screen_saver = + F.(foreign "SDL_DisableScreenSaver" (void @-> returning void)) + + let enable_screen_saver = + F.(foreign "SDL_EnableScreenSaver" (void @-> returning void)) + + let is_screen_saver_enabled = + F.(foreign "SDL_IsScreenSaverEnabled" (void @-> returning bool)) + + module Message_box = struct + let show = + F.(foreign "SDL_ShowMessageBox" + (ptr Types.Message_box.data @-> ptr int @-> returning int)) + + let show_simple = + F.(foreign "SDL_ShowSimpleMessageBox" + (uint32_t @-> string @-> string @-> Types.Window.opt @-> returning int)) + end + + let get_clipboard_text = + F.(foreign "SDL_GetClipboardText" (void @-> returning (ptr char))) + + let has_clipboard_text = + F.(foreign "SDL_HasClipboardText" (void @-> returning bool)) + + let set_clipboard_text = + F.(foreign "SDL_SetClipboardText" (string @-> returning int)) + + let scancode = int + let keycode = int + let keymod = uint16_t + + let get_keyboard_focus = + F.(foreign "SDL_GetKeyboardFocus" (void @-> returning Types.Window.opt)) + + let get_keyboard_state = + F.(foreign "SDL_GetKeyboardState" (ptr int @-> returning (ptr (const uint8_t)))) + + let get_key_from_name = + F.(foreign "SDL_GetKeyFromName" (string @-> returning keycode)) + + let get_key_from_scancode = + F.(foreign "SDL_GetKeyFromScancode" (scancode @-> returning keycode)) + + let get_key_name = + F.(foreign "SDL_GetKeyName" (keycode @-> returning string)) + + let get_mod_state = + F.(foreign "SDL_GetModState" (void @-> returning keymod)) + + let get_scancode_from_key = + F.(foreign "SDL_GetScancodeFromKey" (keycode @-> returning scancode)) + + let get_scancode_from_name = + F.(foreign "SDL_GetScancodeFromName" (string @-> returning scancode)) + + let get_scancode_name = + F.(foreign "SDL_GetScancodeName" (scancode @-> returning string)) + + let has_screen_keyboard_support = + F.(foreign "SDL_HasScreenKeyboardSupport" (void @-> returning bool)) + + let is_screen_keyboard_shown = + F.(foreign "SDL_IsScreenKeyboardShown" (Types.Window.t @-> returning bool)) + + let is_text_input_active = + F.(foreign "SDL_IsTextInputActive" (void @-> returning bool)) + + let set_mod_state = + F.(foreign "SDL_SetModState" (keymod @-> returning void)) + + let set_text_input_rect = + F.(foreign "SDL_SetTextInputRect" (ptr Types.Rect.t @-> returning void)) + + let start_text_input = + F.(foreign "SDL_StartTextInput" (void @-> returning void)) + + let stop_text_input = + F.(foreign "SDL_StopTextInput" (void @-> returning void)) + + let capture_mouse = + F.(foreign "SDL_CaptureMouse" (bool @-> returning int)) + + let create_color_cursor = + F.(foreign "SDL_CreateColorCursor" + (ptr Types.surface @-> int @-> int @-> + returning (ptr_opt Types.cursor))) + + let create_cursor = + F.(foreign "SDL_CreateCursor" + (ptr (*u*)int8_t @-> ptr (*u*)int8_t @-> int @-> int @-> int @-> + int @-> returning (ptr_opt Types.cursor))) + + let create_system_cursor = + F.(foreign "SDL_CreateSystemCursor" + (int @-> returning (ptr_opt Types.cursor))) + + let free_cursor = + F.(foreign "SDL_FreeCursor" (ptr Types.cursor @-> returning void)) + + let get_cursor = + F.(foreign "SDL_GetCursor" (void @-> returning (ptr_opt Types.cursor))) + + let get_default_cursor = + F.(foreign "SDL_GetDefaultCursor" (void @-> returning (ptr_opt Types.cursor))) + + let get_global_mouse_state = + F.(foreign "SDL_GetGlobalMouseState" + (ptr int @-> ptr int @-> returning uint32_t)) + + let get_mouse_focus = + F.(foreign "SDL_GetMouseFocus" (void @-> returning Types.Window.opt)) + + let get_mouse_state = + F.(foreign "SDL_GetMouseState" + (ptr int @-> ptr int @-> returning uint32_t)) + + let get_relative_mouse_mode = + F.(foreign "SDL_GetRelativeMouseMode" (void @-> returning bool)) + + let get_relative_mouse_state = + F.(foreign "SDL_GetRelativeMouseState" + (ptr int @-> ptr int @-> returning uint32_t)) + + let show_cursor = + F.(foreign "SDL_ShowCursor" (int @-> returning int)) + + let set_cursor = + F.(foreign "SDL_SetCursor" (ptr_opt Types.cursor @-> returning void)) + + let set_relative_mouse_mode = + F.(foreign "SDL_SetRelativeMouseMode" (bool @-> returning int)) + + let warp_mouse_in_window = + F.(foreign "SDL_WarpMouseInWindow" + (Types.Window.opt @-> int @-> int @-> returning void)) + + let warp_mouse_global= + F.(foreign "SDL_WarpMouseGlobal" (int @-> int @-> returning int)) + + let get_num_touch_devices = + F.(foreign "SDL_GetNumTouchDevices" (void @-> returning int)) + + let get_num_touch_fingers = + F.(foreign "SDL_GetNumTouchFingers" (int64_t @-> returning int)) + + let get_touch_device = + F.(foreign "SDL_GetTouchDevice" (int @-> returning int64_t)) + + let get_touch_finger = + F.(foreign "SDL_GetTouchFinger" + (int64_t @-> int @-> returning (ptr_opt Types.Finger.t))) + + let load_dollar_templates = + F.(foreign "SDL_LoadDollarTemplates" + (int64_t @-> Types.rw_ops @-> returning int)) + + let record_gesture = + F.(foreign "SDL_RecordGesture" (int64_t @-> returning int)) + + let save_dollar_template = + F.(foreign "SDL_SaveDollarTemplate" + (int64_t @-> Types.rw_ops @-> returning int)) + + let save_all_dollar_templates = + F.(foreign "SDL_SaveAllDollarTemplates" (Types.rw_ops @-> returning int)) + + let joystick_close = + F.(foreign "SDL_JoystickClose" (ptr Types.joystick @-> returning void)) + + let joystick_current_power_level = + F.(foreign "SDL_JoystickCurrentPowerLevel" + (ptr Types.joystick @-> returning int)) + + let joystick_event_state = + F.(foreign "SDL_JoystickEventState" (int @-> returning int)) + + let joystick_from_instance_id = + F.(foreign "SDL_JoystickFromInstanceID" + (int32_t @-> returning (ptr Types.joystick))) + + let joystick_get_attached = + F.(foreign "SDL_JoystickGetAttached" + (ptr Types.joystick @-> returning bool)) + + let joystick_get_axis = + F.(foreign "SDL_JoystickGetAxis" + (ptr Types.joystick @-> int @-> returning int16_t)) + + let joystick_get_axis_initial_state = + F.(foreign "SDL_JoystickGetAxisInitialState" + (ptr Types.joystick @-> int @-> ptr int16_t @-> returning bool)) + + let joystick_get_ball = + F.(foreign "SDL_JoystickGetBall" + (ptr Types.joystick @-> int @-> ptr int @-> ptr int @-> returning int)) + + let joystick_get_button = + F.(foreign "SDL_JoystickGetButton" + (ptr Types.joystick @-> int @-> returning uint8_t)) + + let joystick_get_device_guid = + F.(foreign "SDL_JoystickGetDeviceGUID" (int @-> returning Types.joystick_guid)) + + let joystick_get_device_product = + F.(foreign "SDL_JoystickGetDeviceProduct" (int @-> returning uint16_t)) + + let joystick_get_device_product_version = + F.(foreign "SDL_JoystickGetDeviceProductVersion" + (int @-> returning uint16_t)) + + let joystick_get_device_type = + F.(foreign "SDL_JoystickGetDeviceType" (int @-> returning int)) + + let joystick_get_device_instance_id = + F.(foreign "SDL_JoystickGetDeviceInstanceID" (int @-> returning int32_t)) + + let joystick_get_device_vendor = + F.(foreign "SDL_JoystickGetDeviceVendor" (int @-> returning uint16_t)) + + let joystick_get_guid = + F.(foreign "SDL_JoystickGetGUID" + (ptr Types.joystick @-> returning Types.joystick_guid)) + + let joystick_get_guid_from_string = + F.(foreign "SDL_JoystickGetGUIDFromString" + (string @-> returning Types.joystick_guid)) + + let joystick_get_guid_string = + F.(foreign "SDL_JoystickGetGUIDString" + (Types.joystick_guid @-> ptr char @-> int @-> returning void)) + + let joystick_get_hat = + F.(foreign "SDL_JoystickGetHat" + (ptr Types.joystick @-> int @-> returning uint8_t)) + + let joystick_get_product = + F.(foreign "SDL_JoystickGetProduct" + (ptr Types.joystick @-> returning uint16_t)) + + let joystick_get_product_version = + F.(foreign "SDL_JoystickGetProductVersion" + (ptr Types.joystick @-> returning uint16_t)) + + let joystick_get_type = + F.(foreign "SDL_JoystickGetType" (ptr Types.joystick @-> returning int)) + + let joystick_get_vendor = + F.(foreign "SDL_JoystickGetVendor" + (ptr Types.joystick @-> returning uint16_t)) + + let joystick_instance_id = + F.(foreign "SDL_JoystickInstanceID" + (ptr Types.joystick @-> returning int32_t)) + + let joystick_name = + F.(foreign "SDL_JoystickName" + (ptr Types.joystick @-> returning const_string_opt)) + + let joystick_name_for_index = + F.(foreign "SDL_JoystickNameForIndex" (int @-> returning const_string_opt)) + + let joystick_num_axes = + F.(foreign "SDL_JoystickNumAxes" (ptr Types.joystick @-> returning int)) + + let joystick_num_balls = + F.(foreign "SDL_JoystickNumBalls" (ptr Types.joystick @-> returning int)) + + let joystick_num_buttons = + F.(foreign "SDL_JoystickNumButtons" (ptr Types.joystick @-> returning int)) + + let joystick_num_hats = + F.(foreign "SDL_JoystickNumHats" (ptr Types.joystick @-> returning int)) + + let joystick_open = + F.(foreign "SDL_JoystickOpen" (int @-> returning (ptr_opt Types.joystick))) + + let joystick_update = + F.(foreign "SDL_JoystickUpdate" (void @-> returning void)) + + let num_joysticks = + F.(foreign "SDL_NumJoysticks" (void @-> returning int)) + + type _button_bind + let button_bind : _button_bind structure typ = + structure "SDL_GameControllerButtonBind" + let button_bind_bind_type = field button_bind "bindType" int + let button_bind_value1 = field button_bind "value1" int (* simplified enum *) + let button_bind_value2 = field button_bind "value2" int + let () = seal button_bind + + let game_controller_add_mapping = + F.(foreign "SDL_GameControllerAddMapping" (string @-> returning int)) + + let game_controller_add_mapping_from_rw = + F.(foreign "SDL_GameControllerAddMappingsFromRW" + (Types.rw_ops @-> bool @-> returning int)) + + let game_controller_close = + F.(foreign "SDL_GameControllerClose" (ptr Types.game_controller @-> returning void)) + + let game_controller_event_state = + F.(foreign "SDL_GameControllerEventState" (int @-> returning int)) + + let game_controller_from_instance_id = + F.(foreign "SDL_GameControllerFromInstanceID" + (int32_t @-> returning (ptr Types.game_controller))) + + let game_controller_get_attached = + F.(foreign "SDL_GameControllerGetAttached" + (ptr Types.game_controller @-> returning bool)) + + let game_controller_get_axis = + F.(foreign "SDL_GameControllerGetAxis" + (ptr Types.game_controller @-> int @-> returning int16_t)) + + let game_controller_get_axis_from_string = + F.(foreign "SDL_GameControllerGetAxisFromString" + (string @-> returning int)) + + let game_controller_get_bind_for_axis = + F.(foreign "SDL_GameControllerGetBindForAxis" + (ptr Types.game_controller @-> int @-> returning button_bind)) + + let game_controller_get_bind_for_button = + F.(foreign "SDL_GameControllerGetBindForButton" + (ptr Types.game_controller @-> int @-> returning button_bind)) + + let game_controller_get_button = + F.(foreign "SDL_GameControllerGetButton" + (ptr Types.game_controller @-> int @-> returning uint8_t)) + + let game_controller_get_button_from_string = + F.(foreign "SDL_GameControllerGetButtonFromString" (string @-> returning int)) + + let game_controller_get_joystick = + F.(foreign "SDL_GameControllerGetJoystick" + (ptr Types.game_controller @-> returning (ptr_opt Types.joystick))) + + let game_controller_get_product = + F.(foreign "SDL_GameControllerGetProduct" + (ptr Types.game_controller @-> returning uint16_t)) + + let game_controller_get_product_version = + F.(foreign "SDL_GameControllerGetProductVersion" + (ptr Types.game_controller @-> returning uint16_t)) + + let game_controller_get_string_for_axis = + F.(foreign "SDL_GameControllerGetStringForAxis" + (int @-> returning const_string_opt)) + + let game_controller_get_string_for_button = + F.(foreign "SDL_GameControllerGetStringForButton" + (int @-> returning const_string_opt)) + + let game_controller_get_vendor = + F.(foreign "SDL_GameControllerGetVendor" + (ptr Types.game_controller @-> returning uint16_t)) + + let game_controller_mapping = + F.(foreign "SDL_GameControllerMapping" + (ptr Types.game_controller @-> returning const_string_opt)) + + let game_controller_mapping_for_index = + F.(foreign "SDL_GameControllerMappingForIndex" + (int @-> returning const_string_opt)) + + let game_controller_mapping_for_guid = + F.(foreign "SDL_GameControllerMappingForGUID" + (Types.joystick_guid @-> returning const_string_opt)) + + let game_controller_name = + F.(foreign "SDL_GameControllerName" + (ptr Types.game_controller @-> returning const_string_opt)) + + let game_controller_name_for_index = + F.(foreign "SDL_GameControllerNameForIndex" + (int @-> returning const_string_opt)) + + let game_controller_num_mappings = + F.(foreign "SDL_GameControllerNumMappings" (void @-> returning int)) + + let game_controller_open = + F.(foreign "SDL_GameControllerOpen" + (int @-> returning (ptr_opt Types.game_controller))) + + let game_controller_update = + F.(foreign "SDL_GameControllerUpdate" (void @-> returning void)) + + let is_game_controller = + F.(foreign "SDL_IsGameController" (int @-> returning bool)) + + let event_state = + F.(foreign "SDL_EventState" (uint32_t @-> int @-> returning uint8_t)) + + let flush_event = + F.(foreign "SDL_FlushEvent" (uint32_t @-> returning void)) + + let flush_events = + F.(foreign "SDL_FlushEvents" (uint32_t @-> uint32_t @-> returning void)) + + let has_event = + F.(foreign "SDL_HasEvent" (uint32_t @-> returning bool)) + + let has_events = + F.(foreign "SDL_HasEvents" (uint32_t @-> uint32_t @-> returning bool)) + + let poll_event = + F.(foreign "SDL_PollEvent" (ptr Types.Event.t @-> returning bool)) + + let pump_events = + F.(foreign "SDL_PumpEvents" (void @-> returning void)) + + let push_event = + F.(foreign "SDL_PushEvent" (ptr Types.Event.t @-> returning int)) + + let register_events = + F.(foreign "SDL_RegisterEvents" (int @-> returning uint32_t)) + + (* Force feedback *) + + let haptic_close = + F.(foreign "SDL_HapticClose" (ptr Types.Haptic.t @-> returning void)) + + let haptic_destroy_effect = + F.(foreign "SDL_HapticDestroyEffect" + (ptr Types.Haptic.t @-> int @-> returning void)) + + let haptic_effect_supported = + F.(foreign "SDL_HapticEffectSupported" + (ptr Types.Haptic.t @-> ptr Types.Haptic.Effect.t @-> returning int)) + + let haptic_get_effect_status = + F.(foreign "SDL_HapticGetEffectStatus" + (ptr Types.Haptic.t @-> int @-> returning int)) + + let haptic_index = + F.(foreign "SDL_HapticIndex" (ptr Types.Haptic.t @-> returning int)) + + let haptic_name = + F.(foreign "SDL_HapticName" (int @-> returning const_string_opt)) + + let haptic_new_effect = + F.(foreign "SDL_HapticNewEffect" + (ptr Types.Haptic.t @-> ptr Types.Haptic.Effect.t @-> returning int)) + + let haptic_num_axes = + F.(foreign "SDL_HapticNumAxes" (ptr Types.Haptic.t @-> returning int)) + + let haptic_num_effects = + F.(foreign "SDL_HapticNumEffects" (ptr Types.Haptic.t @-> returning int)) + + let haptic_num_effects_playing = + F.(foreign "SDL_HapticNumEffectsPlaying" (ptr Types.Haptic.t @-> returning int)) + + let haptic_open = + F.(foreign "SDL_HapticOpen" (int @-> returning (ptr_opt Types.Haptic.t))) + + let haptic_open_from_joystick = + F.(foreign "SDL_HapticOpenFromJoystick" + (ptr Types.joystick @-> returning (ptr_opt Types.Haptic.t))) + + let haptic_open_from_mouse = + F.(foreign "SDL_HapticOpenFromMouse" + (void @-> returning (ptr_opt Types.Haptic.t))) + + let haptic_opened = + F.(foreign "SDL_HapticOpened" (int @-> returning int)) + + let haptic_pause = + F.(foreign "SDL_HapticPause" (ptr Types.Haptic.t @-> returning int)) + + let haptic_query = + F.(foreign "SDL_HapticQuery" (ptr Types.Haptic.t @-> returning int)) + + let haptic_rumble_init = + F.(foreign "SDL_HapticRumbleInit" (ptr Types.Haptic.t @-> returning int)) + + let haptic_rumble_play = + F.(foreign "SDL_HapticRumblePlay" + (ptr Types.Haptic.t @-> float @-> int32_t @-> returning int)) + + let haptic_rumble_stop = + F.(foreign "SDL_HapticRumbleStop" (ptr Types.Haptic.t @-> returning int)) + + let haptic_rumble_supported = + F.(foreign "SDL_HapticRumbleSupported" (ptr Types.Haptic.t @-> returning int)) + + let haptic_run_effect = + F.(foreign "SDL_HapticRunEffect" + (ptr Types.Haptic.t @-> int @-> int32_t @-> returning int)) + + let haptic_set_autocenter = + F.(foreign "SDL_HapticSetAutocenter" (ptr Types.Haptic.t @-> int @-> returning int)) + + let haptic_set_gain = + F.(foreign "SDL_HapticSetGain" (ptr Types.Haptic.t @-> int @-> returning int)) + + let haptic_stop_all = + F.(foreign "SDL_HapticStopAll" (ptr Types.Haptic.t @-> returning int)) + + let haptic_stop_effect = + F.(foreign "SDL_HapticStopEffect" + (ptr Types.Haptic.t @-> int @-> returning int)) + + let haptic_unpause = + F.(foreign "SDL_HapticUnpause" (ptr Types.Haptic.t @-> returning int)) + + let haptic_update_effect = + F.(foreign "SDL_HapticUpdateEffect" + (ptr Types.Haptic.t @-> int @-> ptr Types.Haptic.Effect.t @-> + returning int)) + + let joystick_is_haptic = + F.(foreign "SDL_JoystickIsHaptic" (ptr Types.joystick @-> returning int)) + + let mouse_is_haptic = + F.(foreign "SDL_MouseIsHaptic" (void @-> returning int)) + + let num_haptics = + F.(foreign "SDL_NumHaptics" (void @-> returning int)) + + (* Audio *) + + (* Audio drivers *) + + let audio_init = + F.(foreign "SDL_AudioInit" (const_string_opt @-> returning int)) + + let audio_quit = + F.(foreign "SDL_AudioQuit" (void @-> returning void)) + + let get_audio_driver = + F.(foreign "SDL_GetAudioDriver" (int @-> returning const_string_opt)) + + let get_current_audio_driver = + F.(foreign "SDL_GetCurrentAudioDriver" + (void @-> returning const_string_opt)) + + let get_num_audio_drivers = + F.(foreign "SDL_GetNumAudioDrivers" (void @-> returning int)) + + (* Audio devices *) + + let close_audio_device = + F.(foreign "SDL_CloseAudioDevice" (uint32_t @-> returning void)) + + let free_wav = + F.(foreign "SDL_FreeWAV" (ptr void @-> returning void)) + + let get_audio_device_name = + F.(foreign "SDL_GetAudioDeviceName" + (int @-> bool @-> returning const_string_opt)) + + let get_audio_device_status = + F.(foreign "SDL_GetAudioDeviceStatus" (uint32_t @-> returning int)) + + let get_num_audio_devices = + F.(foreign "SDL_GetNumAudioDevices" (bool @-> returning int)) + + let lock_audio_device = + F.(foreign "SDL_LockAudioDevice" (uint32_t @-> returning void)) + + let open_audio_device = + F.(foreign "SDL_OpenAudioDevice" + (const_string_opt @-> bool @-> ptr Types.audio_spec @-> + ptr Types.audio_spec @-> int @-> returning uint32_t)) + + let pause_audio_device = + F.(foreign "SDL_PauseAudioDevice" (uint32_t @-> bool @-> returning void)) + + let unlock_audio_device = + F.(foreign "SDL_UnlockAudioDevice" (uint32_t @-> returning void)) + + let queue_audio = + F.(foreign "SDL_QueueAudio" + (uint32_t @-> ptr void @-> uint32_t @-> returning int)) + + let dequeue_audio = + F.(foreign "SDL_DequeueAudio" + (uint32_t @-> ptr void @-> int @-> returning uint32_t)) + + let get_queued_audio_size = + F.(foreign "SDL_GetQueuedAudioSize" (uint32_t @-> returning uint32_t)) + + let clear_queued_audio = + F.(foreign "SDL_ClearQueuedAudio" (uint32_t @-> returning void)) + + (* Timer *) + + let get_ticks = + F.(foreign "SDL_GetTicks" (void @-> returning int32_t)) + + let get_ticks64 = + F.(foreign "SDL_GetTicks64" (void @-> returning int64_t)) + + let get_performance_counter = + F.(foreign "SDL_GetPerformanceCounter" (void @-> returning int64_t)) + + let get_performance_frequency = + F.(foreign "SDL_GetPerformanceFrequency" (void @-> returning int64_t)) + + (* Platform and CPU information *) + + let get_platform = + F.(foreign "SDL_GetPlatform" (void @-> returning string)) + + let get_cpu_cache_line_size = + F.(foreign "SDL_GetCPUCacheLineSize" (void @-> returning int)) + + let get_cpu_count = + F.(foreign "SDL_GetCPUCount" (void @-> returning int)) + + let get_system_ram = + F.(foreign "SDL_GetSystemRAM" (void @-> returning int)) + + let has_3d_now = + F.(foreign "SDL_Has3DNow" (void @-> returning bool)) + + let has_altivec = + F.(foreign "SDL_HasAltiVec" (void @-> returning bool)) + + let has_avx = + F.(foreign "SDL_HasAVX" (void @-> returning bool)) + + let has_avx2 = + F.(foreign "SDL_HasAVX2" (void @-> returning bool)) + + let has_mmx = + F.(foreign "SDL_HasMMX" (void @-> returning bool)) + + let has_neon = + F.(foreign "SDL_HasNEON" (void @-> returning bool)) + + let has_rdtsc = + F.(foreign "SDL_HasRDTSC" (void @-> returning bool)) + + let has_sse = + F.(foreign "SDL_HasSSE" (void @-> returning bool)) + + let has_sse2 = + F.(foreign "SDL_HasSSE2" (void @-> returning bool)) + + let has_sse3 = + F.(foreign "SDL_HasSSE3" (void @-> returning bool)) + + let has_sse41 = + F.(foreign "SDL_HasSSE41" (void @-> returning bool)) + + let has_sse42 = + F.(foreign "SDL_HasSSE42" (void @-> returning bool)) + + let get_power_info = + F.(foreign "SDL_GetPowerInfo" ((ptr int) @-> (ptr int) @-> returning int)) +end diff --git a/src/libtsdl_stubs.clib b/src/libtsdl_stubs.clib index 2896fab..980af69 100644 --- a/src/libtsdl_stubs.clib +++ b/src/libtsdl_stubs.clib @@ -1,2 +1,3 @@ tsdl_stubs.o async_functions_stubs.o +functions_stubs.o diff --git a/src/tsdl.ml b/src/tsdl.ml index 32fd172..9a7f506 100644 --- a/src/tsdl.ml +++ b/src/tsdl.ml @@ -6,12 +6,15 @@ let unsafe_get = Array.unsafe_get open Ctypes -open Foreign +module C = struct + module Types = Types_generated + module Async_functions = Async_function_description.Functions (Async_functions_generated) + module Functions = Function_description.Functions (Functions_generated) +end module Sdl = struct -module Types = Types_generated -module Async_functions = Async_function_description.Functions (Async_functions_generated) +(* Enum cases and #ifdef'd constants, see support/ in the distribution *) (* Formatting with continuation. *) @@ -37,52 +40,15 @@ let err_array_to_short ~exp ~fnd = (* ctypes views *) -let bool = - view ~read:((<>)0) ~write:(fun b -> compare b false) int;; - -let int_as_uint8_t = - view ~read:Unsigned.UInt8.to_int ~write:Unsigned.UInt8.of_int uint8_t - -let int_as_uint16_t = - view ~read:Unsigned.UInt16.to_int ~write:Unsigned.UInt16.of_int uint16_t - -let int_as_uint32_t = - view ~read:Unsigned.UInt32.to_int ~write:Unsigned.UInt32.of_int uint32_t - -let int_as_int32_t = - view ~read:Signed.Int32.to_int ~write:Signed.Int32.of_int int32_t - -let int32_as_uint32_t = - view ~read:Unsigned.UInt32.to_int32 ~write:Unsigned.UInt32.of_int32 uint32_t - -let string_as_char_array n = (* FIXME: drop this if ctypes proposes better *) - let n_array = array n char in - let read a = - let len = CArray.length a in - let b = Buffer.create len in - try - for i = 0 to len - 1 do - let c = CArray.get a i in - if c = '\000' then raise Exit else Buffer.add_char b c - done; - Buffer.contents b - with Exit -> Buffer.contents b - in - let write s = - let a = CArray.make char n in - let len = min (CArray.length a) (String.length s) in - for i = 0 to len - 1 do CArray.set a i (s.[i]) done; - a - in - view ~read ~write n_array - -let get_error = - foreign "SDL_GetError" (void @-> returning string) +let char_array_as_string a = + Ctypes.(string_from_ptr (CArray.start a) ~length:(CArray.length a)) (* SDL results *) type nonrec 'a result = ( 'a, [ `Msg of string ] ) result +let get_error = C.Functions.get_error + let error () = Error (`Msg (get_error ())) let zero_to_ok = function 0 -> Ok () | _ -> error () @@ -95,17 +61,13 @@ let nat_to_ok = function n when n < 0 -> error () | n -> Ok n let some_to_ok = function Some v -> Ok v | None -> error () -let sdl_free = foreign "SDL_free" (ptr void @-> returning void) +let sdl_free = C.Functions.sdl_free (* Since we never let SDL redefine our main make sure this is always called. *) let () = - let set_main_ready = foreign "SDL_SetMainReady" (void @-> returning void) in - set_main_ready () - -let stub = true - + C.Functions.set_main_ready () (* Integer types and maps *) @@ -160,99 +122,93 @@ let access_ptr_typ_of_ba_kind : ('a, 'b) Bigarray.kind -> 'a ptr typ = fun k -> module Init = struct type t = Unsigned.uint32 - let i = Unsigned.UInt32.of_int let ( + ) = Unsigned.UInt32.logor let ( - ) f f' = Unsigned.UInt32.(logand f (lognot f')) let test f m = Unsigned.UInt32.(compare (logand f m) zero <> 0) let eq f f' = Unsigned.UInt32.(compare f f' = 0) - let nothing = i 0 - include Types.Init + let nothing = Unsigned.UInt32.zero + include C.Types.Init end -let init = - foreign "SDL_Init" (uint32_t @-> returning int) -let init n = init n |> zero_to_ok +let init n = zero_to_ok (C.Functions.init n) -let init_sub_system = - foreign "SDL_InitSubSystem" (uint32_t @-> returning int) -let init_sub_system n = init_sub_system n |> zero_to_ok +let init_sub_system n = zero_to_ok (C.Functions.init_sub_system n) -let quit = - foreign "SDL_Quit" (void @-> returning void) +let quit = C.Functions.quit -let quit_sub_system = - foreign "SDL_QuitSubSystem" (uint32_t @-> returning void) - -let was_init = - foreign "SDL_WasInit" (uint32_t @-> returning uint32_t) +let quit_sub_system = C.Functions.quit_sub_system let was_init = function -| None -> was_init (Unsigned.UInt32.of_int 0) -| Some m -> was_init m +| None -> C.Functions.was_init (Unsigned.UInt32.of_int 0) +| Some m -> C.Functions.was_init m (* Hints *) module Hint = struct type t = string - let audio_resampling_mode = Tsdl_consts.sdl_hint_audio_resampling_mode - let framebuffer_acceleration = Tsdl_consts.sdl_hint_framebuffer_acceleration - let idle_timer_disabled = Tsdl_consts.sdl_hint_idle_timer_disabled - let orientations = Tsdl_consts.sdl_hint_orientations - let mouse_focus_clickthrough = Tsdl_consts.sdl_hint_mouse_focus_clickthrough - let mouse_normal_speed_scale = Tsdl_consts.sdl_hint_mouse_normal_speed_scale - let mouse_relative_speed_scale = Tsdl_consts.sdl_hint_mouse_relative_speed_scale - let render_driver = Tsdl_consts.sdl_hint_render_driver - let render_logical_size_mode = Tsdl_consts.sdl_hint_render_logical_size_mode - let render_opengl_shaders = Tsdl_consts.sdl_hint_render_opengl_shaders - let render_scale_quality = Tsdl_consts.sdl_hint_render_scale_quality - let render_vsync = Tsdl_consts.sdl_hint_render_vsync - let no_signal_handlers = Tsdl_consts.sdl_hint_no_signal_handlers - let thread_stack_size = Tsdl_consts.sdl_hint_thread_stack_size - let touch_mouse_events = Tsdl_consts.sdl_hint_touch_mouse_events - let mouse_touch_events = Tsdl_consts.sdl_hint_mouse_touch_events + let audio_resampling_mode = + char_array_as_string (!@ C.Functions.Hint.audio_resampling_mode) + let framebuffer_acceleration = + char_array_as_string (!@ C.Functions.Hint.framebuffer_acceleration) + let idle_timer_disabled = + char_array_as_string (!@ C.Functions.Hint.idle_timer_disabled) + let orientations = char_array_as_string (!@ C.Functions.Hint.orientations) + let mouse_focus_clickthrough = + char_array_as_string (!@ C.Functions.Hint.mouse_focus_clickthrough) + let mouse_normal_speed_scale = + char_array_as_string (!@ C.Functions.Hint.mouse_normal_speed_scale) + let mouse_relative_speed_scale = + char_array_as_string (!@ C.Functions.Hint.mouse_relative_speed_scale) + let render_driver = char_array_as_string (!@ C.Functions.Hint.render_driver) + let render_logical_size_mode = + char_array_as_string (!@ C.Functions.Hint.render_logical_size_mode) + let render_opengl_shaders = + char_array_as_string (!@ C.Functions.Hint.render_opengl_shaders) + let render_scale_quality = + char_array_as_string (!@ C.Functions.Hint.render_scale_quality) + let render_vsync = char_array_as_string (!@ C.Functions.Hint.render_vsync) + let no_signal_handlers = + char_array_as_string (!@ C.Functions.Hint.no_signal_handlers) + let thread_stack_size = + char_array_as_string (!@ C.Functions.Hint.thread_stack_size) + let touch_mouse_events = + char_array_as_string (!@ C.Functions.Hint.touch_mouse_events) + let mouse_touch_events = + char_array_as_string (!@ C.Functions.Hint.mouse_touch_events) let window_frame_usable_while_cursor_hidden = - Tsdl_consts.sdl_hint_window_frame_usable_while_cursor_hidden + char_array_as_string + (!@ C.Functions.Hint.window_frame_usable_while_cursor_hidden) type priority = int - - include Types.Hint + include C.Types.Hint end -let clear_hints = - foreign "SDL_ClearHints" (void @-> returning void) +let clear_hints = C.Functions.clear_hints -let get_hint = - foreign "SDL_GetHint" (string @-> returning string_opt) +let get_hint x = C.Functions.get_hint x -let get_hint_boolean = - foreign "SDL_GetHintBoolean" (string @-> bool @-> returning bool) +let get_hint_boolean = C.Functions.get_hint_boolean -let set_hint = - foreign "SDL_SetHint" (string @-> string @-> returning bool) +let set_hint = C.Functions.set_hint -let set_hint_with_priority = - foreign "SDL_SetHintWithPriority" - (string @-> string @-> int @-> returning bool) +let set_hint_with_priority = C.Functions.set_hint_with_priority (* Errors *) -let clear_error = - foreign "SDL_ClearError" (void @-> returning void) - -let set_error = - foreign "SDL_SetError" (string @-> returning int) +let clear_error = C.Functions.clear_error let set_error fmt = - kpp (fun s -> ignore (set_error s)) fmt + kpp (fun s -> ignore (C.Functions.set_error s)) fmt (* Log *) module Log = struct type category = int + type priority = int let priority_compare : int -> int -> int = compare - include Types.Log + include C.Types.Log end external log_message : int -> int -> string -> unit = "ocaml_tsdl_log_message" @@ -266,365 +222,286 @@ let log_error c fmt = log_message c Log.priority_error fmt let log_verbose c fmt = log_message c Log.priority_verbose fmt let log_warn c fmt = log_message c Log.priority_warn fmt -let log_get_priority = - foreign "SDL_LogGetPriority" (int @-> returning int) +let log_get_priority = C.Functions.log_get_priority -let log_reset_priorities = - foreign "SDL_LogResetPriorities" (void @-> returning void) +let log_reset_priorities = C.Functions.log_reset_priorities -let log_set_all_priority = - foreign "SDL_LogSetAllPriority" (int @-> returning void) +let log_set_all_priority = C.Functions.log_set_all_priority -let log_set_priority = - foreign "SDL_LogSetPriority" (int @-> int @-> returning void) +let log_set_priority = C.Functions.log_set_priority (* Version *) - -let get_version = - foreign "SDL_GetVersion" (ptr Types.version @-> returning void) - let get_version () = let get v f = Unsigned.UInt8.to_int (getf v f) in - let v = make Types.version in - get_version (addr v); - (get v Types.version_major), - (get v Types.version_minor), - (get v Types.version_patch) + let v = make C.Types.version in + C.Functions.get_version (addr v); + C.Types.((get v version_major), (get v version_minor), (get v version_patch)) -let get_revision = - foreign "SDL_GetRevision" (void @-> returning string) +let get_revision = C.Functions.get_revision -(* IO absraction *) - -type rw_ops = Types.rw_ops - -let load_file_rw = - foreign "SDL_LoadFile_RW" - (Types.rw_ops @-> ptr int @-> bool @-> returning string_opt) +type rw_ops = C.Types.rw_ops let load_file_rw rw_ops close = - load_file_rw rw_ops (coerce (ptr void) (ptr int) null) close |> some_to_ok - -let rw_from_file = - foreign "SDL_RWFromFile" - (string @-> string @-> returning Types.rw_ops_opt) - let rw_from_file x y = rw_from_file x y |> some_to_ok + some_to_ok (C.Functions.load_file_rw + rw_ops (coerce (ptr void) (ptr size_t) null) close) -let rw_from_const_mem = - foreign "SDL_RWFromConstMem" - (ocaml_string @-> int @-> returning Types.rw_ops_opt) +let rw_from_file x y = some_to_ok (C.Functions.rw_from_file x y) -let rw_from_const_mem str = rw_from_const_mem - (ocaml_string_start str) (String.length str) |> some_to_ok - -let rw_from_mem = - foreign "SDL_RWFromMem" - (ocaml_bytes @-> int @-> returning Types.rw_ops_opt) +let rw_from_const_mem str = + some_to_ok (C.Functions.rw_from_const_mem + (ocaml_string_start str) (String.length str)) let rw_from_mem b = - rw_from_mem (ocaml_bytes_start b) (Bytes.length b) |> some_to_ok + some_to_ok (C.Functions.rw_from_mem (ocaml_bytes_start b) (Bytes.length b)) let load_file filename = (* defined as a macro in SDL_rwops.h *) match rw_from_file filename "rb" with | Error _ as e -> e | Ok rw -> load_file_rw rw true -let rw_close = - foreign "SDL_RWclose" (Types.rw_ops @-> returning int) - let rw_close ops = - if rw_close ops = 0 then Ok () else (error ()) + if C.Functions.rw_close ops = 0 then Ok () else (error ()) -let unsafe_rw_ops_of_ptr addr : Types.rw_ops = - from_voidp Types.rw_ops_struct (ptr_of_raw_address addr) +let unsafe_rw_ops_of_ptr addr : C.Types.rw_ops = + from_voidp C.Types.rw_ops_struct (ptr_of_raw_address addr) let unsafe_ptr_of_rw_ops rw_ops = raw_address_of_ptr (to_voidp rw_ops) (* File system paths *) -let get_base_path = - foreign "SDL_GetBasePath" (void @-> returning (ptr char)) - let get_base_path () = - let p = get_base_path () in + let p = C.Functions.get_base_path () in let path = coerce (ptr char) string_opt p in sdl_free (coerce (ptr char) (ptr void) p); - path |> some_to_ok - -let get_pref_path = - foreign "SDL_GetPrefPath" (string @-> string @-> returning (ptr char)) + some_to_ok path let get_pref_path ~org ~app = - let p = get_pref_path org app in + let p = C.Functions.get_pref_path org app in let path = coerce (ptr char) string_opt p in sdl_free (coerce (ptr char) (ptr void) p); - path |> some_to_ok - -(* Video *) - -type window = Types.Window.t - -let unsafe_window_of_ptr addr : window = - from_voidp Types.Window.raw (ptr_of_raw_address addr) -let unsafe_ptr_of_window window = - raw_address_of_ptr (to_voidp window) + some_to_ok path (* Colors *) -type color = Types.Color.t - module Color = struct let create ~r ~g ~b ~a = - let c = make Types.Color.t in - setf c Types.Color.r (Unsigned.UInt8.of_int r); - setf c Types.Color.g (Unsigned.UInt8.of_int g); - setf c Types.Color.b (Unsigned.UInt8.of_int b); - setf c Types.Color.a (Unsigned.UInt8.of_int a); + let c = make C.Types.Color.t in + setf c C.Types.Color.r (Unsigned.UInt8.of_int r); + setf c C.Types.Color.g (Unsigned.UInt8.of_int g); + setf c C.Types.Color.b (Unsigned.UInt8.of_int b); + setf c C.Types.Color.a (Unsigned.UInt8.of_int a); c - let r c = Unsigned.UInt8.to_int (getf c Types.Color.r) - let g c = Unsigned.UInt8.to_int (getf c Types.Color.g) - let b c = Unsigned.UInt8.to_int (getf c Types.Color.b) - let a c = Unsigned.UInt8.to_int (getf c Types.Color.a) + let r c = Unsigned.UInt8.to_int (getf c C.Types.Color.r) + let g c = Unsigned.UInt8.to_int (getf c C.Types.Color.g) + let b c = Unsigned.UInt8.to_int (getf c C.Types.Color.b) + let a c = Unsigned.UInt8.to_int (getf c C.Types.Color.a) - let set_r c r = setf c Types.Color.r (Unsigned.UInt8.of_int r) - let set_g c g = setf c Types.Color.g (Unsigned.UInt8.of_int g) - let set_b c b = setf c Types.Color.b (Unsigned.UInt8.of_int b) - let set_a c a = setf c Types.Color.a (Unsigned.UInt8.of_int a) + let set_r c r = setf c C.Types.Color.r (Unsigned.UInt8.of_int r) + let set_g c g = setf c C.Types.Color.g (Unsigned.UInt8.of_int g) + let set_b c b = setf c C.Types.Color.b (Unsigned.UInt8.of_int b) + let set_a c a = setf c C.Types.Color.a (Unsigned.UInt8.of_int a) end -(* Points *) +type color = C.Types.Color.t +let color = C.Types.Color.t -type point = Types.Point.t +(* Points *) +type point = C.Types.Point.t module Point = struct let create ~x ~y = - let p = make Types.Point.t in - setf p Types.Point.x x; - setf p Types.Point.y y; + let p = make C.Types.Point.t in + setf p C.Types.Point.x x; + setf p C.Types.Point.y y; p - let x p = getf p Types.Point.x - let y p = getf p Types.Point.y + let x p = getf p C.Types.Point.x + let y p = getf p C.Types.Point.y - let set_x p x = setf p Types.Point.x x - let set_y p y = setf p Types.Point.y y + let set_x p x = setf p C.Types.Point.x x + let set_y p y = setf p C.Types.Point.y y let opt_addr = function - | None -> coerce (ptr void) (ptr Types.Point.t) null + | None -> coerce (ptr void) (ptr C.Types.Point.t) null | Some v -> addr v end (* Float Points *) - -type fpoint = Types.Fpoint.t +type fpoint = C.Types.Fpoint.t module Fpoint = struct let create ~x ~y = - let p = make Types.Fpoint.t in - setf p Types.Fpoint.x x; - setf p Types.Fpoint.y y; + let p = make C.Types.Fpoint.t in + setf p C.Types.Fpoint.x x; + setf p C.Types.Fpoint.y y; p - let x p = getf p Types.Fpoint.x - let y p = getf p Types.Fpoint.y + let x p = getf p C.Types.Fpoint.x + let y p = getf p C.Types.Fpoint.y - let set_x p x = setf p Types.Fpoint.x x - let set_y p y = setf p Types.Fpoint.y y + let set_x p x = setf p C.Types.Fpoint.x x + let set_y p y = setf p C.Types.Fpoint.y y end (* Vertices *) -type vertex = Types.Vertex.t +type vertex = C.Types.Vertex.t module Vertex = struct + open C.Types + let create ~position ~color ~tex_coord = - let v = make Types.Vertex.t in - setf v Types.Vertex.position position; - setf v Types.Vertex.color color; - setf v Types.Vertex.tex_coord tex_coord; + let v = make Vertex.t in + setf v Vertex.position position; + setf v Vertex.color color; + setf v Vertex.tex_coord tex_coord; v - let position v = getf v Types.Vertex.position - let color v = getf v Types.Vertex.color - let tex_coord v = getf v Types.Vertex.tex_coord + let position v = getf v Vertex.position + let color v = getf v Vertex.color + let tex_coord v = getf v Vertex.tex_coord - let set_position v position = setf v Types.Vertex.position position - let set_color v color = setf v Types.Vertex.color color - let set_tex_coord v tex_coord = setf v Types.Vertex.tex_coord tex_coord + let set_position v position = setf v Vertex.position position + let set_color v color = setf v Vertex.color color + let set_tex_coord v tex_coord = setf v Vertex.tex_coord tex_coord end (* Rectangle *) -type rect = Types.Rect.t +type rect = C.Types.Rect.t module Rect = struct let create ~x ~y ~w ~h = - let r = make Types.Rect.t in - setf r Types.Rect.x x; - setf r Types.Rect.y y; - setf r Types.Rect.w w; - setf r Types.Rect.h h; + let r = make C.Types.Rect.t in + setf r C.Types.Rect.x x; + setf r C.Types.Rect.y y; + setf r C.Types.Rect.w w; + setf r C.Types.Rect.h h; r - let x r = getf r Types.Rect.x - let y r = getf r Types.Rect.y - let w r = getf r Types.Rect.w - let h r = getf r Types.Rect.h + let x r = getf r C.Types.Rect.x + let y r = getf r C.Types.Rect.y + let w r = getf r C.Types.Rect.w + let h r = getf r C.Types.Rect.h - let set_x r x = setf r Types.Rect.x x - let set_y r y = setf r Types.Rect.y y - let set_w r w = setf r Types.Rect.w w - let set_h r h = setf r Types.Rect.h h + let set_x r x = setf r C.Types.Rect.x x + let set_y r y = setf r C.Types.Rect.y y + let set_w r w = setf r C.Types.Rect.w w + let set_h r h = setf r C.Types.Rect.h h let opt_addr = function - | None -> coerce (ptr void) (ptr Types.Rect.t) null + | None -> coerce (ptr void) (ptr C.Types.Rect.t) null | Some v -> addr v end (* Float Rectangle *) -type frect = Types.Frect.t +type frect = C.Types.Frect.t module Frect = struct let create ~x ~y ~w ~h = - let r = make Types.Frect.t in - setf r Types.Frect.x x; - setf r Types.Frect.y y; - setf r Types.Frect.w w; - setf r Types.Frect.h h; + let r = make C.Types.Frect.t in + setf r C.Types.Frect.x x; + setf r C.Types.Frect.y y; + setf r C.Types.Frect.w w; + setf r C.Types.Frect.h h; r - let x r = getf r Types.Frect.x - let y r = getf r Types.Frect.y - let w r = getf r Types.Frect.w - let h r = getf r Types.Frect.h + let x r = getf r C.Types.Frect.x + let y r = getf r C.Types.Frect.y + let w r = getf r C.Types.Frect.w + let h r = getf r C.Types.Frect.h - let set_x r x = setf r Types.Frect.x x - let set_y r y = setf r Types.Frect.y y - let set_w r w = setf r Types.Frect.w w - let set_h r h = setf r Types.Frect.h h + let set_x r x = setf r C.Types.Frect.x x + let set_y r y = setf r C.Types.Frect.y y + let set_w r w = setf r C.Types.Frect.w w + let set_h r h = setf r C.Types.Frect.h h end -let enclose_points = - foreign "SDL_EnclosePoints" - (ptr void @-> int @-> ptr Types.Rect.t @-> ptr Types.Rect.t @-> returning bool) - let enclose_points_ba ?clip ps = let len = Bigarray.Array1.dim ps in if len mod 2 <> 0 then invalid_arg (err_length_mul len 2) else let count = len / 2 in let ps = to_voidp (bigarray_start array1 ps) in - let res = make Types.Rect.t in - if enclose_points ps count (Rect.opt_addr clip) (addr res) + let res = make C.Types.Rect.t in + if C.Functions.enclose_points ps count (Rect.opt_addr clip) (addr res) then Some res else None let enclose_points ?clip ps = - let a = CArray.of_list Types.Point.t ps in + let a = CArray.of_list C.Types.Point.t ps in let ps = to_voidp (CArray.start a) in - let res = make Types.Rect.t in - if enclose_points ps (CArray.length a) (Rect.opt_addr clip) (addr res) + let res = make C.Types.Rect.t in + if C.Functions.enclose_points ps (CArray.length a) (Rect.opt_addr clip) (addr res) then Some res else None -let has_intersection = - foreign "SDL_HasIntersection" - (ptr Types.Rect.t @-> ptr Types.Rect.t @-> returning bool) - let has_intersection a b = - has_intersection (addr a) (addr b) - -let intersect_rect = - foreign "SDL_IntersectRect" - (ptr Types.Rect.t @-> ptr Types.Rect.t @-> ptr Types.Rect.t @-> returning bool) + C.Functions.has_intersection (addr a) (addr b) let intersect_rect a b = - let res = make Types.Rect.t in - if intersect_rect (addr a) (addr b) (addr res) then Some res else None - -let intersect_rect_and_line = - foreign "SDL_IntersectRectAndLine" - (ptr Types.Rect.t @-> ptr int @-> ptr int @-> ptr int @-> ptr int @-> - returning bool) + let res = make C.Types.Rect.t in + if C.Functions.intersect_rect (addr a) (addr b) (addr res) + then Some res + else None let intersect_rect_and_line r x1 y1 x2 y2 = let alloc v = allocate int v in let x1, y1 = alloc x1, alloc y1 in let x2, y2 = alloc x2, alloc y2 in - if intersect_rect_and_line (addr r) x1 y1 x2 y2 + if C.Functions.intersect_rect_and_line (addr r) x1 y1 x2 y2 then Some ((!@x1, !@y1), (!@x2, !@y2)) else None -let point_in_rect p r = - (* SDL_FORCE_INLINE *) - let px = Point.x p in - let py = Point.y p in - let rx = Rect.x r in - let ry = Rect.y r in - px >= rx && px < rx + Rect.w r && py >= ry && py < ry + Rect.h r - -let rect_empty r = - (* symbol doesn't exist: SDL_FORCE_INLINE directive - foreign "SDL_RectEmpty" (ptr rect @-> returning bool) *) - Rect.w r <= 0 || Rect.h r <= 0 - -let rect_equals a b = - (* symbol doesn't exist: SDL_FORCE_INLINE directive - foreign "SDL_RectEquals" (ptr rect @-> ptr rect @-> returning bool) *) - (Rect.x a = Rect.x b) && (Rect.y a = Rect.y b) && - (Rect.w a = Rect.w b) && (Rect.h a = Rect.h b) - -let union_rect = - foreign "SDL_UnionRect" - (ptr Types.Rect.t @-> ptr Types.Rect.t @-> ptr Types.Rect.t @-> returning void) +let point_in_rect p r = C.Functions.point_in_rect (addr p) (addr r) + +let rect_empty r = C.Functions.rect_empty (addr r) + +let rect_equals a b = C.Functions.rect_equals (addr a) (addr b) let union_rect a b = - let res = make Types.Rect.t in - union_rect (addr a) (addr b) (addr res); + let res = make C.Types.Rect.t in + C.Functions.union_rect (addr a) (addr b) (addr res); res (* Palettes *) -type palette = Types.palette ptr +type palette = C.Types.palette ptr let unsafe_palette_of_ptr addr : palette = - from_voidp Types.palette (ptr_of_raw_address addr) + from_voidp C.Types.palette (ptr_of_raw_address addr) let unsafe_ptr_of_palette palette = raw_address_of_ptr (to_voidp palette) -let alloc_palette = - foreign "SDL_AllocPalette" - (int @-> returning (ptr_opt Types.palette)) -let alloc_palette x = alloc_palette x |> some_to_ok +let alloc_palette x = some_to_ok (C.Functions.alloc_palette x) -let free_palette = - foreign "SDL_FreePalette" (ptr Types.palette @-> returning void) +let free_palette = C.Functions.free_palette let get_palette_ncolors p = - getf (!@ p) Types.palette_ncolors + getf (!@ p) C.Types.palette_ncolors let get_palette_colors p = let ps = !@ p in CArray.to_list - (CArray.from_ptr (getf ps Types.palette_colors) (getf ps Types.palette_ncolors)) + (CArray.from_ptr + (getf ps C.Types.palette_colors) + (getf ps C.Types.palette_ncolors)) let get_palette_colors_ba p = let ps = !@ p in (* FIXME: ctypes should have a CArray.copy function *) - let n = getf ps Types.palette_ncolors in + let n = getf ps C.Types.palette_ncolors in let ba = Bigarray.(Array1.create int8_unsigned c_layout (n * 4)) in let ba_ptr = - CArray.from_ptr (coerce (ptr int) (ptr Types.Color.t) (bigarray_start array1 ba)) n + CArray.from_ptr (coerce (ptr int) (ptr color) (bigarray_start array1 ba)) n in - let ca = CArray.from_ptr (getf ps Types.palette_colors) n in + let ca = CArray.from_ptr (getf ps C.Types.palette_colors) n in for i = 0 to n - 1 do CArray.set ba_ptr i (CArray.get ca i) done; ba -let set_palette_colors = - foreign "SDL_SetPaletteColors" - (ptr Types.palette @-> ptr void @-> int @-> int @-> returning int) - let set_palette_colors x y z t = set_palette_colors x y z t |> zero_to_ok +let set_palette_colors x y z t = + zero_to_ok (C.Functions.set_palette_colors x y z t) let set_palette_colors_ba p cs ~fst = let len = Bigarray.Array1.dim cs in @@ -634,160 +511,126 @@ let set_palette_colors_ba p cs ~fst = set_palette_colors p cs fst count let set_palette_colors p cs ~fst = - let a = CArray.of_list Types.Color.t cs in + let a = CArray.of_list color cs in set_palette_colors p (to_voidp (CArray.start a)) fst (CArray.length a) (* Pixel formats *) type gamma_ramp = (int, Bigarray.int16_unsigned_elt) bigarray -let calculate_gamma_ramp = - foreign "SDL_CalculateGammaRamp" - (float @-> ptr void @-> returning void) - let calculate_gamma_ramp g = let ba = Bigarray.(Array1.create int16_unsigned c_layout 256) in - calculate_gamma_ramp g (to_voidp (bigarray_start array1 ba)); + C.Functions.calculate_gamma_ramp g (bigarray_start array1 ba); ba module Blend = struct - type factor = int type operation = int - include Types.Blend + type factor = int + include C.Types.Blend end -let compose_custom_blend_mode = - foreign "SDL_ComposeCustomBlendMode" - (int @-> int @-> int @-> int @-> int @-> int @-> returning uint) +let compose_custom_blend_mode = C.Functions.compose_custom_blend_mode module Pixel = struct type format_enum = Unsigned.UInt32.t - let i = Unsigned.UInt32.of_int32 let to_uint32 = Unsigned.UInt32.to_int32 let eq f f' = Unsigned.UInt32.(compare f f' = 0) - include Types.Pixel + include C.Types.Pixel end (* Note. Giving direct access to the palette field of SDL_PixelFormat is problematic. We can't ensure the pointer won't become invalid at a certain point. *) -type pixel_format = Types.pixel_format ptr +type pixel_format = C.Types.pixel_format ptr let unsafe_pixel_format_of_ptr addr : pixel_format = - from_voidp Types.pixel_format (ptr_of_raw_address addr) + from_voidp C.Types.pixel_format (ptr_of_raw_address addr) let unsafe_ptr_of_pixel_format pixel_format = raw_address_of_ptr (to_voidp pixel_format) -let alloc_format = - foreign "SDL_AllocFormat" - (uint32_t @-> returning (ptr_opt Types.pixel_format)) - let alloc_format x = alloc_format x |> some_to_ok +let alloc_format x = some_to_ok (C.Functions.alloc_format x) -let free_format = - foreign "SDL_FreeFormat" (ptr Types.pixel_format @-> returning void) +let free_format = C.Functions.free_format -let get_pixel_format_name = - foreign "SDL_GetPixelFormatName" (uint32_t @-> returning string) +let get_pixel_format_name = C.Functions.get_pixel_format_name let get_pixel_format_format pf = - getf (!@ pf) Types.pf_format + getf (!@ pf) C.Types.pf_format let get_pixel_format_bits_pp pf = - Unsigned.UInt8.to_int (getf (!@ pf) Types.pf_bits_per_pixel) + Unsigned.UInt8.to_int (getf (!@ pf) C.Types.pf_bits_per_pixel) let get_pixel_format_bytes_pp pf = - Unsigned.UInt8.to_int (getf (!@ pf) Types.pf_bytes_per_pixel) - -let get_rgb = - foreign "SDL_GetRGB" - (int32_as_uint32_t @-> ptr Types.pixel_format @-> ptr uint8_t @-> - ptr uint8_t @-> ptr uint8_t @-> returning void) + Unsigned.UInt8.to_int (getf (!@ pf) C.Types.pf_bytes_per_pixel) let get_rgb pf p = let alloc () = allocate uint8_t Unsigned.UInt8.zero in let to_int = Unsigned.UInt8.to_int in let r, g, b = alloc (), alloc (), alloc () in - get_rgb p pf r g b; + C.Functions.get_rgb (Unsigned.UInt32.of_int32 p) pf r g b; to_int (!@ r), to_int (!@ g), to_int (!@ b) -let get_rgba = - foreign "SDL_GetRGBA" - (int32_as_uint32_t @-> ptr Types.pixel_format @-> ptr uint8_t @-> - ptr uint8_t @-> ptr uint8_t @-> ptr uint8_t @-> returning void) - let get_rgba pf p = let alloc () = allocate uint8_t Unsigned.UInt8.zero in let to_int = Unsigned.UInt8.to_int in let r, g, b, a = alloc (), alloc (), alloc (), alloc () in - get_rgba p pf r g b a; + C.Functions.get_rgba (Unsigned.UInt32.of_int32 p) pf r g b a; to_int (!@ r), to_int (!@ g), to_int (!@ b), to_int (!@ a) -let map_rgb = - foreign "SDL_MapRGB" - (ptr Types.pixel_format @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> - returning int32_as_uint32_t) - -let map_rgba = - foreign "SDL_MapRGBA" - (ptr Types.pixel_format @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> - int_as_uint8_t @-> returning int32_as_uint32_t) - -let masks_to_pixel_format_enum = - foreign "SDL_MasksToPixelFormatEnum" - (int @-> int32_as_uint32_t @-> int32_as_uint32_t @-> int32_as_uint32_t @-> - int32_as_uint32_t @-> returning uint32_t) - -let pixel_format_enum_to_masks = - foreign "SDL_PixelFormatEnumToMasks" - (uint32_t @-> ptr int @-> - ptr uint32_t @-> ptr uint32_t @-> ptr uint32_t @-> ptr uint32_t @-> - returning bool) - let pixel_format_enum_to_masks pf = let ui () = allocate uint32_t (Unsigned.UInt32.of_int 0) in let get iptr = Unsigned.UInt32.to_int32 (!@ iptr) in let bpp = allocate int 0 in let rm, gm, bm, am = ui (), ui (), ui (), ui () in - if not (pixel_format_enum_to_masks pf bpp rm gm bm am) then error () else - Ok (!@ bpp, get rm, get gm, get bm, get am) - -let set_pixel_format_palette = - foreign "SDL_SetPixelFormatPalette" - (ptr Types.pixel_format @-> ptr Types.palette @-> returning int) -let set_pixel_format_palette x y = set_pixel_format_palette x y |> zero_to_ok + if not (C.Functions.pixel_format_enum_to_masks pf bpp rm gm bm am) + then error () + else Ok (!@ bpp, get rm, get gm, get bm, get am) + +let map_rgb pf r g b = + Unsigned.UInt32.to_int32 + (C.Functions.map_rgb + pf + (Unsigned.UInt8.of_int r) + (Unsigned.UInt8.of_int g) + (Unsigned.UInt8.of_int b)) + +let map_rgba pf r g b a = + Unsigned.UInt32.to_int32 + (C.Functions.map_rgba + pf + (Unsigned.UInt8.of_int r) + (Unsigned.UInt8.of_int g) + (Unsigned.UInt8.of_int b) + (Unsigned.UInt8.of_int a)) + +let masks_to_pixel_format_enum bpp rm gm bm am = + C.Functions.masks_to_pixel_format_enum + bpp + (Unsigned.UInt32.of_int32 rm) + (Unsigned.UInt32.of_int32 gm) + (Unsigned.UInt32.of_int32 bm) + (Unsigned.UInt32.of_int32 am) + +let set_pixel_format_palette x y = + zero_to_ok (C.Functions.set_pixel_format_palette x y) (* Surface *) -type surface = Types.surface ptr -let surface : surface typ = ptr Types.surface -let surface_opt : surface option typ = ptr_opt Types.surface +type surface = C.Types.surface ptr let unsafe_surface_of_ptr addr : surface = - from_voidp Types.surface (ptr_of_raw_address addr) + from_voidp C.Types.surface (ptr_of_raw_address addr) let unsafe_ptr_of_surface surface = raw_address_of_ptr (to_voidp surface) -let blit_scaled = - (* SDL_BlitScaled is #ifdef'd to SDL_UpperBlitScaled *) - foreign "SDL_UpperBlitScaled" - (surface @-> ptr Types.Rect.t @-> surface @-> ptr Types.Rect.t @-> returning int) - let blit_scaled ~src sr ~dst dr = - blit_scaled src (Rect.opt_addr sr) dst (Rect.opt_addr dr) |> zero_to_ok - -let blit_surface = - (* SDL_BlitSurface is #ifdef'd to SDL_UpperBlit *) - foreign "SDL_UpperBlit" - (surface @-> ptr Types.Rect.t @-> surface @-> ptr Types.Rect.t @-> returning int) + zero_to_ok + (C.Functions.blit_scaled src (Rect.opt_addr sr) dst (Rect.opt_addr dr)) let blit_surface ~src sr ~dst dr = - blit_surface src (Rect.opt_addr sr) dst (Rect.opt_addr dr) |> zero_to_ok - -let convert_pixels = - foreign "SDL_ConvertPixels" - (int @-> int @-> uint32_t @-> ptr void @-> int @-> uint32_t @-> - ptr void @-> int @-> returning int) + zero_to_ok + (C.Functions.blit_surface src (Rect.opt_addr sr) dst (Rect.opt_addr dr)) let convert_pixels ~w ~h ~src sp spitch ~dst dp dpitch = (* FIXME: we could try check bounds. *) @@ -795,145 +638,101 @@ let convert_pixels ~w ~h ~src sp spitch ~dst dp dpitch = let dpitch = ba_kind_byte_size (Bigarray.Array1.kind dp) * dpitch in let sp = to_voidp (bigarray_start array1 sp) in let dp = to_voidp (bigarray_start array1 dp) in - convert_pixels w h src sp spitch dst dp dpitch |> zero_to_ok - -let convert_surface = - foreign "SDL_ConvertSurface" - (surface @-> ptr Types.pixel_format @-> uint32_t @-> - returning surface_opt) + zero_to_ok (C.Functions.convert_pixels w h src sp spitch dst dp dpitch) let convert_surface s pf = - convert_surface s pf Unsigned.UInt32.zero |> some_to_ok - -let convert_surface_format = - foreign "SDL_ConvertSurfaceFormat" - (surface @-> uint32_t @-> uint32_t @-> returning surface_opt) + some_to_ok (C.Functions.convert_surface s pf Unsigned.UInt32.zero) let convert_surface_format s pf = - convert_surface_format s pf Unsigned.UInt32.zero |> some_to_ok - -let create_rgb_surface = - foreign "SDL_CreateRGBSurface" - (uint32_t @-> int @-> int @-> int @-> int32_as_uint32_t @-> - int32_as_uint32_t @-> int32_as_uint32_t @-> int32_as_uint32_t @-> - returning surface_opt) + some_to_ok (C.Functions.convert_surface_format s pf Unsigned.UInt32.zero) let create_rgb_surface ~w ~h ~depth rmask gmask bmask amask = - create_rgb_surface Unsigned.UInt32.zero w h depth rmask gmask bmask amask |> some_to_ok - -let create_rgb_surface_from = - foreign "SDL_CreateRGBSurfaceFrom" - (ptr void @-> int @-> int @-> int @-> int @-> int32_as_uint32_t @-> - int32_as_uint32_t @-> int32_as_uint32_t @-> int32_as_uint32_t @-> - returning surface_opt) + some_to_ok + (C.Functions.create_rgb_surface + Unsigned.UInt32.zero w h depth + (Unsigned.UInt32.of_int32 rmask) + (Unsigned.UInt32.of_int32 gmask) + (Unsigned.UInt32.of_int32 bmask) + (Unsigned.UInt32.of_int32 amask)) let create_rgb_surface_from p ~w ~h ~depth ~pitch rmask gmask bmask amask = (* FIXME: we could try check bounds. *) let pitch = ba_kind_byte_size (Bigarray.Array1.kind p) * pitch in let p = to_voidp (bigarray_start array1 p) in - create_rgb_surface_from p w h depth pitch rmask gmask bmask amask |> some_to_ok - -let create_rgb_surface_with_format = - foreign "SDL_CreateRGBSurfaceWithFormat" - (uint32_t @-> int @-> int @-> int @-> uint32_t @-> - returning surface_opt) + some_to_ok + (C.Functions.create_rgb_surface_from + p w h depth pitch + (Unsigned.UInt32.of_int32 rmask) + (Unsigned.UInt32.of_int32 gmask) + (Unsigned.UInt32.of_int32 bmask) + (Unsigned.UInt32.of_int32 amask)) let create_rgb_surface_with_format ~w ~h ~depth format = - create_rgb_surface_with_format Unsigned.UInt32.zero w h depth format |> some_to_ok - -let create_rgb_surface_with_format_from = - foreign "SDL_CreateRGBSurfaceWithFormatFrom" - (ptr void @-> int @-> int @-> int @-> int @-> uint32_t @-> - returning surface_opt) + some_to_ok + (C.Functions.create_rgb_surface_with_format + Unsigned.UInt32.zero w h depth format) let create_rgb_surface_with_format_from p ~w ~h ~depth ~pitch format = (* FIXME: check bounds? *) let pitch = ba_kind_byte_size (Bigarray.Array1.kind p) * pitch in let p = to_voidp (bigarray_start array1 p) in - create_rgb_surface_with_format_from p w h depth pitch format |> some_to_ok - -let duplicate_surface = - foreign "SDL_DuplicateSurface" (surface @-> returning surface) + some_to_ok + (C.Functions.create_rgb_surface_with_format_from p w h depth pitch format) -let fill_rect = - foreign "SDL_FillRect" - (surface @-> ptr Types.Rect.t @-> int32_as_uint32_t @-> returning int) +let duplicate_surface = C.Functions.duplicate_surface let fill_rect s r c = - fill_rect s (Rect.opt_addr r) c |> zero_to_ok - -let fill_rects = - foreign "SDL_FillRects" - (surface @-> ptr void @-> int @-> int32_as_uint32_t @-> - returning int) + zero_to_ok + (C.Functions.fill_rect s (Rect.opt_addr r) (Unsigned.UInt32.of_int32 c)) let fill_rects_ba s rs col = let len = Bigarray.Array1.dim rs in if len mod 4 <> 0 then invalid_arg (err_length_mul len 4) else let count = len / 4 in let rs = to_voidp (bigarray_start array1 rs) in - fill_rects s rs count col |> zero_to_ok + zero_to_ok (C.Functions.fill_rects s rs count (Unsigned.UInt32.of_int32 col)) let fill_rects s rs col = - let a = CArray.of_list Types.Rect.t rs in - fill_rects s (to_voidp (CArray.start a)) (CArray.length a) col |> zero_to_ok - -let free_surface = - foreign "SDL_FreeSurface" (surface @-> returning void) + let a = CArray.of_list C.Types.Rect.t rs in + let col = Unsigned.UInt32.of_int32 col in + zero_to_ok + (C.Functions.fill_rects s (to_voidp (CArray.start a)) (CArray.length a) col) -let get_clip_rect = - foreign "SDL_GetClipRect" (surface @-> ptr Types.Rect.t @-> returning void) +let free_surface = C.Functions.free_surface let get_clip_rect s = - let r = make Types.Rect.t in - (get_clip_rect s (addr r); r) - -let get_color_key = - foreign "SDL_GetColorKey" - (surface @-> ptr uint32_t @-> returning int) + let r = make C.Types.Rect.t in + (C.Functions.get_clip_rect s (addr r); r) let get_color_key s = let key = allocate uint32_t Unsigned.UInt32.zero in - match get_color_key s key with + match C.Functions.get_color_key s key with | 0 -> Ok (Unsigned.UInt32.to_int32 (!@ key)) | _ -> error () -let get_surface_alpha_mod = - foreign "SDL_GetSurfaceAlphaMod" - (surface @-> ptr uint8_t @-> returning int) - let get_surface_alpha_mod s = let alpha = allocate uint8_t Unsigned.UInt8.zero in - match get_surface_alpha_mod s alpha with + match C.Functions.get_surface_alpha_mod s alpha with | 0 -> Ok (Unsigned.UInt8.to_int (!@ alpha)) | _ -> error () -let get_surface_blend_mode = - foreign "SDL_GetSurfaceBlendMode" - (surface @-> ptr uint @-> returning int) - let get_surface_blend_mode s = - let mode = allocate uint Unsigned.UInt.zero in - match get_surface_blend_mode s mode with + let mode = allocate Blend.mode Blend.mode_invalid in + match C.Functions.get_surface_blend_mode s mode with 0 -> Ok (!@ mode) | _ -> error () -let get_surface_color_mod = - foreign "SDL_GetSurfaceColorMod" - (surface @-> ptr uint8_t @-> ptr uint8_t @-> ptr uint8_t @-> - returning int) - let get_surface_color_mod s = let alloc () = allocate uint8_t Unsigned.UInt8.zero in let get v = Unsigned.UInt8.to_int (!@ v) in let r, g, b = alloc (), alloc (), alloc () in - match get_surface_color_mod s r g b with + match C.Functions.get_surface_color_mod s r g b with | 0 -> Ok (get r, get g, get b) | _ -> error () let get_surface_format_enum s = (* We don't give direct access to the format field. This prevents memory ownership problems. *) - get_pixel_format_format (getf (!@ s) Types.surface_format) + get_pixel_format_format (getf (!@ s) C.Types.surface_format) let get_surface_pitch s = - getf (!@ s) Types.surface_pitch + getf (!@ s) C.Types.surface_pitch let get_surface_pixels s kind = let pitch = get_surface_pitch s in @@ -941,21 +740,17 @@ let get_surface_pixels s kind = if pitch mod kind_size <> 0 then invalid_arg (err_bigarray_pitch pitch kind_size) else - let h = getf (!@ s) Types.surface_h in + let h = getf (!@ s) C.Types.surface_h in let ba_size = (pitch * h) / kind_size in - let pixels = getf (!@ s) Types.surface_pixels in + let pixels = getf (!@ s) C.Types.surface_pixels in let pixels = coerce (ptr void) (access_ptr_typ_of_ba_kind kind) pixels in bigarray_of_ptr array1 ba_size kind pixels let get_surface_size s = - getf (!@ s) Types.surface_w, getf (!@ s) Types.surface_h - -let load_bmp_rw = - foreign "SDL_LoadBMP_RW" - (Types.rw_ops @-> bool @-> returning surface_opt) + getf (!@ s) C.Types.surface_w, getf (!@ s) C.Types.surface_h let load_bmp_rw rw ~close = - load_bmp_rw rw close |> some_to_ok + some_to_ok (C.Functions.load_bmp_rw rw close) let load_bmp file = (* SDL_LoadBMP is cpp based *) @@ -963,30 +758,17 @@ let load_bmp file = | Error _ as e -> e | Ok rw -> load_bmp_rw rw ~close:true -let lock_surface = - foreign "SDL_LockSurface" (surface @-> returning int) -let lock_surface x = lock_surface x |> zero_to_ok - -let lower_blit = - foreign "SDL_LowerBlit" - (surface @-> ptr Types.Rect.t @-> surface @-> ptr Types.Rect.t @-> returning int) +let lock_surface x = zero_to_ok (C.Functions.lock_surface x) let lower_blit ~src sr ~dst dr = - lower_blit src (addr sr) dst (addr dr) |> zero_to_ok - -let lower_blit_scaled = - foreign "SDL_LowerBlitScaled" - (surface @-> ptr Types.Rect.t @-> surface @-> ptr Types.Rect.t @-> returning int) + zero_to_ok (C.Functions.lower_blit src (addr sr) dst (addr dr)) let lower_blit_scaled ~src sr ~dst dr = - lower_blit_scaled src (addr sr) dst (addr dr) |> zero_to_ok - -let save_bmp_rw = - foreign "SDL_SaveBMP_RW" - (surface @-> Types.rw_ops @-> bool @-> returning int) + zero_to_ok + (C.Functions.lower_blit_scaled src (addr sr) dst (addr dr)) let save_bmp_rw s rw ~close = - save_bmp_rw s rw close |> zero_to_ok + zero_to_ok (C.Functions.save_bmp_rw s rw close) let save_bmp s file = (* SDL_SaveBMP is cpp based *) @@ -994,75 +776,59 @@ let save_bmp s file = | Error _ as e -> e | Ok rw -> save_bmp_rw s rw ~close:true -let set_clip_rect = - foreign "SDL_SetClipRect" (surface @-> ptr Types.Rect.t @-> returning bool) - let set_clip_rect s r = - set_clip_rect s (addr r) + C.Functions.set_clip_rect s (addr r) -let set_color_key = - foreign "SDL_SetColorKey" - (surface @-> bool @-> int32_as_uint32_t @-> returning int) -let set_color_key s b x = set_color_key s b x |> zero_to_ok +let set_color_key s b x = + zero_to_ok (C.Functions.set_color_key s b (Unsigned.UInt32.of_int32 x)) -let set_surface_alpha_mod = - foreign "SDL_SetSurfaceAlphaMod" - (surface @-> int_as_uint8_t @-> returning int) -let set_surface_alpha_mod s x = set_surface_alpha_mod s x |> zero_to_ok +let set_surface_alpha_mod s x = + zero_to_ok (C.Functions.set_surface_alpha_mod s (Unsigned.UInt8.of_int x)) -let set_surface_blend_mode = - foreign "SDL_SetSurfaceBlendMode" - (surface @-> uint @-> returning int) -let set_surface_blend_mode s x = set_surface_blend_mode s x |> zero_to_ok +let set_surface_blend_mode s x = + zero_to_ok (C.Functions.set_surface_blend_mode s x) -let set_surface_color_mod = - foreign "SDL_SetSurfaceColorMod" - (surface @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> - returning int) -let set_surface_color_mod s x y z = set_surface_color_mod s x y z |> zero_to_ok +let set_surface_color_mod s x y z = + zero_to_ok + (C.Functions.set_surface_color_mod + s + (Unsigned.UInt8.of_int x) + (Unsigned.UInt8.of_int y) + (Unsigned.UInt8.of_int z)) -let set_surface_palette = - foreign "SDL_SetSurfacePalette" - (surface @-> ptr Types.palette @-> returning int) -let set_surface_palette s p = set_surface_palette s p |> zero_to_ok +let set_surface_palette s p = + zero_to_ok (C.Functions.set_surface_palette s p) -let set_surface_rle = - foreign "SDL_SetSurfaceRLE" (surface @-> bool @-> returning int) -let set_surface_rle s b = set_surface_rle s b |> zero_to_ok +let set_surface_rle s b = + zero_to_ok (C.Functions.set_surface_rle s b) -let unlock_surface = - foreign "SDL_UnlockSurface" (surface @-> returning void) +let unlock_surface = C.Functions.unlock_surface (* Renderers *) type flip = int module Flip = struct let ( + ) = ( lor ) - include Types.Flip + include C.Types.Flip end -type texture = unit ptr -let texture : texture typ = ptr void -let texture_opt : texture option typ = ptr_opt void +type texture = C.Types.Texture.t ptr let unsafe_texture_of_ptr addr : texture = - ptr_of_raw_address addr + from_voidp C.Types.Texture.t (ptr_of_raw_address addr) let unsafe_ptr_of_texture texture = raw_address_of_ptr (to_voidp texture) module Renderer = struct type flags = Unsigned.uint32 - let i = Unsigned.UInt32.of_int let ( + ) = Unsigned.UInt32.logor let ( - ) f f' = Unsigned.UInt32.(logand f (lognot f')) let test f m = Unsigned.UInt32.(compare (logand f m) zero <> 0) let eq f f' = Unsigned.UInt32.(compare f f' = 0) - include Types.Renderer + include C.Types.Renderer end type renderer = Renderer.t ptr -let renderer : renderer typ = ptr Renderer.t -let renderer_opt : renderer option typ = ptr_opt Renderer.t let unsafe_renderer_of_ptr addr : renderer = from_voidp Renderer.t (Ctypes.ptr_of_raw_address addr) @@ -1077,266 +843,176 @@ type renderer_info = ri_max_texture_height : int; } let renderer_info_of_c c = - let ri_name = getf c Types.ri_name in - let ri_flags = getf c Types.ri_flags in - let num_tf = Unsigned.UInt32.to_int (getf c Types.ri_num_tf) in - let tfs = getf c Types.ri_tfs in + let ri_name = getf c C.Types.ri_name in + let ri_flags = getf c C.Types.ri_flags in + let num_tf = Unsigned.UInt32.to_int (getf c C.Types.ri_num_tf) in + let tfs = getf c C.Types.ri_tfs in let ri_texture_formats = let acc = ref [] in for i = 0 to num_tf - 1 do acc := (CArray.get tfs i) :: !acc done; List.rev !acc in - let ri_max_texture_width = getf c Types.ri_max_texture_width in - let ri_max_texture_height = getf c Types.ri_max_texture_height in + let ri_max_texture_width = getf c C.Types.ri_max_texture_width in + let ri_max_texture_height = getf c C.Types.ri_max_texture_height in { ri_name; ri_flags; ri_texture_formats; ri_max_texture_width; ri_max_texture_height } -let create_renderer = - foreign "SDL_CreateRenderer" - (Types.Window.t @-> int @-> uint32_t @-> returning renderer_opt) - let create_renderer ?(index = -1) ?(flags = Unsigned.UInt32.zero) w = - create_renderer w index flags |> some_to_ok + some_to_ok (C.Functions.create_renderer w index flags) -let create_software_renderer = - foreign "SDL_CreateSoftwareRenderer" - (surface @-> returning renderer_opt) -let create_software_renderer s = create_software_renderer s |> some_to_ok +let create_software_renderer s = + some_to_ok (C.Functions.create_software_renderer s) -let destroy_renderer = - foreign "SDL_DestroyRenderer" (renderer @-> returning void) +let destroy_renderer = C.Functions.destroy_renderer -let get_num_render_drivers = - foreign "SDL_GetNumRenderDrivers" (void @-> returning int) -let get_num_render_drivers () = get_num_render_drivers () |> nat_to_ok - -let get_render_draw_blend_mode = - foreign "SDL_GetRenderDrawBlendMode" - (renderer @-> ptr uint @-> returning int) +let get_num_render_drivers () = + nat_to_ok (C.Functions.get_num_render_drivers ()) let get_render_draw_blend_mode r = - let m = allocate uint Unsigned.UInt.zero in - match get_render_draw_blend_mode r m with + let m = allocate Blend.mode Blend.mode_invalid in + match C.Functions.get_render_draw_blend_mode r m with | 0 -> Ok !@m | _ -> error () -let get_render_draw_color = - foreign "SDL_GetRenderDrawColor" - (renderer @-> ptr uint8_t @-> ptr uint8_t @-> ptr uint8_t @-> - ptr uint8_t @-> returning int) - let get_render_draw_color rend = let alloc () = allocate uint8_t Unsigned.UInt8.zero in let get v = Unsigned.UInt8.to_int (!@ v) in let r, g, b, a = alloc (), alloc (), alloc (), alloc () in - match get_render_draw_color rend r g b a with + match C.Functions.get_render_draw_color rend r g b a with | 0 -> Ok (get r, get g, get b, get a) | _ -> error () -let get_render_driver_info = - foreign "SDL_GetRenderDriverInfo" - (int @-> ptr Types.renderer_info @-> returning int) - let get_render_driver_info i = - let info = make Types.renderer_info in - match get_render_driver_info i (addr info) with + let info = make C.Types.renderer_info in + match C.Functions.get_render_driver_info i (addr info) with | 0 -> Ok (renderer_info_of_c info) | _ -> error () -let get_render_target = - foreign "SDL_GetRenderTarget" (renderer @-> returning texture_opt) +let get_render_target = C.Functions.get_render_target -let get_renderer = - foreign "SDL_GetRenderer" - (Types.Window.t @-> returning renderer_opt) -let get_renderer w = get_renderer w |> some_to_ok - -let get_renderer_info = - foreign "SDL_GetRendererInfo" - (renderer @-> ptr Types.renderer_info @-> returning int) +let get_renderer w = + some_to_ok (C.Functions.get_renderer w) let get_renderer_info r = - let info = make Types.renderer_info in - match get_renderer_info r (addr info) with + let info = make C.Types.renderer_info in + match C.Functions.get_renderer_info r (addr info) with | 0 -> Ok (renderer_info_of_c info) | _ -> error () -let get_renderer_output_size = - foreign "SDL_GetRendererOutputSize" - (renderer @-> ptr int @-> ptr int @-> returning int) - let get_renderer_output_size r = let w = allocate int 0 in let h = allocate int 0 in - match get_renderer_output_size r w h with + match C.Functions.get_renderer_output_size r w h with | 0 -> Ok (!@ w, !@ h) | _ -> error () -let render_clear = - foreign "SDL_RenderClear" (renderer @-> returning int) -let render_clear r = render_clear r |> zero_to_ok - -let render_copy = - foreign "SDL_RenderCopy" - (renderer @-> texture @-> ptr Types.Rect.t @-> ptr Types.Rect.t @-> - returning int) +let render_clear r = + zero_to_ok (C.Functions.render_clear r) let render_copy ?src ?dst r t = - render_copy r t (Rect.opt_addr src) (Rect.opt_addr dst) |> zero_to_ok - -let render_copy_ex = - foreign "SDL_RenderCopyEx" - (renderer @-> texture @-> ptr Types.Rect.t @-> ptr Types.Rect.t @-> double @-> - ptr Types.Point.t @-> int @-> returning int) + zero_to_ok + (C.Functions.render_copy r t (Rect.opt_addr src) (Rect.opt_addr dst)) let render_copy_ex ?src ?dst r t angle c flip = - render_copy_ex r t (Rect.opt_addr src) (Rect.opt_addr dst) angle - (Point.opt_addr c) flip |> zero_to_ok - -let render_draw_line = - foreign "SDL_RenderDrawLine" - (renderer @-> int @-> int @-> int @-> int @-> returning int) -let render_draw_line r a b c d = render_draw_line r a b c d |> zero_to_ok + zero_to_ok + (C.Functions.render_copy_ex r t (Rect.opt_addr src) (Rect.opt_addr dst) + angle (Point.opt_addr c) flip) -let render_draw_line_f = - foreign "SDL_RenderDrawLineF" - (renderer @-> float @-> float @-> float @-> float @-> returning int) -let render_draw_line_f r a b c d = render_draw_line_f r a b c d |> zero_to_ok +let render_draw_line r a b c d = + zero_to_ok (C.Functions.render_draw_line r a b c d) -let render_draw_lines = - foreign "SDL_RenderDrawLines" - (renderer @-> ptr void @-> int @-> returning int) +let render_draw_line_f r a b c d = + zero_to_ok (C.Functions.render_draw_line_f r a b c d) let render_draw_lines_ba r ps = let len = Bigarray.Array1.dim ps in if len mod 2 <> 0 then invalid_arg (err_length_mul len 2) else let count = len / 2 in let ps = to_voidp (bigarray_start array1 ps) in - render_draw_lines r ps count |> zero_to_ok + zero_to_ok (C.Functions.render_draw_lines r ps count) let render_draw_lines r ps = - let a = CArray.of_list Types.Point.t ps in - render_draw_lines r (to_voidp (CArray.start a)) (CArray.length a) |> zero_to_ok - -let render_draw_point = - foreign "SDL_RenderDrawPoint" - (renderer @-> int @-> int @-> returning int) -let render_draw_point r a b = render_draw_point r a b |> zero_to_ok + let a = CArray.of_list C.Types.Point.t ps in + zero_to_ok (C.Functions.render_draw_lines + r (to_voidp (CArray.start a)) (CArray.length a)) -let render_draw_points = - foreign "SDL_RenderDrawPoints" - (renderer @-> ptr void @-> int @-> returning int) +let render_draw_point r a b = + zero_to_ok (C.Functions.render_draw_point r a b) let render_draw_points_ba r ps = let len = Bigarray.Array1.dim ps in if len mod 2 <> 0 then invalid_arg (err_length_mul len 2) else let count = len / 2 in let ps = to_voidp (bigarray_start array1 ps) in - render_draw_points r ps count |> zero_to_ok + zero_to_ok (C.Functions.render_draw_points r ps count) let render_draw_points r ps = - let a = CArray.of_list Types.Point.t ps in - render_draw_points r (to_voidp (CArray.start a)) (CArray.length a) |> zero_to_ok + let a = CArray.of_list C.Types.Point.t ps in + zero_to_ok (C.Functions.render_draw_points + r (to_voidp (CArray.start a)) (CArray.length a)) -let render_draw_point_f = - foreign "SDL_RenderDrawPointF" - (renderer @-> float @-> float @-> returning int) -let render_draw_point_f r a b = render_draw_point_f r a b |> zero_to_ok - -let render_draw_points_f = - foreign "SDL_RenderDrawPointsF" - (renderer @-> ptr void @-> int @-> returning int) +let render_draw_point_f r a b = + zero_to_ok (C.Functions.render_draw_point_f r a b) let render_draw_points_f_ba r ps = let len = Bigarray.Array1.dim ps in if len mod 2 <> 0 then invalid_arg (err_length_mul len 2) else let count = len / 2 in let ps = to_voidp (bigarray_start array1 ps) in - render_draw_points_f r ps count |> zero_to_ok + zero_to_ok (C.Functions.render_draw_points_f r ps count) let render_draw_points_f r ps = - let a = CArray.of_list Types.Fpoint.t ps in - render_draw_points_f r (to_voidp (CArray.start a)) (CArray.length a) |> zero_to_ok - -let render_draw_rect = - foreign "SDL_RenderDrawRect" - (renderer @-> ptr Types.Rect.t @-> returning int) + let a = CArray.of_list C.Types.Fpoint.t ps in + zero_to_ok (C.Functions.render_draw_points_f + r (to_voidp (CArray.start a)) (CArray.length a)) let render_draw_rect rend r = - render_draw_rect rend (Rect.opt_addr r) |> zero_to_ok - -let render_draw_rects = - foreign "SDL_RenderDrawRects" - (renderer @-> ptr void @-> int @-> returning int) + zero_to_ok (C.Functions.render_draw_rect rend (Rect.opt_addr r)) let render_draw_rects_ba r rs = let len = Bigarray.Array1.dim rs in if len mod 4 <> 0 then invalid_arg (err_length_mul len 4) else let count = len / 4 in let rs = to_voidp (bigarray_start array1 rs) in - render_draw_rects r rs count |> zero_to_ok + zero_to_ok (C.Functions.render_draw_rects r rs count) let render_draw_rects r rs = - let a = CArray.of_list Types.Rect.t rs in - render_draw_rects r (to_voidp (CArray.start a)) (CArray.length a) |> zero_to_ok - -let render_fill_rect = - foreign "SDL_RenderFillRect" - (renderer @-> ptr Types.Rect.t @-> returning int) + let a = CArray.of_list C.Types.Rect.t rs in + zero_to_ok (C.Functions.render_draw_rects + r (to_voidp (CArray.start a)) (CArray.length a)) let render_fill_rect rend r = - render_fill_rect rend (Rect.opt_addr r) |> zero_to_ok - -let render_fill_rects = - foreign "SDL_RenderFillRects" - (renderer @-> ptr void @-> int @-> returning int) + zero_to_ok (C.Functions.render_fill_rect rend (Rect.opt_addr r)) let render_fill_rects_ba r rs = let len = Bigarray.Array1.dim rs in if len mod 4 <> 0 then invalid_arg (err_length_mul len 4) else let count = len / 4 in let rs = to_voidp (bigarray_start array1 rs) in - render_fill_rects r rs count |> zero_to_ok + zero_to_ok (C.Functions.render_fill_rects r rs count) let render_fill_rects r rs = - let a = CArray.of_list Types.Rect.t rs in - render_fill_rects r (to_voidp (CArray.start a)) (CArray.length a) |> zero_to_ok - -let render_geometry = - foreign "SDL_RenderGeometry" - (renderer @-> texture @-> ptr void @-> int @-> ptr void @-> int @-> - returning int) + let a = CArray.of_list C.Types.Rect.t rs in + zero_to_ok (C.Functions.render_fill_rects + r (to_voidp (CArray.start a)) (CArray.length a)) let render_geometry ?indices ?texture r vertices = - let a1 = CArray.of_list Types.Vertex.t vertices in - let t = match texture with - | None -> null | Some texture -> texture - in + let a1 = CArray.of_list C.Types.Vertex.t vertices in let a2_ptr, a2_len = match indices with - | None -> (null, 0) + | None -> (None, 0) | Some is -> let a2 = CArray.of_list int is in - (to_voidp (CArray.start a2), CArray.length a2) + (Some (CArray.start a2), CArray.length a2) in - render_geometry - r t (to_voidp (CArray.start a1)) (CArray.length a1) a2_ptr a2_len |> zero_to_ok - -let render_geometry_raw = - foreign "SDL_RenderGeometryRaw" - (renderer @-> texture @-> - ptr void @-> int @-> - ptr void @-> int @-> - ptr void @-> int @-> - int @-> ptr void @-> int @-> int @-> returning int) + zero_to_ok + (C.Functions.render_geometry + r texture (CArray.start a1) (CArray.length a1) a2_ptr a2_len) let render_geometry_raw ?indices ?texture r ~xy ?(xy_stride = 8) ~color ?(color_stride = 4) ~uv ?(uv_stride = 8) ~num_vertices () = - let t = match texture with - | None -> null | Some texture -> texture - in let i_ptr, i_len = match indices with | None -> null, 0 | Some is -> to_voidp (bigarray_start array1 is), Bigarray.Array1.dim is in let i_stride = 4 in (* indices are assumed to be 4-byte integers *) - let xy_ptr = to_voidp (bigarray_start array1 xy) in + let xy_ptr = bigarray_start array1 xy in let xy_len_bytes = Bigarray.Array1.dim xy * 4 in let xy_exp_bytes = num_vertices * xy_stride - (xy_stride - 8) in if xy_len_bytes < xy_exp_bytes then begin @@ -1352,7 +1028,7 @@ let render_geometry_raw in invalid_arg msg end; - let uv_ptr = to_voidp (bigarray_start array1 uv) in + let uv_ptr = bigarray_start array1 uv in let uv_len_bytes = Bigarray.Array1.dim uv * 4 in let uv_exp_bytes = num_vertices * uv_stride - (uv_stride - 8) in if uv_len_bytes < uv_exp_bytes then begin @@ -1361,197 +1037,122 @@ let render_geometry_raw in invalid_arg msg end; - render_geometry_raw - r t xy_ptr xy_stride color_ptr color_stride uv_ptr uv_stride num_vertices - i_ptr i_len i_stride |> zero_to_ok - -let render_get_clip_rect = - foreign "SDL_RenderGetClipRect" - (renderer @-> ptr Types.Rect.t @-> returning void) + zero_to_ok + (C.Functions.render_geometry_raw + r texture xy_ptr xy_stride color_ptr color_stride uv_ptr uv_stride + num_vertices i_ptr i_len i_stride) let render_get_clip_rect rend = - let r = make Types.Rect.t in - render_get_clip_rect rend (addr r); + let r = make C.Types.Rect.t in + C.Functions.render_get_clip_rect rend (addr r); r -let render_is_clip_enabled = - foreign "SDL_RenderIsClipEnabled" (renderer @-> returning bool) - -let render_get_integer_scale = - foreign "SDL_RenderGetIntegerScale" - (renderer @-> returning bool) +let render_is_clip_enabled = C.Functions.render_is_clip_enabled -let render_get_logical_size = - foreign "SDL_RenderGetLogicalSize" - (renderer @-> ptr int @-> ptr int @-> returning void) +let render_get_integer_scale = C.Functions.render_get_integer_scale let render_get_logical_size r = let w = allocate int 0 in let h = allocate int 0 in - render_get_logical_size r w h; + C.Functions.render_get_logical_size r w h; !@ w, !@ h -let render_get_scale = - foreign "SDL_RenderGetScale" - (renderer @-> ptr float @-> ptr float @-> returning void) - let render_get_scale r = let x = allocate float 0. in let y = allocate float 0. in - render_get_scale r x y; + C.Functions.render_get_scale r x y; !@ x, !@ y -let render_get_viewport = - foreign "SDL_RenderGetViewport" - (renderer @-> ptr Types.Rect.t @-> returning void) - let render_get_viewport rend = - let r = make Types.Rect.t in - render_get_viewport rend (addr r); + let r = make C.Types.Rect.t in + C.Functions.render_get_viewport rend (addr r); r -let render_present = Async_functions.render_present - -let render_read_pixels = - foreign "SDL_RenderReadPixels" - (renderer @-> ptr Types.Rect.t @-> uint32_t @-> ptr void @-> int @-> - returning int) +let render_present = C.Async_functions.render_present let render_read_pixels r rect format pixels pitch = let format = match format with None -> Unsigned.UInt32.zero | Some f -> f in let pixels = to_voidp (bigarray_start array1 pixels) in - render_read_pixels r (Rect.opt_addr rect) format pixels pitch |> zero_to_ok - -let render_set_clip_rect = - foreign "SDL_RenderSetClipRect" - (renderer @-> ptr Types.Rect.t @-> returning int) + zero_to_ok (C.Functions.render_read_pixels + r (Rect.opt_addr rect) format pixels pitch) let render_set_clip_rect rend r = - render_set_clip_rect rend (Rect.opt_addr r) |> zero_to_ok - -let render_set_integer_scale = - foreign "SDL_RenderSetIntegerScale" - (renderer @-> bool @-> returning int) -let render_set_integer_scale r b = render_set_integer_scale r b |> zero_to_ok + zero_to_ok (C.Functions.render_set_clip_rect rend (Rect.opt_addr r)) -let render_set_logical_size = - foreign "SDL_RenderSetLogicalSize" - (renderer @-> int @-> int @-> returning int) -let render_set_logical_size r x y = render_set_logical_size r x y |> zero_to_ok +let render_set_integer_scale r b = + zero_to_ok (C.Functions.render_set_integer_scale r b) -let render_set_scale = - foreign "SDL_RenderSetScale" - (renderer @-> float @-> float @-> returning int) -let render_set_scale r x y = render_set_scale r x y |> zero_to_ok +let render_set_logical_size r x y = + zero_to_ok (C.Functions.render_set_logical_size r x y) -let render_set_viewport = - foreign "SDL_RenderSetViewport" - (renderer @-> ptr Types.Rect.t @-> returning int) +let render_set_scale r x y = + zero_to_ok (C.Functions.render_set_scale r x y) let render_set_viewport rend r = - render_set_viewport rend (Rect.opt_addr r) |> zero_to_ok + zero_to_ok (C.Functions.render_set_viewport rend (Rect.opt_addr r)) -let render_target_supported = - foreign "SDL_RenderTargetSupported" (renderer @-> returning bool) +let render_target_supported = C.Functions.render_target_supported -let set_render_draw_blend_mode = - foreign "SDL_SetRenderDrawBlendMode" - (renderer @-> uint @-> returning int) -let set_render_draw_blend_mode r x = set_render_draw_blend_mode r x |> zero_to_ok +let set_render_draw_blend_mode r x = + zero_to_ok (C.Functions.set_render_draw_blend_mode r x) -let set_render_draw_color = - foreign "SDL_SetRenderDrawColor" - (renderer @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> - int_as_uint8_t @-> returning int) -let set_render_draw_color r a b c d = set_render_draw_color r a b c d |> zero_to_ok - -let set_render_target = - foreign "SDL_SetRenderTarget" - (renderer @-> texture @-> returning int) +let set_render_draw_color r a b c d = + zero_to_ok (C.Functions.set_render_draw_color r + (Unsigned.UInt8.of_int a) + (Unsigned.UInt8.of_int b) + (Unsigned.UInt8.of_int c) + (Unsigned.UInt8.of_int d)) let set_render_target r t = - let t = match t with None -> null | Some t -> t in - set_render_target r t |> zero_to_ok + zero_to_ok (C.Functions.set_render_target r t) (* Textures *) module Texture = struct type access = int - let i = Unsigned.UInt32.of_int type modulate = Unsigned.uint32 - include Types.Texture + include C.Types.Texture end -let create_texture = - foreign "SDL_CreateTexture" - (renderer @-> uint32_t @-> int @-> int @-> int @-> - returning texture_opt) - let create_texture r pf access ~w ~h = - create_texture r pf access w h |> some_to_ok - -let create_texture_from_surface = - foreign "SDL_CreateTextureFromSurface" - (renderer @-> surface @-> returning texture_opt) -let create_texture_from_surface r s = create_texture_from_surface r s |> some_to_ok + some_to_ok (C.Functions.create_texture r pf access w h) -let destroy_texture = - foreign "SDL_DestroyTexture" (texture @-> returning void) +let create_texture_from_surface r s = + some_to_ok (C.Functions.create_texture_from_surface r s) -let get_texture_alpha_mod = - foreign "SDL_GetTextureAlphaMod" - (texture @-> ptr uint8_t @-> returning int) +let destroy_texture = C.Functions.destroy_texture let get_texture_alpha_mod t = let alpha = allocate uint8_t Unsigned.UInt8.zero in - match get_texture_alpha_mod t alpha with + match C.Functions.get_texture_alpha_mod t alpha with | 0 -> Ok (Unsigned.UInt8.to_int (!@ alpha)) | _ -> error () -let get_texture_blend_mode = - foreign "SDL_GetTextureBlendMode" - (texture @-> ptr uint @-> returning int) - let get_texture_blend_mode t = - let m = allocate uint Unsigned.UInt.zero in - match get_texture_blend_mode t m with + let m = allocate Blend.mode Blend.mode_invalid in + match C.Functions.get_texture_blend_mode t m with | 0 -> Ok (!@ m) | _ -> error () -let get_texture_color_mod = - foreign "SDL_GetTextureColorMod" - (texture @-> ptr uint8_t @-> ptr uint8_t @-> ptr uint8_t @-> - returning int) - let get_texture_color_mod t = let alloc () = allocate uint8_t Unsigned.UInt8.zero in let get v = Unsigned.UInt8.to_int (!@ v) in let r, g, b = alloc (), alloc (), alloc () in - match get_texture_color_mod t r g b with + match C.Functions.get_texture_color_mod t r g b with | 0 -> Ok (get r, get g, get b) | _ -> error () -let query_texture = - foreign "SDL_QueryTexture" - (texture @-> ptr uint32_t @-> ptr int @-> ptr int @-> ptr int @-> - returning int) - let _texture_height t = let h = allocate int 0 in let unull = coerce (ptr void) (ptr uint32_t) null in let inull = coerce (ptr void) (ptr int) null in - match query_texture t unull inull inull h with + match C.Functions.query_texture t unull inull inull h with | 0 -> Ok (!@ h) | _ -> error () -let lock_texture = - foreign "SDL_LockTexture" - (texture @-> ptr Types.Rect.t @-> ptr (ptr void) @-> ptr int @-> - returning int) - let lock_texture t r kind = match (match r with None -> _texture_height t | Some r -> Ok (Rect.h r)) with | Error _ as e -> e | Ok h -> let pitch = allocate int 0 in let p = allocate (ptr void) null in - match lock_texture t (Rect.opt_addr r) p pitch with + match C.Functions.lock_texture t (Rect.opt_addr r) p pitch with | 0 -> let p = !@ p in let pitch = !@ pitch in @@ -1569,73 +1170,52 @@ let query_texture t = let access = allocate int 0 in let w = allocate int 0 in let h = allocate int 0 in - match query_texture t pf access w h with + match C.Functions.query_texture t pf access w h with | 0 -> Ok (!@ pf, !@ access, (!@ w, !@ h)) | _ -> error () -let set_texture_alpha_mod = - foreign "SDL_SetTextureAlphaMod" - (texture @-> int_as_uint8_t @-> returning int) -let set_texture_alpha_mod t a = set_texture_alpha_mod t a |> zero_to_ok - -let set_texture_blend_mode = - foreign "SDL_SetTextureBlendMode" - (texture @-> uint @-> returning int) -let set_texture_blend_mode t b = set_texture_blend_mode t b |> zero_to_ok +let set_texture_alpha_mod t a = + zero_to_ok (C.Functions.set_texture_alpha_mod t (Unsigned.UInt8.of_int a)) -let set_texture_color_mod = - foreign "SDL_SetTextureColorMod" - (texture @-> int_as_uint8_t @-> int_as_uint8_t @-> int_as_uint8_t @-> - returning int) -let set_texture_color_mod t a b c = set_texture_color_mod t a b c |> zero_to_ok +let set_texture_blend_mode t b = + zero_to_ok (C.Functions.set_texture_blend_mode t b) -let unlock_texture = - foreign "SDL_UnlockTexture" (texture @-> returning void) +let set_texture_color_mod t a b c = + zero_to_ok (C.Functions.set_texture_color_mod + t + (Unsigned.UInt8.of_int a) + (Unsigned.UInt8.of_int b) + (Unsigned.UInt8.of_int c)) -let update_texture = - foreign "SDL_UpdateTexture" - (texture @-> ptr Types.Rect.t @-> ptr void @-> int @-> returning int) +let unlock_texture = C.Functions.unlock_texture let update_texture t rect pixels pitch = let pitch = pitch * (ba_kind_byte_size (Bigarray.Array1.kind pixels)) in let pixels = to_voidp (bigarray_start array1 pixels) in - update_texture t (Rect.opt_addr rect) pixels pitch |> zero_to_ok - -let update_yuv_texture = - foreign "SDL_UpdateYUVTexture" - (texture @-> ptr Types.Rect.t @-> - ptr void @-> int @-> ptr void @-> int @-> ptr void @-> int @-> - returning int) + zero_to_ok (C.Functions.update_texture t (Rect.opt_addr rect) pixels pitch) let update_yuv_texture r rect ~y ypitch ~u upitch ~v vpitch = - let yp = to_voidp (bigarray_start array1 y) in - let up = to_voidp (bigarray_start array1 u) in - let vp = to_voidp (bigarray_start array1 v) in - update_yuv_texture r (Rect.opt_addr rect) yp ypitch up upitch vp vpitch |> zero_to_ok + let yp = bigarray_start array1 y in + let up = bigarray_start array1 u in + let vp = bigarray_start array1 v in + zero_to_ok (C.Functions.update_yuv_texture + r (Rect.opt_addr rect) yp ypitch up upitch vp vpitch) (* Video drivers *) -let get_current_video_driver = - foreign "SDL_GetCurrentVideoDriver" (void @-> returning string_opt) +let get_current_video_driver = C.Functions.get_current_video_driver -let get_num_video_drivers = - foreign "SDL_GetNumVideoDrivers" (void @-> returning int) -let get_num_video_drivers () = get_num_video_drivers () |> nat_to_ok +let get_num_video_drivers () = + nat_to_ok (C.Functions.get_num_video_drivers ()) -let get_video_driver = - foreign "SDL_GetVideoDriver" (int @-> returning string_opt) -let get_video_driver x = get_video_driver x |> some_to_ok +let get_video_driver x = some_to_ok (C.Functions.get_video_driver x) -let video_init = - foreign "SDL_VideoInit" (string_opt @-> returning int) -let video_init s = video_init s |> zero_to_ok +let video_init s = zero_to_ok (C.Functions.video_init s) -let video_quit = - foreign "SDL_VideoQuit" (void @-> returning void) +let video_quit = C.Functions.video_quit (* Displays *) type driverdata = unit ptr -let driverdata = ptr_opt void type display_mode = { dm_format : Pixel.format_enum; @@ -1645,546 +1225,374 @@ type display_mode = dm_driverdata : driverdata option } let display_mode_to_c o = - let c = make Types.display_mode in + let c = make C.Types.display_mode in let rate = match o.dm_refresh_rate with None -> 0 | Some r -> r in - setf c Types.dm_format o.dm_format; - setf c Types.dm_w o.dm_w; - setf c Types.dm_h o.dm_h; - setf c Types.dm_refresh_rate rate; - setf c Types.dm_driverdata o.dm_driverdata; + setf c C.Types.dm_format o.dm_format; + setf c C.Types.dm_w o.dm_w; + setf c C.Types.dm_h o.dm_h; + setf c C.Types.dm_refresh_rate rate; + setf c C.Types.dm_driverdata o.dm_driverdata; c let display_mode_of_c c = - let dm_format = getf c Types.dm_format in - let dm_w = getf c Types.dm_w in - let dm_h = getf c Types.dm_h in - let dm_refresh_rate = match getf c Types.dm_refresh_rate with + let dm_format = getf c C.Types.dm_format in + let dm_w = getf c C.Types.dm_w in + let dm_h = getf c C.Types.dm_h in + let dm_refresh_rate = match getf c C.Types.dm_refresh_rate with | 0 -> None | r -> Some r in - let dm_driverdata = getf c Types.dm_driverdata in + let dm_driverdata = getf c C.Types.dm_driverdata in { dm_format; dm_w; dm_h; dm_refresh_rate; dm_driverdata } -let get_closest_display_mode = - foreign "SDL_GetClosestDisplayMode" - (int @-> ptr Types.display_mode @-> ptr Types.display_mode @-> - returning (ptr_opt void)) - let get_closest_display_mode i m = let mode = display_mode_to_c m in - let closest = make Types.display_mode in - match get_closest_display_mode i (addr mode) (addr closest) with + let closest = make C.Types.display_mode in + match C.Functions.get_closest_display_mode i (addr mode) (addr closest) with | None -> None | Some _ -> Some (display_mode_of_c closest) -let get_current_display_mode = - foreign "SDL_GetCurrentDisplayMode" - (int @-> ptr Types.display_mode @-> returning int) - let get_current_display_mode i = - let mode = make Types.display_mode in - match get_current_display_mode i (addr mode) with + let mode = make C.Types.display_mode in + match C.Functions.get_current_display_mode i (addr mode) with | 0 -> Ok (display_mode_of_c mode) | _ -> error () -let get_desktop_display_mode = - foreign "SDL_GetDesktopDisplayMode" - (int @-> ptr Types.display_mode @-> returning int) - let get_desktop_display_mode i = - let mode = make Types.display_mode in - match get_desktop_display_mode i (addr mode) with + let mode = make C.Types.display_mode in + match C.Functions.get_desktop_display_mode i (addr mode) with | 0 -> Ok (display_mode_of_c mode) | _ -> error () -let get_display_bounds = - foreign "SDL_GetDisplayBounds" - (int @-> ptr Types.Rect.t @-> returning int) - let get_display_bounds i = - let r = make Types.Rect.t in - match get_display_bounds i (addr r) with + let r = make C.Types.Rect.t in + match C.Functions.get_display_bounds i (addr r) with | 0 -> Ok r | _ -> error () -let get_display_dpi = - foreign "SDL_GetDisplayDPI" - (int @-> ptr float @-> ptr float @-> ptr float @-> returning int) - let get_display_dpi display = let diagonal = allocate float 0. in let horizontal = allocate float 0. in let vertical = allocate float 0. in - match get_display_dpi display diagonal horizontal vertical with + match C.Functions.get_display_dpi display diagonal horizontal vertical with | 0 -> Ok (!@diagonal,!@horizontal,!@vertical) | _ -> error () -let get_display_mode = - foreign "SDL_GetDisplayMode" - (int @-> int @-> ptr Types.display_mode @-> returning int) - let get_display_mode d i = - let mode = make Types.display_mode in - match get_display_mode d i (addr mode) with + let mode = make C.Types.display_mode in + match C.Functions.get_display_mode d i (addr mode) with | 0 -> Ok (display_mode_of_c mode) | _ -> error () -let get_display_usable_bounds = - foreign "SDL_GetDisplayUsableBounds" - (int @-> ptr Types.Rect.t @-> returning int) - let get_display_usable_bounds i = - let r = make Types.Rect.t in - match get_display_usable_bounds i (addr r) with + let r = make C.Types.Rect.t in + match C.Functions.get_display_usable_bounds i (addr r) with | 0 -> Ok r | _ -> error () -let get_num_display_modes = - foreign "SDL_GetNumDisplayModes" (int @-> returning int) -let get_num_display_modes x = get_num_display_modes x |> nat_to_ok +let get_num_display_modes x = nat_to_ok (C.Functions.get_num_display_modes x) -let get_display_name = - foreign "SDL_GetDisplayName" (int @-> returning string_opt) -let get_display_name x = get_display_name x |> some_to_ok +let get_display_name x = some_to_ok (C.Functions.get_display_name x) -let get_num_video_displays = - foreign "SDL_GetNumVideoDisplays" (void @-> returning int) -let get_num_video_displays () = get_num_video_displays () |> nat_to_ok +let get_num_video_displays () = + nat_to_ok (C.Functions.get_num_video_displays ()) (* Windows *) module Window = struct type flags = Unsigned.uint32 - let i = Unsigned.UInt32.of_int let ( + ) = Unsigned.UInt32.logor let ( - ) f f' = Unsigned.UInt32.(logand f (lognot f')) let test f m = Unsigned.UInt32.(compare (logand f m) zero <> 0) let eq f f' = Unsigned.UInt32.(compare f f' = 0) - let windowed = i 0 - include Types.Window + let windowed = Unsigned.UInt32.zero + include C.Types.Window end -let create_window = - foreign "SDL_CreateWindow" - (string @-> int @-> int @-> int @-> int @-> uint32_t @-> - returning Types.Window.opt) +(* Video *) -let create_window t ?(x = Window.pos_undefined) ?(y = Window.pos_undefined) - ~w ~h flags = create_window t x y w h flags |> some_to_ok +type window = Window.t -let create_window_and_renderer = - foreign "SDL_CreateWindowAndRenderer" - (int @-> int @-> uint32_t @-> ptr Types.Window.t @-> ptr renderer @-> - (returning int)) +let unsafe_window_of_ptr addr : Window.t = + from_voidp Window.raw (ptr_of_raw_address addr) +let unsafe_ptr_of_window window = + raw_address_of_ptr (to_voidp window) + +let create_window t ?(x = Window.pos_undefined) ?(y = Window.pos_undefined) + ~w ~h flags = some_to_ok (C.Functions.create_window t x y w h flags) let create_window_and_renderer ~w ~h flags = let win = allocate Window.t (from_voidp Window.raw null) in - let r = allocate renderer (from_voidp Renderer.t null) in - match create_window_and_renderer w h flags win r with + let r = allocate (ptr Renderer.t) (from_voidp Renderer.t null) in + match C.Functions.create_window_and_renderer w h flags win r with | 0 -> Ok (!@ win, !@ r) | _ -> error () -let destroy_window = - foreign "SDL_DestroyWindow" (Types.Window.t @-> returning void) - -let get_window_brightness = - foreign "SDL_GetWindowBrightness" (Types.Window.t @-> returning float) +let destroy_window = C.Functions.destroy_window -let get_window_borders_size = - foreign "SDL_GetWindowBordersSize" - (Types.Window.t @-> ptr int @-> ptr int @-> ptr int @-> ptr int @-> - returning int) +let get_window_brightness = C.Functions.get_window_brightness let get_window_borders_size w = let top = allocate int 0 in let left = allocate int 0 in let bottom = allocate int 0 in let right = allocate int 0 in - match get_window_borders_size w top bottom left right with + match C.Functions.get_window_borders_size w top bottom left right with | 0 -> Ok (!@ top, !@ left, !@ bottom, !@ right) | _ -> error () -let get_window_display_index = - foreign "SDL_GetWindowDisplayIndex" (Types.Window.t @-> returning int) -let get_window_display_index w = get_window_display_index w |> nat_to_ok - -let get_window_display_mode = - foreign "SDL_GetWindowDisplayMode" - (Types.Window.t @-> (ptr Types.display_mode) @-> returning int) +let get_window_display_index w = + nat_to_ok (C.Functions.get_window_display_index w) let get_window_display_mode w = - let mode = make Types.display_mode in - match get_window_display_mode w (addr mode) with + let mode = make C.Types.display_mode in + match C.Functions.get_window_display_mode w (addr mode) with | 0 -> Ok (display_mode_of_c mode) | _err -> error () -let get_window_flags = - foreign "SDL_GetWindowFlags" (Types.Window.t @-> returning uint32_t) +let get_window_flags = C.Functions.get_window_flags -let get_window_from_id = - foreign "SDL_GetWindowFromID" - (int_as_uint32_t @-> returning Types.Window.opt) -let get_window_from_id x = get_window_from_id x |> some_to_ok - -let get_window_gamma_ramp = - foreign "SDL_GetWindowGammaRamp" - (Types.Window.t @-> ptr void @-> ptr void @-> ptr void @-> returning int) +let get_window_from_id x = + some_to_ok (C.Functions.get_window_from_id (Unsigned.UInt32.of_int x)) let get_window_gamma_ramp w = let create_ramp () = ba_create Bigarray.int16_unsigned 256 in let r, g, b = create_ramp (), create_ramp (), create_ramp () in - let ramp_ptr r = to_voidp (bigarray_start array1 r) in - match get_window_gamma_ramp w (ramp_ptr r) (ramp_ptr g) (ramp_ptr b) with + let ramp_ptr r = bigarray_start array1 r in + match C.Functions.get_window_gamma_ramp + w (ramp_ptr r) (ramp_ptr g) (ramp_ptr b) with | 0 -> Ok (r, g, b) | _ -> error () -let get_window_grab = - foreign "SDL_GetWindowGrab" (Types.Window.t @-> returning bool) - -let get_grabbed_window = - foreign "SDL_GetGrabbedWindow" (void @-> returning Types.Window.t) +let get_window_grab = C.Functions.get_window_grab -let get_window_id = - foreign "SDL_GetWindowID" (Types.Window.t @-> returning int_as_uint32_t) +let get_grabbed_window = C.Functions.get_grabbed_window -let get_window_maximum_size = - foreign "SDL_GetWindowMaximumSize" - (Types.Window.t @-> (ptr int) @-> (ptr int) @-> returning void) +let get_window_id w = Unsigned.UInt32.to_int (C.Functions.get_window_id w) let get_window_maximum_size win = let w = allocate int 0 in let h = allocate int 0 in - get_window_maximum_size win w h; + C.Functions.get_window_maximum_size win w h; !@ w, !@ h -let get_window_minimum_size = - foreign "SDL_GetWindowMinimumSize" - (Types.Window.t @-> (ptr int) @-> (ptr int) @-> returning void) - let get_window_minimum_size win = let w = allocate int 0 in let h = allocate int 0 in - get_window_minimum_size win w h; + C.Functions.get_window_minimum_size win w h; !@ w, !@ h -let get_window_opacity = - foreign "SDL_GetWindowOpacity" - (Types.Window.t @-> (ptr float) @-> returning int) - let get_window_opacity win = let x = allocate float 0. in - match get_window_opacity win x with + match C.Functions.get_window_opacity win x with | 0 -> Ok !@x | _ -> error () -let get_window_pixel_format = - foreign "SDL_GetWindowPixelFormat" (Types.Window.t @-> returning uint32_t) - -let get_window_position = - foreign "SDL_GetWindowPosition" - (Types.Window.t @-> (ptr int) @-> (ptr int) @-> returning void) +let get_window_pixel_format = C.Functions.get_window_pixel_format let get_window_position win = let x = allocate int 0 in let y = allocate int 0 in - get_window_position win x y; + C.Functions.get_window_position win x y; !@ x, !@ y -let get_window_size = - foreign "SDL_GetWindowSize" - (Types.Window.t @-> (ptr int) @-> (ptr int) @-> returning void) - let get_window_size win = let w = allocate int 0 in let h = allocate int 0 in - get_window_size win w h; + C.Functions.get_window_size win w h; !@ w, !@ h -let get_window_surface = - foreign "SDL_GetWindowSurface" - (Types.Window.t @-> returning surface_opt) -let get_window_surface w = get_window_surface w |> some_to_ok +let get_window_surface w = + some_to_ok (C.Functions.get_window_surface w) -let get_window_title = - foreign "SDL_GetWindowTitle" (Types.Window.t @-> returning string) +let get_window_title = C.Functions.get_window_title -let hide_window = - foreign "SDL_HideWindow" (Types.Window.t @-> returning void) +let hide_window = C.Functions.hide_window -let maximize_window = - foreign "SDL_MaximizeWindow" (Types.Window.t @-> returning void) +let maximize_window = C.Functions.maximize_window -let minimize_window = - foreign "SDL_MinimizeWindow" (Types.Window.t @-> returning void) +let minimize_window = C.Functions.minimize_window -let raise_window = - foreign "SDL_RaiseWindow" (Types.Window.t @-> returning void) +let raise_window = C.Functions.raise_window -let restore_window = - foreign "SDL_RestoreWindow" (Types.Window.t @-> returning void) +let restore_window = C.Functions.restore_window -let set_window_bordered = - foreign "SDL_SetWindowBordered" (Types.Window.t @-> bool @-> returning void) +let set_window_bordered = C.Functions.set_window_bordered -let set_window_brightness = - foreign "SDL_SetWindowBrightness" - (Types.Window.t @-> float @-> returning int) -let set_window_brightness w x = set_window_brightness w x |> zero_to_ok - -let set_window_display_mode = - foreign "SDL_SetWindowDisplayMode" - (Types.Window.t @-> (ptr Types.display_mode) @-> returning int) +let set_window_brightness w x = + zero_to_ok (C.Functions.set_window_brightness w x) let set_window_display_mode w m = let mode = display_mode_to_c m in - set_window_display_mode w (addr mode) |> zero_to_ok - -let set_window_fullscreen = - foreign "SDL_SetWindowFullscreen" - (Types.Window.t @-> uint32_t @-> returning int) -let set_window_fullscreen w x = set_window_fullscreen w x |> zero_to_ok + zero_to_ok (C.Functions.set_window_display_mode w (addr mode)) -let set_window_gamma_ramp = - foreign "SDL_SetWindowGammaRamp" - (Types.Window.t @-> ptr void @-> ptr void @-> ptr void @-> - returning int) +let set_window_fullscreen w x = + zero_to_ok (C.Functions.set_window_fullscreen w x) let set_window_gamma_ramp w r g b = - let ramp_ptr r = to_voidp (bigarray_start array1 r) in - set_window_gamma_ramp w (ramp_ptr r) (ramp_ptr g) (ramp_ptr b) |> zero_to_ok - -let set_window_grab = - foreign "SDL_SetWindowGrab" (Types.Window.t @-> bool @-> returning void) + let ramp_ptr r = bigarray_start array1 r in + zero_to_ok (C.Functions.set_window_gamma_ramp + w (ramp_ptr r) (ramp_ptr g) (ramp_ptr b)) -let set_window_icon = - foreign "SDL_SetWindowIcon" (Types.Window.t @-> surface @-> returning void) +let set_window_grab = C.Functions.set_window_grab -let set_window_input_focus = - foreign "SDL_SetWindowInputFocus" (Types.Window.t @-> returning int) -let set_window_input_focus w = set_window_input_focus w |> zero_to_ok +let set_window_icon = C.Functions.set_window_icon -let set_window_maximum_size = - foreign "SDL_SetWindowMaximumSize" - (Types.Window.t @-> int @-> int @-> returning void) +let set_window_input_focus w = + zero_to_ok (C.Functions.set_window_input_focus w) let set_window_maximum_size win ~w ~h = - set_window_maximum_size win w h - -let set_window_minimum_size = - foreign "SDL_SetWindowMinimumSize" - (Types.Window.t @-> int @-> int @-> returning void) + C.Functions.set_window_maximum_size win w h let set_window_minimum_size win ~w ~h = - set_window_minimum_size win w h - -let set_window_modal_for = - foreign "SDL_SetWindowModalFor" ( Types.Window.t @-> Types.Window.t @-> returning int) - -let set_window_modal_for ~modal ~parent = set_window_modal_for modal parent |> zero_to_ok + C.Functions.set_window_minimum_size win w h -let set_window_opacity = - foreign "SDL_SetWindowOpacity" ( Types.Window.t @-> float @-> returning int) -let set_window_opacity w x = set_window_opacity w x |> zero_to_ok +let set_window_modal_for ~modal ~parent = + zero_to_ok (C.Functions.set_window_modal_for modal parent) -let set_window_position = - foreign "SDL_SetWindowPosition" - (Types.Window.t @-> int @-> int @-> returning void) +let set_window_opacity w x = + zero_to_ok (C.Functions.set_window_opacity w x) let set_window_position win ~x ~y = - set_window_position win x y + C.Functions.set_window_position win x y -let set_window_resizable = - foreign "SDL_SetWindowResizable" (Types.Window.t @-> bool @-> returning void) - -let set_window_size = - foreign "SDL_SetWindowSize" (Types.Window.t @-> int @-> int @-> returning void) +let set_window_resizable = C.Functions.set_window_resizable let set_window_size win ~w ~h = - set_window_size win w h - -let set_window_title = - foreign "SDL_SetWindowTitle" (Types.Window.t @-> string @-> returning void) + C.Functions.set_window_size win w h -let show_window = - foreign "SDL_ShowWindow" (Types.Window.t @-> returning void) +let set_window_title = C.Functions.set_window_title -let update_window_surface = - foreign "SDL_UpdateWindowSurface" (Types.Window.t @-> returning int) -let update_window_surface w = update_window_surface w |> zero_to_ok +let show_window = C.Functions.show_window -let update_window_surface_rects = - foreign "SDL_UpdateWindowSurfaceRects" - (Types.Window.t @-> ptr void @-> int @-> returning int) +let update_window_surface w = + zero_to_ok (C.Functions.update_window_surface w) let update_window_surface_rects_ba w rs = let len = Bigarray.Array1.dim rs in if len mod 4 <> 0 then invalid_arg (err_length_mul len 4) else let count = len / 4 in let rs = to_voidp (bigarray_start array1 rs) in - update_window_surface_rects w rs count |> zero_to_ok + zero_to_ok (C.Functions.update_window_surface_rects w rs count) let update_window_surface_rects w rs = - let a = CArray.of_list Types.Rect.t rs in + let a = CArray.of_list C.Types.Rect.t rs in let rs = to_voidp (CArray.start a) in - update_window_surface_rects w rs (CArray.length a) |> zero_to_ok + zero_to_ok (C.Functions.update_window_surface_rects w rs (CArray.length a)) (* OpenGL contexts *) -type gl_context = unit ptr -let gl_context : unit ptr typ = ptr void -let gl_context_opt : unit ptr option typ = ptr_opt void - -let unsafe_gl_context_of_ptr addr : gl_context = - ptr_of_raw_address addr -let unsafe_ptr_of_gl_context gl_context = - raw_address_of_ptr (to_voidp gl_context) - module Gl = struct type context_flags = int type profile = int type attr = int - include Types.Gl + + include C.Types.Gl end -let gl_bind_texture = - foreign "SDL_GL_BindTexture" - (texture @-> ptr float @-> ptr float @-> returning int) +type gl_context = C.Types.Gl.context ptr + +let unsafe_gl_context_of_ptr addr : gl_context = + from_voidp C.Types.Gl.context (ptr_of_raw_address addr) +let unsafe_ptr_of_gl_context gl_context = + raw_address_of_ptr (to_voidp gl_context) let gl_bind_texture t = let w = allocate float 0. in let h = allocate float 0. in - match gl_bind_texture t w h with + match C.Functions.gl_bind_texture t w h with | 0 -> Ok (!@ w, !@ h) | _ -> error () -let gl_create_context = - foreign "SDL_GL_CreateContext" - (Types.Window.t @-> returning gl_context_opt) -let gl_create_context w = gl_create_context w |> some_to_ok - -let gl_delete_context = - foreign "SDL_GL_DeleteContext" (gl_context @-> returning void) +let gl_create_context w = + some_to_ok (C.Functions.gl_create_context w) -let gl_extension_supported = - foreign "SDL_GL_ExtensionSupported" (string @-> returning bool) +let gl_delete_context = C.Functions.gl_delete_context -let gl_get_attribute = - foreign "SDL_GL_GetAttribute" (int @-> (ptr int) @-> returning int) +let gl_extension_supported = C.Functions.gl_extension_supported let gl_get_attribute att = let value = allocate int 0 in - match gl_get_attribute att value with + match C.Functions.gl_get_attribute att value with | 0 -> Ok (!@ value) | _err -> error () -let gl_get_current_context = - foreign "SDL_GL_GetCurrentContext" - (void @-> returning gl_context_opt) -let gl_get_current_context () = gl_get_current_context () |> some_to_ok - -let gl_get_drawable_size = - foreign "SDL_GL_GetDrawableSize" - (Types.Window.t @-> ptr int @-> ptr int @-> returning void) +let gl_get_current_context () = + some_to_ok (C.Functions.gl_get_current_context ()) let gl_get_drawable_size win = let w = allocate int 0 in let h = allocate int 0 in - gl_get_drawable_size win w h; + C.Functions.gl_get_drawable_size win w h; (!@ w, !@ h) -let gl_get_swap_interval = - foreign "SDL_GL_GetSwapInterval" (void @-> returning int) -let gl_get_swap_interval () = Ok (gl_get_swap_interval ()) +let gl_get_swap_interval () = Ok (C.Functions.gl_get_swap_interval ()) -let gl_make_current = - foreign "SDL_GL_MakeCurrent" - (Types.Window.t @-> gl_context @-> returning int) -let gl_make_current w g = gl_make_current w g |> zero_to_ok +let gl_make_current w g = + zero_to_ok (C.Functions.gl_make_current w g) -let gl_reset_attributes = - foreign "SDL_GL_ResetAttributes" ~stub (void @-> returning void) +let gl_reset_attributes = C.Functions.gl_reset_attributes -let gl_set_attribute = - foreign "SDL_GL_SetAttribute" (int @-> int @-> returning int) -let gl_set_attribute x y = gl_set_attribute x y |> zero_to_ok +let gl_set_attribute x y = + zero_to_ok (C.Functions.gl_set_attribute x y) -let gl_set_swap_interval = - foreign "SDL_GL_SetSwapInterval" (int @-> returning int) -let gl_set_swap_interval x = gl_set_swap_interval x |> zero_to_ok +let gl_set_swap_interval x = + zero_to_ok (C.Functions.gl_set_swap_interval x) -let gl_swap_window = - foreign "SDL_GL_SwapWindow" (Types.Window.t @-> returning void) +let gl_swap_window = C.Functions.gl_swap_window -let gl_unbind_texture = - foreign "SDL_GL_UnbindTexture" (texture @-> returning int) -let gl_unbind_texture t = gl_unbind_texture t |> zero_to_ok +let gl_unbind_texture t = + zero_to_ok (C.Functions.gl_unbind_texture t) (* Vulkan *) module Vulkan = struct type instance = unit ptr - let instance = ptr void let unsafe_ptr_of_instance = raw_address_of_ptr let unsafe_instance_of_ptr x = ptr_of_raw_address x - type surface = uint64 - let surface = int64_t - let unsafe_uint64_of_surface x = x - let unsafe_surface_of_uint64 x = x - - let load_library = - foreign "SDL_Vulkan_LoadLibrary" (string_opt @-> returning int) - let load_library s = load_library s |> zero_to_ok + type surface = C.Types.Vulkan.surface + let unsafe_uint64_of_surface x = + Int64.of_nativeint (raw_address_of_ptr (to_voidp x)) + let unsafe_surface_of_uint64 x = + from_voidp C.Types.Vulkan.raw_surface + (ptr_of_raw_address (Int64.to_nativeint x)) - let unload_library = - foreign "SDL_Vulkan_UnloadLibrary" (void @-> returning void) + let load_library s = + zero_to_ok (C.Functions.Vulkan.load_library s) - let get_instance_extensions = - foreign "SDL_Vulkan_GetInstanceExtensions" - (Types.Window.t @-> ptr int @-> ptr string @-> returning bool) + let unload_library = C.Functions.Vulkan.unload_library let get_instance_extensions window = let n = allocate int 0 in - match get_instance_extensions window n + match C.Functions.Vulkan.get_instance_extensions window n (Ctypes.coerce (ptr void) (ptr string) null) with | false -> None | true -> let exts = allocate_n string ~count:(!@n) in - match get_instance_extensions window n exts with + match C.Functions.Vulkan.get_instance_extensions window n exts with | false -> None | true -> Some CArray.(to_list @@ from_ptr exts (!@n)) - let create_surface = - foreign "SDL_Vulkan_CreateSurface" - (Types.Window.t @-> instance @-> ptr surface @-> returning bool) - let create_surface window instance = - let s = allocate_n surface ~count:1 in - if create_surface window instance s then + let s = allocate_n C.Types.Vulkan.surface ~count:1 in + if C.Functions.Vulkan.create_surface window instance s then Some !@s else None - let get_drawable_size = - foreign "SDL_Vulkan_GetDrawableSize" - (Types.Window.t @-> ptr int @-> ptr int @-> returning void) - let get_drawable_size window = let w = allocate int 0 in let h = allocate int 0 in - get_drawable_size window w h; + C.Functions.Vulkan.get_drawable_size window w h; !@w, !@h end (* Screen saver *) -let disable_screen_saver = - foreign "SDL_DisableScreenSaver" (void @-> returning void) +let disable_screen_saver = C.Functions.disable_screen_saver -let enable_screen_saver = - foreign "SDL_EnableScreenSaver" (void @-> returning void) +let enable_screen_saver = C.Functions.enable_screen_saver -let is_screen_saver_enabled = - foreign "SDL_IsScreenSaverEnabled" (void @-> returning bool) +let is_screen_saver_enabled = C.Functions.is_screen_saver_enabled (* Message boxes *) module Message_box = struct - include Types.Message_box - let i = Unsigned.UInt32.of_int + include C.Types.Message_box type button_flags = Unsigned.uint32 - let button_no_default = i 0 + let button_no_default = Unsigned.UInt32.zero type button_data = { button_flags : button_flags; @@ -2204,7 +1612,7 @@ module Message_box = struct type data = { flags : flags; - window : window option; + window : Window.t option; title : string; message : string; buttons : button_data list; @@ -2222,9 +1630,9 @@ module Message_box = struct let color_scheme_to_c s = let st = make color_scheme in - let colors = getf st colors in + let arr = getf st colors in let set i (rv, gv, bv) = - let ct = CArray.get colors i in + let ct = CArray.get arr i in setf ct color_r (Unsigned.UInt8.of_int rv); setf ct color_g (Unsigned.UInt8.of_int gv); setf ct color_b (Unsigned.UInt8.of_int bv); @@ -2249,30 +1657,19 @@ module Message_box = struct dt end -let show_message_box = - foreign "SDL_ShowMessageBox" - (ptr Message_box.data @-> ptr int @-> returning int) - let show_message_box d = let d = addr (Message_box.data_to_c d) in let ret = allocate int 0 in - match show_message_box d ret with + match C.Functions.Message_box.show d ret with | 0 -> Ok (!@ ret) | _ -> error () -let show_simple_message_box = - foreign "SDL_ShowSimpleMessageBox" - (uint32_t @-> string @-> string @-> Types.Window.opt @-> returning int) - let show_simple_message_box t ~title msg w = - show_simple_message_box t title msg w |> zero_to_ok + zero_to_ok (C.Functions.Message_box.show_simple t title msg w) (* Clipboard *) -let get_clipboard_text = - foreign "SDL_GetClipboardText" (void @-> returning (ptr char)) - let get_clipboard_text () = - let p = get_clipboard_text () in + let p = C.Functions.get_clipboard_text () in if (to_voidp p) = null then error () else let b = Buffer.create 255 in let ptr = ref p in @@ -2283,30 +1680,27 @@ let get_clipboard_text () = sdl_free (to_voidp p); Ok (Buffer.contents b) -let has_clipboard_text = - foreign "SDL_HasClipboardText" (void @-> returning bool) +let has_clipboard_text = C.Functions.has_clipboard_text -let set_clipboard_text = - foreign "SDL_SetClipboardText" (string @-> returning int) -let set_clipboard_text s = set_clipboard_text s |> zero_to_ok +let set_clipboard_text s = + zero_to_ok (C.Functions.set_clipboard_text s) (* Input *) type button_state = Unsigned.uint8 -let pressed = Types.pressed -let released = Types.released +let pressed = C.Types.pressed +let released = C.Types.released type toggle_state = Unsigned.uint8 -let disable = Types.disable -let enable = Types.enable +let disable = C.Types.disable +let enable = C.Types.enable (* Keyboard *) type scancode = int -let scancode = int module Scancode = struct - include Types.Scancode + include C.Types.Scancode let enum_of_scancode = [| `Unknown; `Unknown; `Unknown; `Unknown; `A; `B; `C; `D; `E; `F; `G; `H; `I; `J; `K; `L; `M; `N; `O; `P; `Q; `R; `S; `T; `U; `V; @@ -2360,588 +1754,398 @@ module Scancode = struct end type keycode = int -let keycode = int -module K = Types.K +module K = C.Types.K type keymod = int -let keymod = int_as_uint16_t - -module Kmod = Types.Kmod -let get_keyboard_focus = - foreign "SDL_GetKeyboardFocus" (void @-> returning Types.Window.opt) +module Kmod = C.Types.Kmod -let get_keyboard_state = - foreign "SDL_GetKeyboardState" (ptr int @-> returning (ptr int)) +let get_keyboard_focus = C.Functions.get_keyboard_focus let get_keyboard_state () = let count = allocate int 0 in - let p = get_keyboard_state count in - bigarray_of_ptr array1 (!@ count) Bigarray.int8_unsigned p - -let get_key_from_name = - foreign "SDL_GetKeyFromName" (string @-> returning keycode) + let p = C.Functions.get_keyboard_state count in + let p' = coerce (ptr uint8_t) (ptr int) p in + let a = CArray.from_ptr p' (!@ count) in + bigarray_of_array array1 Bigarray.int8_unsigned a -let get_key_from_scancode = - foreign "SDL_GetKeyFromScancode" (scancode @-> returning keycode) +let get_key_from_name = C.Functions.get_key_from_name -let get_key_name = - foreign "SDL_GetKeyName" (keycode @-> returning string) +let get_key_from_scancode = C.Functions.get_key_from_scancode -let get_mod_state = - foreign "SDL_GetModState" (void @-> returning keymod) +let get_key_name = C.Functions.get_key_name -let get_scancode_from_key = - foreign "SDL_GetScancodeFromKey" (keycode @-> returning scancode) +let get_mod_state () = Unsigned.UInt16.to_int (C.Functions.get_mod_state ()) -let get_scancode_from_name = - foreign "SDL_GetScancodeFromName" (string @-> returning scancode) +let get_scancode_from_key = C.Functions.get_scancode_from_key -let get_scancode_name = - foreign "SDL_GetScancodeName" (scancode @-> returning string) +let get_scancode_from_name = C.Functions.get_scancode_from_name -let has_screen_keyboard_support = - foreign "SDL_HasScreenKeyboardSupport" (void @-> returning bool) +let get_scancode_name = C.Functions. get_scancode_name -let is_screen_keyboard_shown = - foreign "SDL_IsScreenKeyboardShown" (Types.Window.t @-> returning bool) +let has_screen_keyboard_support = C.Functions.has_screen_keyboard_support -let is_text_input_active = - foreign "SDL_IsTextInputActive" (void @-> returning bool) +let is_screen_keyboard_shown = C.Functions.is_screen_keyboard_shown -let set_mod_state = - foreign "SDL_SetModState" (keymod @-> returning void) +let is_text_input_active = C.Functions.is_text_input_active -let set_text_input_rect = - foreign "SDL_SetTextInputRect" (ptr Types.Rect.t @-> returning void) +let set_mod_state m = C.Functions.set_mod_state (Unsigned.UInt16.of_int m) let set_text_input_rect r = - set_text_input_rect (Rect.opt_addr r) + C.Functions.set_text_input_rect (Rect.opt_addr r) -let start_text_input = - foreign "SDL_StartTextInput" (void @-> returning void) +let start_text_input = C.Functions.start_text_input -let stop_text_input = - foreign "SDL_StopTextInput" (void @-> returning void) +let stop_text_input = C.Functions.stop_text_input (* Mouse *) -type cursor = unit ptr -let cursor : cursor typ = ptr void -let cursor_opt : cursor option typ = ptr_opt void +type cursor = C.Types.cursor ptr let unsafe_cursor_of_ptr addr : cursor = - ptr_of_raw_address addr + from_voidp C.Types.cursor (ptr_of_raw_address addr) let unsafe_ptr_of_cursor cursor = raw_address_of_ptr (to_voidp cursor) module System_cursor = struct type t = int - include Types.System_cursor + include C.Types.System_cursor end -module Button = Types.Button +module Button = C.Types.Button -let capture_mouse = - foreign "SDL_CaptureMouse" (bool @-> returning int) -let capture_mouse b = capture_mouse b |> zero_to_ok - -let create_color_cursor = - foreign "SDL_CreateColorCursor" - (surface @-> int @-> int @-> returning cursor_opt) +let capture_mouse b = zero_to_ok (C.Functions.capture_mouse b) let create_color_cursor s ~hot_x ~hot_y = - create_color_cursor s hot_x hot_y |> some_to_ok - -let create_cursor = - foreign "SDL_CreateCursor" - (ptr void @-> ptr void @-> int @-> int @-> int @-> int @-> - returning cursor_opt) + some_to_ok (C.Functions.create_color_cursor s hot_x hot_y) let create_cursor d m ~w ~h ~hot_x ~hot_y = (* FIXME: we could try to check bounds *) - let d = to_voidp (bigarray_start array1 d) in - let m = to_voidp (bigarray_start array1 m) in - create_cursor d m w h hot_x hot_y |> some_to_ok - -let create_system_cursor = - foreign "SDL_CreateSystemCursor" - (int @-> returning cursor_opt) -let create_system_cursor i = create_system_cursor i |> some_to_ok + let d = bigarray_start array1 d in + let m = bigarray_start array1 m in + some_to_ok (C.Functions.create_cursor d m w h hot_x hot_y) -let free_cursor = - foreign "SDL_FreeCursor" (cursor @-> returning void) +let create_system_cursor i = + some_to_ok (C.Functions.create_system_cursor i) -let get_cursor = - foreign "SDL_GetCursor" (void @-> returning cursor_opt) +let free_cursor = C.Functions.free_cursor -let get_default_cursor = - foreign "SDL_GetDefaultCursor" (void @-> returning cursor_opt) +let get_cursor = C.Functions.get_cursor -let get_global_mouse_state = - foreign "SDL_GetGlobalMouseState" - (ptr int @-> ptr int @-> returning int32_as_uint32_t) +let get_default_cursor = C.Functions.get_default_cursor let get_global_mouse_state () = let x = allocate int 0 in let y = allocate int 0 in - let s = get_global_mouse_state x y in - s, (!@ x, !@ y) + let s = C.Functions.get_global_mouse_state x y in + Unsigned.UInt32.to_int32 s, (!@ x, !@ y) let get_mouse_focus = - foreign "SDL_GetMouseFocus" (void @-> returning Types.Window.opt) - -let get_mouse_state = - foreign "SDL_GetMouseState" - (ptr int @-> ptr int @-> returning int32_as_uint32_t) + C.Functions.get_mouse_focus let get_mouse_state () = let x = allocate int 0 in let y = allocate int 0 in - let s = get_mouse_state x y in - s, (!@ x, !@ y) - -let get_relative_mouse_mode = - foreign "SDL_GetRelativeMouseMode" (void @-> returning bool) + let s = C.Functions.get_mouse_state x y in + Unsigned.UInt32.to_int32 s, (!@ x, !@ y) -let get_relative_mouse_state = - foreign "SDL_GetRelativeMouseState" - (ptr int @-> ptr int @-> returning int32_as_uint32_t) +let get_relative_mouse_mode = C.Functions.get_relative_mouse_mode -let get_relative_mouse_state () = + let get_relative_mouse_state () = let x = allocate int 0 in let y = allocate int 0 in - let s = get_relative_mouse_state x y in - s, (!@ x, !@ y) - -let show_cursor = - foreign "SDL_ShowCursor" (int @-> returning int) + let s = C.Functions.get_relative_mouse_state x y in + Unsigned.UInt32.to_int32 s, (!@ x, !@ y) let get_cursor_shown () = - show_cursor (-1) |> bool_to_ok + bool_to_ok (C.Functions.show_cursor (-1)) -let set_cursor = - foreign "SDL_SetCursor" (cursor_opt @-> returning void) +let set_cursor = C.Functions.set_cursor -let set_relative_mouse_mode = - foreign "SDL_SetRelativeMouseMode" (bool @-> returning int) -let set_relative_mouse_mode b = set_relative_mouse_mode b |> zero_to_ok +let set_relative_mouse_mode b = + zero_to_ok (C.Functions.set_relative_mouse_mode b) let show_cursor b = - show_cursor (if b then 1 else 0) |> bool_to_ok - -let warp_mouse_in_window = - foreign "SDL_WarpMouseInWindow" - (Types.Window.opt @-> int @-> int @-> returning void) + bool_to_ok (C.Functions.show_cursor (if b then 1 else 0)) let warp_mouse_in_window w ~x ~y = - warp_mouse_in_window w x y - -let warp_mouse_global= - foreign "SDL_WarpMouseGlobal" (int @-> int @-> returning int) + C.Functions.warp_mouse_in_window w x y let warp_mouse_global ~x ~y = - warp_mouse_global x y |> zero_to_ok + zero_to_ok (C.Functions.warp_mouse_global x y) (* Touch *) type touch_id = int64 -let touch_id = int64_t -let touch_mouse_id = Types.touch_mouseid +let touch_mouse_id = C.Types.touch_mouseid type gesture_id = int64 -let gesture_id = int64_t type finger_id = int64 -let finger_id = int64_t module Finger = struct - let id f = getf f Types.Finger.id - let x f = getf f Types.Finger.x - let y f = getf f Types.Finger.y - let pressure f = getf f Types.Finger.pressure -end -type finger = Types.Finger.t + include C.Types.Finger -let get_num_touch_devices = - foreign "SDL_GetNumTouchDevices" (void @-> returning int) + let id f = getf f id + let x f = getf f x + let y f = getf f y + let pressure f = getf f pressure +end +type finger = Finger.t -let get_num_touch_fingers = - foreign "SDL_GetNumTouchFingers" (touch_id @-> returning int) +let get_num_touch_devices = C.Functions.get_num_touch_devices -let get_touch_device = - foreign "SDL_GetTouchDevice" (int @-> returning touch_id) +let get_num_touch_fingers = C.Functions.get_num_touch_fingers let get_touch_device i = - match get_touch_device i with + match C.Functions.get_touch_device i with | 0L -> error () | id -> Ok id -let get_touch_finger = - foreign "SDL_GetTouchFinger" - (touch_id @-> int @-> returning (ptr_opt Types.Finger.t)) - let get_touch_finger id i = - match get_touch_finger id i with + match C.Functions.get_touch_finger id i with | None -> None | Some p -> Some (!@ p) -let load_dollar_templates = - foreign "SDL_LoadDollarTemplates" - (touch_id @-> Types.rw_ops @-> returning int) -let load_dollar_templates x y = load_dollar_templates x y |> zero_to_ok +let load_dollar_templates x y = + zero_to_ok (C.Functions.load_dollar_templates x y) -let record_gesture = - foreign "SDL_RecordGesture" (touch_id @-> returning int) -let record_gesture i = record_gesture i |> one_to_ok +let record_gesture i = + one_to_ok (C.Functions.record_gesture i) -let save_dollar_template = - foreign "SDL_SaveDollarTemplate" - (gesture_id @-> Types.rw_ops @-> returning int) -let save_dollar_template x y = save_dollar_template x y |> zero_to_ok +let save_dollar_template x y = + zero_to_ok (C.Functions.save_dollar_template x y) -let save_all_dollar_templates = - foreign "SDL_SaveAllDollarTemplates" (Types.rw_ops @-> returning int) -let save_all_dollar_templates o = save_all_dollar_templates o |> zero_to_ok +let save_all_dollar_templates o = + zero_to_ok (C.Functions.save_all_dollar_templates o) (* Joystick *) +type joystick_guid = C.Types.guid + type joystick_id = int32 -let joystick_id = int32_t - - type _joystick_guid - type joystick_guid = _joystick_guid structure - let joystick_guid : joystick_guid typ = - structure "SDL_JoystickGUID" - (* FIXME: No array here, see - https://github.com/ocamllabs/ocaml-ctypes/issues/113 *) - (* let _= field joystick_guid "data" (array 16 uint8_t) *) - let _= field joystick_guid "data0" uint8_t - let _= field joystick_guid "data1" uint8_t - let _= field joystick_guid "data2" uint8_t - let _= field joystick_guid "data3" uint8_t - let _= field joystick_guid "data4" uint8_t - let _= field joystick_guid "data5" uint8_t - let _= field joystick_guid "data6" uint8_t - let _= field joystick_guid "data7" uint8_t - let _= field joystick_guid "data8" uint8_t - let _= field joystick_guid "data9" uint8_t - let _= field joystick_guid "data10" uint8_t - let _= field joystick_guid "data11" uint8_t - let _= field joystick_guid "data12" uint8_t - let _= field joystick_guid "data13" uint8_t - let _= field joystick_guid "data14" uint8_t - let _= field joystick_guid "data15" uint8_t - let () = seal joystick_guid - -type joystick = Types.joystick ptr + +type joystick = C.Types.joystick ptr let unsafe_joystick_of_ptr addr : joystick = - from_voidp Types.joystick (ptr_of_raw_address addr) + from_voidp C.Types.joystick (ptr_of_raw_address addr) let unsafe_ptr_of_joystick joystick = raw_address_of_ptr (to_voidp joystick) -module Hat = Types.Hat +module Hat = C.Types.Hat -module Joystick_power_level = Types.Joystick_power_level +module Joystick_power_level = C.Types.Joystick_power_level -module Joystick_type = struct - include Types.Joystick_type -end +module Joystick_type = C.Types.Joystick_type -let joystick_close = - foreign "SDL_JoystickClose" (ptr Types.joystick @-> returning void) +let joystick_close = C.Functions.joystick_close -let joystick_current_power_level = - foreign "SDL_JoystickCurrentPowerLevel" - (ptr Types.joystick @-> returning int) +let joystick_current_power_level = C.Functions.joystick_current_power_level -let joystick_event_state = - foreign "SDL_JoystickEventState" (int @-> returning int) -let joystick_event_state i = joystick_event_state i |> nat_to_ok |> Result.map Unsigned.UInt8.of_int +let joystick_event_state i = + C.Functions.joystick_event_state i |> nat_to_ok |> Result.map Unsigned.UInt8.of_int -let joystick_from_instance_id = - foreign "SDL_JoystickFromInstanceID" - (joystick_id @-> returning (ptr Types.joystick)) +let joystick_from_instance_id = C.Functions.joystick_from_instance_id let joystick_get_event_state () = - joystick_event_state Types.sdl_query + joystick_event_state C.Types.sdl_query let joystick_set_event_state s = joystick_event_state (Unsigned.UInt8.to_int s) -let joystick_get_attached = - foreign "SDL_JoystickGetAttached" (ptr Types.joystick @-> returning bool) - -let joystick_get_axis = - foreign "SDL_JoystickGetAxis" (ptr Types.joystick @-> int @-> returning int16_t) +let joystick_get_attached = C.Functions.joystick_get_attached -let joystick_get_axis_initial_state = - foreign "SDL_JoystickGetAxisInitialState" - (ptr Types.joystick @-> int @-> returning int16_t) +let joystick_get_axis = C.Functions.joystick_get_axis -let joystick_get_ball = - foreign "SDL_JoystickGetBall" - (ptr Types.joystick @-> int @-> (ptr int) @-> (ptr int) @-> returning int) +let joystick_get_axis_initial_state j i = + let out = allocate int16_t 0 in + (* FIXME: should probably be an option, no? *) + if C.Functions.joystick_get_axis_initial_state j i out then !@ out else 0 let joystick_get_ball j i = let x = allocate int 0 in let y = allocate int 0 in - match joystick_get_ball j i x y with + match C.Functions.joystick_get_ball j i x y with | 0 -> Ok (!@ x, !@ y) | _ -> error () -let joystick_get_button = - foreign "SDL_JoystickGetButton" - (ptr Types.joystick @-> int @-> returning int_as_uint8_t) +let joystick_get_button j i = + Unsigned.UInt8.to_int (C.Functions.joystick_get_button j i) -let joystick_get_device_guid = - foreign "SDL_JoystickGetDeviceGUID" (int @-> returning joystick_guid) +let joystick_get_device_guid = C.Functions.joystick_get_device_guid -let joystick_get_device_product = - foreign "SDL_JoystickGetDeviceProduct" (int @-> returning int_as_uint16_t) +let joystick_get_device_product i = + Unsigned.UInt16.to_int (C.Functions.joystick_get_device_product i) -let joystick_get_device_product_version = - foreign "SDL_JoystickGetDeviceProductVersion" - (int @-> returning int_as_uint16_t) +let joystick_get_device_product_version i = + Unsigned.UInt16.to_int (C.Functions.joystick_get_device_product_version i) -let joystick_get_device_type = - foreign "SDL_JoystickGetDeviceType" (int @-> returning int) +let joystick_get_device_type = C.Functions.joystick_get_device_type -let joystick_get_device_instance_id = - foreign "SDL_JoystickGetDeviceInstanceID" (int @-> returning joystick_id) +let joystick_get_device_instance_id = C.Functions.joystick_get_device_instance_id -let joystick_get_device_vendor = - foreign "SDL_JoystickGetDeviceVendor" (int @-> returning int_as_uint16_t) +let joystick_get_device_vendor i = + Unsigned.UInt16.to_int (C.Functions.joystick_get_device_vendor i) -let joystick_get_guid = - foreign "SDL_JoystickGetGUID" (ptr Types.joystick @-> returning joystick_guid) +let joystick_get_guid = C.Functions.joystick_get_guid -let joystick_get_guid_from_string = - foreign "SDL_JoystickGetGUIDFromString" (string @-> returning joystick_guid) - -let joystick_get_guid_string = - foreign "SDL_JoystickGetGUIDString" - (joystick_guid @-> ptr char @-> int @-> returning void) +let joystick_get_guid_from_string = C.Functions.joystick_get_guid_from_string let joystick_get_guid_string guid = let len = 33 in let s = CArray.start (CArray.make char 33) in - joystick_get_guid_string guid s len; + C.Functions.joystick_get_guid_string guid s len; coerce (ptr char) string s -let joystick_get_hat = - foreign "SDL_JoystickGetHat" - (ptr Types.joystick @-> int @-> returning int_as_uint8_t) - -let joystick_get_product = - foreign "SDL_JoystickGetProduct" - (ptr Types.joystick @-> returning int_as_uint16_t) +let joystick_get_hat j i = + Unsigned.UInt8.to_int (C.Functions.joystick_get_hat j i) -let joystick_get_product_version = - foreign "SDL_JoystickGetProductVersion" - (ptr Types.joystick @-> returning int_as_uint16_t) +let joystick_get_product j = + Unsigned.UInt16.to_int (C.Functions.joystick_get_product j) -let joystick_get_type = - foreign "SDL_JoystickGetType" (ptr Types.joystick @-> returning int) +let joystick_get_product_version j = + Unsigned.UInt16.to_int (C.Functions.joystick_get_product_version j) -let joystick_get_vendor = - foreign "SDL_JoystickGetVendor" - (ptr Types.joystick @-> returning int_as_uint16_t) +let joystick_get_type = C.Functions.joystick_get_type -let joystick_instance_id = - foreign "SDL_JoystickInstanceID" - (ptr Types.joystick @-> returning joystick_id) +let joystick_get_vendor j = + Unsigned.UInt16.to_int (C.Functions.joystick_get_vendor j) let joystick_instance_id j = - match joystick_instance_id j with + match C.Functions.joystick_instance_id j with | n when n < 0l -> error () | n -> Ok n -let joystick_name = - foreign "SDL_JoystickName" (ptr Types.joystick @-> returning string_opt) -let joystick_name j = joystick_name j |> some_to_ok +let joystick_name j = + some_to_ok (C.Functions.joystick_name j) -let joystick_name_for_index = - foreign "SDL_JoystickNameForIndex" (int @-> returning string_opt) -let joystick_name_for_index i = joystick_name_for_index i |> some_to_ok +let joystick_name_for_index i = + some_to_ok (C.Functions.joystick_name_for_index i) -let joystick_num_axes = - foreign "SDL_JoystickNumAxes" (ptr Types.joystick @-> returning int) -let joystick_num_axes j = joystick_num_axes j |> nat_to_ok +let joystick_num_axes j = + nat_to_ok (C.Functions.joystick_num_axes j) -let joystick_num_balls = - foreign "SDL_JoystickNumBalls" (ptr Types.joystick @-> returning int) -let joystick_num_balls j = joystick_num_balls j |> nat_to_ok +let joystick_num_balls j = + nat_to_ok (C.Functions.joystick_num_balls j) -let joystick_num_buttons = - foreign "SDL_JoystickNumButtons" (ptr Types.joystick @-> returning int) -let joystick_num_buttons j = joystick_num_buttons j |> nat_to_ok +let joystick_num_buttons j = + nat_to_ok (C.Functions.joystick_num_buttons j) -let joystick_num_hats = - foreign "SDL_JoystickNumHats" (ptr Types.joystick @-> returning int) -let joystick_num_hats j = joystick_num_hats j |> nat_to_ok +let joystick_num_hats j = + nat_to_ok (C.Functions.joystick_num_hats j) -let joystick_open = - foreign "SDL_JoystickOpen" (int @-> returning (ptr_opt Types.joystick)) -let joystick_open i = joystick_open i |> some_to_ok +let joystick_open i = + some_to_ok (C.Functions.joystick_open i) -let joystick_update = - foreign "SDL_JoystickUpdate" (void @-> returning void) +let joystick_update = C.Functions.joystick_update -let num_joysticks = - foreign "SDL_NumJoysticks" (void @-> returning int) -let num_joysticks () = num_joysticks () |> nat_to_ok +let num_joysticks () = + nat_to_ok (C.Functions.num_joysticks ()) (* Game controller *) -type game_controller = unit ptr -let game_controller : game_controller typ = ptr void -let game_controller_opt : game_controller option typ = ptr_opt void +type game_controller = C.Types._game_controller structure ptr let unsafe_game_controller_of_ptr addr : game_controller = - ptr_of_raw_address addr + from_voidp C.Types.game_controller (ptr_of_raw_address addr) let unsafe_ptr_of_game_controller game_controller = raw_address_of_ptr (to_voidp game_controller) -type _button_bind -let button_bind : _button_bind structure typ = - structure "SDL_GameControllerBindType" -let button_bind_bind_type = field button_bind "bindType" int -let button_bind_value1 = field button_bind "value1" int (* simplified enum *) -let button_bind_value2 = field button_bind "value2" int -let () = seal button_bind - module Controller = struct - include Types.Controller - type button_bind = _button_bind structure - let bind_type v = getf v button_bind_bind_type - let bind_button_value v = getf v button_bind_value1 - let bind_axis_value v = getf v button_bind_value1 - let bind_hat_value v = getf v button_bind_value1, getf v button_bind_value2 + include C.Types.Controller + + type button_bind = C.Functions._button_bind structure + let bind_type v = getf v C.Functions.button_bind_bind_type + let bind_button_value v = getf v C.Functions.button_bind_value1 + let bind_axis_value v = getf v C.Functions.button_bind_value1 + let bind_hat_value v = + getf v C.Functions.button_bind_value1, getf v C.Functions.button_bind_value2 end -let game_controller_add_mapping = - foreign "SDL_GameControllerAddMapping" (string @-> returning int) -let game_controller_add_mapping s = game_controller_add_mapping s |> bool_to_ok +let game_controller_add_mapping s = + bool_to_ok (C.Functions.game_controller_add_mapping s) -let game_controller_add_mapping_from_rw = - foreign "SDL_GameControllerAddMappingsFromRW" - ~stub (Types.rw_ops @-> bool @-> returning int) let game_controller_add_mapping_from_rw r b = - game_controller_add_mapping_from_rw r b |> nat_to_ok + nat_to_ok (C.Functions.game_controller_add_mapping_from_rw r b) -let game_controller_close = - foreign "SDL_GameControllerClose" (game_controller @-> returning void) +let game_controller_close = C.Functions.game_controller_close -let game_controller_event_state = - foreign "SDL_GameControllerEventState" (int @-> returning int) let game_controller_event_state i = - game_controller_event_state i |> nat_to_ok |> Result.map Unsigned.UInt8.of_int + C.Functions.game_controller_event_state i |> nat_to_ok |> Result.map Unsigned.UInt8.of_int -let game_controller_from_instance_id = - foreign "SDL_GameControllerFromInstanceID" - (joystick_id @-> returning game_controller) +let game_controller_from_instance_id = C.Functions.game_controller_from_instance_id let game_controller_get_event_state () = - game_controller_event_state Types.sdl_query + game_controller_event_state C.Types.sdl_query let game_controller_set_event_state t = game_controller_event_state (Unsigned.UInt8.to_int t) -let game_controller_get_attached = - foreign "SDL_GameControllerGetAttached" (game_controller @-> returning bool) +let game_controller_get_attached = C.Functions.game_controller_get_attached -let game_controller_get_axis = - foreign "SDL_GameControllerGetAxis" - (game_controller @-> int @-> returning int16_t) +let game_controller_get_axis = C.Functions.game_controller_get_axis let game_controller_get_axis_from_string = - foreign "SDL_GameControllerGetAxisFromString" - (string @-> returning int) + C.Functions.game_controller_get_axis_from_string let game_controller_get_bind_for_axis = - foreign "SDL_GameControllerGetBindForAxis" - (game_controller @-> int @-> returning button_bind) + C.Functions.game_controller_get_bind_for_axis let game_controller_get_bind_for_button = - foreign "SDL_GameControllerGetBindForButton" - (game_controller @-> int @-> returning button_bind) + C.Functions.game_controller_get_bind_for_button -let game_controller_get_button = - foreign "SDL_GameControllerGetButton" - (game_controller @-> int @-> returning int_as_uint8_t) +let game_controller_get_button c i = + Unsigned.UInt8.to_int (C.Functions.game_controller_get_button c i) let game_controller_get_button_from_string = - foreign "SDL_GameControllerGetButtonFromString" (string @-> returning int) + C.Functions.game_controller_get_button_from_string -let game_controller_get_joystick = - foreign "SDL_GameControllerGetJoystick" - (game_controller @-> returning (ptr_opt Types.joystick)) -let game_controller_get_joystick c = game_controller_get_joystick c |> some_to_ok +let game_controller_get_joystick c = + some_to_ok (C.Functions.game_controller_get_joystick c) -let game_controller_get_product = - foreign "SDL_GameControllerGetProduct" - (game_controller @-> returning int_as_uint16_t) +let game_controller_get_product t = + Unsigned.UInt16.to_int (C.Functions.game_controller_get_product t) -let game_controller_get_product_version = - foreign "SDL_GameControllerGetProductVersion" - (game_controller @-> returning int_as_uint16_t) +let game_controller_get_product_version t = + Unsigned.UInt16.to_int (C.Functions.game_controller_get_product_version t) let game_controller_get_string_for_axis = - foreign "SDL_GameControllerGetStringForAxis" (int @-> returning string_opt) + C.Functions.game_controller_get_string_for_axis let game_controller_get_string_for_button = - foreign "SDL_GameControllerGetStringForButton" (int @-> returning string_opt) + C.Functions.game_controller_get_string_for_button -let game_controller_get_vendor = - foreign "SDL_GameControllerGetVendor" - (game_controller @-> returning int_as_uint16_t) +let game_controller_get_vendor t = + Unsigned.UInt16.to_int (C.Functions.game_controller_get_vendor t) -let game_controller_mapping = - foreign "SDL_GameControllerMapping" - (game_controller @-> returning string_opt) -let game_controller_mapping c = game_controller_mapping c |> some_to_ok +let game_controller_mapping c = + some_to_ok (C.Functions.game_controller_mapping c) -let game_controller_mapping_for_index = - foreign "SDL_GameControllerMappingForIndex" - (int @-> returning string_opt) -let game_controller_mapping_for_index i = game_controller_mapping_for_index i |> some_to_ok +let game_controller_mapping_for_index i = + some_to_ok (C.Functions.game_controller_mapping_for_index i) -let game_controller_mapping_for_guid = - foreign "SDL_GameControllerMappingForGUID" - (joystick_guid @-> returning string_opt) -let game_controller_mapping_for_guid g = game_controller_mapping_for_guid g |> some_to_ok +let game_controller_mapping_for_guid g = + some_to_ok (C.Functions.game_controller_mapping_for_guid g) -let game_controller_name = - foreign "SDL_GameControllerName" - (game_controller @-> returning string_opt) -let game_controller_name c = game_controller_name c |> some_to_ok +let game_controller_name c = + some_to_ok (C.Functions.game_controller_name c) -let game_controller_name_for_index = - foreign "SDL_GameControllerNameForIndex" - (int @-> returning string_opt) -let game_controller_name_for_index i = game_controller_name_for_index i |> some_to_ok +let game_controller_name_for_index i = + some_to_ok (C.Functions.game_controller_name_for_index i) -let game_controller_num_mappings = - foreign "SDL_GameControllerNumMappings" (void @-> returning int) +let game_controller_num_mappings = C.Functions.game_controller_num_mappings -let game_controller_open = - foreign "SDL_GameControllerOpen" - (int @-> returning game_controller_opt) -let game_controller_open i = game_controller_open i |> some_to_ok +let game_controller_open i = + some_to_ok (C.Functions.game_controller_open i) -let game_controller_update = - foreign "SDL_GameControllerUpdate" (void @-> returning void) +let game_controller_update = C.Functions.game_controller_update -let is_game_controller = - foreign "SDL_IsGameController" (int @-> returning bool) +let is_game_controller = C.Functions.is_game_controller (* Events *) type event_type = int -let event_type : event_type typ = int_as_uint32_t module Event = struct - - include Types.Event + include C.Types.Event + (* Event structures *) let create () = make t let opt_addr = function @@ -3222,6 +2426,7 @@ module Event = struct | `Unknown of window_event_id ] let enum_of_window_event_id = + (*let add acc (k, v) = Imap.add k v acc in*) let enums = [ window_event_shown, `Shown; window_event_hidden, `Hidden; @@ -3240,7 +2445,7 @@ module Event = struct window_event_take_focus, `Take_focus; window_event_hit_test, `Hit_test; ] in - enums + (*List.fold_left add Imap.empty*) enums let window_event_enum id = try List.assoc id enum_of_window_event_id with Not_found -> `Unknown id @@ -3378,10 +2583,10 @@ module Event = struct sys_wm_event, `Sys_wm_event; text_editing, `Text_editing; text_input, `Text_input; - user_event, `User_event; + C.Types.Event.user_event, `User_event; quit, `Quit; - window_event, `Window_event; - display_event, `Display_event; + C.Types.Event.window_event, `Window_event; + C.Types.Event.display_event, `Display_event; sensor_update, `Sensor_update; ] in List.fold_left add Imap.empty enums @@ -3392,64 +2597,45 @@ end type event = Event.t union -let event_state = - foreign "SDL_EventState" (event_type @-> int @-> returning uint8_t) - let get_event_state e = - event_state e Types.sdl_query + C.Functions.event_state (Unsigned.UInt32.of_int e) C.Types.sdl_query let set_event_state e s = - ignore (event_state e (Unsigned.UInt8.to_int s)) - -let flush_event = - foreign "SDL_FlushEvent" (event_type @-> returning void) + ignore (C.Functions.event_state + (Unsigned.UInt32.of_int e) (Unsigned.UInt8.to_int s)) -let flush_events = - foreign "SDL_FlushEvents" (event_type @-> event_type @-> returning void) +let flush_event e = C.Functions.flush_event (Unsigned.UInt32.of_int e) -let has_event = - foreign "SDL_HasEvent" (event_type @-> returning bool) +let flush_events f t = + C.Functions.flush_events (Unsigned.UInt32.of_int f) (Unsigned.UInt32.of_int t) -let has_events = - foreign "SDL_HasEvents" (event_type @-> event_type @-> returning bool) +let has_event e = C.Functions.has_event (Unsigned.UInt32.of_int e) -let poll_event = - foreign "SDL_PollEvent" (ptr Event.t @-> returning bool) +let has_events f t = + C.Functions.has_events (Unsigned.UInt32.of_int f) (Unsigned.UInt32.of_int t) let poll_event e = - poll_event (Event.opt_addr e) + C.Functions.poll_event (Event.opt_addr e) -let pump_events = - foreign "SDL_PumpEvents" (void @-> returning void) - -let push_event = - foreign "SDL_PushEvent" (ptr Event.t @-> returning int) +let pump_events = C.Functions.pump_events let push_event e = - push_event (addr e) |> bool_to_ok - -let register_events = - foreign "SDL_RegisterEvents" (int @-> returning uint32_t) + bool_to_ok (C.Functions.push_event (addr e)) -let register_event () = match Unsigned.UInt32.to_int32 (register_events 1) with -| -1l -> None | t -> Some (Int32.to_int t) +let register_event () = + let out = C.Functions.register_events 1 in + if Unsigned.UInt32.(equal out max_int) then None else Some (Unsigned.UInt32.to_int out) -let wait_event e = match Async_functions.wait_event (Event.opt_addr e) with +let wait_event e = match C.Async_functions.wait_event (Event.opt_addr e) with | 1 -> Ok () | _ -> error () let wait_event_timeout e t = - Async_functions.wait_event_timeout (Event.opt_addr e) t + C.Async_functions.wait_event_timeout (Event.opt_addr e) t (* Force feedback *) -type haptic = unit ptr -let haptic : haptic typ = ptr void -let haptic_opt : haptic option typ = ptr_opt void - module Haptic = struct - let infinity = -1l - - include Types.Haptic + include C.Types.Haptic module Direction = struct include Direction @@ -3469,8 +2655,6 @@ module Haptic = struct let dir_2 d = CArray.get (getf d dir) 2 end - (* Effects *) - type effect_type = int let create_effect () = make Effect.t @@ -3729,177 +2913,108 @@ module Haptic = struct Unsigned.UInt16.to_int, Unsigned.UInt16.of_int) end +type haptic = Haptic.t ptr + type haptic_effect = Haptic.Effect.t union type haptic_effect_id = int -let haptic_effect_id : int typ = int -let haptic_close = - foreign "SDL_HapticClose" (haptic @-> returning void) +let haptic_close = C.Functions.haptic_close -let haptic_destroy_effect = - foreign "SDL_HapticDestroyEffect" - (haptic @-> int @-> returning void) - -let haptic_effect_supported = - foreign "SDL_HapticEffectSupported" - (haptic @-> ptr Haptic.Effect.t @-> returning int) +let haptic_destroy_effect = C.Functions.haptic_destroy_effect let haptic_effect_supported h e = - haptic_effect_supported h (addr e) |> bool_to_ok - -let haptic_get_effect_status = - foreign "SDL_HapticGetEffectStatus" - (haptic @-> haptic_effect_id @-> returning int) -let haptic_get_effect_status h i = haptic_get_effect_status h i |> bool_to_ok + bool_to_ok (C.Functions.haptic_effect_supported h (addr e)) -let haptic_index = - foreign "SDL_HapticIndex" (haptic @-> returning int) -let haptic_index h = haptic_index h |> nat_to_ok +let haptic_get_effect_status h i = + bool_to_ok (C.Functions.haptic_get_effect_status h i) -let haptic_name = - foreign "SDL_HapticName" (int @-> returning string_opt) -let haptic_name i = haptic_name i |> some_to_ok +let haptic_index h = nat_to_ok (C.Functions.haptic_index h) -let haptic_new_effect = - foreign "SDL_HapticNewEffect" - (haptic @-> ptr Haptic.Effect.t @-> returning int) +let haptic_name i = some_to_ok (C.Functions.haptic_name i) let haptic_new_effect h e = - haptic_new_effect h (addr e) |> nat_to_ok - -let haptic_num_axes = - foreign "SDL_HapticNumAxes" (haptic @-> returning int) -let haptic_num_axes h = haptic_num_axes h |> nat_to_ok + nat_to_ok (C.Functions.haptic_new_effect h (addr e)) -let haptic_num_effects = - foreign "SDL_HapticNumEffects" (haptic @-> returning int) -let haptic_num_effects h = haptic_num_effects h |> nat_to_ok +let haptic_num_axes h = + nat_to_ok (C.Functions.haptic_num_axes h) -let haptic_num_effects_playing = - foreign "SDL_HapticNumEffectsPlaying" (haptic @-> returning int) -let haptic_num_effects_playing h = haptic_num_effects_playing h |> nat_to_ok +let haptic_num_effects h = + nat_to_ok (C.Functions.haptic_num_effects h) -let haptic_open = - foreign "SDL_HapticOpen" (int @-> returning haptic_opt) -let haptic_open i = haptic_open i |> some_to_ok +let haptic_num_effects_playing h = + nat_to_ok (C.Functions.haptic_num_effects_playing h) -let haptic_open_from_joystick = - foreign "SDL_HapticOpenFromJoystick" - (ptr Types.joystick @-> returning haptic_opt) -let haptic_open_from_joystick j = haptic_open_from_joystick j |> some_to_ok +let haptic_open i = some_to_ok (C.Functions.haptic_open i) -let haptic_open_from_mouse = - foreign "SDL_HapticOpenFromMouse" - (void @-> returning haptic_opt) -let haptic_open_from_mouse () = haptic_open_from_mouse () |> some_to_ok +let haptic_open_from_joystick j = + some_to_ok (C.Functions.haptic_open_from_joystick j) -let haptic_opened = - foreign "SDL_HapticOpened" (int @-> returning int) +let haptic_open_from_mouse () = + some_to_ok (C.Functions.haptic_open_from_mouse ()) -let haptic_opened i = match haptic_opened i with +let haptic_opened i = match C.Functions.haptic_opened i with | 0 -> false | 1 -> true | _ -> assert false -let haptic_pause = - foreign "SDL_HapticPause" (haptic @-> returning int) -let haptic_pause h = haptic_pause h |> zero_to_ok +let haptic_pause h = zero_to_ok (C.Functions.haptic_pause h) -let haptic_query = - foreign "SDL_HapticQuery" (haptic @-> returning int) +let haptic_query = C.Functions.haptic_query -let haptic_rumble_init = - foreign "SDL_HapticRumbleInit" (haptic @-> returning int) -let haptic_rumble_init h = haptic_rumble_init h |> zero_to_ok +let haptic_rumble_init h = + zero_to_ok (C.Functions.haptic_rumble_init h) -let haptic_rumble_play = - foreign "SDL_HapticRumblePlay" - (haptic @-> float @-> int32_t @-> returning int) -let haptic_rumble_play h x y = haptic_rumble_play h x y |> zero_to_ok +let haptic_rumble_play h x y = + zero_to_ok (C.Functions.haptic_rumble_play h x y) -let haptic_rumble_stop = - foreign "SDL_HapticRumbleStop" (haptic @-> returning int) -let haptic_rumble_stop h = haptic_rumble_stop h |> zero_to_ok +let haptic_rumble_stop h = + zero_to_ok (C.Functions.haptic_rumble_stop h) -let haptic_rumble_supported = - foreign "SDL_HapticRumbleSupported" (haptic @-> returning int) -let haptic_rumble_supported h = haptic_rumble_supported h |> bool_to_ok +let haptic_rumble_supported h = + bool_to_ok (C.Functions.haptic_rumble_supported h) -let haptic_run_effect = - foreign "SDL_HapticRunEffect" - (haptic @-> haptic_effect_id @-> int32_t @-> returning int) -let haptic_run_effect h i n = haptic_run_effect h i n |> zero_to_ok +let haptic_run_effect h i n = + zero_to_ok (C.Functions.haptic_run_effect h i n) -let haptic_set_autocenter = - foreign "SDL_HapticSetAutocenter" (haptic @-> int @-> returning int) -let haptic_set_autocenter h n = haptic_set_autocenter h n |> zero_to_ok +let haptic_set_autocenter h n = + zero_to_ok (C.Functions.haptic_set_autocenter h n) -let haptic_set_gain = - foreign "SDL_HapticSetGain" (haptic @-> int @-> returning int) -let haptic_set_gain h n = haptic_set_gain h n |> zero_to_ok +let haptic_set_gain h n = zero_to_ok (C.Functions.haptic_set_gain h n) -let haptic_stop_all = - foreign "SDL_HapticStopAll" (haptic @-> returning int) -let haptic_stop_all h = haptic_stop_all h |> zero_to_ok +let haptic_stop_all h = zero_to_ok (C.Functions.haptic_stop_all h) -let haptic_stop_effect = - foreign "SDL_HapticStopEffect" - (haptic @-> haptic_effect_id @-> returning int) -let haptic_stop_effect h i = haptic_stop_effect h i |> zero_to_ok +let haptic_stop_effect h i = zero_to_ok (C.Functions.haptic_stop_effect h i) -let haptic_unpause = - foreign "SDL_HapticUnpause" (haptic @-> returning int) -let haptic_unpause h = haptic_unpause h |> zero_to_ok - -let haptic_update_effect = - foreign "SDL_HapticUpdateEffect" - (haptic @-> haptic_effect_id @-> ptr Haptic.Effect.t @-> - returning int) +let haptic_unpause h = zero_to_ok (C.Functions.haptic_unpause h) let haptic_update_effect h id e = - haptic_update_effect h id (addr e) |> zero_to_ok + zero_to_ok (C.Functions.haptic_update_effect h id (addr e)) -let joystick_is_haptic = - foreign "SDL_JoystickIsHaptic" - (ptr Types.joystick @-> returning int) -let joystick_is_haptic j = joystick_is_haptic j |> bool_to_ok +let joystick_is_haptic j = bool_to_ok (C.Functions.joystick_is_haptic j) -let mouse_is_haptic = - foreign "SDL_MouseIsHaptic" (void @-> returning int) -let mouse_is_haptic () = mouse_is_haptic () |> bool_to_ok +let mouse_is_haptic () = bool_to_ok (C.Functions.mouse_is_haptic ()) -let num_haptics = - foreign "SDL_NumHaptics" (void @-> returning int) -let num_haptics () = num_haptics () |> nat_to_ok +let num_haptics () = nat_to_ok (C.Functions.num_haptics ()) (* Audio *) (* Audio drivers *) -let audio_init = - foreign "SDL_AudioInit" (string_opt @-> returning int) -let audio_init s = audio_init s |> zero_to_ok +let audio_init s = zero_to_ok (C.Functions.audio_init s) -let audio_quit = - foreign "SDL_AudioQuit" (void @-> returning void) +let audio_quit = C.Functions.audio_quit -let get_audio_driver = - foreign "SDL_GetAudioDriver" - (int @-> returning string_opt) -let get_audio_driver i = get_audio_driver i |> some_to_ok +let get_audio_driver i = some_to_ok (C.Functions.get_audio_driver i) -let get_current_audio_driver = - foreign "SDL_GetCurrentAudioDriver" (void @-> returning string_opt) +let get_current_audio_driver = C.Functions.get_current_audio_driver -let get_num_audio_drivers = - foreign "SDL_GetNumAudioDrivers" (void @-> returning int) -let get_num_audio_drivers () = get_num_audio_drivers () |> nat_to_ok +let get_num_audio_drivers () = + nat_to_ok (C.Functions.get_num_audio_drivers ()) (* Audio devices *) -module Audio = Types.Audio +module Audio = C.Types.Audio -type audio_device_id = int32 -let audio_device_id = int32_as_uint32_t +type audio_device_id = uint32 type audio_callback = unit Ctypes_static.ptr -> Unsigned.uint8 Ctypes_static.ptr -> int -> unit @@ -3909,7 +3024,7 @@ type audio_spec = as_format : Audio.format; as_channels : uint8; as_silence : uint8; - as_samples : uint8; + as_samples : uint16; as_size : uint32; as_callback : audio_callback option; } @@ -3922,57 +3037,51 @@ let audio_callback kind f = f (bigarray_of_ptr array1 len kind p) let as_callback = - Foreign.funptr_opt ~thread_registration:true ~runtime_lock:true Types.as_callback_type + Foreign.funptr_opt ~thread_registration:true ~runtime_lock:true C.Types.as_callback_type let audio_spec_of_c c = - let as_freq = getf c Types.as_freq in - let as_format = Unsigned.UInt16.to_int (getf c Types.as_format) in - let as_channels = Unsigned.UInt8.to_int (getf c Types.as_channels) in - let as_silence = Unsigned.UInt8.to_int (getf c Types.as_silence) in - let as_samples = Unsigned.UInt16.to_int (getf c Types.as_samples) in - let as_size = Unsigned.UInt32.to_int32 (getf c Types.as_size) in + let as_freq = getf c C.Types.as_freq in + let as_format = Unsigned.UInt16.to_int (getf c C.Types.as_format) in + let as_channels = Unsigned.UInt8.to_int (getf c C.Types.as_channels) in + let as_silence = Unsigned.UInt8.to_int (getf c C.Types.as_silence) in + let as_samples = Unsigned.UInt16.to_int (getf c C.Types.as_samples) in + let as_size = Unsigned.UInt32.to_int32 (getf c C.Types.as_size) in let as_callback = None in { as_freq; as_format; as_channels; as_silence; as_samples; as_size; as_callback; } let audio_spec_to_c a = - let c = make Types.audio_spec in - setf c Types.as_freq a.as_freq; - setf c Types.as_format (Unsigned.UInt16.of_int a.as_format); - setf c Types.as_channels (Unsigned.UInt8.of_int a.as_channels); - setf c Types.as_silence (Unsigned.UInt8.of_int a.as_silence); (* irrelevant *) - setf c Types.as_samples (Unsigned.UInt16.of_int a.as_samples); - setf c Types.as_size (Unsigned.UInt32.of_int32 a.as_size); (* irrelevant *) - setf c Types.as_callback - (coerce as_callback (static_funptr Types.as_callback_type) a.as_callback); - setf c Types.as_userdata null; + let c = make C.Types.audio_spec in + setf c C.Types.as_freq a.as_freq; + setf c C.Types.as_format (Unsigned.UInt16.of_int a.as_format); + setf c C.Types.as_channels (Unsigned.UInt8.of_int a.as_channels); + setf c C.Types.as_silence (Unsigned.UInt8.of_int a.as_silence); (* irrelevant *) + setf c C.Types.as_samples (Unsigned.UInt16.of_int a.as_samples); + setf c C.Types.as_size (Unsigned.UInt32.of_int32 a.as_size); (* irrelevant *) + setf c C.Types.as_callback + (coerce as_callback (static_funptr C.Types.as_callback_type) a.as_callback); + setf c C.Types.as_userdata null; c -let close_audio_device = - foreign "SDL_CloseAudioDevice" (audio_device_id @-> returning void) - -let free_wav = - foreign "SDL_FreeWAV" (ptr void @-> returning void) +let close_audio_device d = + C.Functions.close_audio_device (Unsigned.UInt32.of_int32 d) let free_wav ba = - free_wav (to_voidp (bigarray_start array1 ba)) + C.Functions.free_wav (to_voidp (bigarray_start array1 ba)) -let get_audio_device_name = - foreign "SDL_GetAudioDeviceName" - (int @-> bool @-> returning string_opt) -let get_audio_device_name i b = get_audio_device_name i b |> some_to_ok +let get_audio_device_name i b = + some_to_ok (C.Functions.get_audio_device_name i b) -let get_audio_device_status = - foreign "SDL_GetAudioDeviceStatus" (audio_device_id @-> returning int) +let get_audio_device_status d = + C.Functions.get_audio_device_status (Unsigned.UInt32.of_int32 d) -let get_num_audio_devices = - foreign "SDL_GetNumAudioDevices" (bool @-> returning int) -let get_num_audio_devices b = get_num_audio_devices b |> nat_to_ok +let get_num_audio_devices b = nat_to_ok (C.Functions.get_num_audio_devices b) let load_wav_rw ops spec kind = let d = allocate (ptr uint8_t) (from_voidp uint8_t null) in let len = allocate uint32_t Unsigned.UInt32.zero in - match Async_functions.load_wav_rw ops 0 (addr (audio_spec_to_c spec)) d len with + match C.Async_functions.load_wav_rw + ops 0 (addr (audio_spec_to_c spec)) d len with | None -> error () | Some r -> let rspec = audio_spec_of_c (!@ r) in @@ -3986,119 +3095,93 @@ let load_wav_rw ops spec kind = let d = coerce (ptr uint8_t) ba_ptr (!@ d) in Ok (rspec, bigarray_of_ptr array1 ba_size kind d) -let lock_audio_device = - foreign "SDL_LockAudioDevice" (audio_device_id @-> returning void) - -let open_audio_device = - foreign "SDL_OpenAudioDevice" - (string_opt @-> bool @-> ptr Types.audio_spec @-> ptr Types.audio_spec @-> - int @-> returning int32_as_uint32_t) +let lock_audio_device d = + C.Functions.lock_audio_device (Unsigned.UInt32.of_int32 d) let open_audio_device dev capture desired allow = let desiredc = audio_spec_to_c desired in - let obtained = make Types.audio_spec in - match open_audio_device dev capture (addr desiredc) (addr obtained) allow + let obtained = make C.Types.audio_spec in + match C.Functions.open_audio_device + dev capture (addr desiredc) (addr obtained) allow with - | id when id = Int32.zero -> error () - | id -> Ok (id, audio_spec_of_c obtained) + | id when Unsigned.UInt32.(equal id zero) -> error () + | id -> Ok (Unsigned.UInt32.to_int32 id, audio_spec_of_c obtained) -let pause_audio_device = - foreign "SDL_PauseAudioDevice" (audio_device_id @-> bool @-> returning void) +let pause_audio_device d = + C.Functions.pause_audio_device (Unsigned.UInt32.of_int32 d) -let unlock_audio_device = - foreign "SDL_UnlockAudioDevice" (audio_device_id @-> returning void) - -let queue_audio = - foreign "SDL_QueueAudio" - (audio_device_id @-> ptr void @-> int_as_uint32_t @-> returning int) +let unlock_audio_device d = + C.Functions.unlock_audio_device (Unsigned.UInt32.of_int32 d) let queue_audio dev ba = let len = Bigarray.Array1.dim ba in let kind_size = ba_kind_byte_size (Bigarray.Array1.kind ba) in - queue_audio dev (to_voidp (bigarray_start array1 ba)) (len * kind_size) |> zero_to_ok - -let dequeue_audio = - foreign "SDL_DequeueAudio" - (audio_device_id @-> ptr void @-> int @-> returning int_as_uint32_t) + zero_to_ok (C.Functions.queue_audio + (Unsigned.UInt32.of_int32 dev) + (to_voidp (bigarray_start array1 ba)) + (Unsigned.UInt32.of_int (len * kind_size))) let dequeue_audio dev ba = let len = Bigarray.Array1.dim ba in let kind_size = ba_kind_byte_size (Bigarray.Array1.kind ba) in - dequeue_audio dev (to_voidp (bigarray_start array1 ba)) (len * kind_size) + Unsigned.UInt32.to_int + (C.Functions.dequeue_audio + (Unsigned.UInt32.of_int32 dev) + (to_voidp (bigarray_start array1 ba)) (len * kind_size)) -let get_queued_audio_size = - foreign "SDL_GetQueuedAudioSize" - (audio_device_id @-> returning int_as_uint32_t) +let get_queued_audio_size d = + Unsigned.UInt32.to_int + (C.Functions.get_queued_audio_size (Unsigned.UInt32.of_int32 d)) -let clear_queued_audio = - foreign "SDL_ClearQueuedAudio" (audio_device_id @-> returning void) +let clear_queued_audio d = + C.Functions.clear_queued_audio (Unsigned.UInt32.of_int32 d) (* Timer *) -let delay = Async_functions.delay +let delay = C.Async_functions.delay -let get_ticks = - foreign "SDL_GetTicks" (void @-> returning int32_t) +let get_ticks = C.Functions.get_ticks -let get_ticks64 = - foreign "SDL_GetTicks64" (void @-> returning int64_t) +let get_ticks64 = C.Functions.get_ticks64 -let get_performance_counter = - foreign "SDL_GetPerformanceCounter" (void @-> returning int64_t) +let get_performance_counter = C.Functions.get_performance_counter -let get_performance_frequency = - foreign "SDL_GetPerformanceFrequency" (void @-> returning int64_t) +let get_performance_frequency = C.Functions.get_performance_frequency (* Platform and CPU information *) -let get_platform = - foreign "SDL_GetPlatform" (void @-> returning string) +let get_platform = C.Functions.get_platform -let get_cpu_cache_line_size = - foreign "SDL_GetCPUCacheLineSize" (void @-> returning int) -let get_cpu_cache_line_size () = get_cpu_cache_line_size () |> nat_to_ok +let get_cpu_cache_line_size () = + nat_to_ok (C.Functions.get_cpu_cache_line_size ()) -let get_cpu_count = - foreign "SDL_GetCPUCount" (void @-> returning int) +let get_cpu_count = C.Functions.get_cpu_count -let get_system_ram = - foreign "SDL_GetSystemRAM" (void @-> returning int) +let get_system_ram = C.Functions.get_system_ram -let has_3d_now = - foreign "SDL_Has3DNow" (void @-> returning bool) +let has_3d_now = C.Functions.has_3d_now -let has_altivec = - foreign "SDL_HasAltiVec" (void @-> returning bool) +let has_altivec = C.Functions.has_altivec -let has_avx = - foreign ~stub "SDL_HasAVX" (void @-> returning bool) +let has_avx = C.Functions.has_avx -let has_avx2 = - foreign "SDL_HasAVX2" (void @-> returning bool) +let has_avx2 = C.Functions.has_avx2 -let has_mmx = - foreign "SDL_HasMMX" (void @-> returning bool) +let has_mmx = C.Functions.has_mmx -let has_neon = - foreign "SDL_HasNEON" (void @-> returning bool) +let has_neon = C.Functions.has_neon -let has_rdtsc = - foreign "SDL_HasRDTSC" (void @-> returning bool) +let has_rdtsc = C.Functions.has_rdtsc -let has_sse = - foreign "SDL_HasSSE" (void @-> returning bool) +let has_sse = C.Functions.has_sse -let has_sse2 = - foreign "SDL_HasSSE2" (void @-> returning bool) +let has_sse2 = C.Functions.has_sse2 -let has_sse3 = - foreign "SDL_HasSSE3" (void @-> returning bool) +let has_sse3 = C.Functions.has_sse3 -let has_sse41 = - foreign "SDL_HasSSE41" (void @-> returning bool) +let has_sse41 = C.Functions.has_sse41 -let has_sse42 = - foreign "SDL_HasSSE42" (void @-> returning bool) +let has_sse42 = C.Functions.has_sse42 (* Power management *) @@ -4106,24 +3189,21 @@ type power_state = [ `Unknown | `On_battery | `No_battery | `Charging | `Charged ] let power_state = - Types.[ Powerstate.unknown, `Unknown; - Powerstate.on_battery, `On_battery; - Powerstate.no_battery, `No_battery; - Powerstate.charging, `Charging; - Powerstate.charged, `Charged; ] + C.Types.Powerstate.[ unknown, `Unknown; + on_battery, `On_battery; + no_battery, `No_battery; + charging, `Charging; + charged, `Charged; ] type power_info = { pi_state : power_state; pi_secs : int option; pi_pct : int option; } -let get_power_info = - foreign "SDL_GetPowerInfo" ((ptr int) @-> (ptr int) @-> returning int) - let get_power_info () = let secs = allocate int 0 in let pct = allocate int 0 in - let s = get_power_info secs pct in + let s = C.Functions.get_power_info secs pct in let pi_state = try List.assoc s power_state with Not_found -> assert false in let pi_secs = match !@ secs with -1 -> None | secs -> Some secs in let pi_pct = match !@ pct with -1 -> None | pct -> Some pct in diff --git a/src/tsdl.mllib b/src/tsdl.mllib index 26bfff5..b22c40b 100644 --- a/src/tsdl.mllib +++ b/src/tsdl.mllib @@ -1,7 +1,8 @@ -Tsdl_consts Type_description Types_stubs Types_generated Async_function_description Async_functions_generated +Function_description +Functions_generated Tsdl \ No newline at end of file diff --git a/src/type_description.ml b/src/type_description.ml index 717c66b..c6b3469 100644 --- a/src/type_description.ml +++ b/src/type_description.ml @@ -985,12 +985,13 @@ module Types (F : Ctypes.TYPE) = struct let () = F.seal t end - (*type guid = _guid Ctypes_static.structure + type _guid + type guid = _guid Ctypes_static.structure let guid : guid F.typ = F.typedef (F.structure "_guid") "SDL_GUID" let _= F.field guid "data" F.(array 16 uint8_t) let () = F.seal guid - let joystick_guid = F.typedef guid "SDL_JoystickGUID"*) + let joystick_guid = F.typedef guid "SDL_JoystickGUID" type _joystick type joystick = _joystick Ctypes_static.structure diff --git a/support/consts.ml b/support/consts.ml deleted file mode 100644 index fb3d4e8..0000000 --- a/support/consts.ml +++ /dev/null @@ -1,19 +0,0 @@ -(*--------------------------------------------------------------------------- - Copyright (c) 2013 The tsdl programmers. All rights reserved. - SPDX-License-Identifier: ISC - ---------------------------------------------------------------------------*) - -(* Outputs SDL's #defines and enum values as OCaml let bindings. *) - -external output_consts : string -> unit = "output_consts" - -let main () = - let outf = - if Array.length Sys.argv < 2 then "" else - if Sys.argv.(1) = "" then "" else - if Sys.argv.(1) = "-" then "" else - Sys.argv.(1) - in - output_consts outf - -let () = main () diff --git a/support/consts_stub.c b/support/consts_stub.c deleted file mode 100644 index e661f43..0000000 --- a/support/consts_stub.c +++ /dev/null @@ -1,83 +0,0 @@ -/*--------------------------------------------------------------------------- - Copyright (c) 2013 The tsdl programmers. All rights reserved. - SPDX-License-Identifier: ISC - ---------------------------------------------------------------------------*/ - -#include -#include -#include -#include -#include "SDL.h" -#include - -void let (FILE *fd, const char *symb) -{ - int i; - fprintf (fd, "let "); - for (i = 0; i < strlen(symb); i++) { fprintf (fd, "%c", tolower (symb[i])); } -} - -void str_v (FILE *fd, char *symb, const char *value) -{ let (fd, symb); fprintf (fd, " = \"%s\"\n", value); } - -void int_v (FILE *fd, char *symb, int value) -{ let (fd, symb); fprintf (fd, " = %d\n", value); } - -void int_vx (FILE *fd, char *symb, int value) -{ let (fd, symb); fprintf (fd, " = 0x%X\n", value); } - -void int32_v (FILE *fd, char *symb, int32_t value) -{ let (fd, symb); fprintf (fd, " = 0x%Xl\n", value); } - -void consts (FILE *fd) -{ - -#define int_v(e) int_v(fd, "" # e, (int)e) -#define int_vx(e) int_vx(fd, "" # e, (int)e) -#define int32_v(e) int32_v(fd, "" # e, (int32_t)e) -#define str_v(e) str_v(fd, "" # e, (const char *)e) - - /* Check that a C int is 32 bits. We rely on that when we pass - arrays of Point or Rect structs as bigarrays (e.g. see - Sdl.enclose_points_ba */ - - assert(sizeof(int) == 4); - - str_v (SDL_HINT_FRAMEBUFFER_ACCELERATION); - str_v (SDL_HINT_IDLE_TIMER_DISABLED); - str_v (SDL_HINT_MOUSE_FOCUS_CLICKTHROUGH); - str_v (SDL_HINT_ORIENTATIONS); - str_v (SDL_HINT_RENDER_DRIVER); - str_v (SDL_HINT_RENDER_OPENGL_SHADERS); - str_v (SDL_HINT_RENDER_LOGICAL_SIZE_MODE); - str_v (SDL_HINT_RENDER_SCALE_QUALITY); - str_v (SDL_HINT_RENDER_VSYNC); - - str_v (SDL_HINT_NO_SIGNAL_HANDLERS); - str_v (SDL_HINT_THREAD_STACK_SIZE); - str_v (SDL_HINT_WINDOW_FRAME_USABLE_WHILE_CURSOR_HIDDEN); - - str_v (SDL_HINT_AUDIO_RESAMPLING_MODE); - str_v (SDL_HINT_MOUSE_NORMAL_SPEED_SCALE); - str_v (SDL_HINT_MOUSE_RELATIVE_SPEED_SCALE); - str_v (SDL_HINT_TOUCH_MOUSE_EVENTS); - str_v (SDL_HINT_MOUSE_TOUCH_EVENTS); - -} - -CAMLprim value output_consts (value fname) -{ - const char *outf = String_val (fname); - FILE *fd; - if (strlen(outf) == 0) { fd = stdout; } - else - { - fd = fopen (outf, "w"); - if (!fd) { perror(outf); exit (1); } - } - - consts(fd); - fflush(fd); - if (fd != stdout) { fclose (fd); } - return Val_unit; -} diff --git a/support/functions_generator.ml b/support/functions_generator.ml new file mode 100644 index 0000000..7e34d43 --- /dev/null +++ b/support/functions_generator.ml @@ -0,0 +1,27 @@ +let c_headers = "#define SDL_MAIN_HANDLED 1\n\ + #include \"SDL.h\"\n\ + #include \"SDL_vulkan.h\"\n\ + #undef main" + +let concurrency = Cstubs.sequential +let errno = Cstubs.ignore_errno +let prefix = "sdl2_stubs" + +let main () = + match Sys.argv.(1) with + | "ml" -> + let ml_out = open_out "src/functions_generated.ml" in + let ml_fmt = Format.formatter_of_out_channel ml_out in + Cstubs.write_ml ~concurrency ml_fmt ~prefix (module Function_description.Functions); + Format.pp_print_flush ml_fmt (); + close_out ml_out + | "c" -> + let c_out = open_out "src/functions_stubs.c" in + let c_fmt = Format.formatter_of_out_channel c_out in + Format.fprintf c_fmt "%s@\n" c_headers; + Cstubs.write_c ~concurrency c_fmt ~prefix (module Function_description.Functions); + Format.pp_print_flush c_fmt (); + close_out c_out + | _ -> () + +let () = main () From e24632802819a658e292a5c0ff0c9e5a386a04e5 Mon Sep 17 00:00:00 2001 From: Pierre Boutillier Date: Tue, 27 May 2025 14:14:32 +0200 Subject: [PATCH 8/8] Add assertions to test hardwirred values correctness --- src/tsdl.ml | 13 +++++++++++++ src/type_description.ml | 4 ++-- 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/src/tsdl.ml b/src/tsdl.ml index 9a7f506..49130c6 100644 --- a/src/tsdl.ml +++ b/src/tsdl.ml @@ -1591,6 +1591,11 @@ let is_screen_saver_enabled = C.Functions.is_screen_saver_enabled module Message_box = struct include C.Types.Message_box + let () = assert (color_button_max = 5) + (* if this assertion fails, correct the length of the field + ["colors"] of [color_scheme] in type_description.ml before + updating it here *) + type button_flags = Unsigned.uint32 let button_no_default = Unsigned.UInt32.zero @@ -2376,6 +2381,10 @@ module Event = struct F (multi_gesture_event, Multi_gesture_event.num_fingers, Unsigned.UInt16.to_int, (fun _ x -> Unsigned.UInt16.of_int x)) + let () = assert (texteditingevent_text_size = 32) + (* if this assertion fails, correct the length of the field ["text"] + of [Text_editing_event.t] in type_description.ml before updating + it here *) let text_editing_window_id = F (text_editing_event, Text_editing_event.window_id, Unsigned.UInt32.to_int, (fun _ x -> Unsigned.UInt32.of_int x)) @@ -2390,6 +2399,10 @@ module Event = struct F (text_editing_event, Text_editing_event.length, Int32.to_int, (fun _ x -> Int32.of_int x)) + let () = assert (textinputevent_text_size = 32) + (* if this assertion fails, correct the length of the field ["text"] + of [Text_input_event.t] in type_description.ml before updating it + here *) let text_input_window_id = F (text_input_event, Text_input_event.window_id, Unsigned.UInt32.to_int, (fun _ x -> Unsigned.UInt32.of_int x)) diff --git a/src/type_description.ml b/src/type_description.ml index c6b3469..a05f762 100644 --- a/src/type_description.ml +++ b/src/type_description.ml @@ -1438,7 +1438,7 @@ module Types (F : Ctypes.TYPE) = struct let _ = F.field t "type" F.uint32_t let _ = F.field t "timestamp" F.uint32_t let window_id = F.field t "windowID" F.uint32_t - let text = F.field t "text" F.(array 32 char (* FIXME *)) + let text = F.field t "text" F.(array 32 char) let start = F.field t "start" F.int32_t let length = F.field t "length" F.int32_t let () = F.seal t @@ -1451,7 +1451,7 @@ module Types (F : Ctypes.TYPE) = struct let _ = F.field t "type" F.uint32_t let _ = F.field t "timestamp" F.uint32_t let window_id = F.field t "windowID" F.uint32_t - let text = F.field t "text" F.(array 32 char (* FIXME *)) + let text = F.field t "text" F.(array 32 char) let () = F.seal t end