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

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

Use MAKE-INSTANCE vice MAKE-OBJC-INSTANCE in example code.
Try to avoid SLET, SEND, DEFINE-OBJC-METHOD.
Demo IDE "works" (modulo backtrace) on x86-64 Leopard, bridge
still needs work on PPC.

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