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
))))
8 (defun null-method-list ()
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))
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
))
23 (concatenate 'string
(string object
) "-" (string slot
))))
26 ,(mapcar (lambda (slot slot-name
)
27 `(,slot-name
(cffi:foreign-slot-value
,object
',type
',slot
)))
28 slots named-slots
) ,@body
)))
30 (defmacro define-objc-class
(name superclass ivar-list
&body body
)
32 (%define-objc-class
,name
,superclass
33 ',(mapcar (lambda (ivar-spec)
34 (list (first ivar-spec
) (second ivar-spec
)))
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
)
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)
45 ;; CANNOT DECLARE ONES WITH STRUCTS AS IVARS YET
47 (let (newclass metaclass rootclass
)
49 ;; The superclass must exist
50 (when (cffi:null-pointer-p superclass
)
51 (error "You cannot make a subclass of a null pointer"))
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
))))
63 ;; We must find the root class
64 (setq rootclass
(find-root-class superclass
))
66 (setq newclass
(cffi:foreign-alloc
'objc_class
)
67 metaclass
(cffi:foreign-alloc
'objc_class
))
69 (let* ((instance-size (cffi:foreign-slot-value superclass
'objc_class
'instance_size
))
70 (offset instance-size
)
71 (ivars-ptr (cffi:foreign-alloc
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
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
)
86 (setf (cffi:foreign-slot-value ivar
'objc_ivar
'ivar_type
)
88 (setf (cffi:foreign-slot-value ivar
'objc_ivar
'ivar_offset
)
90 (incf offset type-size
)
91 (cffi:incf-pointer ivar-ptr
(cffi:foreign-type-size
'objc_ivar
)))))
93 (with-named-foreign-slots (newclass objc_class
)
94 (setf newclass-isa metaclass
95 newclass-super_class superclass
96 newclass-name class-name
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
))))
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
)
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
)))
119 (%objc_addClass newclass
)