auxiliary.lisp

   1 (in-package :objcffi)
   2
   3 (defun ivar (object name)
   4   (assert (cffi:pointerp object))
   5   (let* ((ivar
   6           (%class_getInstanceVariable
   7            (cffi:foreign-slot-value object 'objc_object 'isa) name))
   8          (decoded-type (decode-type (cffi:foreign-slot-value ivar 'objc_ivar 'ivar_type))))
   9     (cffi:with-foreign-object (x decoded-type)
  10       (%object_getInstanceVariable object name x)
  11       (cffi:mem-ref x decoded-type))))
  12
  13 (defun set-ivar (object name value)
  14   (assert (cffi:pointerp object))
  15   (let* ((ivar
  16           (%class_getInstanceVariable
  17            (cffi:foreign-slot-value object 'objc_object 'isa) name))
  18          (decoded-type (decode-type (cffi:foreign-slot-value ivar 'objc_ivar 'ivar_type)))
  19          (ivar-place (cffi:inc-pointer
  20                       object
  21                       (cffi:foreign-slot-value ivar 'objc_ivar 'ivar_offset))))
  22     (setf (cffi:mem-ref ivar-place decoded-type) value)))
  23
  24 (defsetf ivar set-ivar)
  25
  26 (defmacro with-ivars (object (&rest names-and-symbols) &body body) ;; hopefully phase this out
  27   `(symbol-macrolet ,(mapcar (lambda (name-and-symbol)
  28                                (list (second name-and-symbol)
  29                                      `(ivar ,object ,(first name-and-symbol))))
  30                              names-and-symbols)
  31      ,@body))
  32
  33 (defun guess-cffi-type (object) ;; used for varargs type-guessing
  34   (cond ((cffi:pointerp object) :pointer)
  35         ((stringp object) :string)
  36         ((integerp object) :int) ;; int long etc ?
  37         ((numberp object) :double) ;; needs more checks float/double-float
  38         (t (cerror "Use :pointer" "No applicable CFFI type for object \"~S\" [~a]" object (type-of object))
  39            :pointer)))
  40
  41 (let (defined-structures (compiled-messages (make-hash-table :test #'equal)))
  42   (defun name-objc-struct (name struct)
  43     (push (cons name struct) defined-structures))
  44
  45   (defun canonicalize-type (type)
  46     (if (and (listp type)
  47              (eq (first type) :struct))
  48         (let ((struct
  49                (assoc (second type) defined-structures :test #'string=)))
  50           (if struct (cdr struct)
  51               (error "Unknown struct type \"~a\"" (second type)))) ;; should possibly define the structure at this moment
  52         type))
  53
  54   (defun compile-message (function-prototype)
  55     (let* ((return-type (first function-prototype))
  56            (parameter-types (rest function-prototype))
  57            (gensyms (loop repeat (length parameter-types) collect (gensym "parameter")))
  58            (types-and-gensyms (mapcan #'list parameter-types gensyms)))
  59       (compile nil `(lambda ,gensyms
  60                       (cffi:foreign-funcall ,(cond ((and (find return-type defined-structures :key #'cdr)
  61                                                          (not (find (cffi:foreign-type-size return-type) '(1 2 4 8))))
  62                                                     "objc_msgSend_stret")
  63                                                    ((find return-type '(:float :double))
  64                                                     "objc_msgSend_fpret")
  65                                                    (t "objc_msgSend"))
  66                                             ,@types-and-gensyms
  67                                             ,return-type)))))
  68
  69   (defun get-compiled-message (function-prototype)
  70     (let ((compiled-message (gethash function-prototype compiled-messages)))
  71       (unless compiled-message
  72         (return-from get-compiled-message
  73           (setf (gethash function-prototype compiled-messages) (compile-message function-prototype))))
  74       compiled-message))
  75
  76   (defun-with-types send ((object name instance :objc-object)
  77                           (selector selector-name :objc-selector)
  78                           &rest parameters)
  79     (multiple-value-bind (method-types method)
  80         (get-method-types (if instance (cffi:foreign-slot-value object 'objc_object 'isa) object)
  81                           selector
  82                           instance)
  83       (declare (ignore method))
  84       (setf method-types (decode-method-types method-types))
  85       (let ((function-prototype (mapcar #'canonicalize-type
  86                                         (append method-types
  87                                                 (mapcar #'guess-cffi-type ;; Variadic function call support
  88                                                         (nthcdr (- (length method-types) 1 2)
  89                                                                 parameters))))))
  90         (apply (get-compiled-message function-prototype) object selector parameters)))))