Skip to content

Commit

Permalink
Refactor.
Browse files Browse the repository at this point in the history
  • Loading branch information
@dboris
dboris committed Oct 4, 2024
1 parent e405b13 commit 672443d
Show file tree
Hide file tree
Showing 3 changed files with 103 additions and 107 deletions.
4 changes: 4 additions & 0 deletions runtime/function_description.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)

Expand Down
190 changes: 90 additions & 100 deletions runtime/objc_t.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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 ->
Expand Down
16 changes: 9 additions & 7 deletions runtime/runtime.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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}) ->
Expand All @@ -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))
Expand Down Expand Up @@ -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
;;
Expand Down Expand Up @@ -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"
Expand Down

0 comments on commit 672443d

Please sign in to comment.