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

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

Use FOREIGN-STRUCT-ENCPSULATIONs, which were probably a bad idea.
(Will use typed MACPTRs instead, after this code is checked in.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 59.7 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        (unparse-foreign-type ftype)))))
951
952
953;;; Not a perfect mechanism.
954(defclass objc-dispatch-function (funcallable-standard-object)
955    ()
956  (:metaclass funcallable-standard-class))
957
958(defmethod print-object ((o objc-dispatch-function) stream)
959  (print-unreadable-object (o stream :type t :identity t)
960    (let* ((name (function-name o)))
961      (when name
962        (format stream "~s" name)))))
963
964(declaim (inline check-receiever))
965
966;;; Return a NULL pointer if RECEIVER is a null pointer.
967;;; Otherwise, insist that it's an ObjC object of some sort, and return NIL.
968(defun check-receiver (receiver)
969  (if (%null-ptr-p receiver)
970    (%null-ptr)
971    (let* ((domain (%macptr-domain receiver))
972           (valid (eql domain *objc-object-domain*)))
973      (declare (fixnum domain))
974      (when (zerop domain)
975        (if (recognize-objc-object receiver)
976          (progn (%set-macptr-domain receiver *objc-object-domain*)
977                 (setq valid t))))
978      (unless valid
979        (report-bad-arg receiver 'objc:objc-object)))))
980
981(defmethod shared-initialize :after ((gf objc-dispatch-function) slot-names &key message-info &allow-other-keys)
982  (declare (ignore slot-names))
983  (if message-info
984    (let* ((ambiguous-methods (getf (objc-message-info-flags message-info) :ambiguous))
985           (selector (objc-message-info-selector message-info))
986           (first-method (car (objc-message-info-methods message-info))))
987      (lfun-bits gf (dpb (1+ (objc-message-info-req-args message-info))
988                         $lfbits-numreq
989                         (lfun-bits gf)))
990      (flet ((signature-function-for-method (m)
991               (let* ((signature-info (objc-method-info-signature-info m)))
992                 (or (objc-method-signature-info-function signature-info)
993                     (setf (objc-method-signature-info-function signature-info)
994                           (compile-send-function-for-signature
995                                    (objc-method-signature-info-type-signature signature-info)))))))
996                     
997      (if (null ambiguous-methods)
998        ;; Pick an arbitrary method, since all methods have the same
999        ;; signature.
1000        (let* ((function (signature-function-for-method first-method)))
1001          (set-funcallable-instance-function
1002           gf
1003           (nfunction
1004            send-unambiguous-message
1005            (lambda (receiver &rest args)
1006               (declare (dynamic-extent args))
1007               (or (check-receiver receiver)
1008                   (with-ns-exceptions-as-errors 
1009                       (apply function receiver selector args)))))))
1010        (let* ((protocol-pairs (mapcar #'(lambda (pm)
1011                                           (cons (lookup-objc-protocol
1012                                                  (objc-method-info-class-name pm))
1013                                                 (signature-function-for-method
1014                                                  pm)))
1015                                       (objc-message-info-protocol-methods message-info)))
1016               (method-pairs (mapcar #'(lambda (group)
1017                                         (cons (mapcar #'(lambda (m)
1018                                                           (get-objc-method-info-class m))
1019                                                       group)
1020                                               (signature-function-for-method (car group))))
1021                                     (objc-message-info-ambiguous-methods message-info)))
1022               (default-function (if method-pairs
1023                                   (prog1 (cdar (last method-pairs))
1024                                     (setq method-pairs (nbutlast method-pairs)))
1025                                   (prog1 (cdr (last protocol-pairs))
1026                                     (setq protocol-pairs (nbutlast protocol-pairs))))))
1027          (set-funcallable-instance-function
1028           gf
1029           (nfunction
1030            send-unambiguous-message
1031            (lambda (receiver &rest args)
1032               (declare (dynamic-extent args))
1033               (or (check-receiver receiver)
1034                   (let* ((function
1035                           (or (dolist (pair protocol-pairs)
1036                                 (when (conforms-to-protocol receiver (car pair))
1037                                   (return (cdr pair))))
1038                               (block m
1039                                 (dolist (pair method-pairs default-function)
1040                                   (dolist (class (car pair))
1041                                     (when (typep receiver class)
1042                                       (return-from m (cdr pair)))))))))
1043                     (with-ns-exceptions-as-errors
1044                         (apply function receiver selector args)))))))))))
1045    (with-slots (name) gf
1046      (set-funcallable-instance-function
1047       gf
1048       #'(lambda (&rest args)
1049           (error "Unknown ObjC message ~a called with arguments ~s"
1050                  (symbol-name name) args))))))
1051                                             
1052
1053
1054(defun postprocess-objc-message-info (message-info)
1055  (let* ((objc-name (objc-message-info-message-name message-info))
1056         (lisp-name (or (objc-message-info-lisp-name message-info)
1057                            (setf (objc-message-info-lisp-name message-info)
1058                                  (compute-objc-to-lisp-function-name  objc-name))))
1059         (gf (or (fboundp lisp-name)
1060                 (setf (fdefinition lisp-name)
1061                       (make-instance 'objc-dispatch-function :name lisp-name)))))
1062
1063    (unless (objc-message-info-selector message-info)
1064      (setf (objc-message-info-selector message-info)
1065            (ensure-objc-selector (objc-message-info-message-name message-info))))
1066   
1067  (flet ((reduce-to-ffi-type (ftype)
1068           (concise-foreign-type ftype)))
1069    (flet ((ensure-method-signature (m)
1070             (or (objc-method-info-signature m)
1071                 (setf (objc-method-info-signature m)
1072                       (let* ((sig 
1073                               (cons (reduce-to-ffi-type
1074                                      (objc-method-info-result-type m))
1075                                     (mapcar #'reduce-to-ffi-type
1076                                             (objc-method-info-arglist m)))))
1077                         (setf (objc-method-info-signature-info m)
1078                               (objc-method-signature-info sig))
1079                         sig)))))
1080      (let* ((methods (objc-message-info-methods message-info))
1081             (signatures ())
1082             (protocol-methods)
1083             (signature-alist ()))
1084        (dolist (m methods)
1085          (let* ((signature (ensure-method-signature m)))
1086            (pushnew signature signatures :test #'equal)
1087            (if (getf (objc-method-info-flags m) :protocol)
1088              (push m protocol-methods)
1089              (let* ((pair (assoc signature signature-alist :test #'equal)))
1090                (if pair
1091                  (push m (cdr pair))
1092                  (push (cons signature (list m)) signature-alist))))))
1093        (setf (objc-message-info-ambiguous-methods message-info)
1094              (mapcar #'cdr
1095                      (sort signature-alist
1096                            #'(lambda (x y)
1097                                (< (length (cdr x))
1098                                   (length (cdr y)))))))
1099        (setf (objc-message-info-flags message-info) nil)
1100        (setf (objc-message-info-protocol-methods message-info)
1101              protocol-methods)
1102        (when (cdr signatures)
1103          (setf (getf (objc-message-info-flags message-info) :ambiguous) t))
1104        (let* ((first-method (car methods))
1105               (first-sig (objc-method-info-signature first-method))
1106               (first-sig-len (length first-sig)))
1107          (setf (objc-message-info-req-args message-info)
1108                (1- first-sig-len))
1109          ;; Whether some arg/result types vary or not, we want to insist
1110          ;; on (a) either no methods take a variable number of arguments,
1111          ;; or all do, and (b) either no method uses structure-return
1112          ;; conventions, or all do. (It's not clear that these restrictions
1113          ;; are entirely reasonable in the long run; in the short term,
1114          ;; they'll help get things working.)
1115          (flet ((method-returns-structure (m)
1116                   (result-type-requires-structure-return
1117                    (objc-method-info-result-type m)))
1118                 (method-accepts-varargs (m)
1119                   (eq (car (last (objc-method-info-arglist m)))
1120                       *void-foreign-type*)))
1121            (let* ((first-result-is-structure (method-returns-structure first-method))
1122                   (first-accepts-varargs (method-accepts-varargs first-method)))
1123              (if (dolist (m (cdr methods) t)
1124                    (unless (eq (method-returns-structure m)
1125                                first-result-is-structure)
1126                      (return nil)))
1127                (if first-result-is-structure
1128                  (setf (getf (objc-message-info-flags message-info)
1129                              :returns-structure) t)))
1130              (if (dolist (m (cdr methods) t)
1131                    (unless (eq (method-accepts-varargs m)
1132                                first-accepts-varargs)
1133                      (return nil)))
1134                (if first-accepts-varargs
1135                  (progn
1136                    (setf (getf (objc-message-info-flags message-info)
1137                                :accepts-varargs) t)
1138                    (decf (objc-message-info-req-args message-info)))))))))
1139      (reinitialize-instance gf :message-info message-info)))))
1140         
1141;;; -may- need to invalidate cached info whenever new interface files
1142;;; are made accessible.  Probably the right thing to do is to insist
1143;;; that (known) message signatures be updated in that case.
1144(defun get-objc-message-info (message-name &optional (use-database t))
1145  (setq message-name (string message-name))
1146  (or (gethash message-name *objc-message-info*)
1147      (and use-database
1148           (let* ((info (lookup-objc-message-info message-name)))
1149             (when info
1150               (setf (gethash message-name *objc-message-info*) info)
1151               (postprocess-objc-message-info info)
1152               info)))))
1153
1154(defun need-objc-message-info (message-name)
1155  (or (get-objc-message-info message-name)
1156      (error "Undeclared message: ~s" message-name)))
1157
1158;;; Should be called after using new interfaces that may define
1159;;; new methods on existing messages.
1160(defun update-objc-method-info ()
1161  (maphash #'(lambda (message-name info)
1162               (lookup-objc-message-info message-name info)
1163               (postprocess-objc-message-info info))
1164           *objc-message-info*))
1165
1166
1167;;; Of the method declarations (OBJC-METHOD-INFO structures) associated
1168;;; with the message-declaration (OBJC-MESSAGE-INFO structure) M,
1169;;; return the one that seems to be applicable for the object O.
1170;;; (If there's no ambiguity among the declare methods, any method
1171;;; will do; this just tells runtime %SEND functions how to compose
1172;;; an %FF-CALL).
1173(defun %lookup-objc-method-info (m o)
1174  (let* ((methods (objc-message-info-methods m))
1175         (ambiguous (getf (objc-message-info-flags m) :ambiguous)))
1176    (if (not ambiguous)
1177      (car methods)
1178      (or 
1179       (dolist (method methods)
1180         (let* ((mclass (get-objc-method-info-class method)))
1181           (if (typep o mclass)
1182             (return method))))
1183       (error "Can't determine ObjC method type signature for message ~s, object ~s" (objc-message-info-message-name m) o)))))
1184
1185(defun %declare-objc-method (message-name class-name class-p result-type args)
1186  (let* ((info (get-objc-message-info message-name)))
1187    (unless info
1188      (setq info (make-objc-message-info :message-name message-name))
1189      (setf (gethash message-name *objc-message-info*) info))
1190    (let* ((was-ambiguous (getf (objc-message-info-flags info) :ambiguous))
1191           (method-info (make-objc-method-info :message-info info
1192                                               :class-name class-name
1193                                               :result-type result-type
1194                                               :arglist args
1195                                               :flags (if class-p '(:class t)))))
1196      (push method-info (objc-message-info-methods info))
1197      (postprocess-objc-message-info info)
1198      (if (and (getf (objc-message-info-flags info) :ambiguous)
1199               (not was-ambiguous))
1200        (warn "previously declared methods on ~s all had the same type signature, but ~s introduces ambiguity" message-name method-info))
1201      info)))
1202
1203
1204
1205;;; TRANSLATE-FOREIGN-ARG-TYPE doesn't accept :VOID
1206
1207(defun translate-foreign-result-type (ftype)
1208  (ensure-foreign-type-bits (parse-foreign-type ftype))
1209  (if (eq ftype :void)
1210    :void
1211    (translate-foreign-arg-type ftype)))
1212
1213
1214
1215
1216
1217;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1218;;;;                        Invoking ObjC Methods                           ;;;;
1219;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1220
1221
1222;;; The SEND and SEND/STRET macros
1223
1224(defmacro send (o msg &rest args &environment env)
1225  (make-optimized-send o msg args env))
1226
1227(defmacro send/stret (s o msg &rest args &environment env)
1228  (make-optimized-send o msg args env s))
1229
1230
1231
1232
1233;;; Optimize special cases of SEND and SEND/STRET
1234
1235(defun make-optimized-send (o msg args env  &optional s super sclassname)
1236  (multiple-value-bind (msg args vargs) (parse-message (cons msg args))
1237    (let* ((message-info (get-objc-message-info msg)))
1238      (if (null message-info)
1239        (error "Unknown message: ~S" msg))
1240      ;; If a vararg exists, make sure that the message can accept it
1241      (when (and vargs (not (getf (objc-message-info-flags message-info)
1242                                  :accepts-varargs)))
1243        (error "Message ~S cannot accept a variable number of arguments" msg))
1244      (unless (= (length args) (objc-message-info-req-args message-info))
1245        (error "Message ~S requires ~a ~d args, but ~d were provided."
1246               msg
1247               (if vargs "at least" "exactly")
1248               (objc-message-info-req-args message-info)
1249               (length args)))
1250      (multiple-value-bind (args svarforms sinitforms) (sletify-message-args args)
1251        (let* ((ambiguous (getf (objc-message-info-flags message-info) :ambiguous))
1252               (methods (objc-message-info-methods message-info))
1253               (method (if (not ambiguous) (car methods))))
1254          (when ambiguous
1255            (let* ((class (if sclassname 
1256                            (find-objc-class sclassname)
1257                            (get-objc-class-from-declaration (declared-type o env)))))
1258              (if class
1259                (dolist (m methods)
1260                  (unless (getf (objc-method-info-flags m) :protocol)
1261                    (let* ((mclass (or (get-objc-method-info-class m)
1262                                       (error "Can't find ObjC class named ~s"
1263                                              (objc-method-info-class-name m)))))
1264                      (when (and class (subtypep class mclass))
1265                        (return (setq method m)))))))))
1266          (if method
1267            (build-call-from-method-info method
1268                                         args
1269                                         vargs
1270                                         o
1271                                         msg
1272                                         svarforms
1273                                         sinitforms
1274                                         s
1275                                         super)
1276            (build-ambiguous-send-form message-info
1277                                       args
1278                                       vargs
1279                                       o
1280                                       msg
1281                                       svarforms
1282                                       sinitforms
1283                                       s
1284                                       super)))))))
1285
1286   
1287;;; WITH-NS-EXCEPTIONS-AS-ERRORS is only available in OpenMCL 0.14 and above
1288
1289#-openmcl-native-threads
1290(defmacro with-ns-exceptions-as-errors (&body body)
1291  `(progn ,@body))
1292
1293
1294;;; Return a call to the method specified by SEL on object O, with the args
1295;;; specified by ARGSPECS.  This decides whether a normal or stret call is
1296;;; needed and, if the latter, uses the memory S to hold the result. If SUPER
1297;;; is nonNIL, then this builds a send to super.  Finally, this also
1298;;; coerces return #$YES/#$NO values to T/NIL. The entire call takes place
1299;;; inside an implicit SLET.
1300
1301(defun build-call (o sel msg argspecs svarforms sinitforms &optional s super)
1302  `(with-ns-exceptions-as-errors
1303     (rlet ,svarforms
1304       ,@sinitforms
1305       ,(let ((rspec (first (last argspecs))))
1306          (if (requires-stret-p rspec)
1307            (if (null s)
1308              ;; STRET required but not provided
1309              (error "The message ~S must be sent using SEND/STRET" msg)
1310              ;; STRET required and provided, use stret send
1311              (if (null super)
1312                ;; Regular stret send
1313                `(progn
1314                   (objc-message-send-stret ,s ,o ,(cadr sel)
1315                    ,@(append (butlast argspecs) (list :void)))
1316                   ,s)
1317                ;; Super stret send
1318                `(progn
1319                   (objc-message-send-super-stret ,s ,super ,(cadr sel)
1320                    ,@(append (butlast argspecs) (list :void)))
1321                   ,s)))
1322            (if (null s)
1323              ;; STRET not required and not provided, use send
1324              (if (null super)
1325                ;; Regular send
1326                (if (eq rspec :<BOOL>)
1327                  `(coerce-from-bool
1328                    (objc-message-send ,o ,(cadr sel) ,@argspecs))
1329                  `(objc-message-send ,o ,(cadr sel) ,@argspecs))
1330                ;; Super send
1331                (if (eq rspec :<BOOL>)
1332                  `(coerce-from-bool
1333                    (objc-message-send-super ,super ,(cadr sel) ,@argspecs))
1334                  `(objc-message-send-super ,super ,(cadr sel) ,@argspecs)))
1335              ;; STRET not required but provided
1336              (error "The message ~S must be sent using SEND" msg)))))))
1337
1338(defun objc-id-type-p (foreign-type)
1339  (and (typep foreign-type 'foreign-pointer-type)
1340       (let* ((to (foreign-pointer-type-to foreign-type)))
1341         (and (typep to 'foreign-record-type)
1342              (eq :struct (foreign-record-type-kind to))
1343              (not (null (progn (ensure-foreign-type-bits to) (foreign-record-type-fields to))))
1344              (let* ((target (foreign-record-field-type (car (foreign-record-type-fields to)))))
1345                (and (typep target 'foreign-pointer-type)
1346                     (let* ((target-to (foreign-pointer-type-to target)))
1347                       (and (typep target-to 'foreign-record-type)
1348                            (eq :struct (foreign-record-type-kind target-to))
1349                            (eq :objc_class (foreign-record-type-name target-to))))))))))
1350
1351(defun unique-objc-classes-in-method-info-list (method-info-list)
1352  (if (cdr method-info-list)                     ; if more than 1 class
1353    (flet ((subclass-of-some-other-class (c)
1354             (let* ((c-class (get-objc-method-info-class c)))
1355               (dolist (other method-info-list)
1356                 (unless (eq other c)
1357                   (when (subtypep c-class (get-objc-method-info-class other))
1358                   (return t)))))))
1359      (remove-if #'subclass-of-some-other-class method-info-list))
1360    method-info-list))
1361 
1362(defun get-objc-method-info-class (method-info)
1363  (or (objc-method-info-class-pointer method-info)
1364      (setf (objc-method-info-class-pointer method-info)
1365            (let* ((c (lookup-objc-class (objc-method-info-class-name method-info) nil)))
1366              (when c
1367                (let* ((meta-p (getf (objc-method-info-flags method-info) :class)))
1368                  (if meta-p
1369                    (with-macptrs ((m (pref c :objc_class.isa)))
1370                      (canonicalize-registered-metaclass m))
1371                    (canonicalize-registered-class c))))))))
1372
1373;;; Generate some sort of CASE or COND to handle an ambiguous message
1374;;; send (where the signature of the FF-CALL depends on the type of the
1375;;; receiver.)
1376;;; AMBIGUOUS-METHODS is a list of lists of OBJC-METHOD-INFO structures,
1377;;; where the methods in each sublist share the same type signature.  It's
1378;;; sorted so that more unique method/signature combinations appear first
1379;;; (and are easier to special-case via TYPECASE.)
1380(defun build-send-case (ambiguous-methods
1381                        args
1382                        vargs
1383                        receiver
1384                        msg
1385                        s
1386                        super
1387                        protocol-methods)
1388  (flet ((method-class-name (m)
1389           (let* ((mclass (get-objc-method-info-class m)))
1390             (unless mclass
1391               (error "Can't find class with ObjC name ~s"
1392                      (objc-method-info-class-name m)))
1393             (class-name mclass))))
1394
1395    (collect ((clauses))
1396      (let* ((protocol (gensym))
1397             (protocol-address (gensym)))
1398        (dolist (method protocol-methods)
1399          (let* ((protocol-name (objc-method-info-class-name method)))
1400            (clauses `((let* ((,protocol (lookup-objc-protocol ,protocol-name))
1401                              (,protocol-address (and ,protocol (protocol-address ,protocol))))
1402                         (and ,protocol-address
1403                              (objc-message-send ,receiver
1404                                                 "conformsToProtocol:"
1405                                                 :address ,protocol-address
1406                                                 :<BOOL>)))
1407                       ,(build-internal-call-from-method-info
1408                         method args vargs receiver msg s super))))))
1409      (do* ((methods ambiguous-methods (cdr methods)))
1410           ((null (cdr methods))
1411            (when ambiguous-methods
1412              (clauses `(t
1413                         ,(build-internal-call-from-method-info
1414                           (caar methods) args vargs receiver msg s super)))))
1415        (clauses `(,(if (cdar methods)
1416                        `(or ,@(mapcar #'(lambda (m)
1417                                           `(typep ,receiver
1418                                             ',(method-class-name m)))
1419                                       (unique-objc-classes-in-method-info-list
1420                                        (car methods))))
1421                        `(typep ,receiver ',(method-class-name (caar methods))))
1422                   ,(build-internal-call-from-method-info
1423                     (caar methods) args vargs receiver msg s super))))
1424      `(cond
1425        ,@(clauses)))))
1426
1427(defun build-ambiguous-send-form (message-info args vargs o msg svarforms sinitforms s super)
1428  (let* ((receiver (gensym))
1429         (caseform (build-send-case
1430                    (objc-message-info-ambiguous-methods message-info)
1431                    args
1432                    vargs
1433                    receiver
1434                    msg
1435                    s
1436                    super
1437                    (objc-message-info-protocol-methods message-info))))
1438    `(with-ns-exceptions-as-errors
1439      (rlet ,svarforms
1440        ,@sinitforms
1441        (let* ((,receiver ,o))
1442          ,caseform)))))
1443
1444
1445;;; Generate the "internal" part of a method call; the "external" part
1446;;; has established ObjC exception handling and handled structure-return
1447;;  details
1448(defun build-internal-call-from-method-info (method-info args vargs o msg s super)
1449  (let* ((arglist ()))
1450    (collect ((specs))
1451      (do* ((args args (cdr args))
1452            (argtypes (objc-method-info-arglist method-info) (cdr argtypes))
1453            (reptypes (cdr (objc-method-info-signature method-info)) (cdr reptypes)))
1454           ((null args) (setq arglist (append (specs) vargs)))
1455        (let* ((reptype (if (objc-id-type-p (car argtypes)) :id (car reptypes)))
1456               (arg (car args)))
1457          (specs reptype)
1458          (specs arg)))
1459      ;;(break "~& arglist = ~s" arglist)
1460      (if (result-type-requires-structure-return
1461           (objc-method-info-result-type method-info))
1462        (if (null s)
1463          ;; STRET required but not provided
1464          (error "The message ~S must be sent using SEND/STRET" msg)
1465          (if (null super)
1466            `(objc-message-send-stret ,s ,o ,msg ,@arglist ,(car (objc-method-info-signature method-info)))
1467            `(objc-message-send-super-stret ,s ,super ,msg ,@arglist ,(car (objc-method-info-signature method-info)))))
1468        (if s
1469          ;; STRET provided but not required
1470          (error "The message ~S must be sent using SEND" msg)
1471          (let* ((result-spec (car (objc-method-info-signature method-info)))
1472                 (form (if super
1473                         `(objc-message-send-super ,super ,msg ,@arglist ,result-spec)
1474                         `(objc-message-send ,o ,msg ,@arglist ,result-spec))))
1475            form))))))
1476 
1477(defun build-call-from-method-info (method-info args vargs o  msg  svarforms sinitforms s super)
1478  `(with-ns-exceptions-as-errors
1479    (rlet ,svarforms
1480      ,@sinitforms
1481      ,(build-internal-call-from-method-info
1482        method-info
1483        args
1484        vargs
1485        o
1486        msg
1487        s
1488        super))))
1489
1490 
1491
1492;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1493;;;;                       Instantiating ObjC Class                         ;;;;
1494;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1495
1496;;; A MAKE-INSTANCE like interface to ObjC object creation
1497
1498(defun make-objc-instance (cname &rest initargs)
1499  (declare (dynamic-extent initargs))
1500  (multiple-value-bind (ks vs) (keys-and-vals initargs)
1501    (declare (dynamic-extent ks vs))
1502    (when (not (stringp cname))
1503      (setf cname (lisp-to-objc-classname cname)))
1504    (send-objc-init-message (send (find-objc-class cname) 'alloc)
1505                            ks
1506                            vs)))
1507
1508;;; Provide the BRIDGE module
1509
1510(provide "BRIDGE")
Note: See TracBrowser for help on using the repository browser.