From 672443d41ca8545a9ea1ac2054ca2ebc611cb1d2 Mon Sep 17 00:00:00 2001 From: "Boris D." Date: Fri, 4 Oct 2024 13:57:43 -0700 Subject: [PATCH] Refactor. --- runtime/function_description.ml | 4 + runtime/objc_t.ml | 190 +++++++++++++++----------------- runtime/runtime.ml | 16 +-- 3 files changed, 103 insertions(+), 107 deletions(-) diff --git a/runtime/function_description.ml b/runtime/function_description.ml index ab39be0c..4e760f8f 100644 --- a/runtime/function_description.ml +++ b/runtime/function_description.ml @@ -65,12 +65,16 @@ module Functions = struct let get_name = foreign "class_getName" (_Class @-> returning string) + (** Returns the superclass of a class. *) let get_superclass = foreign "class_getSuperclass" (_Class @-> returning _Class) + (** Adds a protocol to a class. *) let add_protocol = foreign "class_addProtocol" (_Class @-> _Protocol @-> returning bool) + (** Returns a Boolean value that indicates whether a class conforms + to a given protocol. *) let conforms_to_protocol = foreign "class_conformsToProtocol" (_Class @-> _Protocol @-> returning bool) diff --git a/runtime/objc_t.ml b/runtime/objc_t.ml index c9e27e9f..c87d5769 100644 --- a/runtime/objc_t.ml +++ b/runtime/objc_t.ml @@ -2,61 +2,35 @@ open Ctypes include C.Types type _ t = -| Id : unit ptr t -| Class : unit ptr t -| Sel : selector_t t -| Void : unit t -| Str : string t -| Char : char t -| Bool : bool t -| Int : int t -| Short : int t -| Long : Signed.long t -| LLong : Signed.llong t -| ULLong : Unsigned.ullong t -| Float : float t -| Double : float t -| Unknown : unit ptr t -| Ptr : 'a t -> 'a ptr t -| Arr : 'a t -> 'a carray t -| Struc : 'a t -> 'a structure t -| Union : 'a t -> 'a union t -| Imp : unit ptr t -| Enc : _Enc t -| Proto : protocol_t t -| Ivar : ivar_t t + | Id : unit ptr t + | Class : unit ptr t + | Sel : selector_t t + | Void : unit t + | Str : string t + | Char : char t + | Bool : bool t + | Int : int t + | Short : int t + | Long : Signed.long t + | LLong : Signed.llong t + | ULLong : Unsigned.ullong t + | Float : float t + | Double : float t + | Unknown : unit ptr t + | Ptr : 'a t -> 'a ptr t + | Arr : 'a t -> 'a carray t + | Struc : 'a t -> 'a structure t + | Union : 'a t -> 'a union t + | Imp : unit ptr t + | Enc : _Enc t + | Proto : protocol_t t + | Ivar : ivar_t t type (_, _) hlist = -| [] : ('r, 'r) hlist -| (::) : 'a t * ('b, 'r) hlist -> ('a -> 'b, 'r) hlist - -let id = Id -let _Class = Class -let _SEL = Sel -let _IMP = Imp -let _Enc = Enc -let _Protocol = Proto -let _Ivar = Ivar -let void = Void -let string = Str -let char = Char -let bool = Bool -let int = Int -let short = Short -let long = Long -let llong = LLong -let ullong = ULLong -let float = Float -let double = Double -let unknown = Unknown -let ptr ty = Ptr ty -let array ty = Arr ty -let struc ty = Struc ty -let union ty = Union ty + | [] : ('r, 'r) hlist + | (::) : 'a t * ('b, 'r) hlist -> ('a -> 'b, 'r) hlist let rec ctype_of_t : type a. a t -> a typ = - let open Ctypes in - let open C.Types in function | Id -> id | Class -> _Class @@ -75,65 +49,81 @@ let rec ctype_of_t : type a. a t -> a typ = | Unknown -> ptr void | Ptr ty -> ptr (ctype_of_t ty) | Arr ty -> array 0 (ctype_of_t ty) - | Struc _ty -> structure "" (* FIXME *) - | Union _ty -> union "" (* FIXME *) | Imp -> _IMP | Enc -> _Enc | Proto -> _Protocol | Ivar -> _Ivar + | Struc _ | Union _ -> invalid_arg "not implemented" + +let id = Id +let _Class = Class +let _SEL = Sel +let _IMP = Imp +let _Enc = Enc +let _Protocol = Proto +let _Ivar = Ivar +let void = Void +let string = Str +let char = Char +let bool = Bool +let int = Int +let short = Short +let long = Long +let llong = LLong +let ullong = ULLong +let float = Float +let double = Double +let unknown = Unknown +let ptr ty = Ptr ty +let array ty = Arr ty +let struc ty = Struc ty +let union ty = Union ty module Encode = struct exception Encode_struct of string - let byte_size_of_t : type a. a t -> int = function - | Id -> sizeof (ctype_of_t Id) - | Class -> sizeof (ctype_of_t Class) - | Sel -> sizeof (ctype_of_t Sel) - | Void -> sizeof (ctype_of_t Void) - | Str -> sizeof (ctype_of_t Str) - | Char -> sizeof (ctype_of_t Char) - | Bool -> sizeof (ctype_of_t Bool) - | Int -> sizeof (ctype_of_t Int) - | Short -> sizeof (ctype_of_t Short) - | Long -> sizeof (ctype_of_t Long) - | LLong -> sizeof (ctype_of_t LLong) - | ULLong -> sizeof (ctype_of_t ULLong) - | Float -> sizeof (ctype_of_t Float) - | Double -> sizeof (ctype_of_t Double) - | Unknown -> sizeof (ctype_of_t Unknown) - | Ptr ty -> sizeof (ctype_of_t ty) - | Arr _ty -> 0 (* FIXME *) - | Struc _ty -> 0 (* FIXME *) - | Union _ty -> 0 (* FIXME *) - | Imp -> 8 - | Enc -> 0 (* FIXME *) - | Proto -> 8 (* FIXME *) - | Ivar -> 8 (* FIXME *) + let byte_size_of_t : type a. a t -> int = + let open Ctypes in + function + | Void -> sizeof void + | Str -> sizeof string + | Char -> sizeof char + | Bool -> sizeof bool + | Int -> sizeof int + | Short -> sizeof short + | Long -> sizeof long + | LLong -> sizeof llong + | ULLong -> sizeof ullong + | Float -> sizeof float + | Double -> sizeof double + | Id | Class | Sel | Ptr _ | Imp | Enc | Proto | Ivar | Unknown -> + sizeof (ptr void) + | Arr _ | Struc _ | Union _ -> invalid_arg "not implemented" let rec enc_of_t : type a. a t -> string = function - | Id -> "@" - | Class -> "#" - | Sel -> ":" - | Void -> "v" - | Str -> "*" - | Char -> "c" - | Bool -> "C" - | Int -> "i" - | Short -> "s" - | Long -> "l" - | LLong -> "q" - | ULLong -> "Q" - | Float -> "f" - | Double -> "d" - | Unknown -> "?" - | Ptr ty -> "^" ^ enc_of_t ty - | Arr ty -> "[" ^ enc_of_t ty ^ "]" - | Struc ty -> "{" ^ enc_of_t ty ^ "}" - | Union ty -> "(" ^ enc_of_t ty ^ ")" - | Imp -> "?" - | Enc -> "?" - | Proto -> "?" - | Ivar -> "?" + | Id -> "@" + | Class -> "#" + | Sel -> ":" + | Void -> "v" + | Str -> "*" + | Char -> "c" + | Bool -> "C" + | Int -> "i" + | Short -> "s" + | Long -> "l" + | LLong -> "q" + | ULLong -> "Q" + | Float -> "f" + | Double -> "d" + | Unknown -> "?" + | Ptr ty -> "^" ^ enc_of_t ty + | Arr ty -> "[" ^ enc_of_t ty ^ "]" + | Struc ty -> "{" ^ enc_of_t ty ^ "}" + | Union ty -> "(" ^ enc_of_t ty ^ ")" + | Imp -> "?" + | Enc -> "?" + | Proto -> "?" + | Ivar -> "?" let rec fold_enc : type a b. int -> (a, b) hlist -> string = fun arg_offset -> diff --git a/runtime/runtime.ml b/runtime/runtime.ml index 4ce6fa5d..96f7f12f 100644 --- a/runtime/runtime.ml +++ b/runtime/runtime.ml @@ -22,8 +22,6 @@ end module Class = struct include C.Functions.Class - module Objc = C.Functions.Objc - let alignment_of_size size = let open Float in Size_t.to_int size @@ -63,14 +61,14 @@ module Class = struct (** Defines a new class and registers it with the Objective-C runtime. *) let define - ?(superclass = Objc.get_class "NSObject") + ?(superclass = C.Functions.Objc.get_class "NSObject") ?(protocols = []) ?(ivars = []) ?(methods = []) ?(class_methods = []) name = - let self = Objc.allocate_class ~superclass name in + let self = C.Functions.Objc.allocate_class ~superclass name in assert (not (is_null self)); methods |> List.iter (fun (Define.MethodSpec {cmd; typ; imp; enc}) -> @@ -89,10 +87,10 @@ module Class = struct let size = Size_t.of_int (sizeof typ) in assert (add_ivar ~self ~name ~size ~enc)); - Objc.register_class self; + C.Functions.Objc.register_class self; if (List.length class_methods > 0) then begin - let metaclass = Objc.get_meta_class name in + let metaclass = C.Functions.Objc.get_meta_class name in assert (not (is_null metaclass)); class_methods |> List.iter (fun (Define.MethodSpec {cmd; typ; imp; enc}) -> assert (add_method ~self: metaclass ~cmd ~typ ~imp ~enc)) @@ -266,7 +264,7 @@ let gc_autorelease self = self ;; -(** Allocates an object and sends it "init" and "gc_autorelease". *) +(** Allocates an object and sends it [init] and [gc_autorelease]. *) let new_object class_name = alloc_object class_name |> init |> gc_autorelease ;; @@ -335,6 +333,10 @@ module Block_descriptor = struct end module Block = struct + (** Represents a single task or unit of behavior. Blocks are Objective-C + objects, which means they can be added to collections like [NSArray] or + [NSDictionary]. *) + type t let t : t structure typ = structure "Block_literal_1"