1 | ;;;; -*- Mode: Lisp; Package: CCL -*- |
---|
2 | ;;;; bridge.lisp |
---|
3 | ;;;; |
---|
4 | ;;;; A Lisp bridge for Cocoa |
---|
5 | ;;;; |
---|
6 | ;;;; This provides: |
---|
7 | ;;;; (1) Convenient Lisp syntax for instantiating ObjC classes |
---|
8 | ;;;; (2) Convenient Lisp syntax for invoking ObjC methods |
---|
9 | ;;;; |
---|
10 | ;;;; Copyright (c) 2003 Randall D. Beer |
---|
11 | ;;;; |
---|
12 | ;;;; This software is licensed under the terms of the Lisp Lesser GNU Public |
---|
13 | ;;;; License, known as the LLGPL. The LLGPL consists of a preamble and |
---|
14 | ;;;; the LGPL. Where these conflict, the preamble takes precedence. The |
---|
15 | ;;;; LLGPL is available online at http://opensource.franz.com/preamble.html. |
---|
16 | ;;;; |
---|
17 | ;;;; Please send comments and bug reports to <beer@eecs.cwru.edu> |
---|
18 | |
---|
19 | ;;; Temporary package and module stuff |
---|
20 | |
---|
21 | (in-package "CCL") |
---|
22 | |
---|
23 | (require "OBJC-RUNTIME") |
---|
24 | (require "NAME-TRANSLATION") |
---|
25 | |
---|
26 | ;;; Used in PRINT-OBJECT methods. |
---|
27 | |
---|
28 | (defun describe-macptr-allocation-and-address (p stream) |
---|
29 | (format stream " ~@[~a ~](#x~x)" |
---|
30 | (%macptr-allocation-string p) |
---|
31 | (%ptr-to-int p))) |
---|
32 | |
---|
33 | (defstruct typed-foreign-struct-info |
---|
34 | foreign-type |
---|
35 | lisp-class-name |
---|
36 | initializer |
---|
37 | constructor |
---|
38 | with-form-name |
---|
39 | predicate-name) |
---|
40 | |
---|
41 | (defparameter *typed-foreign-struct-info* ()) |
---|
42 | |
---|
43 | (defun note-typed-foreign-struct-info (foreign-type lisp-class-name initializer constructor with-form-name predicate-name) |
---|
44 | (let* ((info (find foreign-type *typed-foreign-struct-info* :test #'equal :key #'typed-foreign-struct-info-foreign-type))) |
---|
45 | (unless info |
---|
46 | (setq info (make-typed-foreign-struct-info :foreign-type foreign-type)) |
---|
47 | (push info *typed-foreign-struct-info*)) |
---|
48 | (setf (typed-foreign-struct-info-lisp-class-name info) lisp-class-name |
---|
49 | (typed-foreign-struct-info-initializer info) initializer |
---|
50 | (typed-foreign-struct-info-constructor info) constructor |
---|
51 | (typed-foreign-struct-info-with-form-name info) with-form-name |
---|
52 | (typed-foreign-struct-info-predicate-name info) predicate-name) |
---|
53 | info)) |
---|
54 | |
---|
55 | ;;; This gets installed as the COMPILER-MACRO-FUNCTION on any dispatch |
---|
56 | ;;; function associated with a method that passes structures by value. |
---|
57 | (defun hoist-struct-constructors (whole env) |
---|
58 | (declare (ignorable env)) |
---|
59 | (destructuring-bind (operator receiver &rest args) whole |
---|
60 | ;;See if any arguments are "obviously" known structure-creation forms. |
---|
61 | (if (null (dolist (arg args) |
---|
62 | (if (and (consp arg) |
---|
63 | (find (car arg) *typed-foreign-struct-info* :key #'typed-foreign-struct-info-constructor)) |
---|
64 | (return t)))) |
---|
65 | whole |
---|
66 | ;;; Simplest to hoist one call, then let compiler-macroexpand |
---|
67 | ;;; call us again. |
---|
68 | (let* ((with-name nil) |
---|
69 | (info nil) |
---|
70 | (temp (gensym))) |
---|
71 | (collect ((new-args)) |
---|
72 | (new-args operator) |
---|
73 | (new-args receiver) |
---|
74 | (dolist (arg args) |
---|
75 | (if (or info |
---|
76 | (atom arg) |
---|
77 | (not (setq info (find (car arg) *typed-foreign-struct-info* :key #'typed-foreign-struct-info-constructor)))) |
---|
78 | (new-args arg) |
---|
79 | (progn |
---|
80 | (setq with-name (typed-foreign-struct-info-with-form-name info)) |
---|
81 | (if (cdr arg) |
---|
82 | (new-args `(progn (,(typed-foreign-struct-info-initializer info) |
---|
83 | ,temp |
---|
84 | ,@(cdr arg)) |
---|
85 | ,temp)) |
---|
86 | (new-args temp))))) |
---|
87 | `(,with-name (,temp) |
---|
88 | (values ,(new-args)))))))) |
---|
89 | |
---|
90 | |
---|
91 | |
---|
92 | (defun define-typed-foreign-struct-accessor (type-name lisp-accessor-name foreign-accessor &optional (transform-output #'identity) (transform-input #'identity)) |
---|
93 | (let* ((arg (gensym)) |
---|
94 | (val (gensym))) |
---|
95 | `(progn |
---|
96 | (declaim (inline ,lisp-accessor-name)) |
---|
97 | (defun ,lisp-accessor-name (,arg) |
---|
98 | (if (typep ,arg ',type-name) |
---|
99 | ,(funcall transform-input `(pref ,arg ,foreign-accessor)) |
---|
100 | (report-bad-arg ,arg ',type-name))) |
---|
101 | (declaim (inline (setf ,lisp-accessor-name))) |
---|
102 | (defun (setf ,lisp-accessor-name) (,val ,arg) |
---|
103 | (if (typep ,arg ',type-name) |
---|
104 | (setf (pref ,arg ,foreign-accessor) ,(funcall transform-output val)) |
---|
105 | (report-bad-arg ,arg ',type-name)))))) |
---|
106 | |
---|
107 | (defun define-typed-foreign-struct-accessors (type-name tuples) |
---|
108 | (collect ((body)) |
---|
109 | (dolist (tuple tuples `(progn ,@(body))) |
---|
110 | (body (apply #'define-typed-foreign-struct-accessor type-name (cdr tuple)))))) |
---|
111 | |
---|
112 | (defun define-typed-foreign-struct-initializer (init-function-name tuples) |
---|
113 | (when init-function-name |
---|
114 | (let* ((struct (gensym))) |
---|
115 | (collect ((initforms) |
---|
116 | (args)) |
---|
117 | (args struct) |
---|
118 | (dolist (tuple tuples) |
---|
119 | (destructuring-bind (arg-name lisp-accessor foreign-accessor &optional (transform #'identity)) tuple |
---|
120 | (declare (ignore lisp-accessor)) |
---|
121 | (args arg-name) |
---|
122 | (initforms `(setf (pref ,struct ,foreign-accessor) ,(funcall transform arg-name))))) |
---|
123 | `(progn |
---|
124 | (declaim (inline ,init-function-name)) |
---|
125 | (defun ,init-function-name ,(args) |
---|
126 | (declare (ignorable ,struct)) |
---|
127 | ,@(initforms) |
---|
128 | ,struct)))))) |
---|
129 | |
---|
130 | (defun define-typed-foreign-struct-creation-function (creation-function-name init-function-name foreign-type accessors) |
---|
131 | (when creation-function-name |
---|
132 | (let* ((struct (gensym)) |
---|
133 | (arg-names (mapcar #'car accessors))) |
---|
134 | `(defun ,creation-function-name ,arg-names |
---|
135 | (let* ((,struct (make-gcable-record ,foreign-type))) |
---|
136 | (,init-function-name ,struct ,@arg-names) |
---|
137 | ,struct))))) |
---|
138 | |
---|
139 | (defun define-typed-foreign-struct-class-with-form (with-form-name foreign-type init-function-name) |
---|
140 | (declare (ignorable init-function-name)) |
---|
141 | (when with-form-name |
---|
142 | `(defmacro ,with-form-name ((instance &rest inits) &body body) |
---|
143 | (multiple-value-bind (body decls) (parse-body body nil) |
---|
144 | `(rlet ((,instance ,,foreign-type)) |
---|
145 | ,@decls |
---|
146 | ,@(when inits |
---|
147 | `((,',init-function-name ,instance ,@inits))) |
---|
148 | ,@body))))) |
---|
149 | |
---|
150 | |
---|
151 | (defmacro define-typed-foreign-struct-class (class-name (foreign-type predicate-name init-function-name creation-function-name with-form-name) &rest accessors) |
---|
152 | (let* ((arg (gensym))) |
---|
153 | `(progn |
---|
154 | (%register-type-ordinal-class (parse-foreign-type ',foreign-type) ',class-name) |
---|
155 | (def-foreign-type ,class-name ,foreign-type) |
---|
156 | (declaim (inline ,predicate-name)) |
---|
157 | (note-typed-foreign-struct-info ',foreign-type ',class-name ',init-function-name ',creation-function-name ',with-form-name ',predicate-name) |
---|
158 | (defun ,predicate-name (,arg) |
---|
159 | (and (typep ,arg 'macptr) |
---|
160 | (<= (the fixnum (%macptr-domain ,arg)) 1) |
---|
161 | (= (the fixnum (%macptr-type ,arg)) |
---|
162 | (foreign-type-ordinal (load-time-value (parse-foreign-type ',foreign-type)))))) |
---|
163 | (eval-when (:compile-toplevel :load-toplevel :execute) |
---|
164 | (setf (type-predicate ',class-name) ',predicate-name)) |
---|
165 | ,(define-typed-foreign-struct-initializer init-function-name accessors) |
---|
166 | ,(define-typed-foreign-struct-creation-function creation-function-name init-function-name foreign-type accessors) |
---|
167 | ,(define-typed-foreign-struct-class-with-form with-form-name foreign-type init-function-name) |
---|
168 | ,(define-typed-foreign-struct-accessors class-name accessors) |
---|
169 | ',class-name))) |
---|
170 | |
---|
171 | (eval-when (:compile-toplevel :load-toplevel :execute) |
---|
172 | (defun wrap-cg-float (x) |
---|
173 | `(float ,x +cgfloat-zero+))) |
---|
174 | |
---|
175 | |
---|
176 | |
---|
177 | ;;; AEDesc (Apple Event Descriptor) |
---|
178 | |
---|
179 | (define-typed-foreign-struct-class ns::aedesc (:<AED>esc ns::aedesc-p ns::init-aedesc ns::make-aedesc ns::with-aedesc) |
---|
180 | (descriptor-type ns::aedesc-descriptor-type :<AED>esc.descriptor<T>ype) |
---|
181 | (data-handle ns::aedesc-data-handle :<AED>esc.data<H>andle)) |
---|
182 | |
---|
183 | |
---|
184 | (defmethod print-object ((a ns::aedesc) stream) |
---|
185 | (print-unreadable-object (a stream :type t :identity (%gcable-ptr-p a)) |
---|
186 | (unless (%null-ptr-p a) |
---|
187 | (format stream "~s ~s" |
---|
188 | (ns::aedesc-descriptor-type a) |
---|
189 | (ns::aedesc-data-handle a))) |
---|
190 | (describe-macptr-allocation-and-address a stream))) |
---|
191 | |
---|
192 | ;;; It's not clear how useful this would be; I think that it's |
---|
193 | ;;; part of the ObjC 2.0 extensible iteration stuff ("foreach"). |
---|
194 | #+apple-objc-2.0 |
---|
195 | (define-typed-foreign-struct-class ns::ns-fast-enumeration-state (:<NSF>ast<E>numeration<S>tate ns::ns-fast-enumeration-state-p ns::init-ns-fast-enumeration-state ns::make-ns-fast-enumeration-state ns::with-ns-fast-enumeration-state)) |
---|
196 | |
---|
197 | ;;; NSAffineTransformStruct CGAffineTransform |
---|
198 | (define-typed-foreign-struct-class ns::ns-affine-transform-struct (:<NSA>ffine<T>ransform<S>truct ns::ns-affine-transform-struct-p ns::init-ns-affine-transform-struct ns::make-ns-affine-transform-struct ns::wint-ns-affine-transform-struct) |
---|
199 | (m11 ns::ns-affine-transform-struct-m11 :<NSA>ffine<T>ransform<S>truct.m11 wrap-cg-float) |
---|
200 | (m12 ns::ns-affine-transform-struct-m12 :<NSA>ffine<T>ransform<S>truct.m12 wrap-cg-float) |
---|
201 | (m21 ns::ns-affine-transform-struct-m21 :<NSA>ffine<T>ransform<S>truct.m21 wrap-cg-float) |
---|
202 | (m22 ns::ns-affine-transform-struct-m22 :<NSA>ffine<T>ransform<S>truct.m22 wrap-cg-float) |
---|
203 | (tx ns::ns-affine-transform-struct-tx :<NSA>ffine<T>ransform<S>truct.t<X> wrap-cg-float) |
---|
204 | (ty ns::ns-affine-transform-struct-ty :<NSA>ffine<T>ransform<S>truct.t<Y> wrap-cg-float)) |
---|
205 | |
---|
206 | |
---|
207 | (defmethod print-object ((transform ns::ns-affine-transform-struct) stream) |
---|
208 | (print-unreadable-object (transform stream :type t :identity t) |
---|
209 | (format stream "~s ~s ~s ~s ~s ~s" |
---|
210 | (ns::ns-affine-transform-struct-m11 transform) |
---|
211 | (ns::ns-affine-transform-struct-m12 transform) |
---|
212 | (ns::ns-affine-transform-struct-m21 transform) |
---|
213 | (ns::ns-affine-transform-struct-m22 transform) |
---|
214 | (ns::ns-affine-transform-struct-tx transform) |
---|
215 | (ns::ns-affine-transform-struct-ty transform)) |
---|
216 | (describe-macptr-allocation-and-address transform stream))) |
---|
217 | |
---|
218 | |
---|
219 | |
---|
220 | |
---|
221 | |
---|
222 | ;;; An <NSA>ffine<T>ransform<S>truct is identical to a |
---|
223 | ;;; (:struct :<GGA>ffine<T>ransform), except for the names of its fields. |
---|
224 | |
---|
225 | (setf (foreign-type-ordinal (parse-foreign-type '(:struct :<GGA>ffine<T>ransform))) |
---|
226 | (foreign-type-ordinal (parse-foreign-type :<NSA>ffine<T>ransform<S>truct))) |
---|
227 | |
---|
228 | |
---|
229 | (eval-when (:compile-toplevel :load-toplevel :execute) |
---|
230 | (defun unwrap-boolean (form) |
---|
231 | `(not (eql 0 ,form))) |
---|
232 | (defun wrap-boolean (form) |
---|
233 | `(if ,form 1 0))) |
---|
234 | |
---|
235 | |
---|
236 | ;;; NSDecimal |
---|
237 | (define-typed-foreign-struct-class ns::ns-decimal (:<NSD>ecimal ns::ns-decimal-p nil nil nil) |
---|
238 | (nil ns::ns-decimal-exponent :<NSD>ecimal._exponent) |
---|
239 | (nil ns::ns-decimal-length :<NSD>ecimal._length) |
---|
240 | (nil ns::ns-decimal-is-negative :<NSD>ecimal._is<N>egative wrap-boolean unwrap-boolean) |
---|
241 | (nil ns::ns-decimal-is-compact :<NSD>ecimal._is<C>ompact wrap-boolean unwrap-boolean)) |
---|
242 | |
---|
243 | |
---|
244 | (defun ns::init-ns-decimal (data exponent length is-negative is-compact mantissa) |
---|
245 | (setf (pref data :<NSD>ecimal._exponent) exponent |
---|
246 | (pref data :<NSD>ecimal._length) length |
---|
247 | (pref data :<NSD>ecimal._is<N>egative) (if is-negative 1 0) |
---|
248 | (pref data :<NSD>ecimal._is<C>ompact) (if is-compact 1 0)) |
---|
249 | (let* ((v (coerce mantissa '(vector (unsigned-byte 16) 8)))) |
---|
250 | (declare (type (simple-array (unsigned-byte 16) (8)) v)) |
---|
251 | (with-macptrs ((m (pref data :<NSD>ecimal._mantissa))) |
---|
252 | (dotimes (i 8) |
---|
253 | (setf (paref m (:* (:unsigned 16)) i) (aref v i)))))) |
---|
254 | |
---|
255 | (defun ns::make-ns-decimal (exponent length is-negative is-compact mantissa) |
---|
256 | (let* ((data (make-gcable-record :<NSD>ecimal))) |
---|
257 | (ns::init-ns-decimal data exponent length is-negative is-compact mantissa) |
---|
258 | data)) |
---|
259 | |
---|
260 | |
---|
261 | |
---|
262 | |
---|
263 | (defun ns::ns-decimal-mantissa (decimal) |
---|
264 | (if (typep decimal 'ns::ns-decimal) |
---|
265 | (let* ((dest (make-array 8 :element-type '(unsigned-byte 16)))) |
---|
266 | (with-macptrs ((m (pref decimal :<NSD>ecimal._mantissa))) |
---|
267 | (dotimes (i 8 dest) |
---|
268 | (setf (aref dest i) (paref m (:* (:unsigned 16)) i))))) |
---|
269 | (report-bad-arg decimal 'ns::ns-decimal))) |
---|
270 | |
---|
271 | (defun (setf ns::ns-decimal-mantissa) (new decimal) |
---|
272 | (if (typep decimal 'ns::ns-decimal) |
---|
273 | (let* ((src (coerce new '(simple-array (unsigned-byte 16) (8))))) |
---|
274 | (declare (type (simple-array (unsigned-byte 16) 8) src)) |
---|
275 | (with-macptrs ((m (pref decimal :<NSD>ecimal._mantissa))) |
---|
276 | (dotimes (i 8 new) |
---|
277 | (setf (paref m (:* (:unsigned 16)) i) (aref src i))))) |
---|
278 | (report-bad-arg decimal 'ns::ns-decimal))) |
---|
279 | |
---|
280 | (defmethod print-object ((d ns::ns-decimal) stream) |
---|
281 | (print-unreadable-object (d stream :type t :identity t) |
---|
282 | (unless (%null-ptr-p d) |
---|
283 | (format stream "exponent = ~d, length = ~s, is-negative = ~s, is-compact = ~s, mantissa = ~s" (ns::ns-decimal-exponent d) (ns::ns-decimal-length d) (ns::ns-decimal-is-negative d) (ns::ns-decimal-is-compact d) (ns::ns-decimal-mantissa d))) |
---|
284 | (describe-macptr-allocation-and-address d stream))) |
---|
285 | |
---|
286 | |
---|
287 | |
---|
288 | |
---|
289 | ;;; NSRect |
---|
290 | |
---|
291 | (define-typed-foreign-struct-class ns::ns-rect (:<NSR>ect ns::ns-rect-p ns::init-ns-rect ns::make-ns-rect ns::with-ns-rect) |
---|
292 | (x ns::ns-rect-x :<NSR>ect.origin.x wrap-cg-float) |
---|
293 | (y ns::ns-rect-y :<NSR>ect.origin.y wrap-cg-float) |
---|
294 | (width ns::ns-rect-width :<NSR>ect.size.width wrap-cg-float) |
---|
295 | (height ns::ns-rect-height :<NSR>ect.size.height wrap-cg-float)) |
---|
296 | |
---|
297 | |
---|
298 | (defmethod print-object ((r ns::ns-rect) stream) |
---|
299 | (print-unreadable-object (r stream :type t :identity t) |
---|
300 | (unless (%null-ptr-p r) |
---|
301 | (flet ((maybe-round (x) |
---|
302 | (multiple-value-bind (q r) (round x) |
---|
303 | (if (zerop r) q x)))) |
---|
304 | (format stream "~s X ~s @ ~s,~s" |
---|
305 | (maybe-round (ns::ns-rect-width r)) |
---|
306 | (maybe-round (ns::ns-rect-height r)) |
---|
307 | (maybe-round (ns::ns-rect-x r)) |
---|
308 | (maybe-round (ns::ns-rect-y r))) |
---|
309 | (describe-macptr-allocation-and-address r stream))))) |
---|
310 | |
---|
311 | |
---|
312 | |
---|
313 | ;;; NSSize |
---|
314 | (define-typed-foreign-struct-class ns::ns-size (:<NSS>ize ns::ns-size-p ns::init-ns-size ns::make-ns-size ns::with-ns-size) |
---|
315 | (width ns::ns-size-width :<NSS>ize.width wrap-cg-float) |
---|
316 | (height ns::ns-size-height :<NSS>ize.height wrap-cg-float)) |
---|
317 | |
---|
318 | |
---|
319 | (defmethod print-object ((s ns::ns-size) stream) |
---|
320 | (flet ((maybe-round (x) |
---|
321 | (multiple-value-bind (q r) (round x) |
---|
322 | (if (zerop r) q x)))) |
---|
323 | (unless (%null-ptr-p s) |
---|
324 | (print-unreadable-object (s stream :type t :identity t) |
---|
325 | (format stream "~s X ~s" |
---|
326 | (maybe-round (ns::ns-size-width s)) |
---|
327 | (maybe-round (ns::ns-size-height s))))) |
---|
328 | (describe-macptr-allocation-and-address s stream))) |
---|
329 | |
---|
330 | |
---|
331 | ;;; NSPoint |
---|
332 | (define-typed-foreign-struct-class ns::ns-point (:<NSP>oint ns::ns-point-p ns::init-ns-point ns::make-ns-point ns::with-ns-point) |
---|
333 | (x ns::ns-point-x :<NSP>oint.x wrap-cg-float) |
---|
334 | (y ns::ns-point-y :<NSP>oint.y wrap-cg-float)) |
---|
335 | |
---|
336 | (defmethod print-object ((p ns::ns-point) stream) |
---|
337 | (flet ((maybe-round (x) |
---|
338 | (multiple-value-bind (q r) (round x) |
---|
339 | (if (zerop r) q x)))) |
---|
340 | (print-unreadable-object (p stream :type t :identity t) |
---|
341 | (unless (%null-ptr-p p) |
---|
342 | (format stream "~s,~s" |
---|
343 | (maybe-round (ns::ns-point-x p)) |
---|
344 | (maybe-round (ns::ns-point-y p)))) |
---|
345 | (describe-macptr-allocation-and-address p stream)))) |
---|
346 | |
---|
347 | |
---|
348 | ;;; NSRange |
---|
349 | (define-typed-foreign-struct-class ns::ns-range (:<NSR>ange ns::ns-range-p ns::init-ns-range ns::make-ns-range ns::with-ns-range) |
---|
350 | (location ns::ns-range-location :<NSR>ange.location) |
---|
351 | (length ns::ns-range-length :<NSR>ange.length )) |
---|
352 | |
---|
353 | (defmethod print-object ((r ns::ns-range) stream) |
---|
354 | (print-unreadable-object (r stream :type t :identity t) |
---|
355 | (unless (%null-ptr-p r) |
---|
356 | (format stream "~s/~s" |
---|
357 | (ns::ns-range-location r) |
---|
358 | (ns::ns-range-length r))) |
---|
359 | (describe-macptr-allocation-and-address r stream))) |
---|
360 | |
---|
361 | |
---|
362 | ;;; String might be stack allocated; make a copy before complaining |
---|
363 | ;;; about it. |
---|
364 | (defun check-objc-message-name (string) |
---|
365 | (dotimes (i (length string)) |
---|
366 | (let* ((ch (char string i))) |
---|
367 | (unless (or (alpha-char-p ch) |
---|
368 | (digit-char-p ch 10) |
---|
369 | (eql ch #\:) |
---|
370 | (eql ch #\_)) |
---|
371 | (error "Illegal character ~s in ObjC message name ~s" |
---|
372 | ch (copy-seq string))))) |
---|
373 | (when (and (position #\: string) |
---|
374 | (not (eql (char string (1- (length string))) #\:))) |
---|
375 | (error "ObjC message name ~s contains colons, but last character is not a colon" (copy-seq string)))) |
---|
376 | |
---|
377 | |
---|
378 | (setf (pkg.intern-hook (find-package "NSFUN")) |
---|
379 | 'get-objc-message-info) |
---|
380 | |
---|
381 | (set-dispatch-macro-character #\# #\/ |
---|
382 | (lambda (stream subchar numarg) |
---|
383 | (declare (ignorable subchar numarg)) |
---|
384 | (let* ((token (make-array 16 :element-type 'character :fill-pointer 0 :adjustable t)) |
---|
385 | (attrtab (rdtab.ttab *readtable*))) |
---|
386 | (when (peek-char t stream nil nil) |
---|
387 | (loop |
---|
388 | (multiple-value-bind (char attr) |
---|
389 | (%next-char-and-attr stream attrtab) |
---|
390 | (unless (eql attr $cht_cnst) |
---|
391 | (when char (unread-char char stream)) |
---|
392 | (return)) |
---|
393 | (vector-push-extend char token)))) |
---|
394 | (unless *read-suppress* |
---|
395 | (unless (> (length token) 0) |
---|
396 | (signal-reader-error stream "Invalid token after #/.")) |
---|
397 | (check-objc-message-name token) |
---|
398 | (intern token "NSFUN"))))) |
---|
399 | |
---|
400 | |
---|
401 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
402 | ;;;; Utilities ;;;; |
---|
403 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
404 | |
---|
405 | ;;; Return separate lists of the keys and values in a keyword/value list |
---|
406 | |
---|
407 | (defun keys-and-vals (klist) |
---|
408 | (when (oddp (length klist)) |
---|
409 | (error "Invalid keyword/value list: ~S" klist)) |
---|
410 | (loop for l = klist then (cddr l) |
---|
411 | until (null l) |
---|
412 | collect (first l) into keys |
---|
413 | collect (second l) into vals |
---|
414 | finally (return (values keys vals)))) |
---|
415 | |
---|
416 | |
---|
417 | ;;; Return the typestring for an ObjC METHOD |
---|
418 | |
---|
419 | (defun method-typestring (method) |
---|
420 | (%get-cstring #+apple-objc-2.0 |
---|
421 | (#_method_getTypeEncoding method) |
---|
422 | #-apple-objc-2.0 |
---|
423 | (pref method :objc_method.method_types))) |
---|
424 | |
---|
425 | |
---|
426 | ;;; Parse the ObjC message from a SENDxxx macro |
---|
427 | |
---|
428 | (defun parse-message (args) |
---|
429 | (let ((f (first args)) |
---|
430 | (nargs (length args))) |
---|
431 | (cond ((or (= nargs 1) (= nargs 2)) |
---|
432 | ;; (THING {VARGS}) |
---|
433 | (if (constantp f) |
---|
434 | (%parse-message (cons (eval f) (rest args))) |
---|
435 | (values f (rest args) nil))) |
---|
436 | ;; (THING1 ARG1 ... THINGN ARGN) |
---|
437 | ((evenp nargs) |
---|
438 | (multiple-value-bind (ks vs) (keys-and-vals args) |
---|
439 | (if (every #'constantp ks) |
---|
440 | (%parse-message (mapcan #'list (mapcar #'eval ks) vs)) |
---|
441 | (values f (rest args) nil)))) |
---|
442 | ;; (THING1 ARG1 ... THINGN ARGN VARGS) |
---|
443 | (t (multiple-value-bind (ks vs) (keys-and-vals (butlast args)) |
---|
444 | (if (every #'constantp ks) |
---|
445 | (%parse-message |
---|
446 | (nconc (mapcan #'list (mapcar #'eval ks) vs) (last args))) |
---|
447 | (values f (rest args) nil))))))) |
---|
448 | |
---|
449 | |
---|
450 | ;;; Parse the ObjC message from the evaluated args of a %SENDxxx function |
---|
451 | |
---|
452 | (defun %parse-message (args) |
---|
453 | (let ((f (first args)) |
---|
454 | (l (first (last args)))) |
---|
455 | (cond ((stringp f) |
---|
456 | ;; (STRING-with-N-colons ARG1 ... ARGN {LIST}) |
---|
457 | (let* ((n (count #\: (the simple-string f))) |
---|
458 | (message-info (need-objc-message-info f)) |
---|
459 | (args (rest args)) |
---|
460 | (nargs (length args))) |
---|
461 | (cond ((and (= nargs 1) |
---|
462 | (getf (objc-message-info-flags message-info) |
---|
463 | :accepts-varargs)) |
---|
464 | (values f nil l)) |
---|
465 | ((= nargs n) (values f args nil)) |
---|
466 | ((= nargs (1+ n)) (values f (butlast args) l)) |
---|
467 | (t (error "Improperly formatted argument list: ~S" args))))) |
---|
468 | ((keywordp f) |
---|
469 | ;; (KEY1 ARG1 ... KEYN ARGN {LIST}) or (KEY LIST) |
---|
470 | (let ((nargs (length args))) |
---|
471 | (cond ((and (= nargs 2) (consp l) |
---|
472 | (let* ((info (need-objc-message-info |
---|
473 | (lisp-to-objc-message (list f))))) |
---|
474 | (getf (objc-message-info-flags info) |
---|
475 | :accepts-varargs))) |
---|
476 | (values (lisp-to-objc-message (list f)) nil l)) |
---|
477 | ((evenp nargs) |
---|
478 | (multiple-value-bind (ks vs) (keys-and-vals args) |
---|
479 | (values (lisp-to-objc-message ks) vs nil))) |
---|
480 | ((and (> nargs 1) (listp l)) |
---|
481 | (multiple-value-bind (ks vs) (keys-and-vals (butlast args)) |
---|
482 | (values (lisp-to-objc-message ks) vs l))) |
---|
483 | (t (error "Improperly formatted argument list: ~S" args))))) |
---|
484 | ((symbolp f) |
---|
485 | ;; (SYMBOL {LIST}) |
---|
486 | (let ((nargs (length (rest args)))) |
---|
487 | (cond ((= nargs 0) (values (lisp-to-objc-message (list f)) nil nil)) |
---|
488 | ((= nargs 1) (values (lisp-to-objc-message (list f)) nil l)) |
---|
489 | (t (error "Improperly formatted argument list: ~S" args))))) |
---|
490 | (t (error "Improperly formatted argument list: ~S" args))))) |
---|
491 | |
---|
492 | |
---|
493 | ;;; Return the declared type of FORM in ENV |
---|
494 | |
---|
495 | (defun declared-type (form env) |
---|
496 | (cond ((symbolp form) |
---|
497 | (multiple-value-bind (ignore ignore decls) |
---|
498 | (variable-information form env) |
---|
499 | (declare (ignore ignore)) |
---|
500 | (or (cdr (assoc 'type decls)) t))) |
---|
501 | ((and (consp form) (eq (first form) 'the)) |
---|
502 | (second form)) |
---|
503 | (t t))) |
---|
504 | |
---|
505 | |
---|
506 | ;;; Return the current optimization setting of KEY in ENV |
---|
507 | |
---|
508 | (defun optimization-setting (key &optional env) |
---|
509 | (cadr (assoc key (declaration-information 'optimize env)))) |
---|
510 | |
---|
511 | |
---|
512 | ;;; Return the ObjC class named CNAME |
---|
513 | |
---|
514 | (defun find-objc-class (cname) |
---|
515 | (%objc-class-classptr |
---|
516 | (if (symbolp cname) |
---|
517 | (find-class cname) |
---|
518 | (load-objc-class-descriptor cname)))) |
---|
519 | |
---|
520 | |
---|
521 | ;;; Return the class object of an ObjC object O, signalling an error |
---|
522 | ;;; if O is not an ObjC object |
---|
523 | |
---|
524 | (defun objc-class-of (o) |
---|
525 | (if (objc-object-p o) |
---|
526 | (class-of o) |
---|
527 | (progn |
---|
528 | #+debug |
---|
529 | (#_NSLog #@"class name = %s" :address (pref (pref o :objc_object.isa) |
---|
530 | :objc_class.name)) |
---|
531 | (error "~S is not an ObjC object" o)))) |
---|
532 | |
---|
533 | |
---|
534 | ;;; Returns the ObjC class corresponding to the declared type OTYPE if |
---|
535 | ;;; possible, NIL otherwise |
---|
536 | |
---|
537 | (defun get-objc-class-from-declaration (otype) |
---|
538 | (cond ((symbolp otype) (lookup-objc-class (lisp-to-objc-classname otype))) |
---|
539 | ((and (consp otype) (eq (first otype) '@metaclass)) |
---|
540 | (let* ((name (second otype)) |
---|
541 | (c |
---|
542 | (typecase name |
---|
543 | (string (lookup-objc-class name)) |
---|
544 | (symbol (lookup-objc-class (lisp-to-objc-classname name))) |
---|
545 | (t (error "Improper metaclass typespec: ~S" otype))))) |
---|
546 | (unless (null c) (objc-class-of c)))))) |
---|
547 | |
---|
548 | |
---|
549 | ;;; Returns the selector of MSG |
---|
550 | |
---|
551 | (defun get-selector (msg) |
---|
552 | (%get-selector (load-objc-selector msg))) |
---|
553 | |
---|
554 | |
---|
555 | ;;; Get the instance method structure corresponding to SEL for CLASS |
---|
556 | |
---|
557 | (defun get-method (class sel) |
---|
558 | (let ((m (class-get-instance-method class sel))) |
---|
559 | (if (%null-ptr-p m) |
---|
560 | (error "Instances of ObjC class ~S cannot respond to the message ~S" |
---|
561 | (objc-class-name class) |
---|
562 | (lisp-string-from-sel sel)) |
---|
563 | m))) |
---|
564 | |
---|
565 | |
---|
566 | ;;; Get the class method structure corresponding to SEL for CLASS |
---|
567 | |
---|
568 | (defun get-class-method (class sel) |
---|
569 | (let ((m (class-get-class-method class sel))) |
---|
570 | (if (%null-ptr-p m) |
---|
571 | (error "ObjC class ~S cannot respond to the message ~S" |
---|
572 | (objc-class-name class) |
---|
573 | (lisp-string-from-sel sel)) |
---|
574 | m))) |
---|
575 | |
---|
576 | |
---|
577 | ;;; For some reason, these types sometimes show up as :STRUCTs even though they |
---|
578 | ;;; are not structure tags, but type names |
---|
579 | |
---|
580 | (defun fudge-objc-type (ftype) |
---|
581 | (if (equal ftype '(:STRUCT :<NSD>ecimal)) |
---|
582 | :<NSD>ecimal |
---|
583 | ftype)) |
---|
584 | |
---|
585 | |
---|
586 | ;;; Returns T if the result spec requires a STRET for its return, NIL otherwise |
---|
587 | ;;; RSPEC may be either a number (in which case it is interpreted as a number |
---|
588 | ;;; of words) or a foreign type spec acceptable to PARSE-FOREIGN-TYPE. STRETS |
---|
589 | ;;; must be used when a structure larger than 4 bytes is returned |
---|
590 | |
---|
591 | (defun requires-stret-p (rspec) |
---|
592 | (when (member rspec '(:DOUBLE-FLOAT :UNSIGNED-DOUBLEWORD :SIGNED-DOUBLEWORD) |
---|
593 | :test #'eq) |
---|
594 | (return-from requires-stret-p nil)) |
---|
595 | (setq rspec (fudge-objc-type rspec)) |
---|
596 | (if (numberp rspec) |
---|
597 | (> rspec 1) |
---|
598 | (> (ensure-foreign-type-bits (parse-foreign-type rspec)) target::nbits-in-word))) |
---|
599 | |
---|
600 | |
---|
601 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
602 | ;;;; Stret Convenience Stuff ;;;; |
---|
603 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
604 | |
---|
605 | ;;; Allocate any temporary storage necessary to hold strets required |
---|
606 | ;;; AT TOPLEVEL in the value forms. Special recognition is given to |
---|
607 | ;;; SENDs involving strets and to stret pseudo-functions |
---|
608 | ;;; NS-MAKE-POINT, NS-MAKE-RANGE, NS-MAKE-RECT and NS-MAKE-SIZE |
---|
609 | |
---|
610 | (defmacro slet (varforms &body body &environment env) |
---|
611 | (multiple-value-bind (clean-body decls) (parse-body body env nil) |
---|
612 | (loop with r and s |
---|
613 | for (var val) in varforms |
---|
614 | do (multiple-value-setq (r s) (sletify val t var)) |
---|
615 | collect r into rvarforms |
---|
616 | unless (null s) collect s into stretforms |
---|
617 | finally |
---|
618 | (return |
---|
619 | `(rlet ,rvarforms |
---|
620 | ,@decls |
---|
621 | ,@stretforms |
---|
622 | ,@clean-body))))) |
---|
623 | |
---|
624 | |
---|
625 | ;;; Note that SLET* does not allow declarations |
---|
626 | |
---|
627 | (defmacro slet* (varforms &body body &environment env) |
---|
628 | (if (= (length varforms) 1) |
---|
629 | `(slet ,varforms ,@body) |
---|
630 | `(slet ,(list (first varforms)) |
---|
631 | (slet* ,(rest varforms) ,@body)))) |
---|
632 | |
---|
633 | |
---|
634 | ;;; Collect the info necessary to transform a SLET into an RLET |
---|
635 | |
---|
636 | (defun sletify (form &optional errorp (var (gensym))) |
---|
637 | (if (listp form) |
---|
638 | (case (first form) |
---|
639 | (ns-make-point |
---|
640 | (assert (= (length form) 3)) |
---|
641 | `(,var :<NSP>oint :x ,(second form) :y ,(third form))) |
---|
642 | (ns-make-rect |
---|
643 | (assert (= (length form) 5)) |
---|
644 | `(,var :<NSR>ect :origin.x ,(second form) :origin.y ,(third form) |
---|
645 | :size.width ,(fourth form) :size.height ,(fifth form))) |
---|
646 | (ns-make-range |
---|
647 | (assert (= (length form) 3)) |
---|
648 | `(,var :<NSR>ange :location ,(second form) :length ,(third form))) |
---|
649 | (ns-make-size |
---|
650 | (assert (= (length form) 3)) |
---|
651 | `(,var :<NSS>ize :width ,(second form) :height ,(third form))) |
---|
652 | (send |
---|
653 | (let* ((info (get-objc-message-info (parse-message (cddr form))))) |
---|
654 | (if (null info) |
---|
655 | (error "Can't determine message being sent in ~s" form)) |
---|
656 | (let* ((rtype (objc-method-info-result-type |
---|
657 | (car (objc-message-info-methods info))))) |
---|
658 | (if (getf (objc-message-info-flags info) :returns-structure) |
---|
659 | (values `(,var ,(if (typep rtype 'foreign-type) |
---|
660 | (unparse-foreign-type rtype) |
---|
661 | rtype)) |
---|
662 | `(send/stret ,var ,@(rest form))) |
---|
663 | (if errorp |
---|
664 | (error "NonSTRET SEND in ~S" form) |
---|
665 | form))))) |
---|
666 | (send-super |
---|
667 | (let* ((info (get-objc-message-info (parse-message (cddr form))))) |
---|
668 | (if (null info) |
---|
669 | (error "Can't determine message being sent in ~s" form)) |
---|
670 | (let* ((rtype (objc-method-info-result-type |
---|
671 | (car (objc-message-info-methods info))))) |
---|
672 | (if (getf (objc-message-info-flags info) :returns-structure) |
---|
673 | (values `(,var ,(if (typep rtype 'foreign-type) |
---|
674 | (unparse-foreign-type rtype) |
---|
675 | rtype)) |
---|
676 | `(send-super/stret ,var ,@(rest form))) |
---|
677 | (if errorp |
---|
678 | (error "NonSTRET SEND-SUPER in ~S" form) |
---|
679 | form))))) |
---|
680 | (t (if errorp |
---|
681 | (error "Unrecognized STRET call in ~S" form) |
---|
682 | form))) |
---|
683 | (if errorp |
---|
684 | (error "Unrecognized STRET call in ~S" form) |
---|
685 | form))) |
---|
686 | |
---|
687 | |
---|
688 | ;;; Process the arguments to a message send as an implicit SLET, collecting |
---|
689 | ;;; the info necessary to build the corresponding RLET |
---|
690 | |
---|
691 | (defun sletify-message-args (args) |
---|
692 | (loop with svf and sif |
---|
693 | for a in args |
---|
694 | do (multiple-value-setq (svf sif) (sletify a)) |
---|
695 | unless (null sif) collect sif into sifs |
---|
696 | unless (equal svf a) |
---|
697 | do (setf a (first svf)) |
---|
698 | and collect svf into svfs |
---|
699 | collect a into nargs |
---|
700 | finally (return (values nargs svfs sifs)))) |
---|
701 | |
---|
702 | |
---|
703 | ;;; Convenience macros for some common Cocoa structures. More |
---|
704 | ;;; could be added |
---|
705 | |
---|
706 | (defmacro ns-max-range (r) |
---|
707 | (let ((rtemp (gensym))) |
---|
708 | `(let ((,rtemp ,r)) |
---|
709 | (+ (pref ,rtemp :<NSR>ange.location) (pref ,rtemp :<NSR>ange.length))))) |
---|
710 | (defmacro ns-min-x (r) `(pref ,r :<NSR>ect.origin.x)) |
---|
711 | (defmacro ns-min-y (r) `(pref ,r :<NSR>ect.origin.y)) |
---|
712 | (defmacro ns-max-x (r) |
---|
713 | (let ((rtemp (gensym))) |
---|
714 | `(let ((,rtemp ,r)) |
---|
715 | (+ (pref ,r :<NSR>ect.origin.x) |
---|
716 | (pref ,r :<NSR>ect.size.width))))) |
---|
717 | (defmacro ns-max-y (r) |
---|
718 | (let ((rtemp (gensym))) |
---|
719 | `(let ((,rtemp ,r)) |
---|
720 | (+ (pref ,r :<NSR>ect.origin.y) |
---|
721 | (pref ,r :<NSR>ect.size.height))))) |
---|
722 | (defmacro ns-mid-x (r) |
---|
723 | (let ((rtemp (gensym))) |
---|
724 | `(let ((,rtemp ,r)) |
---|
725 | (* 0.5 (+ (ns-min-x ,rtemp) (ns-max-x ,rtemp)))))) |
---|
726 | (defmacro ns-mid-y (r) |
---|
727 | (let ((rtemp (gensym))) |
---|
728 | `(let ((,rtemp ,r)) |
---|
729 | (* 0.5 (+ (ns-min-y ,rtemp) (ns-max-y ,rtemp)))))) |
---|
730 | (defmacro ns-height (r) `(pref ,r :<NSR>ect.size.height)) |
---|
731 | (defmacro ns-width (r) `(pref ,r :<NSR>ect.size.width)) |
---|
732 | |
---|
733 | |
---|
734 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
735 | ;;;; Type Stuff ;;;; |
---|
736 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
737 | |
---|
738 | |
---|
739 | |
---|
740 | (defvar *objc-message-info* (make-hash-table :test #'equal :size 800)) |
---|
741 | |
---|
742 | (defun result-type-requires-structure-return (result-type) |
---|
743 | ;; Use objc-msg-send-stret for all methods that return |
---|
744 | ;; record types. |
---|
745 | (or (typep result-type 'foreign-record-type) |
---|
746 | (and (not (typep result-type 'foreign-type)) |
---|
747 | (typep (parse-foreign-type result-type) 'foreign-record-type)))) |
---|
748 | |
---|
749 | (defvar *objc-method-signatures* (make-hash-table :test #'equal)) |
---|
750 | |
---|
751 | (defstruct objc-method-signature-info |
---|
752 | type-signature |
---|
753 | function |
---|
754 | super-function) |
---|
755 | |
---|
756 | (defun objc-method-signature-info (sig) |
---|
757 | (or (gethash sig *objc-method-signatures*) |
---|
758 | (setf (gethash sig *objc-method-signatures*) |
---|
759 | (make-objc-method-signature-info |
---|
760 | :type-signature sig |
---|
761 | :function (compile-send-function-for-signature sig) |
---|
762 | :super-function (%compile-send-function-for-signature sig t))))) |
---|
763 | |
---|
764 | (defun concise-foreign-type (ftype) |
---|
765 | (if (typep ftype 'foreign-record-type) |
---|
766 | (let* ((name (foreign-record-type-name ftype))) |
---|
767 | (if name |
---|
768 | `(,(foreign-record-type-kind ftype) ,name) |
---|
769 | (unparse-foreign-type ftype))) |
---|
770 | (if (objc-id-type-p ftype) |
---|
771 | :id |
---|
772 | (if (typep ftype 'foreign-pointer-type) |
---|
773 | (let* ((to (foreign-pointer-type-to ftype))) |
---|
774 | (if (null to) |
---|
775 | '(:* :void) |
---|
776 | `(:* ,(concise-foreign-type to)))) |
---|
777 | (if (typep ftype 'foreign-type) |
---|
778 | (unparse-foreign-type ftype) |
---|
779 | ftype))))) |
---|
780 | |
---|
781 | |
---|
782 | ;;; Not a perfect mechanism. |
---|
783 | (defclass objc-dispatch-function (funcallable-standard-object) |
---|
784 | () |
---|
785 | (:metaclass funcallable-standard-class)) |
---|
786 | |
---|
787 | (defmethod print-object ((o objc-dispatch-function) stream) |
---|
788 | (print-unreadable-object (o stream :type t :identity t) |
---|
789 | (let* ((name (function-name o))) |
---|
790 | (when name |
---|
791 | (format stream "~s" name))))) |
---|
792 | |
---|
793 | |
---|
794 | |
---|
795 | |
---|
796 | (declaim (inline check-receiver)) |
---|
797 | |
---|
798 | ;;; Return a NULL pointer if RECEIVER is a null pointer. |
---|
799 | ;;; Otherwise, insist that it's an ObjC object of some sort, and return NIL. |
---|
800 | (defun check-receiver (receiver) |
---|
801 | (if (%null-ptr-p receiver) |
---|
802 | (%null-ptr) |
---|
803 | (let* ((domain (%macptr-domain receiver)) |
---|
804 | (valid (eql domain *objc-object-domain*))) |
---|
805 | (declare (fixnum domain)) |
---|
806 | (when (zerop domain) |
---|
807 | (if (recognize-objc-object receiver) |
---|
808 | (progn (%set-macptr-domain receiver *objc-object-domain*) |
---|
809 | (setq valid t)))) |
---|
810 | (unless valid |
---|
811 | (report-bad-arg receiver 'objc:objc-object))))) |
---|
812 | |
---|
813 | (defmethod shared-initialize :after ((gf objc-dispatch-function) slot-names &key message-info &allow-other-keys) |
---|
814 | (declare (ignore slot-names)) |
---|
815 | (if message-info |
---|
816 | (let* ((ambiguous-methods (getf (objc-message-info-flags message-info) :ambiguous)) |
---|
817 | (selector (objc-message-info-selector message-info)) |
---|
818 | (first-method (car (objc-message-info-methods message-info)))) |
---|
819 | (lfun-bits gf (dpb (1+ (objc-message-info-req-args message-info)) |
---|
820 | $lfbits-numreq |
---|
821 | (logior (ash |
---|
822 | (if (getf (objc-message-info-flags message-info) |
---|
823 | :accepts-varargs) |
---|
824 | 1 |
---|
825 | 0) |
---|
826 | $lfbits-rest-bit) |
---|
827 | (logandc2 (lfun-bits gf) (ash 1 $lfbits-aok-bit))))) |
---|
828 | (flet ((signature-function-for-method (m) |
---|
829 | (let* ((signature-info (objc-method-info-signature-info m))) |
---|
830 | (or (objc-method-signature-info-function signature-info) |
---|
831 | (setf (objc-method-signature-info-function signature-info) |
---|
832 | (compile-send-function-for-signature |
---|
833 | (objc-method-signature-info-type-signature signature-info))))))) |
---|
834 | |
---|
835 | (if (null ambiguous-methods) |
---|
836 | ;; Pick an arbitrary method, since all methods have the same |
---|
837 | ;; signature. |
---|
838 | (let* ((function (signature-function-for-method first-method))) |
---|
839 | (set-funcallable-instance-function |
---|
840 | gf |
---|
841 | (nfunction |
---|
842 | send-unambiguous-message |
---|
843 | (lambda (receiver &rest args) |
---|
844 | (declare (dynamic-extent args)) |
---|
845 | (or (check-receiver receiver) |
---|
846 | (with-ns-exceptions-as-errors |
---|
847 | (apply function receiver selector args))))))) |
---|
848 | (let* ((protocol-pairs (mapcar #'(lambda (pm) |
---|
849 | (cons (lookup-objc-protocol |
---|
850 | (objc-method-info-class-name pm)) |
---|
851 | (signature-function-for-method |
---|
852 | pm))) |
---|
853 | (objc-message-info-protocol-methods message-info))) |
---|
854 | (method-pairs (mapcar #'(lambda (group) |
---|
855 | (cons (mapcar #'(lambda (m) |
---|
856 | (get-objc-method-info-class m)) |
---|
857 | group) |
---|
858 | (signature-function-for-method (car group)))) |
---|
859 | (objc-message-info-ambiguous-methods message-info))) |
---|
860 | (default-function (if method-pairs |
---|
861 | (prog1 (cdar (last method-pairs)) |
---|
862 | (setq method-pairs (nbutlast method-pairs))) |
---|
863 | (prog1 (cdr (last protocol-pairs)) |
---|
864 | (setq protocol-pairs (nbutlast protocol-pairs)))))) |
---|
865 | (set-funcallable-instance-function |
---|
866 | gf |
---|
867 | (nfunction |
---|
868 | send-unambiguous-message |
---|
869 | (lambda (receiver &rest args) |
---|
870 | (declare (dynamic-extent args)) |
---|
871 | (or (check-receiver receiver) |
---|
872 | (let* ((function |
---|
873 | (or (dolist (pair protocol-pairs) |
---|
874 | (when (conforms-to-protocol receiver (car pair)) |
---|
875 | (return (cdr pair)))) |
---|
876 | (block m |
---|
877 | (dolist (pair method-pairs default-function) |
---|
878 | (dolist (class (car pair)) |
---|
879 | (when (typep receiver class) |
---|
880 | (return-from m (cdr pair))))))))) |
---|
881 | (with-ns-exceptions-as-errors |
---|
882 | (apply function receiver selector args))))))))))) |
---|
883 | (with-slots (name) gf |
---|
884 | (set-funcallable-instance-function |
---|
885 | gf |
---|
886 | #'(lambda (&rest args) |
---|
887 | (error "Unknown ObjC message ~a called with arguments ~s" |
---|
888 | (symbol-name name) args)))))) |
---|
889 | |
---|
890 | |
---|
891 | (defun %call-next-objc-method (self class selector sig &rest args) |
---|
892 | (declare (dynamic-extent args)) |
---|
893 | (rlet ((s :objc_super #+apple-objc :receiver #+gnu-objc :self self |
---|
894 | #+apple-objc-2.0 :super_class #-apple-objc-2.0 :class |
---|
895 | #+apple-objc-2.0 (#_class_getSuperclass class) |
---|
896 | #-apple-objc-2.0 (pref class :objc_class.super_class))) |
---|
897 | (let* ((siginfo (objc-method-signature-info sig)) |
---|
898 | (function (or (objc-method-signature-info-super-function siginfo) |
---|
899 | (setf (objc-method-signature-info-super-function siginfo) |
---|
900 | (%compile-send-function-for-signature sig t))))) |
---|
901 | (with-ns-exceptions-as-errors |
---|
902 | (apply function s selector args))))) |
---|
903 | |
---|
904 | |
---|
905 | (defun %call-next-objc-class-method (self class selector sig &rest args) |
---|
906 | (rlet ((s :objc_super #+apple-objc :receiver #+gnu-objc :self self |
---|
907 | #+apple-objc-2.0 :super_class #-apple-objc-2.0 :class |
---|
908 | #+apple-objc-2.0 (#_class_getSuperclass (pref class :objc_class.isa)) |
---|
909 | #-apple-objc-2.0 (pref (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer) :objc_class.super_class))) |
---|
910 | (let* ((siginfo (objc-method-signature-info sig)) |
---|
911 | (function (or (objc-method-signature-info-super-function siginfo) |
---|
912 | (setf (objc-method-signature-info-super-function siginfo) |
---|
913 | (%compile-send-function-for-signature sig t))))) |
---|
914 | (with-ns-exceptions-as-errors |
---|
915 | (apply function s selector args))))) |
---|
916 | |
---|
917 | (defun postprocess-objc-message-info (message-info) |
---|
918 | (let* ((objc-name (objc-message-info-message-name message-info)) |
---|
919 | (lisp-name (or (objc-message-info-lisp-name message-info) |
---|
920 | (setf (objc-message-info-lisp-name message-info) |
---|
921 | (compute-objc-to-lisp-function-name objc-name)))) |
---|
922 | (gf (or (fboundp lisp-name) |
---|
923 | (setf (fdefinition lisp-name) |
---|
924 | (make-instance 'objc-dispatch-function :name lisp-name))))) |
---|
925 | |
---|
926 | (unless (objc-message-info-selector message-info) |
---|
927 | (setf (objc-message-info-selector message-info) |
---|
928 | (ensure-objc-selector (objc-message-info-message-name message-info)))) |
---|
929 | |
---|
930 | (flet ((reduce-to-ffi-type (ftype) |
---|
931 | (concise-foreign-type ftype))) |
---|
932 | (flet ((ensure-method-signature (m) |
---|
933 | (or (objc-method-info-signature m) |
---|
934 | (setf (objc-method-info-signature m) |
---|
935 | (let* ((sig |
---|
936 | (cons (reduce-to-ffi-type |
---|
937 | (objc-method-info-result-type m)) |
---|
938 | (mapcar #'reduce-to-ffi-type |
---|
939 | (objc-method-info-arglist m))))) |
---|
940 | (setf (objc-method-info-signature-info m) |
---|
941 | (objc-method-signature-info sig)) |
---|
942 | sig))))) |
---|
943 | (let* ((methods (objc-message-info-methods message-info)) |
---|
944 | (signatures ()) |
---|
945 | (protocol-methods) |
---|
946 | (signature-alist ())) |
---|
947 | (labels ((signatures-equal (xs ys) |
---|
948 | (and xs |
---|
949 | ys |
---|
950 | (do* ((xs xs (cdr xs)) |
---|
951 | (ys ys (cdr ys))) |
---|
952 | ((null xs) (null ys)) |
---|
953 | (unless (foreign-type-= (ensure-foreign-type (car xs)) |
---|
954 | (ensure-foreign-type (car ys))) |
---|
955 | (return nil)))))) |
---|
956 | (dolist (m methods) |
---|
957 | (let* ((signature (ensure-method-signature m))) |
---|
958 | (pushnew signature signatures :test #'signatures-equal) |
---|
959 | (if (getf (objc-method-info-flags m) :protocol) |
---|
960 | (push m protocol-methods) |
---|
961 | (let* ((pair (assoc signature signature-alist :test #'signatures-equal))) |
---|
962 | (if pair |
---|
963 | (push m (cdr pair)) |
---|
964 | (push (cons signature (list m)) signature-alist))))))) |
---|
965 | (setf (objc-message-info-ambiguous-methods message-info) |
---|
966 | (mapcar #'cdr |
---|
967 | (sort signature-alist |
---|
968 | #'(lambda (x y) |
---|
969 | (< (length (cdr x)) |
---|
970 | (length (cdr y))))))) |
---|
971 | (setf (objc-message-info-flags message-info) nil) |
---|
972 | (setf (objc-message-info-protocol-methods message-info) |
---|
973 | protocol-methods) |
---|
974 | (when (cdr signatures) |
---|
975 | (setf (getf (objc-message-info-flags message-info) :ambiguous) t)) |
---|
976 | (let* ((first-method (car methods)) |
---|
977 | (first-sig (objc-method-info-signature first-method)) |
---|
978 | (first-sig-len (length first-sig))) |
---|
979 | (setf (objc-message-info-req-args message-info) |
---|
980 | (1- first-sig-len)) |
---|
981 | ;; Whether some arg/result types vary or not, we want to insist |
---|
982 | ;; on (a) either no methods take a variable number of arguments, |
---|
983 | ;; or all do, and (b) either no method uses structure-return |
---|
984 | ;; conventions, or all do. (It's not clear that these restrictions |
---|
985 | ;; are entirely reasonable in the long run; in the short term, |
---|
986 | ;; they'll help get things working.) |
---|
987 | (flet ((method-returns-structure (m) |
---|
988 | (result-type-requires-structure-return |
---|
989 | (objc-method-info-result-type m))) |
---|
990 | (method-accepts-varargs (m) |
---|
991 | (eq (car (last (objc-method-info-arglist m))) |
---|
992 | *void-foreign-type*)) |
---|
993 | (method-has-structure-arg (m) |
---|
994 | (dolist (arg (objc-method-info-arglist m)) |
---|
995 | (when (typep (ensure-foreign-type arg) 'foreign-record-type) |
---|
996 | (return t))))) |
---|
997 | (when (dolist (method methods) |
---|
998 | (when (method-has-structure-arg method) |
---|
999 | (return t))) |
---|
1000 | (setf (compiler-macro-function lisp-name) |
---|
1001 | 'hoist-struct-constructors)) |
---|
1002 | (let* ((first-result-is-structure (method-returns-structure first-method)) |
---|
1003 | (first-accepts-varargs (method-accepts-varargs first-method))) |
---|
1004 | (if (dolist (m (cdr methods) t) |
---|
1005 | (unless (eq (method-returns-structure m) |
---|
1006 | first-result-is-structure) |
---|
1007 | (return nil))) |
---|
1008 | (if first-result-is-structure |
---|
1009 | (setf (getf (objc-message-info-flags message-info) |
---|
1010 | :returns-structure) t))) |
---|
1011 | (if (dolist (m (cdr methods) t) |
---|
1012 | (unless (eq (method-accepts-varargs m) |
---|
1013 | first-accepts-varargs) |
---|
1014 | (return nil))) |
---|
1015 | (if first-accepts-varargs |
---|
1016 | (progn |
---|
1017 | (setf (getf (objc-message-info-flags message-info) |
---|
1018 | :accepts-varargs) t) |
---|
1019 | (decf (objc-message-info-req-args message-info))))))))) |
---|
1020 | (reinitialize-instance gf :message-info message-info))))) |
---|
1021 | |
---|
1022 | ;;; -may- need to invalidate cached info whenever new interface files |
---|
1023 | ;;; are made accessible. Probably the right thing to do is to insist |
---|
1024 | ;;; that (known) message signatures be updated in that case. |
---|
1025 | (defun get-objc-message-info (message-name &optional (use-database t)) |
---|
1026 | (setq message-name (string message-name)) |
---|
1027 | (or (gethash message-name *objc-message-info*) |
---|
1028 | (and use-database |
---|
1029 | (let* ((info (lookup-objc-message-info message-name))) |
---|
1030 | (when info |
---|
1031 | (setf (gethash message-name *objc-message-info*) info) |
---|
1032 | (postprocess-objc-message-info info) |
---|
1033 | info))))) |
---|
1034 | |
---|
1035 | (defun need-objc-message-info (message-name) |
---|
1036 | (or (get-objc-message-info message-name) |
---|
1037 | (error "Undeclared message: ~s" message-name))) |
---|
1038 | |
---|
1039 | ;;; Should be called after using new interfaces that may define |
---|
1040 | ;;; new methods on existing messages. |
---|
1041 | (defun update-objc-method-info () |
---|
1042 | (maphash #'(lambda (message-name info) |
---|
1043 | (lookup-objc-message-info message-name info) |
---|
1044 | (postprocess-objc-message-info info)) |
---|
1045 | *objc-message-info*)) |
---|
1046 | |
---|
1047 | |
---|
1048 | ;;; Of the method declarations (OBJC-METHOD-INFO structures) associated |
---|
1049 | ;;; with the message-declaration (OBJC-MESSAGE-INFO structure) M, |
---|
1050 | ;;; return the one that seems to be applicable for the object O. |
---|
1051 | ;;; (If there's no ambiguity among the declared methods, any method |
---|
1052 | ;;; will do; this just tells runtime %SEND functions how to compose |
---|
1053 | ;;; an %FF-CALL). |
---|
1054 | (defun %lookup-objc-method-info (m o) |
---|
1055 | (let* ((methods (objc-message-info-methods m)) |
---|
1056 | (ambiguous (getf (objc-message-info-flags m) :ambiguous))) |
---|
1057 | (if (not ambiguous) |
---|
1058 | (car methods) |
---|
1059 | (or |
---|
1060 | (dolist (method methods) |
---|
1061 | (let* ((mclass (get-objc-method-info-class method))) |
---|
1062 | (if (typep o mclass) |
---|
1063 | (return method)))) |
---|
1064 | (error "Can't determine ObjC method type signature for message ~s, object ~s" (objc-message-info-message-name m) o))))) |
---|
1065 | |
---|
1066 | (defun resolve-existing-objc-method-info (message-info class-name class-p result-type args) |
---|
1067 | (let* ((method-info (dolist (m (objc-message-info-methods message-info)) |
---|
1068 | (when (and (eq (getf (objc-method-info-flags m) :class-p) |
---|
1069 | class-p) |
---|
1070 | (equal (objc-method-info-class-name m) |
---|
1071 | class-name)) |
---|
1072 | (return m))))) |
---|
1073 | (when method-info |
---|
1074 | (unless (and (foreign-type-= (ensure-foreign-type (objc-method-info-result-type method-info)) |
---|
1075 | (parse-foreign-type result-type)) |
---|
1076 | (do* ((existing (objc-method-info-arglist method-info) (cdr existing)) |
---|
1077 | (proposed args (cdr proposed))) |
---|
1078 | ((null existing) (null proposed)) |
---|
1079 | (unless (foreign-type-= (ensure-foreign-type (car existing)) |
---|
1080 | (parse-foreign-type (car proposed))) |
---|
1081 | (return nil)))) |
---|
1082 | (cerror "Redefine existing method to have new type signature." |
---|
1083 | "The method ~c[~a ~a] is already declared to have type signature ~s; the new declaration ~s is incompatible." (if class-p #\+ #\-) class-name (objc-message-info-message-name message-info) (objc-method-info-signature method-info) (cons result-type args)) |
---|
1084 | (setf (objc-method-info-arglist method-info) args |
---|
1085 | (objc-method-info-result-type method-info) result-type |
---|
1086 | (objc-method-info-signature method-info) nil |
---|
1087 | (objc-method-info-signature-info method-info) nil)) |
---|
1088 | method-info))) |
---|
1089 | |
---|
1090 | (defvar *objc-verbose* nil) |
---|
1091 | |
---|
1092 | ;;; Still not right; we have to worry about type conflicts with |
---|
1093 | ;;; shadowed methods, as well. |
---|
1094 | (defun %declare-objc-method (message-name class-name class-p result-type args) |
---|
1095 | (let* ((info (get-objc-message-info message-name))) |
---|
1096 | (unless info |
---|
1097 | (when (or *objc-verbose* *compile-print*) |
---|
1098 | (format *error-output* "~&; Note: defining new ObjC message ~c[~a ~a]" (if class-p #\+ #\-) class-name message-name)) |
---|
1099 | (setq info (make-objc-message-info :message-name message-name)) |
---|
1100 | (setf (gethash message-name *objc-message-info*) info)) |
---|
1101 | (let* ((was-ambiguous (getf (objc-message-info-flags info) :ambiguous)) |
---|
1102 | (method-info (or (resolve-existing-objc-method-info info class-name class-p result-type args) |
---|
1103 | (make-objc-method-info :message-info info |
---|
1104 | :class-name class-name |
---|
1105 | :result-type result-type |
---|
1106 | :arglist args |
---|
1107 | :flags (if class-p '(:class t)))))) |
---|
1108 | (pushnew method-info (objc-message-info-methods info)) |
---|
1109 | (postprocess-objc-message-info info) |
---|
1110 | (if (and (getf (objc-message-info-flags info) :ambiguous) |
---|
1111 | (not was-ambiguous)) |
---|
1112 | (warn "previously declared methods on ~s all had the same type signature, but ~s introduces ambiguity" message-name method-info)) |
---|
1113 | |
---|
1114 | (objc-method-info-signature method-info)))) |
---|
1115 | |
---|
1116 | |
---|
1117 | |
---|
1118 | ;;; TRANSLATE-FOREIGN-ARG-TYPE doesn't accept :VOID |
---|
1119 | |
---|
1120 | (defun translate-foreign-result-type (ftype) |
---|
1121 | (ensure-foreign-type-bits (parse-foreign-type ftype)) |
---|
1122 | (if (eq ftype :void) |
---|
1123 | :void |
---|
1124 | (translate-foreign-arg-type ftype))) |
---|
1125 | |
---|
1126 | |
---|
1127 | |
---|
1128 | |
---|
1129 | |
---|
1130 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
1131 | ;;;; Invoking ObjC Methods ;;;; |
---|
1132 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
1133 | |
---|
1134 | |
---|
1135 | ;;; The SEND and SEND/STRET macros |
---|
1136 | |
---|
1137 | (defmacro send (o msg &rest args &environment env) |
---|
1138 | (make-optimized-send o msg args env)) |
---|
1139 | |
---|
1140 | (defmacro send/stret (s o msg &rest args &environment env) |
---|
1141 | (make-optimized-send o msg args env s)) |
---|
1142 | |
---|
1143 | |
---|
1144 | |
---|
1145 | |
---|
1146 | ;;; Optimize special cases of SEND and SEND/STRET |
---|
1147 | |
---|
1148 | (defun make-optimized-send (o msg args env &optional s super sclassname) |
---|
1149 | (multiple-value-bind (msg args vargs) (parse-message (cons msg args)) |
---|
1150 | (let* ((message-info (get-objc-message-info msg))) |
---|
1151 | (if (null message-info) |
---|
1152 | (error "Unknown message: ~S" msg)) |
---|
1153 | ;; If a vararg exists, make sure that the message can accept it |
---|
1154 | (when (and vargs (not (getf (objc-message-info-flags message-info) |
---|
1155 | :accepts-varargs))) |
---|
1156 | (error "Message ~S cannot accept a variable number of arguments" msg)) |
---|
1157 | (unless (= (length args) (objc-message-info-req-args message-info)) |
---|
1158 | (error "Message ~S requires ~a ~d args, but ~d were provided." |
---|
1159 | msg |
---|
1160 | (if vargs "at least" "exactly") |
---|
1161 | (objc-message-info-req-args message-info) |
---|
1162 | (length args))) |
---|
1163 | (multiple-value-bind (args svarforms sinitforms) (sletify-message-args args) |
---|
1164 | (let* ((ambiguous (getf (objc-message-info-flags message-info) :ambiguous)) |
---|
1165 | (methods (objc-message-info-methods message-info)) |
---|
1166 | (method (if (not ambiguous) (car methods)))) |
---|
1167 | (when ambiguous |
---|
1168 | (let* ((class (if sclassname |
---|
1169 | (find-objc-class sclassname) |
---|
1170 | (get-objc-class-from-declaration (declared-type o env))))) |
---|
1171 | (if class |
---|
1172 | (dolist (m methods) |
---|
1173 | (unless (getf (objc-method-info-flags m) :protocol) |
---|
1174 | (let* ((mclass (or (get-objc-method-info-class m) |
---|
1175 | (error "Can't find ObjC class named ~s" |
---|
1176 | (objc-method-info-class-name m))))) |
---|
1177 | (when (and class (subtypep class mclass)) |
---|
1178 | (return (setq method m))))))))) |
---|
1179 | (if method |
---|
1180 | (build-call-from-method-info method |
---|
1181 | args |
---|
1182 | vargs |
---|
1183 | o |
---|
1184 | msg |
---|
1185 | svarforms |
---|
1186 | sinitforms |
---|
1187 | s |
---|
1188 | super) |
---|
1189 | (build-ambiguous-send-form message-info |
---|
1190 | args |
---|
1191 | vargs |
---|
1192 | o |
---|
1193 | msg |
---|
1194 | svarforms |
---|
1195 | sinitforms |
---|
1196 | s |
---|
1197 | super))))))) |
---|
1198 | |
---|
1199 | |
---|
1200 | ;;; WITH-NS-EXCEPTIONS-AS-ERRORS is only available in OpenMCL 0.14 and above |
---|
1201 | |
---|
1202 | #-openmcl-native-threads |
---|
1203 | (defmacro with-ns-exceptions-as-errors (&body body) |
---|
1204 | `(progn ,@body)) |
---|
1205 | |
---|
1206 | |
---|
1207 | ;;; Return a call to the method specified by SEL on object O, with the args |
---|
1208 | ;;; specified by ARGSPECS. This decides whether a normal or stret call is |
---|
1209 | ;;; needed and, if the latter, uses the memory S to hold the result. If SUPER |
---|
1210 | ;;; is nonNIL, then this builds a send to super. Finally, this also |
---|
1211 | ;;; coerces return #$YES/#$NO values to T/NIL. The entire call takes place |
---|
1212 | ;;; inside an implicit SLET. |
---|
1213 | |
---|
1214 | (defun build-call (o sel msg argspecs svarforms sinitforms &optional s super) |
---|
1215 | `(with-ns-exceptions-as-errors |
---|
1216 | (rlet ,svarforms |
---|
1217 | ,@sinitforms |
---|
1218 | ,(let ((rspec (first (last argspecs)))) |
---|
1219 | (if (requires-stret-p rspec) |
---|
1220 | (if (null s) |
---|
1221 | ;; STRET required but not provided |
---|
1222 | (error "The message ~S must be sent using SEND/STRET" msg) |
---|
1223 | ;; STRET required and provided, use stret send |
---|
1224 | (if (null super) |
---|
1225 | ;; Regular stret send |
---|
1226 | `(progn |
---|
1227 | (objc-message-send-stret ,s ,o ,(cadr sel) |
---|
1228 | ,@(append (butlast argspecs) (list :void))) |
---|
1229 | ,s) |
---|
1230 | ;; Super stret send |
---|
1231 | `(progn |
---|
1232 | (objc-message-send-super-stret ,s ,super ,(cadr sel) |
---|
1233 | ,@(append (butlast argspecs) (list :void))) |
---|
1234 | ,s))) |
---|
1235 | (if (null s) |
---|
1236 | ;; STRET not required and not provided, use send |
---|
1237 | (if (null super) |
---|
1238 | ;; Regular send |
---|
1239 | (if (eq rspec :<BOOL>) |
---|
1240 | `(coerce-from-bool |
---|
1241 | (objc-message-send ,o ,(cadr sel) ,@argspecs)) |
---|
1242 | `(objc-message-send ,o ,(cadr sel) ,@argspecs)) |
---|
1243 | ;; Super send |
---|
1244 | (if (eq rspec :<BOOL>) |
---|
1245 | `(coerce-from-bool |
---|
1246 | (objc-message-send-super ,super ,(cadr sel) ,@argspecs)) |
---|
1247 | `(objc-message-send-super ,super ,(cadr sel) ,@argspecs))) |
---|
1248 | ;; STRET not required but provided |
---|
1249 | (error "The message ~S must be sent using SEND" msg))))))) |
---|
1250 | |
---|
1251 | (defun objc-id-type-p (foreign-type) |
---|
1252 | (and (typep foreign-type 'foreign-pointer-type) |
---|
1253 | (let* ((to (foreign-pointer-type-to foreign-type))) |
---|
1254 | (and (typep to 'foreign-record-type) |
---|
1255 | (eq :struct (foreign-record-type-kind to)) |
---|
1256 | (not (null (progn (ensure-foreign-type-bits to) (foreign-record-type-fields to)))) |
---|
1257 | (let* ((target (foreign-record-field-type (car (foreign-record-type-fields to))))) |
---|
1258 | (and (typep target 'foreign-pointer-type) |
---|
1259 | (let* ((target-to (foreign-pointer-type-to target))) |
---|
1260 | (and (typep target-to 'foreign-record-type) |
---|
1261 | (eq :struct (foreign-record-type-kind target-to)) |
---|
1262 | (eq :objc_class (foreign-record-type-name target-to)))))))))) |
---|
1263 | |
---|
1264 | (defun unique-objc-classes-in-method-info-list (method-info-list) |
---|
1265 | (if (cdr method-info-list) ; if more than 1 class |
---|
1266 | (flet ((subclass-of-some-other-class (c) |
---|
1267 | (let* ((c-class (get-objc-method-info-class c))) |
---|
1268 | (dolist (other method-info-list) |
---|
1269 | (unless (eq other c) |
---|
1270 | (when (subtypep c-class (get-objc-method-info-class other)) |
---|
1271 | (return t))))))) |
---|
1272 | (remove-if #'subclass-of-some-other-class method-info-list)) |
---|
1273 | method-info-list)) |
---|
1274 | |
---|
1275 | (defun get-objc-method-info-class (method-info) |
---|
1276 | (or (objc-method-info-class-pointer method-info) |
---|
1277 | (setf (objc-method-info-class-pointer method-info) |
---|
1278 | (let* ((c (lookup-objc-class (objc-method-info-class-name method-info) nil))) |
---|
1279 | (when c |
---|
1280 | (let* ((meta-p (getf (objc-method-info-flags method-info) :class))) |
---|
1281 | (if meta-p |
---|
1282 | (with-macptrs ((m (pref c :objc_class.isa))) |
---|
1283 | (canonicalize-registered-metaclass m)) |
---|
1284 | (canonicalize-registered-class c)))))))) |
---|
1285 | |
---|
1286 | ;;; Generate some sort of CASE or COND to handle an ambiguous message |
---|
1287 | ;;; send (where the signature of the FF-CALL depends on the type of the |
---|
1288 | ;;; receiver.) |
---|
1289 | ;;; AMBIGUOUS-METHODS is a list of lists of OBJC-METHOD-INFO structures, |
---|
1290 | ;;; where the methods in each sublist share the same type signature. It's |
---|
1291 | ;;; sorted so that more unique method/signature combinations appear first |
---|
1292 | ;;; (and are easier to special-case via TYPECASE.) |
---|
1293 | (defun build-send-case (ambiguous-methods |
---|
1294 | args |
---|
1295 | vargs |
---|
1296 | receiver |
---|
1297 | msg |
---|
1298 | s |
---|
1299 | super |
---|
1300 | protocol-methods) |
---|
1301 | (flet ((method-class-name (m) |
---|
1302 | (let* ((mclass (get-objc-method-info-class m))) |
---|
1303 | (unless mclass |
---|
1304 | (error "Can't find class with ObjC name ~s" |
---|
1305 | (objc-method-info-class-name m))) |
---|
1306 | (class-name mclass)))) |
---|
1307 | |
---|
1308 | (collect ((clauses)) |
---|
1309 | (let* ((protocol (gensym)) |
---|
1310 | (protocol-address (gensym))) |
---|
1311 | (dolist (method protocol-methods) |
---|
1312 | (let* ((protocol-name (objc-method-info-class-name method))) |
---|
1313 | (clauses `((let* ((,protocol (lookup-objc-protocol ,protocol-name)) |
---|
1314 | (,protocol-address (and ,protocol (objc-protocol-address ,protocol)))) |
---|
1315 | (and ,protocol-address |
---|
1316 | (objc-message-send ,receiver |
---|
1317 | "conformsToProtocol:" |
---|
1318 | :address ,protocol-address |
---|
1319 | :<BOOL>))) |
---|
1320 | ,(build-internal-call-from-method-info |
---|
1321 | method args vargs receiver msg s super)))))) |
---|
1322 | (do* ((methods ambiguous-methods (cdr methods))) |
---|
1323 | ((null (cdr methods)) |
---|
1324 | (when ambiguous-methods |
---|
1325 | (clauses `(t |
---|
1326 | ,(build-internal-call-from-method-info |
---|
1327 | (caar methods) args vargs receiver msg s super))))) |
---|
1328 | (clauses `(,(if (cdar methods) |
---|
1329 | `(or ,@(mapcar #'(lambda (m) |
---|
1330 | `(typep ,receiver |
---|
1331 | ',(method-class-name m))) |
---|
1332 | (unique-objc-classes-in-method-info-list |
---|
1333 | (car methods)))) |
---|
1334 | `(typep ,receiver ',(method-class-name (caar methods)))) |
---|
1335 | ,(build-internal-call-from-method-info |
---|
1336 | (caar methods) args vargs receiver msg s super)))) |
---|
1337 | `(cond |
---|
1338 | ,@(clauses))))) |
---|
1339 | |
---|
1340 | (defun build-ambiguous-send-form (message-info args vargs o msg svarforms sinitforms s super) |
---|
1341 | (let* ((receiver (gensym)) |
---|
1342 | (caseform (build-send-case |
---|
1343 | (objc-message-info-ambiguous-methods message-info) |
---|
1344 | args |
---|
1345 | vargs |
---|
1346 | receiver |
---|
1347 | msg |
---|
1348 | s |
---|
1349 | super |
---|
1350 | (objc-message-info-protocol-methods message-info)))) |
---|
1351 | `(with-ns-exceptions-as-errors |
---|
1352 | (rlet ,svarforms |
---|
1353 | ,@sinitforms |
---|
1354 | (let* ((,receiver ,o)) |
---|
1355 | ,caseform))))) |
---|
1356 | |
---|
1357 | |
---|
1358 | ;;; Generate the "internal" part of a method call; the "external" part |
---|
1359 | ;;; has established ObjC exception handling and handled structure-return |
---|
1360 | ;; details |
---|
1361 | (defun build-internal-call-from-method-info (method-info args vargs o msg s super) |
---|
1362 | (let* ((arglist ())) |
---|
1363 | (collect ((specs)) |
---|
1364 | (do* ((args args (cdr args)) |
---|
1365 | (argtypes (objc-method-info-arglist method-info) (cdr argtypes)) |
---|
1366 | (reptypes (cdr (objc-method-info-signature method-info)) (cdr reptypes))) |
---|
1367 | ((null args) (setq arglist (append (specs) vargs))) |
---|
1368 | (let* ((reptype (if (objc-id-type-p (car argtypes)) :id (car reptypes))) |
---|
1369 | (arg (car args))) |
---|
1370 | (specs reptype) |
---|
1371 | (specs arg))) |
---|
1372 | ;;(break "~& arglist = ~s" arglist) |
---|
1373 | (if (result-type-requires-structure-return |
---|
1374 | (objc-method-info-result-type method-info)) |
---|
1375 | (if (null s) |
---|
1376 | ;; STRET required but not provided |
---|
1377 | (error "The message ~S must be sent using SEND/STRET" msg) |
---|
1378 | (if (null super) |
---|
1379 | `(objc-message-send-stret ,s ,o ,msg ,@arglist ,(car (objc-method-info-signature method-info))) |
---|
1380 | `(objc-message-send-super-stret ,s ,super ,msg ,@arglist ,(car (objc-method-info-signature method-info))))) |
---|
1381 | (if s |
---|
1382 | ;; STRET provided but not required |
---|
1383 | (error "The message ~S must be sent using SEND" msg) |
---|
1384 | (let* ((result-spec (car (objc-method-info-signature method-info))) |
---|
1385 | (form (if super |
---|
1386 | `(objc-message-send-super ,super ,msg ,@arglist ,result-spec) |
---|
1387 | `(objc-message-send ,o ,msg ,@arglist ,result-spec)))) |
---|
1388 | form)))))) |
---|
1389 | |
---|
1390 | (defun build-call-from-method-info (method-info args vargs o msg svarforms sinitforms s super) |
---|
1391 | `(with-ns-exceptions-as-errors |
---|
1392 | (rlet ,svarforms |
---|
1393 | ,@sinitforms |
---|
1394 | ,(build-internal-call-from-method-info |
---|
1395 | method-info |
---|
1396 | args |
---|
1397 | vargs |
---|
1398 | o |
---|
1399 | msg |
---|
1400 | s |
---|
1401 | super)))) |
---|
1402 | |
---|
1403 | |
---|
1404 | |
---|
1405 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
1406 | ;;;; Instantiating ObjC Class ;;;; |
---|
1407 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
1408 | |
---|
1409 | ;;; A MAKE-INSTANCE like interface to ObjC object creation |
---|
1410 | |
---|
1411 | (defun make-objc-instance (cname &rest initargs) |
---|
1412 | (declare (dynamic-extent initargs)) |
---|
1413 | (multiple-value-bind (ks vs) (keys-and-vals initargs) |
---|
1414 | (declare (dynamic-extent ks vs)) |
---|
1415 | (let* ((class (etypecase cname |
---|
1416 | (string (canonicalize-registered-class |
---|
1417 | (find-objc-class cname))) |
---|
1418 | (symbol (find-class cname)) |
---|
1419 | (class cname)))) |
---|
1420 | (send-objc-init-message (#/alloc class) ks vs)))) |
---|
1421 | |
---|
1422 | |
---|
1423 | |
---|
1424 | |
---|
1425 | |
---|
1426 | ;;; Provide the BRIDGE module |
---|
1427 | |
---|
1428 | (provide "BRIDGE") |
---|