Support proper msg_send_super call.

bin/dune

@@ -4,5 +4,6 @@
  (<> %{context_name} default.ios)
  (<> %{context_name} device.ios)
  (<> %{context_name} simulator.ios)
+ (<> %{context_name} simulator-arm.ios)
  (<> %{context_name} catalyst.ios)))
  (libraries foundation appkit webkit))

demo/dune

@@ -4,7 +4,7 @@
  (= %{context_name} device.ios)
  (= %{context_name} simulator.ios)
  (= %{context_name} catalyst.ios)))
- (libraries camlkit-base.foundation camlkit-gui-ios.uikit))
+ (libraries camlkit-base.foundation camlkit-gui.uikit))
 
 (subdir Demo.app
  (rule

runtime/runtime.ml

@@ -54,6 +54,10 @@ struct
  foreign "class_getInstanceVariable"
  (_Class @-> string @-> returning _Ivar)
  self name
+
+ (** Returns a Boolean value that indicates whether a class object is a metaclass. *)
+ let is_meta_class =
+ foreign "class_isMetaClass" (_Class @-> returning bool)
 end
 
 module Object =
@@ -120,6 +124,26 @@ struct
  include Signed
  include C.Functions.Objc
 
+ module Objc_super = struct
+ type t
+ let t : t structure typ = structure "objc_super"
+ let receiver = field t "receiver" id
+ let super_class = field t "super_class" _Class
+ let () = seal t
+ let make self =
+ let self_class = Object.get_class self in
+ let sup_cls = Class.get_superclass self_class
+ and d = make t
+ in
+ setf d receiver self;
+ (if Class.is_meta_class self_class then
+ Object.get_class sup_cls
+ else
+ sup_cls)
+ |> setf d super_class;
+ allocate t d
+ end
+
  (** Sends a message with a simple return value to an instance of a class. *)
  let msg_send ~self ~cmd ~typ =
  foreign "objc_msgSend"
@@ -130,14 +154,14 @@ struct
  (** Sends a message with a simple return value to the superclass
  of an instance of a class. *)
  let msg_send_super ~self ~cmd ~typ =
- let self = Class.get_superclass self in
- msg_send ~self ~cmd ~typ
- (* match Platform.current with
+ match Platform.current with
  | GNUStep ->
  let self = Class.get_superclass self in
  msg_send ~self ~cmd ~typ
  | _ ->
- foreign "objc_msgSendSuper" (id @-> _SEL @-> typ) self cmd *)
+ let objc_super = Objc_super.make self in
+ foreign "objc_msgSendSuper"
+ (ptr Objc_super.t @-> _SEL @-> typ) objc_super cmd
  ;;
 
  (** Shortcut for type [void @-> id] *)

test/test_objc.ml

@@ -207,6 +207,36 @@ let test_block () =
  A.check A.(list string) "same list" expected (List.rev !actual)
 ;;
 
+let test_msg_send_super () =
+ let actual = ref false in
+ let class_a =
+ Define._class_ "ClassA"
+ ~methods:
+ [ Define._method_
+ ~cmd: (selector "someMethod")
+ ~args: Objc_t.[]
+ ~return: Objc_t.void
+ (fun _self _cmd -> actual := true)
+ ]
+ in
+ let class_b =
+ Define._class_ "ClassB"
+ ~superclass: class_a
+ ~methods:
+ [ Define._method_
+ ~cmd: (selector "someMethod")
+ ~args: Objc_t.[]
+ ~return: Objc_t.void
+ (fun self cmd ->
+ msg_send_super' cmd ~self ~args: Objc_t.[] ~return: Objc_t.void)
+ ]
+ and expected = true
+ in
+ let self = alloc class_b |> NSObject.C.init in
+ msg_send' (selector "someMethod") ~self ~args: Objc_t.[] ~return: Objc_t.void;
+ A.check A.bool "same bool" expected !actual
+;;
+
 let suite =
  [ "get object description", `Quick, test_object_description
  ; "add method to class", `Quick, test_add_method
@@ -224,6 +254,7 @@ let suite =
  ; "set and get ivar via kvc", `Quick, test_kvc ~class_name:"MyClass8" "Test"
  ; "get selector name as string", `Quick, test_string_of_selector
  ; "test block", `Quick, test_block
+ ; "test msg_send_super", `Quick, test_msg_send_super
  ]
 
 let () = A.run "objc" [ "Objc", suite ]