source: release/1.2/source/objc-bridge/bridge.lisp @ 11561

Last change on this file since 11561 was 11561, checked in by gb, 11 years ago

Propagate r11216 to 1.2.

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