define-objc-class.lisp

   1 (in-package :objcffi)
   2
   3 (defun find-root-class (class)
   4   (let ((parent (cffi:foreign-slot-value class 'objc_class 'super_class)))
   5     (if (cffi:null-pointer-p parent) class
   6         (find-root-class parent))))
   7
   8 (defun null-method-list ()
   9   (cffi:foreign-alloc
  10    :pointer :initial-element (cffi:make-pointer #xffffffff))) ;; TODO calculate this number
  11 ;;  (let ((method-list (cffi:foreign-alloc 'objc_method_list)))
  12 ;;    (setf (cffi:foreign-slot-value method-list 'objc_method_list 'obsolete) (cffi:null-pointer)
  13 ;;        (cffi:foreign-slot-value method-list 'objc_method_list 'method_count) 0
  14 ;;        (cffi:foreign-slot-value method-list 'objc_method_list 'method_list) (cffi:null-pointer))
  15 ;;    method-list))
  16
  17 (defmacro with-named-foreign-slots ((object type) &rest body)
  18   ;; possibly a useful addition to CFFI?
  19   (let* ((slots (cffi:foreign-slot-names type))
  20          (named-slots (mapcar
  21                        (lambda (slot)
  22                          (intern
  23                           (concatenate 'string (string object) "-" (string slot))))
  24                        slots)))
  25     `(symbol-macrolet
  26          ,(mapcar (lambda (slot slot-name)
  27                     `(,slot-name (cffi:foreign-slot-value ,object ',type ',slot)))
  28                   slots named-slots) ,@body)))
  29
  30 (defmacro define-objc-class (name superclass ivar-list &body body)
  31   `(progn
  32      (%define-objc-class ,name ,superclass
  33                          ',(mapcar (lambda (ivar-spec)
  34                                      (list (first ivar-spec) (second ivar-spec)))
  35                                    ivar-list))
  36      (symbol-macrolet ,(mapcan (lambda (ivar-spec)
  37                                  (when (= (length ivar-spec) 3)
  38                                    (list `(,(third ivar-spec) (ivar self ,(second ivar-spec)))))) ivar-list)
  39        ,@body)))
  40
  41 (defun-with-types %define-objc-class (class-name (superclass :objc-class) ivars)
  42   ;; should be able to say this symbol is exported with the package here
  43   ;; ivars is a list of (type objective-c-name-string)
  44   ;;
  45   ;; CANNOT DECLARE ONES WITH STRUCTS AS IVARS YET
  46   ;;
  47   (let (newclass metaclass rootclass)
  48
  49     ;; The superclass must exist
  50     (when (cffi:null-pointer-p superclass)
  51       (error "You cannot make a subclass of a null pointer"))
  52
  53     ;; You cannot redefine a class, check if its got the same ivars as the current definition
  54     (let ((current-definition (%objc_lookUpClass class-name)))
  55       (unless (cffi:null-pointer-p current-definition)
  56         (if (every (lambda (ivar-spec defined-ivar)
  57                      (and (eq (first ivar-spec) (first defined-ivar))
  58                           (string= (second ivar-spec) (second defined-ivar))))
  59                    ivars (%list-ivars current-definition))
  60             (return-from %define-objc-class current-definition)
  61             (error "An incompatable definition of class \"~a\" already exists" class-name))))
  62
  63     ;; We must find the root class
  64     (setq rootclass (find-root-class superclass))
  65
  66     (setq newclass (cffi:foreign-alloc 'objc_class)
  67           metaclass (cffi:foreign-alloc 'objc_class))
  68
  69     (let* ((instance-size (cffi:foreign-slot-value superclass 'objc_class 'instance_size))
  70            (offset instance-size)
  71            (ivars-ptr (cffi:foreign-alloc
  72                        :char
  73                        :count (+ (cffi:foreign-type-size 'objc_ivar_list)
  74                                  (* (1- (length ivars)) (cffi:foreign-type-size 'objc_ivar)))))
  75            (ivar-ptr (cffi:inc-pointer
  76                       ivars-ptr
  77                       (cffi:foreign-slot-offset 'objc_ivar_list 'ivar_list))))
  78       (setf (cffi:foreign-slot-value ivars-ptr 'objc_ivar_list 'ivar_count) (length ivars))
  79       (dolist (ivar-spec ivars)
  80         (let ((ivar (cffi:mem-ref ivar-ptr 'objc_ivar)))
  81           (multiple-value-bind (type-string type-size) (encode-type (first ivar-spec))
  82             (if (null type-string)
  83                 (error "Ivar of incorrect/unsupported type: \"~a\"" (first ivar-spec)))
  84           (setf (cffi:foreign-slot-value ivar 'objc_ivar 'ivar_name)
  85                 (second ivar-spec))
  86           (setf (cffi:foreign-slot-value ivar 'objc_ivar 'ivar_type)
  87                 type-string)
  88           (setf (cffi:foreign-slot-value ivar 'objc_ivar 'ivar_offset)
  89                 offset)
  90           (incf offset type-size)
  91           (cffi:incf-pointer ivar-ptr (cffi:foreign-type-size 'objc_ivar)))))
  92
  93       (with-named-foreign-slots (newclass objc_class)
  94         (setf newclass-isa           metaclass
  95               newclass-super_class   superclass
  96               newclass-name          class-name
  97               newclass-version       0
  98               newclass-info          CLS_CLASS
  99               newclass-instance_size offset ;; this is instance-size + ivar-length
 100               newclass-ivars         ivars-ptr
 101               newclass-methodLists   (null-method-list);;(cffi:foreign-alloc 'objc_method_list)
 102               newclass-cache         (cffi:null-pointer)
 103               newclass-protocols     (cffi:null-pointer))))
 104
 105     (with-named-foreign-slots (metaclass objc_class)
 106       (setf metaclass-isa           (cffi:foreign-slot-value rootclass 'objc_class 'isa)
 107             metaclass-super_class   (cffi:foreign-slot-value superclass 'objc_class 'isa)
 108             metaclass-name          (cffi:foreign-slot-value newclass 'objc_class 'name)
 109             metaclass-version       0
 110             metaclass-info          CLS_META
 111             metaclass-instance_size (cffi:foreign-slot-value
 112                                      (cffi:foreign-slot-value superclass 'objc_class 'isa)
 113                                      'objc_class 'instance_size)
 114             metaclass-ivars         (cffi:null-pointer)
 115             metaclass-methodLists   (null-method-list);;(cffi:foreign-alloc 'objc_method_list)
 116             metaclass-cache         (cffi:null-pointer)
 117             metaclass-protocols     (cffi:null-pointer)))
 118
 119     (%objc_addClass newclass)
 120
 121     newclass))