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

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

Define NS:WITH-... macros for typed foreign structs.

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