source: trunk/source/objc-bridge/bridge.lisp @ 13537

Last change on this file since 13537 was 12741, checked in by gb, 10 years ago

Compile named functions (rather than closures) to do ObjC message
dispatch, solely so that backtraces will contain more meaningful
names. TODO: maybe put some effort into not recompiling when
nothing changes, but the functions are tiny and that may not be
worth the effort.
This may introduce some (more) LOAD-TIME-VALUE issues if dispatch
functions are ever fasdumped; I don't think that worked before this
change and the couple of MAKE-LOAD-FORM methods added here probably
aren't enough to make that work.

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