blob: 113900412d5fba73da12d374082d2df5b44abbac (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
(in-package #:mulk.objective-cl)
(pushnew
(merge-pathnames (make-pathname :directory '(:relative "Objective-C"
"shared_obj")
:type :unspecific
:name :unspecific)
(asdf:component-pathname (asdf:find-system
'#:objective-cl)))
cffi:*foreign-library-directories*)
(define-foreign-library libobjcl
(:unix (:or "libobjcl.so"
"libobjcl.so.0"))
(t (:default "libobjcl")))
(use-foreign-library libobjcl)
;; FIXME: docs
(defcfun ("objcl_initialise_runtime" initialise-runtime) :void)
;; FIXME: docs
(defcfun ("objcl_shutdown_runtime" shutdown-runtime) :void)
(defcfun ("objcl_invoke_instance_method"
%objcl-invoke-instance-method) obj-data
(receiver obj-data)
(method-name :string)
(argc :int)
&rest)
(defcfun ("objcl_invoke_class_method"
%objcl-invoke-class-method) obj-data
(receiver obj-data)
(method-name :string)
(argc :int)
&rest)
(defcfun ("objcl_find_class" %objcl-find-class) :pointer
(class-name :string))
(defcfun ("objcl_class_name" %objcl-class-name) :string
(class obj-data))
(defun symbol->objc-class-name (symbol)
(let ((components (split-sequence #\- (symbol-name symbol)
:remove-empty-subseqs t)))
(reduce #'(lambda (x y) (concatenate 'string x y))
(mapcar #'(lambda (x)
(concatenate 'string
(string (char x 0))
(string-downcase (subseq x 1))))
(subseq components 1))
:initial-value (concatenate 'string
(string (char (first components) 0))
(string-upcase
(subseq (first components) 1))))))
(defun find-objc-class (class-name)
"Retrieve an Objective C class by name.
CLASS-NAME: a symbol or a string.
Returns: an OBJC-CLASS object representing the class whose name is
CLASS-NAME.
If CLASS-NAME is a symbol which does not contain a hyphen, its symbol
name is converted to lower case except for the first letter, which is
left intact, and the resulting string used as if directly given as an
argument to FIND-OBJC-CLASS.
If CLASS-NAME is a symbol which containts a hyphen, its symbol name is
split into components seperated by hyphens and each component is
converted into a string according to the following rules:
1. The first component is fully converted to upper case except for its
first letter, which is left intact.
2. Any additional components have all of their letters converted to
lower case, except for their first letters, which are left intact.
After that, the components are concatenated in order and the resulting
string used as if directly given as an argument to FIND-OBJC-CLASS.
Examples:
(find-objc-class \"NSObject\") ;=> #<OBJC-CLASS NSObject>
(find-objc-class 'ns-object) ;=> #<OBJC-CLASS NSObject>
(find-objc-class 'nsobject) ;=> NIL
Rationale:
The first component of an Objective C class name is conventionally
thought of as a namespace identifier. It is therefore sensible to
expect it to be converted to upper case by default, which is the
conventional case for namespace identifiers in Objective C."
(typecase class-name
(string (find-objc-class-by-name class-name))
(symbol (find-objc-class-by-name (symbol->objc-class-name class-name)))))
(defun find-objc-class-by-name (class-name)
(let ((obj-data (%objcl-find-class class-name)))
(prog1
(if (null-pointer-p (foreign-slot-value
(foreign-slot-value obj-data 'obj-data 'data)
'obj-data-union
'class-val))
nil
(obj-data->lisp obj-data))
(dealloc-obj-data obj-data))))
(defun objcl-class-name (class)
(declare (type (or objc-class objc-id objc-exception) class))
(let ((obj-data (foreign-alloc 'obj-data)))
(with-foreign-slots ((type data) obj-data obj-data)
(setf (foreign-slot-value obj-data
'obj-data-union
(etypecase class
(objc-class 'class-val)
(objc-id 'id-val)
(objc-exception 'exc-val)))
(pointer-to class))
(setf type (foreign-string-alloc (etypecase class
(objc-class "#")
(objc-id "@")
(objc-exception "E")))))
(prog1
(%objcl-class-name obj-data)
(dealloc-obj-data obj-data))))
|
