Changeset 6229


Ignore:
Timestamp:
Apr 8, 2007, 5:02:35 PM (12 years ago)
Author:
gb
Message:

Define CGFLOAT, ObjC-2 foreign types here.

Define "foreign struct classes" for several common structure types
(rectangle, point, size); generate inlined accessors for their
slots, PRINT-OBJECT methods, initialization functions, WITH-xxx macros.

#/ reader macro: reads a string containing "constituent" characters
(including #\:), preserving case. Does a little bit of sanity-checking
on it, then interns it in NEXTSTEP-FUNCTIONS package.

Try to deal with cases where foreign type info may be parsed or
unparsed.

Introduce OBJC-DISPATCH-FUNCTIONs, which are funcallable instances.
SHARED-INITIALIZE :AFTER method on OBJC-DISPATCH-FUNCTION looks
at message info, tries to determine ambiguity, calls signature
function (possibly after trying to resolve ambiguity.)

%CALL-NEXT-OBJC-METHOD does some of the same stuff at runtime,
calling a signature function that knows how to dispatch to
SUPER method. (Likewise, %CALL-NEXT-OBJC-CLASS-METHOD for class
methods.)

POSTPROCESS-OBJC-MESSAGE-INFO (re-) initializes the associated
OBJC-DISPATCH-FUNCTION.

Handle PROTOCOLs differently in ambiguous SEND.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/examples/bridge.lisp

    r5939 r6229  
    2323(require "OBJC-RUNTIME")
    2424(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
    25358
    26359;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    282615                        (car (objc-message-info-methods info)))))
    283616           (if (getf (objc-message-info-flags info) :returns-structure)
    284              (values `(,var ,(unparse-foreign-type rtype))
     617             (values `(,var ,(if (typep rtype 'foreign-type)
     618                                 (unparse-foreign-type rtype)
     619                                 rtype))
    285620                     `(send/stret ,var ,@(rest form)))
    286621             (if errorp
     
    294629                        (car (objc-message-info-methods info)))))
    295630           (if (getf (objc-message-info-flags info) :returns-structure)
    296              (values `(,var ,(unparse-foreign-type rtype))
     631             (values `(,var ,(if (typep rtype 'foreign-type)
     632                                 (unparse-foreign-type rtype)
     633                                 rtype))
    297634                     `(send-super/stret ,var ,@(rest form)))
    298635             (if errorp
     
    364701  ;; Use objc-msg-send-stret for all methods that return
    365702  ;; record types.
    366   (typep result-type 'foreign-record-type))
     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)))))
    367871
    368872(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   
    369885  (flet ((reduce-to-ffi-type (ftype)
    370            (if (objc-id-type-p ftype)
    371              :id
    372              (unparse-foreign-type ftype))))
     886           (concise-foreign-type ftype)))
    373887    (flet ((ensure-method-signature (m)
    374888             (or (objc-method-info-signature m)
    375889                 (setf (objc-method-info-signature m)
    376                        (cons (reduce-to-ffi-type
    377                               (objc-method-info-result-type m))
    378                              (mapcar #'reduce-to-ffi-type
    379                                      (objc-method-info-arglist 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)))))
    380898      (let* ((methods (objc-message-info-methods message-info))
    381899             (signatures ())
    382900             (protocol-methods)
    383901             (signature-alist ()))
    384         (dolist (m methods)
    385           (let* ((signature (ensure-method-signature m)))
    386             (pushnew signature signatures :test #'equal)
     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)
    387914            (if (getf (objc-method-info-flags m) :protocol)
    388915              (push m protocol-methods)
    389               (let* ((pair (assoc signature signature-alist :test #'equal)))
     916              (let* ((pair (assoc signature signature-alist :test #'signatures-equal)))
    390917                (if pair
    391918                  (push m (cdr pair))
    392                   (push (cons signature (list m)) signature-alist))))))
     919                  (push (cons signature (list m)) signature-alist)))))))
    393920        (setf (objc-message-info-ambiguous-methods message-info)
    394921              (mapcar #'cdr
     
    436963                    (setf (getf (objc-message-info-flags message-info)
    437964                                :accepts-varargs) t)
    438                     (decf (objc-message-info-req-args message-info))))))))))))
     965                    (decf (objc-message-info-req-args message-info)))))))))
     966      (reinitialize-instance gf :message-info message-info)))))
    439967         
    440968;;; -may- need to invalidate cached info whenever new interface files
    441969;;; are made accessible.  Probably the right thing to do is to insist
    442970;;; that (known) message signatures be updated in that case.
    443 (defun get-objc-message-info (message-name)
     971(defun get-objc-message-info (message-name &optional (use-database t))
     972  (setq message-name (string message-name))
    444973  (or (gethash message-name *objc-message-info*)
    445       (let* ((info (lookup-objc-message-info message-name)))
    446         (when info
    447           (setf (gethash message-name *objc-message-info*) info)
    448           (postprocess-objc-message-info info)
    449           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)))))
    450980
    451981(defun need-objc-message-info (message-name)
     
    465995;;; with the message-declaration (OBJC-MESSAGE-INFO structure) M,
    466996;;; return the one that seems to be applicable for the object O.
    467 ;;; (If there's no ambiguity among the declare methods, any method
     997;;; (If there's no ambiguity among the declared methods, any method
    468998;;; will do; this just tells runtime %SEND functions how to compose
    469999;;; an %FF-CALL).
     
    4801010       (error "Can't determine ObjC method type signature for message ~s, object ~s" (objc-message-info-message-name m) o)))))
    4811011
     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.
    4821038(defun %declare-objc-method (message-name class-name class-p result-type args)
    4831039  (let* ((info (get-objc-message-info message-name)))
    4841040    (unless info
     1041      (format *error-output* "~&; Note: defining new ObjC message ~c[~a ~a]" (if class-p #\+ #\-) class-name message-name)
    4851042      (setq info (make-objc-message-info :message-name message-name))
    4861043      (setf (gethash message-name *objc-message-info*) info))
    4871044    (let* ((was-ambiguous (getf (objc-message-info-flags info) :ambiguous))
    488            (method-info (make-objc-method-info :message-info info
    489                                                :class-name class-name
    490                                                :result-type result-type
    491                                                :arglist args
    492                                                :flags (if class-p '(:class t)))))
    493       (push method-info (objc-message-info-methods info))
     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))
    4941052      (postprocess-objc-message-info info)
    4951053      (if (and (getf (objc-message-info-flags info) :ambiguous)
    4961054               (not was-ambiguous))
    4971055        (warn "previously declared methods on ~s all had the same type signature, but ~s introduces ambiguity" message-name method-info))
    498       info)))
     1056           
     1057      (objc-method-info-signature method-info))))
    4991058
    5001059
     
    6891248                      (objc-method-info-class-name m)))
    6901249             (class-name mclass))))
     1250
    6911251    (collect ((clauses))
    692       (let* ((protocol (gensym)))
     1252      (let* ((protocol (gensym))
     1253             (protocol-address (gensym)))
    6931254        (dolist (method protocol-methods)
    6941255          (let* ((protocol-name (objc-method-info-class-name method)))
    695             (clauses `((let* ((,protocol (lookup-objc-protocol ,protocol-name)))
    696                          (and ,protocol
    697                               (not (zerop (objc-message-send ,receiver
    698                                                              "conformsToProtocol:"
    699                                                              :address ,protocol
    700                                                              :<BOOL>)))))
     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>)))
    7011263                       ,(build-internal-call-from-method-info
    7021264                         method args vargs receiver msg s super))))))
     
    7041266           ((null (cdr methods))
    7051267            (when ambiguous-methods
    706             (clauses `(t
    707                        ,(build-internal-call-from-method-info
    708                          (caar methods) args vargs receiver msg s super)))))
     1268              (clauses `(t
     1269                         ,(build-internal-call-from-method-info
     1270                           (caar methods) args vargs receiver msg s super)))))
    7091271        (clauses `(,(if (cdar methods)
    7101272                        `(or ,@(mapcar #'(lambda (m)
     
    7941356  (multiple-value-bind (ks vs) (keys-and-vals initargs)
    7951357    (declare (dynamic-extent ks vs))
    796     (when (not (stringp cname))
    797       (setf cname (lisp-to-objc-classname cname)))
    798     (send-objc-init-message (send (find-objc-class cname) 'alloc)
    799                             ks
    800                             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))))
    8011364
    8021365;;; Provide the BRIDGE module
Note: See TracChangeset for help on using the changeset viewer.