source: branches/objc-gf/ccl/examples/bridge.lisp @ 6064

Last change on this file since 6064 was 6064, checked in by gb, 13 years ago

In CONCISE-FOREIGN-TYPE: argument might be a typedef name, so don't
try to unparse it unconditionally.

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