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

Last change on this file since 14735 was 14735, checked in by gz, 9 years ago

In #/ reader, don't crash at end of file

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 62.8 KB
Line 
1;;;; -*- Mode: Lisp; Package: CCL -*-
2;;;; bridge.lisp
3;;;;
4;;;; A Lisp bridge for Cocoa
5;;;;
6;;;; This provides:
7;;;;   (1) Convenient Lisp syntax for instantiating ObjC classes
8;;;;   (2) Convenient Lisp syntax for invoking ObjC methods
9;;;;
10;;;; Copyright (c) 2003 Randall D. Beer
11;;;;
12;;;; This software is licensed under the terms of the Lisp Lesser GNU Public
13;;;; License, known as the LLGPL.  The LLGPL consists of a preamble and
14;;;; the LGPL. Where these conflict, the preamble takes precedence.  The
15;;;; LLGPL is available online at http://opensource.franz.com/preamble.html.
16;;;;
17;;;; Please send comments and bug reports to <beer@eecs.cwru.edu>
18
19;;; Temporary package and module stuff
20
21(in-package "CCL")
22
23(require "OBJC-RUNTIME")
24(require "NAME-TRANSLATION")
25
26;;; 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::with-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  (let* ((initial-p t)
369         (colon nil)
370         (lastch nil))
371    (dotimes (i (length string))
372      (let* ((ch (char string i)))
373        (if (eql ch #\:)
374          (setq initial-p t colon t)
375          (progn
376            (if (and initial-p (digit-char-p ch 10))
377              (error "Digit ~d not allowed at position ~d of ObjC message name ~s."
378                     ch i (copy-seq string)))
379            (setq initial-p nil)))
380        (setq lastch ch)))
381    (when (and colon
382               (not (eql lastch #\:)))
383      (error "ObjC message name ~s contains colons, but last character is not a colon" (copy-seq string)))))
384     
385
386(setf (pkg.intern-hook (find-package "NSFUN"))
387      'get-objc-message-info)
388
389(set-dispatch-macro-character #\# #\/ 
390                              (lambda (stream subchar numarg)
391                                (declare (ignorable subchar numarg))
392                                (let* ((token (make-array 16 :element-type 'character :fill-pointer 0 :adjustable t)))
393                                  (loop
394                                    (let* ((char (read-char stream nil nil)))
395                                      (if (or (eql char #\:)
396                                              (eql char #\_)
397                                              (and char (digit-char-p char 36)))
398                                        (vector-push-extend char token)
399                                        (progn
400                                          (when char
401                                            (unread-char char stream))
402                                          (return)))))
403                                  (unless *read-suppress*
404                                    (unless (> (length token) 0)
405                                      (signal-reader-error stream "Invalid token after #/."))
406                                    (check-objc-message-name token)
407                                    (intern token "NSFUN")))))
408
409
410;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
411;;;;                              Utilities                                 ;;;;
412;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
413
414;;; Return separate lists of the keys and values in a keyword/value list
415
416(defun keys-and-vals (klist)
417  (when (oddp (length klist))
418    (error "Invalid keyword/value list: ~S" klist))
419  (loop for l = klist then (cddr l)
420        until (null l)
421        collect (first l) into keys
422        collect (second l) into vals
423        finally (return (values keys vals))))
424
425
426;;; Return the typestring for an ObjC METHOD
427
428(defun method-typestring (method)
429  (%get-cstring #+(or apple-objc-2.0 cocotron-objc)
430                (#_method_getTypeEncoding method)
431                #-(or apple-objc-2.0 cocotron-objc)
432                (pref method :objc_method.method_types)))
433
434
435;;; Parse the ObjC message from a SENDxxx macro
436
437(defun parse-message (args)
438  (let ((f (first args))
439        (nargs (length args)))
440    (cond ((or (= nargs 1) (= nargs 2))
441           ;; (THING {VARGS})
442           (if (constantp f)
443               (%parse-message (cons (eval f) (rest args)))
444             (values f (rest args) nil)))
445          ;; (THING1 ARG1 ... THINGN ARGN)
446          ((evenp nargs)
447           (multiple-value-bind (ks vs) (keys-and-vals args)
448             (if (every #'constantp ks)
449                 (%parse-message (mapcan #'list (mapcar #'eval ks) vs))
450               (values f (rest args) nil))))
451          ;; (THING1 ARG1 ... THINGN ARGN VARGS)
452          (t (multiple-value-bind (ks vs) (keys-and-vals (butlast args))
453               (if (every #'constantp ks)
454                   (%parse-message 
455                    (nconc (mapcan #'list (mapcar #'eval ks) vs) (last args)))
456                 (values f (rest args) nil)))))))
457
458
459;;; Parse the ObjC message from the evaluated args of a %SENDxxx function
460
461(defun %parse-message (args)
462  (let ((f (first args))
463        (l (first (last args))))
464    (cond ((stringp f)
465           ;; (STRING-with-N-colons ARG1 ... ARGN {LIST})
466           (let* ((n (count #\: (the simple-string f)))
467                  (message-info (need-objc-message-info f))
468                  (args (rest args))
469                  (nargs (length args)))
470             (cond ((and (= nargs 1)
471                         (getf (objc-message-info-flags message-info)
472                               :accepts-varargs))
473                    (values f nil l))
474                   ((= nargs n) (values f args nil))
475                   ((= nargs (1+ n)) (values f (butlast args) l))
476                   (t (error "Improperly formatted argument list: ~S" args)))))
477          ((keywordp f)
478           ;; (KEY1 ARG1 ... KEYN ARGN {LIST}) or (KEY LIST)
479           (let ((nargs (length args)))
480             (cond ((and (= nargs 2) (consp l)
481                         (let* ((info (need-objc-message-info
482                                       (lisp-to-objc-message (list f)))))
483                           (getf (objc-message-info-flags info)
484                                 :accepts-varargs)))
485                    (values (lisp-to-objc-message (list f)) nil l))
486                   ((evenp nargs)
487                    (multiple-value-bind (ks vs) (keys-and-vals args)
488                      (values (lisp-to-objc-message ks) vs nil)))
489                   ((and (> nargs 1) (listp l))
490                    (multiple-value-bind (ks vs) (keys-and-vals (butlast args))
491                      (values (lisp-to-objc-message ks) vs l)))
492                 (t (error "Improperly formatted argument list: ~S" args)))))
493          ((symbolp f)
494           ;; (SYMBOL {LIST})
495           (let ((nargs (length (rest args))))
496             (cond ((= nargs 0) (values (lisp-to-objc-message (list f)) nil nil))
497                   ((= nargs 1) (values (lisp-to-objc-message (list f)) nil l))
498                   (t (error "Improperly formatted argument list: ~S" args)))))
499           (t (error "Improperly formatted argument list: ~S" args)))))
500
501
502;;; Return the declared type of FORM in ENV
503
504(defun declared-type (form env)
505  (cond ((symbolp form)
506         (multiple-value-bind (ignore ignore decls) 
507                              (variable-information form env)
508           (declare (ignore ignore))
509           (or (cdr (assoc 'type decls)) t)))
510        ((and (consp form) (eq (first form) 'the))
511         (second form))
512        (t t)))
513
514
515;;; Return the current optimization setting of KEY in ENV
516
517(defun optimization-setting (key &optional env)
518  (cadr (assoc key (declaration-information 'optimize env))))
519
520
521;;; Return the ObjC class named CNAME
522
523(defun find-objc-class (cname)
524  (%objc-class-classptr 
525   (if (symbolp cname) 
526       (find-class cname)
527     (load-objc-class-descriptor cname))))
528
529
530;;; Return the class object of an ObjC object O, signalling an error
531;;; if O is not an ObjC object
532                     
533(defun objc-class-of (o)
534  (if (objc-object-p o)
535      (class-of o)
536    (progn
537      #+debug
538      (#_NSLog #@"class name = %s" :address (pref (pref o :objc_object.isa)
539                                                  :objc_class.name))
540      (error "~S is not an ObjC object" o))))
541
542
543;;; Returns the ObjC class corresponding to the declared type OTYPE if
544;;; possible, NIL otherwise
545
546(defun get-objc-class-from-declaration (otype)
547  (cond ((symbolp otype) (lookup-objc-class (lisp-to-objc-classname otype)))
548        ((and (consp otype) (eq (first otype) '@metaclass))
549         (let* ((name (second otype))
550                (c
551                 (typecase name
552                   (string (lookup-objc-class name))
553                   (symbol (lookup-objc-class (lisp-to-objc-classname name)))
554                   (t (error "Improper metaclass typespec: ~S" otype)))))
555           (unless (null c) (objc-class-of c))))))
556
557
558;;; Returns the selector of MSG
559
560(defun get-selector (msg)
561  (%get-selector (load-objc-selector msg)))
562
563
564;;; Get the instance method structure corresponding to SEL for CLASS
565
566(defun get-method (class sel)
567  (let ((m (class-get-instance-method class sel)))
568    (if (%null-ptr-p m)
569      (error "Instances of ObjC class ~S cannot respond to the message ~S" 
570             (objc-class-name class)
571             (lisp-string-from-sel sel))
572      m)))
573
574
575;;; Get the class method structure corresponding to SEL for CLASS
576
577(defun get-class-method (class sel)
578  (let ((m (class-get-class-method class sel)))
579    (if (%null-ptr-p m)
580      (error "ObjC class ~S cannot respond to the message ~S" 
581             (objc-class-name class)
582             (lisp-string-from-sel sel))
583      m)))
584
585
586;;; For some reason, these types sometimes show up as :STRUCTs even though they
587;;; are not structure tags, but type names
588
589(defun fudge-objc-type (ftype)
590  (if (equal ftype '(:STRUCT :<NSD>ecimal))
591      :<NSD>ecimal
592    ftype))
593
594
595;;; Returns T if the result spec requires a STRET for its return, NIL otherwise
596;;; RSPEC may be either a number (in which case it is interpreted as a number
597;;; of words) or a foreign type spec acceptable to PARSE-FOREIGN-TYPE. STRETS
598;;; must be used when a structure larger than 4 bytes is returned
599
600(defun requires-stret-p (rspec)
601  (when (member rspec '(:DOUBLE-FLOAT :UNSIGNED-DOUBLEWORD :SIGNED-DOUBLEWORD) 
602                :test #'eq)
603    (return-from requires-stret-p nil))
604  (setq rspec (fudge-objc-type rspec))
605  (if (numberp rspec) 
606    (> rspec 1)
607    (> (ensure-foreign-type-bits (parse-foreign-type rspec)) target::nbits-in-word)))
608
609
610;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
611;;;;                      Stret Convenience Stuff                           ;;;;
612;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
613
614;;; Allocate any temporary storage necessary to hold strets required
615;;; AT TOPLEVEL in the value forms.  Special recognition is given to
616;;; SENDs involving strets and to stret pseudo-functions
617;;; NS-MAKE-POINT, NS-MAKE-RANGE, NS-MAKE-RECT and NS-MAKE-SIZE
618
619(defmacro slet (varforms &body body &environment env)
620  (multiple-value-bind (clean-body decls) (parse-body body env nil)
621    (loop with r and s
622          for (var val) in varforms
623          do (multiple-value-setq (r s) (sletify val t var))
624          collect r into rvarforms
625          unless (null s) collect s into stretforms
626          finally 
627          (return
628           `(rlet ,rvarforms
629              ,@decls
630              ,@stretforms
631              ,@clean-body)))))
632
633
634;;; Note that SLET* does not allow declarations
635
636(defmacro slet* (varforms &body body &environment env)
637  (declare (ignorable env))
638  (if (= (length varforms) 1)
639      `(slet ,varforms ,@body)
640    `(slet ,(list (first varforms))
641       (slet* ,(rest varforms) ,@body))))
642
643
644;;; Collect the info necessary to transform a SLET into an RLET
645
646(defun sletify (form &optional errorp (var (gensym)))
647  (if (listp form)
648    (case (first form)
649      (ns-make-point 
650       (assert (= (length form) 3))
651       `(,var :<NSP>oint :x ,(second form) :y ,(third form)))
652      (ns-make-rect 
653       (assert (= (length form) 5))
654       `(,var :<NSR>ect :origin.x ,(second form) :origin.y ,(third form)
655               :size.width ,(fourth form) :size.height ,(fifth form)))
656      (ns-make-range 
657       (assert (= (length form) 3))
658       `(,var :<NSR>ange :location ,(second form) :length ,(third form)))
659      (ns-make-size
660       (assert (= (length form) 3))
661       `(,var :<NSS>ize :width ,(second form) :height ,(third form)))
662      (send
663       (let* ((info (get-objc-message-info (parse-message (cddr form)))))
664         (if (null info)
665           (error "Can't determine message being sent in ~s" form))
666         (let* ((rtype (objc-method-info-result-type
667                        (car (objc-message-info-methods info)))))
668           (if (getf (objc-message-info-flags info) :returns-structure)
669             (values `(,var ,(if (typep rtype 'foreign-type)
670                                 (unparse-foreign-type rtype)
671                                 rtype))
672                     `(send/stret ,var ,@(rest form)))
673             (if errorp
674               (error "NonSTRET SEND in ~S" form)
675               form)))))
676      (send-super
677       (let* ((info (get-objc-message-info (parse-message (cddr form)))))
678         (if (null info)
679           (error "Can't determine message being sent in ~s" form))
680         (let* ((rtype (objc-method-info-result-type
681                        (car (objc-message-info-methods info)))))
682           (if (getf (objc-message-info-flags info) :returns-structure)
683             (values `(,var ,(if (typep rtype 'foreign-type)
684                                 (unparse-foreign-type rtype)
685                                 rtype))
686                     `(send-super/stret ,var ,@(rest form)))
687             (if errorp
688               (error "NonSTRET SEND-SUPER in ~S" form)
689               form)))))
690      (t (if errorp
691           (error "Unrecognized STRET call in ~S" form)
692           form)))
693    (if errorp
694      (error "Unrecognized STRET call in ~S" form)
695      form)))
696
697
698;;; Process the arguments to a message send as an implicit SLET, collecting
699;;; the info necessary to build the corresponding RLET
700
701(defun sletify-message-args (args)
702  (loop with svf and sif
703        for a in args
704        do (multiple-value-setq (svf sif) (sletify a))
705        unless (null sif) collect sif into sifs
706        unless (equal svf a)
707          do (setf a (first svf))
708          and collect svf into svfs
709        collect a into nargs
710        finally (return (values nargs svfs sifs))))
711 
712 
713;;; Convenience macros for some common Cocoa structures.  More
714;;; could be added
715
716(defmacro ns-max-range (r) 
717  (let ((rtemp (gensym)))
718    `(let ((,rtemp ,r))
719       (+ (pref ,rtemp :<NSR>ange.location) (pref ,rtemp :<NSR>ange.length)))))
720(defmacro ns-min-x (r) `(pref ,r :<NSR>ect.origin.x))
721(defmacro ns-min-y (r) `(pref ,r :<NSR>ect.origin.y))
722(defmacro ns-max-x (r)
723  (let ((rtemp (gensym)))
724    `(let ((,rtemp ,r))
725       (+ (pref ,r :<NSR>ect.origin.x) 
726          (pref ,r :<NSR>ect.size.width)))))
727(defmacro ns-max-y (r)
728  (let ((rtemp (gensym)))
729    `(let ((,rtemp ,r))
730       (+ (pref ,r :<NSR>ect.origin.y)
731          (pref ,r :<NSR>ect.size.height)))))
732(defmacro ns-mid-x (r)
733  (let ((rtemp (gensym)))
734    `(let ((,rtemp ,r))
735       (* 0.5 (+ (ns-min-x ,rtemp) (ns-max-x ,rtemp))))))
736(defmacro ns-mid-y (r)
737  (let ((rtemp (gensym)))
738    `(let ((,rtemp ,r))
739       (* 0.5 (+ (ns-min-y ,rtemp) (ns-max-y ,rtemp))))))
740(defmacro ns-height (r) `(pref ,r :<NSR>ect.size.height))
741(defmacro ns-width (r) `(pref ,r :<NSR>ect.size.width))
742
743
744;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
745;;;;                             Type Stuff                                 ;;;;
746;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
747
748
749
750(defvar *objc-message-info* (make-hash-table :test #'equal :size 800))
751
752(defun result-type-requires-structure-return (result-type)
753  ;; Use objc-msg-send-stret for all methods that return
754  ;; record types.
755  (or (typep result-type 'foreign-record-type)
756      (and (not (typep result-type 'foreign-type))
757           (typep (parse-foreign-type result-type) 'foreign-record-type))))
758
759(defvar *objc-method-signatures* (make-hash-table :test #'equal))
760
761(defstruct objc-method-signature-info
762  type-signature
763  function
764  super-function)
765
766(defun objc-method-signature-info (sig)
767  (values
768   (or (gethash sig *objc-method-signatures*)
769       (setf (gethash sig *objc-method-signatures*)
770             (make-objc-method-signature-info
771              :type-signature sig
772              :function (compile-send-function-for-signature  sig)
773              :super-function (%compile-send-function-for-signature  sig t))))))
774
775(defmethod make-load-form ((siginfo objc-method-signature-info) &optional env)
776  (declare (ignore env))
777  `(objc-method-signature-info ',(objc-method-signature-info-type-signature siginfo)))
778
779(defun concise-foreign-type (ftype)
780  (if (typep ftype 'foreign-record-type)
781    (let* ((name (foreign-record-type-name ftype)))
782      (if name
783        `(,(foreign-record-type-kind ftype) ,name)
784        (unparse-foreign-type ftype)))
785    (if (objc-id-type-p ftype)
786      :id
787      (if (typep ftype 'foreign-pointer-type)
788        (let* ((to (foreign-pointer-type-to ftype)))
789          (if (null to)
790            '(:* :void)
791            `(:* ,(concise-foreign-type to))))
792        (if (typep ftype 'foreign-type)
793          (unparse-foreign-type ftype)
794          ftype)))))
795
796
797;;; Not a perfect mechanism.
798(defclass objc-dispatch-function (funcallable-standard-object)
799    ()
800  (:metaclass funcallable-standard-class))
801
802(defmethod print-object ((o objc-dispatch-function) stream)
803  (print-unreadable-object (o stream :type t :identity t)
804    (let* ((name (function-name o)))
805      (when name
806        (format stream "~s" name)))))
807
808
809
810
811(declaim (inline check-receiver))
812
813;;; Return a NULL pointer if RECEIVER is a null pointer.
814;;; Otherwise, insist that it's an ObjC object of some sort, and return NIL.
815(defun check-receiver (receiver)
816  (if (%null-ptr-p receiver)
817    (%null-ptr)
818    (let* ((domain (%macptr-domain receiver))
819           (valid (eql domain *objc-object-domain*)))
820      (declare (fixnum domain))
821      (when (zerop domain)
822        (if (recognize-objc-object receiver)
823          (progn (%set-macptr-domain receiver *objc-object-domain*)
824                 (setq valid t))))
825      (unless valid
826        (report-bad-arg receiver 'objc:objc-object)))))
827
828(defmethod shared-initialize :after ((gf objc-dispatch-function) slot-names &key message-info &allow-other-keys)
829  (declare (ignore slot-names))
830  (with-slots (name) gf
831    (if message-info
832      (let* ((ambiguous-methods (getf (objc-message-info-flags message-info) :ambiguous))
833             (selector (objc-message-info-selector message-info))
834             (first-method (car (objc-message-info-methods message-info))))
835        (lfun-bits gf (dpb (1+ (objc-message-info-req-args message-info))
836                           $lfbits-numreq
837                           (logior (ash
838                                    (if (getf (objc-message-info-flags message-info)
839                                              :accepts-varargs)
840                                      1
841                                      0)
842                                    $lfbits-rest-bit)
843                                   (logandc2 (lfun-bits gf) (ash 1 $lfbits-aok-bit)))))
844        (flet ((signature-function-for-method (m)
845                 (let* ((signature-info (objc-method-info-signature-info m)))
846                   (or (objc-method-signature-info-function signature-info)
847                       (setf (objc-method-signature-info-function signature-info)
848                             (compile-send-function-for-signature
849                              (objc-method-signature-info-type-signature signature-info)))))))
850          (if (null ambiguous-methods)
851            ;; Pick an arbitrary method, since all methods have the same
852            ;; signature.
853            (set-funcallable-instance-function
854             gf
855             (compile-named-function 
856              `(lambda (receiver &rest args)
857                (declare (dynamic-extent args))
858                (or (check-receiver receiver)
859                 (with-ns-exceptions-as-errors 
860                     (apply (objc-method-signature-info-function
861                             (load-time-value                               
862                              (objc-method-info-signature-info ,first-method)))
863                            receiver ,selector args))))
864              :name `(:objc-dispatch ,name)))
865            (let* ((protocol-pairs (mapcar #'(lambda (pm)
866                                               (cons (lookup-objc-protocol
867                                                      (objc-method-info-class-name pm))
868                                                     (objc-method-info-signature-info
869                                                      pm)))
870                                           (objc-message-info-protocol-methods message-info)))
871                   (method-pairs (mapcar #'(lambda (group)
872                                             (cons (mapcar #'(lambda (m)
873                                                               (get-objc-method-info-class m))
874                                                           group)
875                                                   (objc-method-info-signature-info (car group))))
876                                         (objc-message-info-ambiguous-methods message-info)))
877                   (default-function-info (if method-pairs
878                                            (prog1 (cdar (last method-pairs))
879                                              (setq method-pairs (nbutlast method-pairs)))
880                                            (prog1 (cdr (last protocol-pairs))
881                                              (setq protocol-pairs (nbutlast protocol-pairs))))))
882              (set-funcallable-instance-function
883               gf
884               (compile-named-function
885                `(lambda (receiver &rest args)
886                  (declare (dynamic-extent args))
887                  (or (check-receiver receiver)
888                   (let* ((function
889                           (objc-method-signature-info-function 
890                            (or (dolist (pair ',protocol-pairs)
891                                  (when (conforms-to-protocol receiver (car pair))
892                                    (return (cdr pair))))
893                                (block m
894                                  (dolist (pair ',method-pairs ,default-function-info)
895                                    (dolist (class (car pair))
896                                      (when (typep receiver class)
897                                        (return-from m (cdr pair))))))))))
898                     (with-ns-exceptions-as-errors
899                         (apply function receiver ,selector args)))))
900                :name `(:objc-dispatch ,name)))))))
901      (set-funcallable-instance-function
902       gf
903       #'(lambda (&rest args)
904           (error "Unknown ObjC message ~a called with arguments ~s"
905                  (symbol-name name) args))))))
906                                             
907
908(defun %call-next-objc-method (self class selector sig &rest args)
909  (declare (dynamic-extent args))
910  (rlet ((s :objc_super #+(or apple-objc cocotron-objc) :receiver #+gnu-objc :self self
911            #+(or apple-objc-2.0 cocotron-objc)  :super_class #-(or apple-objc-2.0 cocotron-objc) :class
912            #+(or apple-objc-2.0 cocotron-objc) (#_class_getSuperclass class)
913            #-(or apple-objc-2.0 cocotron-objc) (pref class :objc_class.super_class)))
914    (let* ((siginfo (objc-method-signature-info sig))
915           (function (or (objc-method-signature-info-super-function siginfo)
916                         (setf (objc-method-signature-info-super-function siginfo)
917                               (%compile-send-function-for-signature sig t)))))
918      (with-ns-exceptions-as-errors
919          (apply function s selector args)))))
920
921
922(defun %call-next-objc-class-method (self class selector sig &rest args)
923  (rlet ((s :objc_super #+(or apple-objc cocotron-objc) :receiver #+gnu-objc :self self
924            #+(or apple-objc-2.0 cocotron-objc) :super_class #-(or apple-objc-2.0 cocotron-objc) :class
925            #+(or apple-objc-2.0 cocotron-objc) (#_class_getSuperclass (pref class :objc_class.isa))
926            #-(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)))
927    (let* ((siginfo (objc-method-signature-info sig))
928           (function (or (objc-method-signature-info-super-function siginfo)
929                         (setf (objc-method-signature-info-super-function siginfo)
930                               (%compile-send-function-for-signature sig t)))))
931      (with-ns-exceptions-as-errors
932          (apply function s selector args)))))
933
934(defun postprocess-objc-message-info (message-info)
935  (let* ((objc-name (objc-message-info-message-name message-info))
936         (lisp-name (or (objc-message-info-lisp-name message-info)
937                        (setf (objc-message-info-lisp-name message-info)
938                              (compute-objc-to-lisp-function-name  objc-name))))
939         (gf (or (fboundp lisp-name)
940                 (setf (fdefinition lisp-name)
941                       (make-instance 'objc-dispatch-function :name lisp-name)))))
942
943    (unless (objc-message-info-selector message-info)
944      (setf (objc-message-info-selector message-info)
945            (ensure-objc-selector (objc-message-info-message-name message-info))))
946   
947    (flet ((reduce-to-ffi-type (ftype)
948             (concise-foreign-type ftype)))
949      (flet ((ensure-method-signature (m)
950               (or (objc-method-info-signature m)
951                   (setf (objc-method-info-signature m)
952                         (let* ((sig 
953                                 (cons (reduce-to-ffi-type
954                                        (objc-method-info-result-type m))
955                                       (mapcar #'reduce-to-ffi-type
956                                               (objc-method-info-arglist m)))))
957                           (setf (objc-method-info-signature-info m)
958                                 (objc-method-signature-info sig))
959                           sig)))))
960        (let* ((methods (objc-message-info-methods message-info))
961               (signatures ())
962               (protocol-methods)
963               (signature-alist ()))
964          (labels ((signatures-equal (xs ys)
965                     (and xs
966                          ys
967                          (do* ((xs xs (cdr xs))
968                                (ys ys (cdr ys)))
969                               ((or (null xs) (null ys))
970                                (and (null xs) (null ys)))
971                            (unless (foreign-type-= (ensure-foreign-type (car xs))
972                                                    (ensure-foreign-type (car ys)))
973                              (return nil))))))
974            (dolist (m methods)
975              (let* ((signature (ensure-method-signature m)))
976                (pushnew signature signatures :test #'signatures-equal)
977                (if (getf (objc-method-info-flags m) :protocol)
978                  (push m protocol-methods)
979                  (let* ((pair (assoc signature signature-alist :test #'signatures-equal)))
980                    (if pair
981                      (push m (cdr pair))
982                      (push (cons signature (list m)) signature-alist)))))))
983          (setf (objc-message-info-ambiguous-methods message-info)
984                (mapcar #'cdr
985                        (sort signature-alist
986                              #'(lambda (x y)
987                                  (< (length (cdr x))
988                                     (length (cdr y)))))))
989          (setf (objc-message-info-flags message-info) nil)
990          (setf (objc-message-info-protocol-methods message-info)
991                protocol-methods)
992          (when (cdr signatures)
993            (setf (getf (objc-message-info-flags message-info) :ambiguous) t))
994          (let* ((first-method (car methods))
995                 (first-sig (objc-method-info-signature first-method))
996                 (first-sig-len (length first-sig)))
997            (setf (objc-message-info-req-args message-info)
998                  (1- first-sig-len))
999            ;; Whether some arg/result types vary or not, we want to insist
1000            ;; on (a) either no methods take a variable number of arguments,
1001            ;; or all do, and (b) either no method uses structure-return
1002            ;; conventions, or all do. (It's not clear that these restrictions
1003            ;; are entirely reasonable in the long run; in the short term,
1004            ;; they'll help get things working.)
1005            (flet ((method-returns-structure (m)
1006                     (result-type-requires-structure-return
1007                      (objc-method-info-result-type m)))
1008                   (method-accepts-varargs (m)
1009                     (eq (car (last (objc-method-info-arglist m)))
1010                         *void-foreign-type*))
1011                   (method-has-structure-arg (m)
1012                     (dolist (arg (objc-method-info-arglist m))
1013                       (when (typep (ensure-foreign-type arg) 'foreign-record-type)
1014                         (return t)))))
1015              (when (dolist (method methods)
1016                      (when (method-has-structure-arg method)
1017                        (return t)))
1018                (setf (compiler-macro-function lisp-name)
1019                      'hoist-struct-constructors))
1020              (let* ((first-result-is-structure (method-returns-structure first-method))
1021                     (first-accepts-varargs (method-accepts-varargs first-method)))
1022                (if (dolist (m (cdr methods) t)
1023                      (unless (eq (method-returns-structure m)
1024                                  first-result-is-structure)
1025                        (return nil)))
1026                  (if first-result-is-structure
1027                    (setf (getf (objc-message-info-flags message-info)
1028                                :returns-structure) t)))
1029                (if (dolist (m (cdr methods) t)
1030                      (unless (eq (method-accepts-varargs m)
1031                                  first-accepts-varargs)
1032                        (return nil)))
1033                  (if first-accepts-varargs
1034                    (progn
1035                      (setf (getf (objc-message-info-flags message-info)
1036                                  :accepts-varargs) t)
1037                      (decf (objc-message-info-req-args message-info)))))))))
1038        (reinitialize-instance gf :message-info message-info)))))
1039         
1040;;; -may- need to invalidate cached info whenever new interface files
1041;;; are made accessible.  Probably the right thing to do is to insist
1042;;; that (known) message signatures be updated in that case.
1043(defun get-objc-message-info (message-name &optional (use-database t))
1044  (setq message-name (string message-name))
1045  (or (gethash message-name *objc-message-info*)
1046      (and use-database
1047           (let* ((info (lookup-objc-message-info message-name)))
1048             (when info
1049               (setf (gethash message-name *objc-message-info*) info)
1050               (postprocess-objc-message-info info)
1051               info)))))
1052
1053(defun need-objc-message-info (message-name)
1054  (or (get-objc-message-info message-name)
1055      (error "Undeclared message: ~s" message-name)))
1056
1057;;; Should be called after using new interfaces that may define
1058;;; new methods on existing messages.
1059(defun update-objc-method-info ()
1060  (maphash #'(lambda (message-name info)
1061               (lookup-objc-message-info message-name info)
1062               (postprocess-objc-message-info info))
1063           *objc-message-info*))
1064
1065
1066;;; Of the method declarations (OBJC-METHOD-INFO structures) associated
1067;;; with the message-declaration (OBJC-MESSAGE-INFO structure) M,
1068;;; return the one that seems to be applicable for the object O.
1069;;; (If there's no ambiguity among the declared methods, any method
1070;;; will do; this just tells runtime %SEND functions how to compose
1071;;; an %FF-CALL).
1072(defun %lookup-objc-method-info (m o)
1073  (let* ((methods (objc-message-info-methods m))
1074         (ambiguous (getf (objc-message-info-flags m) :ambiguous)))
1075    (if (not ambiguous)
1076      (car methods)
1077      (or 
1078       (dolist (method methods)
1079         (let* ((mclass (get-objc-method-info-class method)))
1080           (if (typep o mclass)
1081             (return method))))
1082       (error "Can't determine ObjC method type signature for message ~s, object ~s" (objc-message-info-message-name m) o)))))
1083
1084(defun resolve-existing-objc-method-info (message-info class-name class-p result-type args)
1085  (let* ((method-info (dolist (m (objc-message-info-methods message-info))
1086                        (when (and (eq (getf (objc-method-info-flags m) :class-p)
1087                                       class-p)
1088                                   (equal (objc-method-info-class-name m)
1089                                          class-name))
1090                          (return m)))))
1091    (when method-info
1092      (unless (and (foreign-type-= (ensure-foreign-type (objc-method-info-result-type method-info))
1093                                   (parse-foreign-type result-type))
1094                   (do* ((existing (objc-method-info-arglist method-info) (cdr existing))
1095                         (proposed args (cdr proposed)))
1096                        ((null existing) (null proposed))
1097                     (unless (foreign-type-= (ensure-foreign-type (car existing))
1098                                             (parse-foreign-type (car proposed)))
1099                       (return nil))))
1100        (cerror "Redefine existing method to have new type signature."
1101                "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))
1102        (setf (objc-method-info-arglist method-info) args
1103              (objc-method-info-result-type method-info) result-type
1104              (objc-method-info-signature method-info) nil
1105              (objc-method-info-signature-info method-info) nil))
1106      method-info)))
1107
1108(defvar *objc-verbose* nil)
1109
1110;;; Still not right; we have to worry about type conflicts with
1111;;; shadowed methods, as well.
1112(defun %declare-objc-method (message-name class-name class-p result-type args)
1113  (let* ((info (get-objc-message-info message-name)))
1114    (unless info
1115      (when (or *objc-verbose* *compile-print*)
1116        (format *error-output* "~&; Note: defining new ObjC message ~c[~a ~a]" (if class-p #\+ #\-) class-name message-name))
1117      (setq info (make-objc-message-info :message-name message-name))
1118      (setf (gethash message-name *objc-message-info*) info))
1119    (let* ((was-ambiguous (getf (objc-message-info-flags info) :ambiguous))
1120           (method-info (or (resolve-existing-objc-method-info info class-name class-p result-type args)
1121                            (make-objc-method-info :message-info info
1122                                                   :class-name class-name
1123                                                   :result-type result-type
1124                                                   :arglist args
1125                                                   :flags (if class-p '(:class t))))))
1126      (pushnew method-info (objc-message-info-methods info))
1127      (postprocess-objc-message-info info)
1128      (if (and (getf (objc-message-info-flags info) :ambiguous)
1129               (not was-ambiguous))
1130        (warn "previously declared methods on ~s all had the same type signature, but ~s introduces ambiguity" message-name method-info))
1131      (when (string= message-name "init" :end1 (min 4 (length message-name)))
1132        (process-init-message info))
1133      (objc-method-info-signature method-info))))
1134
1135
1136
1137;;; TRANSLATE-FOREIGN-ARG-TYPE doesn't accept :VOID
1138
1139(defun translate-foreign-result-type (ftype)
1140  (ensure-foreign-type-bits (parse-foreign-type ftype))
1141  (if (eq ftype :void)
1142    :void
1143    (translate-foreign-arg-type ftype)))
1144
1145
1146
1147
1148
1149;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1150;;;;                        Invoking ObjC Methods                           ;;;;
1151;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1152
1153
1154;;; The SEND and SEND/STRET macros
1155
1156(defmacro send (o msg &rest args &environment env)
1157  (make-optimized-send o msg args env))
1158
1159(defmacro send/stret (s o msg &rest args &environment env)
1160  (make-optimized-send o msg args env s))
1161
1162
1163
1164
1165;;; Optimize special cases of SEND and SEND/STRET
1166
1167(defun make-optimized-send (o msg args env  &optional s super sclassname)
1168  (multiple-value-bind (msg args vargs) (parse-message (cons msg args))
1169    (let* ((message-info (get-objc-message-info msg)))
1170      (if (null message-info)
1171        (error "Unknown message: ~S" msg))
1172      ;; If a vararg exists, make sure that the message can accept it
1173      (when (and vargs (not (getf (objc-message-info-flags message-info)
1174                                  :accepts-varargs)))
1175        (error "Message ~S cannot accept a variable number of arguments" msg))
1176      (unless (= (length args) (objc-message-info-req-args message-info))
1177        (error "Message ~S requires ~a ~d args, but ~d were provided."
1178               msg
1179               (if vargs "at least" "exactly")
1180               (objc-message-info-req-args message-info)
1181               (length args)))
1182      (multiple-value-bind (args svarforms sinitforms) (sletify-message-args args)
1183        (let* ((ambiguous (getf (objc-message-info-flags message-info) :ambiguous))
1184               (methods (objc-message-info-methods message-info))
1185               (method (if (not ambiguous) (car methods))))
1186          (when ambiguous
1187            (let* ((class (if sclassname 
1188                            (find-objc-class sclassname)
1189                            (get-objc-class-from-declaration (declared-type o env)))))
1190              (if class
1191                (dolist (m methods)
1192                  (unless (getf (objc-method-info-flags m) :protocol)
1193                    (let* ((mclass (or (get-objc-method-info-class m)
1194                                       (error "Can't find ObjC class named ~s"
1195                                              (objc-method-info-class-name m)))))
1196                      (when (and class (subtypep class mclass))
1197                        (return (setq method m)))))))))
1198          (if method
1199            (build-call-from-method-info method
1200                                         args
1201                                         vargs
1202                                         o
1203                                         msg
1204                                         svarforms
1205                                         sinitforms
1206                                         s
1207                                         super)
1208            (build-ambiguous-send-form message-info
1209                                       args
1210                                       vargs
1211                                       o
1212                                       msg
1213                                       svarforms
1214                                       sinitforms
1215                                       s
1216                                       super)))))))
1217
1218   
1219;;; WITH-NS-EXCEPTIONS-AS-ERRORS is only available in OpenMCL 0.14 and above
1220
1221#-openmcl-native-threads
1222(defmacro with-ns-exceptions-as-errors (&body body)
1223  `(progn ,@body))
1224
1225
1226;;; Return a call to the method specified by SEL on object O, with the args
1227;;; specified by ARGSPECS.  This decides whether a normal or stret call is
1228;;; needed and, if the latter, uses the memory S to hold the result. If SUPER
1229;;; is nonNIL, then this builds a send to super.  Finally, this also
1230;;; coerces return #$YES/#$NO values to T/NIL. The entire call takes place
1231;;; inside an implicit SLET.
1232
1233(defun build-call (o sel msg argspecs svarforms sinitforms &optional s super)
1234  `(with-ns-exceptions-as-errors
1235     (rlet ,svarforms
1236       ,@sinitforms
1237       ,(let ((rspec (first (last argspecs))))
1238          (if (requires-stret-p rspec)
1239            (if (null s)
1240              ;; STRET required but not provided
1241              (error "The message ~S must be sent using SEND/STRET" msg)
1242              ;; STRET required and provided, use stret send
1243              (if (null super)
1244                ;; Regular stret send
1245                `(progn
1246                   (objc-message-send-stret ,s ,o ,(cadr sel)
1247                    ,@(append (butlast argspecs) (list :void)))
1248                   ,s)
1249                ;; Super stret send
1250                `(progn
1251                   (objc-message-send-super-stret ,s ,super ,(cadr sel)
1252                    ,@(append (butlast argspecs) (list :void)))
1253                   ,s)))
1254            (if (null s)
1255              ;; STRET not required and not provided, use send
1256              (if (null super)
1257                ;; Regular send
1258                (if (eq rspec :<BOOL>)
1259                  `(coerce-from-bool
1260                    (objc-message-send ,o ,(cadr sel) ,@argspecs))
1261                  `(objc-message-send ,o ,(cadr sel) ,@argspecs))
1262                ;; Super send
1263                (if (eq rspec :<BOOL>)
1264                  `(coerce-from-bool
1265                    (objc-message-send-super ,super ,(cadr sel) ,@argspecs))
1266                  `(objc-message-send-super ,super ,(cadr sel) ,@argspecs)))
1267              ;; STRET not required but provided
1268              (error "The message ~S must be sent using SEND" msg)))))))
1269
1270(defun objc-id-type-p (foreign-type)
1271  (and (typep foreign-type 'foreign-pointer-type)
1272       (let* ((to (foreign-pointer-type-to foreign-type)))
1273         (and (typep to 'foreign-record-type)
1274              (eq :struct (foreign-record-type-kind to))
1275              (not (null (progn (ensure-foreign-type-bits to) (foreign-record-type-fields to))))
1276              (let* ((target (foreign-record-field-type (car (foreign-record-type-fields to)))))
1277                (and (typep target 'foreign-pointer-type)
1278                     (let* ((target-to (foreign-pointer-type-to target)))
1279                       (and (typep target-to 'foreign-record-type)
1280                            (eq :struct (foreign-record-type-kind target-to))
1281                            (eq :objc_class (foreign-record-type-name target-to))))))))))
1282
1283(defun unique-objc-classes-in-method-info-list (method-info-list)
1284  (if (cdr method-info-list)                     ; if more than 1 class
1285    (flet ((subclass-of-some-other-class (c)
1286             (let* ((c-class (get-objc-method-info-class c)))
1287               (dolist (other method-info-list)
1288                 (unless (eq other c)
1289                   (when (subtypep c-class (get-objc-method-info-class other))
1290                   (return t)))))))
1291      (remove-if #'subclass-of-some-other-class method-info-list))
1292    method-info-list))
1293 
1294(defun get-objc-method-info-class (method-info)
1295  (or (objc-method-info-class-pointer method-info)
1296      (setf (objc-method-info-class-pointer method-info)
1297            (let* ((c (lookup-objc-class (objc-method-info-class-name method-info) nil)))
1298              (when c
1299                (let* ((meta-p (getf (objc-method-info-flags method-info) :class)))
1300                  (if meta-p
1301                    (with-macptrs ((m (pref c :objc_class.isa)))
1302                      (canonicalize-registered-metaclass m))
1303                    (canonicalize-registered-class c))))))))
1304
1305;;; Generate some sort of CASE or COND to handle an ambiguous message
1306;;; send (where the signature of the FF-CALL depends on the type of the
1307;;; receiver.)
1308;;; AMBIGUOUS-METHODS is a list of lists of OBJC-METHOD-INFO structures,
1309;;; where the methods in each sublist share the same type signature.  It's
1310;;; sorted so that more unique method/signature combinations appear first
1311;;; (and are easier to special-case via TYPECASE.)
1312(defun build-send-case (ambiguous-methods
1313                        args
1314                        vargs
1315                        receiver
1316                        msg
1317                        s
1318                        super
1319                        protocol-methods)
1320  (flet ((method-class-name (m)
1321           (let* ((mclass (get-objc-method-info-class m)))
1322             (unless mclass
1323               (error "Can't find class with ObjC name ~s"
1324                      (objc-method-info-class-name m)))
1325             (class-name mclass))))
1326
1327    (collect ((clauses))
1328      (let* ((protocol (gensym))
1329             (protocol-address (gensym)))
1330        (dolist (method protocol-methods)
1331          (let* ((protocol-name (objc-method-info-class-name method)))
1332            (clauses `((let* ((,protocol (lookup-objc-protocol ,protocol-name))
1333                              (,protocol-address (and ,protocol (objc-protocol-address ,protocol))))
1334                         (and ,protocol-address
1335                              (objc-message-send ,receiver
1336                                                 "conformsToProtocol:"
1337                                                 :address ,protocol-address
1338                                                 :<BOOL>)))
1339                       ,(build-internal-call-from-method-info
1340                         method args vargs receiver msg s super))))))
1341      (do* ((methods ambiguous-methods (cdr methods)))
1342           ((null (cdr methods))
1343            (when ambiguous-methods
1344              (clauses `(t
1345                         ,(build-internal-call-from-method-info
1346                           (caar methods) args vargs receiver msg s super)))))
1347        (clauses `(,(if (cdar methods)
1348                        `(or ,@(mapcar #'(lambda (m)
1349                                           `(typep ,receiver
1350                                             ',(method-class-name m)))
1351                                       (unique-objc-classes-in-method-info-list
1352                                        (car methods))))
1353                        `(typep ,receiver ',(method-class-name (caar methods))))
1354                   ,(build-internal-call-from-method-info
1355                     (caar methods) args vargs receiver msg s super))))
1356      `(cond
1357        ,@(clauses)))))
1358
1359(defun build-ambiguous-send-form (message-info args vargs o msg svarforms sinitforms s super)
1360  (let* ((receiver (gensym))
1361         (caseform (build-send-case
1362                    (objc-message-info-ambiguous-methods message-info)
1363                    args
1364                    vargs
1365                    receiver
1366                    msg
1367                    s
1368                    super
1369                    (objc-message-info-protocol-methods message-info))))
1370    `(with-ns-exceptions-as-errors
1371      (rlet ,svarforms
1372        ,@sinitforms
1373        (let* ((,receiver ,o))
1374          ,caseform)))))
1375
1376
1377;;; Generate the "internal" part of a method call; the "external" part
1378;;; has established ObjC exception handling and handled structure-return
1379;;  details
1380(defun build-internal-call-from-method-info (method-info args vargs o msg s super)
1381  (let* ((arglist ()))
1382    (collect ((specs))
1383      (do* ((args args (cdr args))
1384            (argtypes (objc-method-info-arglist method-info) (cdr argtypes))
1385            (reptypes (cdr (objc-method-info-signature method-info)) (cdr reptypes)))
1386           ((null args) (setq arglist (append (specs) vargs)))
1387        (let* ((reptype (if (objc-id-type-p (car argtypes)) :id (car reptypes)))
1388               (arg (car args)))
1389          (specs reptype)
1390          (specs arg)))
1391      ;;(break "~& arglist = ~s" arglist)
1392      (if (result-type-requires-structure-return
1393           (objc-method-info-result-type method-info))
1394        (if (null s)
1395          ;; STRET required but not provided
1396          (error "The message ~S must be sent using SEND/STRET" msg)
1397          (if (null super)
1398            `(objc-message-send-stret ,s ,o ,msg ,@arglist ,(car (objc-method-info-signature method-info)))
1399            `(objc-message-send-super-stret ,s ,super ,msg ,@arglist ,(car (objc-method-info-signature method-info)))))
1400        (if s
1401          ;; STRET provided but not required
1402          (error "The message ~S must be sent using SEND" msg)
1403          (let* ((result-spec (car (objc-method-info-signature method-info)))
1404                 (form (if super
1405                         `(objc-message-send-super ,super ,msg ,@arglist ,result-spec)
1406                         `(objc-message-send ,o ,msg ,@arglist ,result-spec))))
1407            form))))))
1408 
1409(defun build-call-from-method-info (method-info args vargs o  msg  svarforms sinitforms s super)
1410  `(with-ns-exceptions-as-errors
1411    (rlet ,svarforms
1412      ,@sinitforms
1413      ,(build-internal-call-from-method-info
1414        method-info
1415        args
1416        vargs
1417        o
1418        msg
1419        s
1420        super))))
1421
1422 
1423
1424;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1425;;;;                       Instantiating ObjC Class                         ;;;;
1426;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1427
1428;;; A MAKE-INSTANCE like interface to ObjC object creation
1429
1430(defun make-objc-instance (cname &rest initargs)
1431  (declare (dynamic-extent initargs))
1432  (multiple-value-bind (ks vs) (keys-and-vals initargs)
1433    (declare (dynamic-extent ks vs))
1434    (let* ((class (etypecase cname
1435                    (string (canonicalize-registered-class 
1436                             (find-objc-class cname)))
1437                    (symbol (find-class cname))
1438                    (class cname))))
1439      (send-objc-init-message (#/alloc class) ks vs))))
1440
1441
1442
1443
1444
1445
1446;;; Provide the BRIDGE module
1447
1448(provide "BRIDGE")
Note: See TracBrowser for help on using the repository browser.