define-objc-method.lisp

   1 (in-package :objcffi)
   2
   3 ;; TODO this -must- invaliadate the entry in send's hashtable of compiled functions
   4 (defun-with-types %define-objc-method ((class :objc-class) selector-name
   5                                       method-type imp-callback
   6                                       &optional (instance-method t))
   7   ;; TODO maybe should remove the old method if one already exists?
   8   (let* ((method-list (cffi:foreign-alloc 'objc_method_list))
   9          (method-ptr (cffi:inc-pointer
  10                       method-list
  11                       (cffi:foreign-slot-offset 'objc_method_list 'method_list)))
  12          (method (cffi:mem-ref method-ptr 'objc_method)))
  13     (setf (cffi:foreign-slot-value method-list 'objc_method_list 'method_count) 1)
  14     (setf (cffi:foreign-slot-value method 'objc_method 'method_name)
  15           (%sel_getUid selector-name)
  16
  17           (cffi:foreign-slot-value method 'objc_method 'method_types)
  18           method-type
  19
  20           (cffi:foreign-slot-value method 'objc_method 'method_imp)
  21           imp-callback)
  22     (%class_addMethods (if instance-method class (cffi:foreign-slot-value class 'objc_class 'isa))
  23                        method-list)))
  24
  25 (defun plist->alist+ (plist) ;; shouldn't this be elsewhere?
  26   ;; the + is because this isn't really plist->alist
  27   ;; Instead of turning (X 1 Y 2 Z 3) into ((X . 1) (Y . 2) (Z . 3))
  28   ;; it outputs ((1 X) (2 Y) (3 Z))
  29   (if (endp plist) nil
  30       (cons (list (second plist) (first plist))
  31             (plist->alist+ (rest (rest plist))))))
  32
  33 (defmacro define-objc-method (class instance-method (return-type selector-name &rest parameters) &body body)
  34   (let ((callback (gensym selector-name))
  35         (parameters-alist (plist->alist+ parameters)))
  36     `(progn (cffi:defcallback ,callback ,return-type
  37                 ((self :pointer) (_cmd :pointer) ,@parameters-alist)
  38               (declare (ignorable self _cmd))
  39               ;; TODO? make bindings for class ivars?
  40               (restart-case
  41                   (progn ,@body)
  42                 (return () :report "Return immediatly")))
  43             (%define-objc-method
  44               ,class
  45               ,selector-name
  46               ,(encode-method-type return-type (mapcar #'second parameters-alist))
  47               (cffi:callback ,callback)
  48               ,(eq instance-method '-)))))