Changeset 6056


Ignore:
Timestamp:
Mar 18, 2007, 2:11:57 AM (13 years ago)
Author:
gb
Message:

Use FOREIGN-STRUCT-ENCPSULATIONs, which were probably a bad idea.
(Will use typed MACPTRs instead, after this code is checked in.)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/objc-gf/ccl/examples/bridge.lisp

    r5939 r6056  
    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
     52;;; Associate foreign structure types with lisp structure types
     53(defstruct foreign-struct-association
     54  import-function                       ; set lisp struct from foreign
     55  export-function                       ; set foreign struct from lisp
     56  return-function                       ; create lisp struct from foreign
     57  type-predicate                        ; sanity check
     58  )
     59
     60(defparameter *foreign-struct-associations* (make-hash-table :test #'equalp))
     61
     62(defun create-foreign-struct-association (foreign-structure-type import export return type-predicate)
     63  (setf (gethash foreign-structure-type *foreign-struct-associations*)
     64        (make-foreign-struct-association :import-function import
     65                                         :export-function export
     66                                         :return-function return
     67                                         :type-predicate type-predicate)))
     68
     69(defun get-foreign-struct-association (type)
     70  (let* ((ftype (if (typep type 'foreign-record-type)
     71                  type
     72                  (%foreign-type-or-record type))))
     73    (values (gethash ftype *foreign-struct-associations*))))
     74
     75;;; Next, define some lisp structure types that're equivalent to
     76;;; Cocoa/CG foreign structure types that're known to be returned
     77;;; from Cocoa methods and/or passed by value.  We'll need to be
     78;;; able to extend this mechanism to deal with things not used
     79;;; in Foundation/AppKit; hopefully, that process can be automated.
     80
     81;;; There are a bunch of tradeoffs here.  One attractive approach
     82;;; is to simply wrap a lisp DEFSTRUCT around some foreign data
     83;;; and define some lisp-level accessors for that data, allocating
     84;;; the typically small block of data with CCL::%NEW-GCABLE-PTR.
     85;;; When the GC discovers that the pointer to that data is no
     86;;; longer referenced from lisp, the data will be freed (so be
     87;;; careful about cases where foreign code hangs on to pointers
     88;;; it doesn't "own.")  This freeing will typically happen at
     89;;; some point after a full GC discovers that the encapsulating
     90;;; structure has become garbage.  A downside of this scheme is
     91;;; that it's possible to have millions of foreign pointers
     92;;; floating around between full GCs.
     93;;; An upside is that this scheme simplifies cases where
     94;;; structures are passed by reference; another is that it
     95;;; keeps us from having to worry about structure-layout/endianness
     96;;; issues, and a third upside is that it (probably) lends itself
     97;;; better to automation. The upsides seem to win out.
     98
     99(defstruct foreign-struct-encapsulation
     100  data)
     101
     102(defun return-function-for-encapsulation (foreign-size constructor)
     103  #'(lambda (pointer)
     104      (let* ((data (%new-gcable-ptr foreign-size)))
     105        (#_memcpy data pointer foreign-size)
     106        (funcall constructor data))))
     107
     108(defun export-encapsulation (encapsulation pointer)
     109  (%setf-macptr pointer (foreign-struct-encapsulation-data encapsulation)))
     110
     111(defun create-foreign-struct-association-for-encapsulation (foreign-type constructor predicate)
     112  (create-foreign-struct-association
     113   foreign-type
     114   nil
     115   'export-encapsulation
     116   (return-function-for-encapsulation
     117    (%foreign-type-or-record-size foreign-type :bytes) constructor)
     118   predicate))
     119
     120;;; AEDesc (Apple Event Descriptor)
     121
     122(defconstant aedesc-size (%foreign-type-or-record-size :<AED>esc :bytes))
     123
     124(defstruct (aedesc (:include foreign-struct-encapsulation)
     125                   (:constructor %make-aedesc (data))))
     126
     127(defun make-aedesc (descriptor-type data-handle)
     128  (let* ((data (%new-gcable-ptr aedesc-size)))
     129    (setf (pref data :<AED>esc.descriptor<T>ype) descriptor-type
     130          (pref data :<AED>esc.data<H>andle) data-handle)
     131    (%make-aedesc data)))
     132
     133(declaim (inline aedesc-descriptor-type aedesc-data-handle
     134                 (setf aedesc-descriptor-type) (setf aedesc-data-handle)))
     135
     136(defun aedesc-descriptor-type (aedesc)
     137  (pref (aedesc-data aedesc) :<AED>esc.descriptor<T>ype))
     138
     139(defun (setf aedesc-descriptor-type) (new aedesc)
     140  (setf (pref (aedesc-data aedesc) :<AED>esc.descriptor<T>ype) new))
     141
     142(defun aedesc-data-handle (aedesc)
     143  (pref (aedesc-data aedesc) :<AED>esc.data<H>andle))
     144
     145(defun (setf aedesc-data-handle) (new aedesc)
     146  (setf (pref (aedesc-data aedesc) :<AED>esc.data<H>andle) new))
     147
     148(defmethod print-object ((a aedesc) stream)
     149  (print-unreadable-object (a stream :type t :identity t)
     150    (format stream "~s ~s" (aedesc-descriptor-type a) (aedesc-data-handle a))))
     151
     152
     153(create-foreign-struct-association-for-encapsulation
     154 (parse-foreign-type :<AED>esc)
     155 '%make-aedesc
     156 'aedesc-p)
     157
     158#+apple-objc-2.0
     159(progn
     160  ;;; It's not clear how useful this would be; I think that it's
     161  ;;; part of the ObjC 2.0 extensible iteration stuff ("foreach").
     162
     163  (defconstant fast-enumeration-state-size (%foreign-type-or-record-size :<NSF>ast<E>numeration<S>tate :bytes))
     164 
     165  (defstruct (ns-fast-enumeration-state
     166               (:include foreign-struct-encapsulation)
     167               (:constructor %make-ns-fast-enumeration-state (data))))
     168
     169  (defun make-ns-fast-enumeration-state ()
     170    (%make-ns-fast-enumeration-state (%new-gcable-ptr fast-enumeration-state-size  t)))
     171
     172  (create-foreign-struct-association-for-encapsulation
     173   (parse-foreign-type :<NSF>ast<E>numeration<S>tate)
     174   '%make-ns-fast-enumeration-state
     175   'ns-fast-enumeration-state-p)
     176  )
     177
     178;;; CGAffineTransform
     179
     180(defconstant cg-affine-transform-size
     181  (%foreign-type-or-record-size :<CGA>ffine<T>ransform :bytes))
     182
     183(defstruct (cg-affine-transform
     184             (:include foreign-struct-encapsulation)
     185             (:constructor %make-cg-affine-transform (data))))
     186
     187(defun make-cg-affine-transform (a b c d tx ty)
     188  (let* ((data (%new-gcable-ptr cg-affine-transform-size)))
     189    (setf (pref data :<CGA>ffine<T>ransform.a) (float a +cgfloat-zero+)
     190          (pref data :<CGA>ffine<T>ransform.b) (float b +cgfloat-zero+)
     191          (pref data :<CGA>ffine<T>ransform.c) (float c +cgfloat-zero+)
     192          (pref data :<CGA>ffine<T>ransform.d) (float d +cgfloat-zero+)
     193          (pref data :<CGA>ffine<T>ransform.tx) (float tx +cgfloat-zero+)
     194          (pref data :<CGA>ffine<T>ransform.ty) (float ty +cgfloat-zero+))
     195    (%make-cg-affine-transform data)))
     196
     197(declaim (inline cg-affine-transform-a
     198                 cg-affine-transform-b
     199                 cg-affine-transform-c
     200                 cg-affine-transform-d
     201                 cg-affine-transform-tx
     202                 cg-affine-transform-ty
     203                 (setf cg-affine-transform-a)
     204                 (setf cg-affine-transform-b)
     205                 (setf cg-affine-transform-c)
     206                 (setf cg-affine-transform-d)
     207                 (setf cg-affine-transform-tx)
     208                 (setf cg-affine-transform-ty)))
     209
     210(defun cg-affine-transform-a (transform)
     211  (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.a))
     212
     213(defun (setf cg-affine-transform-a) (new transform)
     214  (setf
     215   (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.a)
     216   (float new +cgfloat-zero+)))
     217
     218(defun cg-affine-transform-b (transform)
     219  (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.b))
     220
     221(defun (setf cg-affine-transform-b) (new transform)
     222  (setf
     223  (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.b)
     224   (float new +cgfloat-zero+)))
     225
     226(defun cg-affine-transform-c (transform)
     227  (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.c))
     228
     229(defun (setf cg-affine-transform-c) (new transform)
     230  (setf
     231   (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.c)
     232   (float new +cgfloat-zero+)))
     233
     234(defun cg-affine-transform-d (transform)
     235   (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.d))
     236
     237(defun (setf cg-affine-transform-d) (new transform)
     238  (setf
     239   (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.d)
     240   (float new +cgfloat-zero+)))
     241
     242(defun cg-affine-transform-tx (transform)
     243  (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.tx))
     244
     245(defun (setf cg-affine-transform-tx) (new transform)
     246  (setf
     247  (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.tx)
     248   (float new +cgfloat-zero+)))
     249
     250(defun cg-affine-transform-ty (transform)
     251  (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.ty))
     252
     253(defun (setf cg-affine-transform-ty) (new transform)
     254  (setf
     255   (pref (cg-affine-transform-data transform) :<CGA>ffine<T>ransform.ty)
     256   (float new +cgfloat-zero+)))
     257
     258(defmethod print-object ((transform cg-affine-transform) stream)
     259  (print-unreadable-object (transform stream :type t :identity t)
     260    (format stream "~s ~s ~s ~s ~s ~s"
     261            (cg-affine-transform-a transform)
     262            (cg-affine-transform-b transform)
     263            (cg-affine-transform-c transform)
     264            (cg-affine-transform-d transform)
     265            (cg-affine-transform-tx transform)
     266            (cg-affine-transform-ty transform))))
     267
     268
     269(create-foreign-struct-association-for-encapsulation
     270 (parse-foreign-type '(:struct :<CGA>ffine<T>ransform))
     271 '%make-cg-affine-transform
     272 'cg-affine-transform-p)
     273
     274
     275;;; An <NSA>ffine<T>ransform<S>truct is identical to a
     276;;; (:struct :<GGA>ffine<T>ransform), except for the names of its fields.
     277
     278(create-foreign-struct-association-for-encapsulation
     279 (parse-foreign-type :<NSA>ffine<T>ransform<S>truct)
     280 '%make-cg-affine-transform
     281 'cg-affine-transform-p)
     282
     283;;; NSDecimal
     284
     285(defconstant ns-decimal-size (%foreign-type-or-record-size :<NSD>ecimal :bytes))
     286
     287(defstruct (ns-decimal
     288             (:include foreign-struct-encapsulation)
     289             (:constructor %make-ns-decimal (data)))
     290  )
     291
     292(defun make-ns-decimal (exponent length is-negative is-compact mantissa)
     293  (let* ((data (%new-gcable-ptr ns-decimal-size)))
     294    (setf (pref data :<NSD>ecimal._exponent) exponent
     295          (pref data :<NSD>ecimal._length) length
     296          (pref data :<NSD>ecimal._is<N>egative) (if is-negative 1 0)
     297          (pref data :<NSD>ecimal._is<C>ompact) (if is-compact 1 0))
     298    (let* ((v (coerce mantissa '(vector (unsigned-byte 16) 8))))
     299      (declare (type (simple-array (unsigned-byte 16) (8)) v))
     300      (with-macptrs ((m (pref data :<NSD>ecimal._mantissa)))
     301        (dotimes (i 8 (%make-ns-decimal data))
     302          (setf (paref m (:* (:unsigned 16)) i) (aref v i)))))))
     303
     304(declaim (inline ns-decimal-exponent ns-decimal-length ns-decimal-is-negative
     305                 ns-decimal-is-compact ns-decimal-mantissa
     306                 (setf ns-decimal-exponent) (setf ns-decimal-length)
     307                 (setf ns-decimal-is-negative)
     308                 (setf ns-decimal-is-compact) (setf ns-decimal-mantissa)))
     309
     310(defun ns-decimal-exponent (decimal)
     311  (pref (ns-decimal-data decimal) :<NSD>ecimal._exponent))
     312
     313(defun (setf ns-decimal-exponent) (new decimal)
     314  (setf (pref (ns-decimal-data decimal) :<NSD>ecimal._exponent) new))
     315
     316(defun ns-decimal-length (decimal)
     317  (pref (ns-decimal-data decimal) :<NSD>ecimal._length))
     318
     319
     320(defun (setf ns-decimal-length) (new decimal)
     321  (setf (pref (ns-decimal-data decimal) :<NSD>ecimal._length) new))
     322
     323(defun ns-decimal-is-negative (decimal)
     324  (not (zerop (pref (ns-decimal-data decimal) :<NSD>ecimal._is<N>egative))))
     325
     326(defun (setf ns-decimal-is-negative) (new decimal)
     327  (setf (pref (ns-decimal-data decimal) :<NSD>ecimal._is<N>egative)
     328        (if new 1 0))
     329  new)
     330
     331(defun ns-decimal-is-compact (decimal)
     332  (pref (ns-decimal-data decimal) :<NSD>ecimal._is<C>ompact))
     333
     334(defun (setf ns-decimal-is-compact) (new decimal)
     335  (setf (pref (ns-decimal-data decimal) :<NSD>ecimal._is<C>ompact)
     336        (if new 1 0))
     337  new)
     338
     339(defun ns-decimal-mantissa (decimal)
     340  (let* ((data (ns-decimal-data decimal))
     341         (dest (make-array 8 :element-type '(unsigned-byte 16))))
     342    (with-macptrs ((m (pref data :<NSD>ecimal._mantissa)))
     343      (dotimes (i 8 dest)
     344        (setf (aref dest i) (paref m (:* (:unsigned 16)) i))))))
     345
     346(defun (setf ns-decimal-mantissa) (new decimal)
     347  (let* ((data (ns-decimal-data decimal))
     348         (src (coerce new '(simple-array (unsigned-byte 16) (8)))))
     349    (declare (type (simple-array (unsigned-byte 16) 8) src))
     350    (with-macptrs ((m (pref data :<NSD>ecimal._mantissa)))
     351      (dotimes (i 8 new)
     352        (setf (paref m (:* (:unsigned 16)) i) (aref src i))))))
     353
     354(defmethod print-object ((d ns-decimal) stream)
     355  (print-unreadable-object (d stream :type t :identity t)
     356    (format stream "exponent = ~d, length = ~s, is-negative = ~s, is-compact = ~s, mantissa = ~s" (ns-decimal-exponent d) (ns-decimal-length d) (ns-decimal-is-negative d) (ns-decimal-is-compact d) (ns-decimal-mantissa d))))
     357
     358
     359
     360   
     361(create-foreign-struct-association-for-encapsulation
     362 (parse-foreign-type :<NSD>ecimal)
     363 '%make-ns-decimal
     364 'ns-decimal-p)   
     365
     366;;; NSRect
     367
     368(defconstant ns-rect-size (%foreign-type-or-record-size :<NSR>ect :bytes))
     369
     370(defstruct (ns-rect (:include foreign-struct-encapsulation)
     371                    (:constructor %make-ns-rect (data))))
     372
     373
     374(defun make-ns-rect (x y width height)
     375  (let* ((data (%new-gcable-ptr ns-rect-size)))
     376    (setf (pref data :<NSR>ect.origin.x) (float x +cgfloat-zero+)
     377          (pref data :<NSR>ect.origin.y) (float y +cgfloat-zero+)
     378          (pref data :<NSR>ect.size.width) (float width +cgfloat-zero+)
     379          (pref data :<NSR>ect.size.height) (float height +cgfloat-zero+))
     380    (%make-ns-rect data)))
     381
     382(declaim (inline ns-rect-x ns-rect-y ns-rect-width ns-rect-height
     383                 (setf ns-rect-x) (setf ns-rect-y) (setf ns-rect-width)
     384                 (setf ns-rect-height)))
     385
     386(defun ns-rect-x (rect)
     387  (pref (ns-rect-data rect) :<NSR>ect.origin.x))
     388
     389(defun (setf ns-rect-x) (new rect)
     390  (setf (pref (ns-rect-data rect) :<NSR>ect.origin.x)
     391        (float new +cgfloat-zero+)))
     392
     393(defun ns-rect-y (rect)
     394  (pref (ns-rect-data rect) :<NSR>ect.origin.y))
     395
     396(defun (setf ns-rect-y) (new rect)
     397  (setf (pref (ns-rect-data rect) :<NSR>ect.origin.y)
     398        (float new +cgfloat-zero+)))
     399
     400(defun ns-rect-width (rect)
     401  (pref (ns-rect-data rect) :<NSR>ect.size.width))
     402
     403(defun (setf ns-rect-width) (new rect)
     404  (setf (pref (ns-rect-data rect) :<NSR>ect.size.width)
     405        (float new +cgfloat-zero+)))
     406
     407(defun ns-rect-height (rect)
     408  (pref (ns-rect-data rect) :<NSR>ect.size.height))
     409
     410(defun (setf ns-rect-height) (new rect)
     411  (setf (pref (ns-rect-data rect) :<NSR>ect.size.height)
     412        (float new +cgfloat-zero+)))
     413
     414(defmethod print-object ((r ns-rect) stream)
     415  (print-unreadable-object (r stream :type t :identity t)
     416    (flet ((maybe-round (x)
     417             (multiple-value-bind (q r) (round x)
     418               (if (zerop r) q x))))
     419      (format stream "~s X ~s @ ~s,~s"
     420              (maybe-round (ns-rect-width r))
     421              (maybe-round (ns-rect-height r))
     422              (maybe-round (ns-rect-x r))
     423              (maybe-round (ns-rect-y r))))))
     424
     425(create-foreign-struct-association-for-encapsulation
     426 (parse-foreign-type :<NSR>ect)
     427 '%make-ns-rect
     428 'ns-rect-p)
     429
     430;;; NSSize
     431
     432(defconstant ns-size-size (%foreign-type-or-record-size :<NSS>ize))
     433
     434(defstruct (ns-size (:include foreign-struct-encapsulation)
     435                    (:constructor %make-ns-size (data))))
     436
     437(defun make-ns-size (width height)
     438  (let* ((data (%new-gcable-ptr ns-size-size)))
     439    (setf (pref data :<NSS>ize.width) (float width +cgfloat-zero+)
     440          (pref data :<NSS>ize.height) (float height +cgfloat-zero+))
     441    (%make-ns-size data)))
     442
     443(declaim (inline ns-size-width ns-size-heigh
     444                 (setf ns-size-width) (setf ns-size-height)))
     445
     446(defun ns-size-width (size)
     447  (pref (ns-size-data size) :<NSS>ize.width))
     448
     449(defun (setf ns-size-width) (new size)
     450  (setf (pref (ns-size-data size) :<NSS>ize.width)
     451        (float new +cgfloat-zero+)))
     452
     453(defun ns-size-height (size)
     454  (pref (ns-size-data size) :<NSS>ize.height))
     455
     456(defun (setf ns-size-height) (new size)
     457  (setf (pref (ns-size-data size) :<NSS>ize.height)
     458        (float new +cgfloat-zero+)))
     459
     460(defmethod print-object ((s ns-size) stream)
     461  (flet ((maybe-round (x)
     462           (multiple-value-bind (q r) (round x)
     463             (if (zerop r) q x))))
     464    (print-unreadable-object (s stream :type t :identity t)
     465      (format stream "~s X ~s"
     466              (maybe-round (ns-size-width s))
     467              (maybe-round (ns-size-height s))))))
     468
     469
     470(create-foreign-struct-association-for-encapsulation
     471 (parse-foreign-type :<NSS>ize)
     472 '%make-ns-size
     473 'ns-size-p)
     474
     475;;; NSPoint
     476(defconstant ns-point-size (%foreign-type-or-record-size :<NSP>oint :bytes))
     477
     478(defstruct (ns-point (:include foreign-struct-encapsulation)
     479                     (:constructor %make-ns-point (data))))
     480
     481(defun make-ns-point (x y)
     482  (let* ((data (%new-gcable-ptr ns-point-size)))
     483    (setf (pref data :<NSP>oint.x) (float x +cgfloat-zero+)
     484          (pref data :<NSP>oint.y) (float y +cgfloat-zero+))
     485    (%make-ns-point data)))
     486
     487(declaim (inline ns-point-x ns-point-y (setf ns-point-x) (setf ns-point-y)))
     488
     489(defun ns-point-x (point)
     490  (pref (ns-point-data point) :<NSP>oint.x))
     491
     492(defun (setf ns-point-x) (new point)
     493  (setf (pref (ns-point-data point) :<NSP>oint.x)
     494        (float new +cgfloat-zero+)))
     495
     496(defun ns-point-y (point)
     497  (pref (ns-point-data point) :<NSP>oint.y))
     498
     499(defun (setf ns-point-y) (new point)
     500  (setf (pref (ns-point-data point) :<NSP>oint.y)
     501        (float new +cgfloat-zero+)))
     502
     503(defmethod print-object ((p ns-point) stream)
     504  (flet ((maybe-round (x)
     505           (multiple-value-bind (q r) (round x)
     506             (if (zerop r) q x))))
     507    (print-unreadable-object (p stream :type t :identity t)
     508      (format stream "~s,~s"
     509              (maybe-round (ns-point-x p))
     510              (maybe-round (ns-point-y p))))))
     511
     512
     513(create-foreign-struct-association-for-encapsulation
     514 (parse-foreign-type :<NSP>oint)
     515 '%make-ns-point
     516 'ns-point-p)
     517
     518;;; NSRange
     519
     520(defconstant ns-range-size (%foreign-type-or-record-size :<NSR>ange :bytes))
     521
     522(defstruct (ns-range (:include foreign-struct-encapsulation)
     523                     (:constructor %make-ns-range (data))))
     524
     525(defun make-ns-range (location length)
     526  (let* ((data (%new-gcable-ptr ns-range-size)))
     527    (setf (pref data :<NSR>ange.location) location
     528          (pref data :<NSR>ange.length) length)
     529    (%make-ns-range data)))
     530
     531(declaim (inline ns-range-location ns-range-length
     532                 (setf ns-range-location)
     533                 (setf ns-range-length)))
     534
     535(defun ns-range-location (range)
     536  (pref (ns-range-data range) :<NSR>ange.location))
     537
     538(defun (setf ns-range-location) (new range)
     539  (setf (pref (ns-range-data range) :<NSR>ange.location)
     540        new))
     541
     542(defun ns-range-length (range)
     543  (pref (ns-range-data range) :<NSR>ange.length))
     544
     545(defun (setf ns-range-length) (new range)
     546  (setf (pref (ns-range-data range) :<NSR>ange.length)
     547        new))
     548
     549
     550(defmethod print-object ((r ns-range) stream)
     551  (print-unreadable-object (r stream :type t :identity t)
     552    (format stream "~s/~s" (ns-range-location r) (ns-range-length r))))
     553
     554
     555
     556(create-foreign-struct-association-for-encapsulation
     557 (parse-foreign-type :<NSR>ange)
     558 '%make-ns-range
     559 'ns-range-p)
     560
     561
     562(set-dispatch-macro-character #\# #\/
     563                              (lambda (stream subchar numarg)
     564                                (declare (ignorable subchar numarg))
     565                                (let* ((token (make-array 16 :element-type 'character :fill-pointer 0 :adjustable t))
     566                                       (attrtab (rdtab.ttab *readtable*)))
     567                                  (when (peek-char t stream nil nil)
     568                                    (loop
     569                                      (multiple-value-bind (char attr)
     570                                          (%next-char-and-attr stream attrtab)
     571                                        (unless (eql attr $cht_cnst)
     572                                          (when char (unread-char char stream))
     573                                          (return))
     574                                        (vector-push-extend char token))))
     575                                  (unless *read-suppress*
     576                                    (unless (> (length token) 0)
     577                                      (signal-reader-error stream "Invalid token after #/."))
     578                                    (let* ((symbol (intern token "NS")))
     579                                      (get-objc-message-info (symbol-name symbol))
     580                                      symbol)))))
     581
    25582
    26583;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    366923  (typep result-type 'foreign-record-type))
    367924
     925(defvar *objc-method-signatures* (make-hash-table :test #'equal))
     926
     927(defstruct objc-method-signature-info
     928  type-signature
     929  function
     930  super-function)
     931
     932(defun objc-method-signature-info (sig)
     933  (or (gethash sig *objc-method-signatures*)
     934      (setf (gethash sig *objc-method-signatures*)
     935            (make-objc-method-signature-info :type-signature sig))))
     936
     937(defun concise-foreign-type (ftype)
     938  (if (typep ftype 'foreign-record-type)
     939    (let* ((name (foreign-record-type-name ftype)))
     940      (if name
     941        `(,(foreign-record-type-kind ftype) ,name)
     942        (unparse-foreign-type ftype)))
     943    (if (objc-id-type-p ftype)
     944      :id
     945      (if (typep ftype 'foreign-pointer-type)
     946        (let* ((to (foreign-pointer-type-to ftype)))
     947          (if (null to)
     948            '(:* :void)
     949            `(:* ,(concise-foreign-type to))))
     950        (unparse-foreign-type ftype)))))
     951
     952
     953;;; Not a perfect mechanism.
     954(defclass objc-dispatch-function (funcallable-standard-object)
     955    ()
     956  (:metaclass funcallable-standard-class))
     957
     958(defmethod print-object ((o objc-dispatch-function) stream)
     959  (print-unreadable-object (o stream :type t :identity t)
     960    (let* ((name (function-name o)))
     961      (when name
     962        (format stream "~s" name)))))
     963
     964(declaim (inline check-receiever))
     965
     966;;; Return a NULL pointer if RECEIVER is a null pointer.
     967;;; Otherwise, insist that it's an ObjC object of some sort, and return NIL.
     968(defun check-receiver (receiver)
     969  (if (%null-ptr-p receiver)
     970    (%null-ptr)
     971    (let* ((domain (%macptr-domain receiver))
     972           (valid (eql domain *objc-object-domain*)))
     973      (declare (fixnum domain))
     974      (when (zerop domain)
     975        (if (recognize-objc-object receiver)
     976          (progn (%set-macptr-domain receiver *objc-object-domain*)
     977                 (setq valid t))))
     978      (unless valid
     979        (report-bad-arg receiver 'objc:objc-object)))))
     980
     981(defmethod shared-initialize :after ((gf objc-dispatch-function) slot-names &key message-info &allow-other-keys)
     982  (declare (ignore slot-names))
     983  (if message-info
     984    (let* ((ambiguous-methods (getf (objc-message-info-flags message-info) :ambiguous))
     985           (selector (objc-message-info-selector message-info))
     986           (first-method (car (objc-message-info-methods message-info))))
     987      (lfun-bits gf (dpb (1+ (objc-message-info-req-args message-info))
     988                         $lfbits-numreq
     989                         (lfun-bits gf)))
     990      (flet ((signature-function-for-method (m)
     991               (let* ((signature-info (objc-method-info-signature-info m)))
     992                 (or (objc-method-signature-info-function signature-info)
     993                     (setf (objc-method-signature-info-function signature-info)
     994                           (compile-send-function-for-signature
     995                                    (objc-method-signature-info-type-signature signature-info)))))))
     996                     
     997      (if (null ambiguous-methods)
     998        ;; Pick an arbitrary method, since all methods have the same
     999        ;; signature.
     1000        (let* ((function (signature-function-for-method first-method)))
     1001          (set-funcallable-instance-function
     1002           gf
     1003           (nfunction
     1004            send-unambiguous-message
     1005            (lambda (receiver &rest args)
     1006               (declare (dynamic-extent args))
     1007               (or (check-receiver receiver)
     1008                   (with-ns-exceptions-as-errors
     1009                       (apply function receiver selector args)))))))
     1010        (let* ((protocol-pairs (mapcar #'(lambda (pm)
     1011                                           (cons (lookup-objc-protocol
     1012                                                  (objc-method-info-class-name pm))
     1013                                                 (signature-function-for-method
     1014                                                  pm)))
     1015                                       (objc-message-info-protocol-methods message-info)))
     1016               (method-pairs (mapcar #'(lambda (group)
     1017                                         (cons (mapcar #'(lambda (m)
     1018                                                           (get-objc-method-info-class m))
     1019                                                       group)
     1020                                               (signature-function-for-method (car group))))
     1021                                     (objc-message-info-ambiguous-methods message-info)))
     1022               (default-function (if method-pairs
     1023                                   (prog1 (cdar (last method-pairs))
     1024                                     (setq method-pairs (nbutlast method-pairs)))
     1025                                   (prog1 (cdr (last protocol-pairs))
     1026                                     (setq protocol-pairs (nbutlast protocol-pairs))))))
     1027          (set-funcallable-instance-function
     1028           gf
     1029           (nfunction
     1030            send-unambiguous-message
     1031            (lambda (receiver &rest args)
     1032               (declare (dynamic-extent args))
     1033               (or (check-receiver receiver)
     1034                   (let* ((function
     1035                           (or (dolist (pair protocol-pairs)
     1036                                 (when (conforms-to-protocol receiver (car pair))
     1037                                   (return (cdr pair))))
     1038                               (block m
     1039                                 (dolist (pair method-pairs default-function)
     1040                                   (dolist (class (car pair))
     1041                                     (when (typep receiver class)
     1042                                       (return-from m (cdr pair)))))))))
     1043                     (with-ns-exceptions-as-errors
     1044                         (apply function receiver selector args)))))))))))
     1045    (with-slots (name) gf
     1046      (set-funcallable-instance-function
     1047       gf
     1048       #'(lambda (&rest args)
     1049           (error "Unknown ObjC message ~a called with arguments ~s"
     1050                  (symbol-name name) args))))))
     1051                                             
     1052
     1053
    3681054(defun postprocess-objc-message-info (message-info)
     1055  (let* ((objc-name (objc-message-info-message-name message-info))
     1056         (lisp-name (or (objc-message-info-lisp-name message-info)
     1057                            (setf (objc-message-info-lisp-name message-info)
     1058                                  (compute-objc-to-lisp-function-name  objc-name))))
     1059         (gf (or (fboundp lisp-name)
     1060                 (setf (fdefinition lisp-name)
     1061                       (make-instance 'objc-dispatch-function :name lisp-name)))))
     1062
     1063    (unless (objc-message-info-selector message-info)
     1064      (setf (objc-message-info-selector message-info)
     1065            (ensure-objc-selector (objc-message-info-message-name message-info))))
     1066   
    3691067  (flet ((reduce-to-ffi-type (ftype)
    370            (if (objc-id-type-p ftype)
    371              :id
    372              (unparse-foreign-type ftype))))
     1068           (concise-foreign-type ftype)))
    3731069    (flet ((ensure-method-signature (m)
    3741070             (or (objc-method-info-signature m)
    3751071                 (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)))))))
     1072                       (let* ((sig
     1073                               (cons (reduce-to-ffi-type
     1074                                      (objc-method-info-result-type m))
     1075                                     (mapcar #'reduce-to-ffi-type
     1076                                             (objc-method-info-arglist m)))))
     1077                         (setf (objc-method-info-signature-info m)
     1078                               (objc-method-signature-info sig))
     1079                         sig)))))
    3801080      (let* ((methods (objc-message-info-methods message-info))
    3811081             (signatures ())
     
    4361136                    (setf (getf (objc-message-info-flags message-info)
    4371137                                :accepts-varargs) t)
    438                     (decf (objc-message-info-req-args message-info))))))))))))
     1138                    (decf (objc-message-info-req-args message-info)))))))))
     1139      (reinitialize-instance gf :message-info message-info)))))
    4391140         
    4401141;;; -may- need to invalidate cached info whenever new interface files
    4411142;;; are made accessible.  Probably the right thing to do is to insist
    4421143;;; that (known) message signatures be updated in that case.
    443 (defun get-objc-message-info (message-name)
     1144(defun get-objc-message-info (message-name &optional (use-database t))
     1145  (setq message-name (string message-name))
    4441146  (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))))
     1147      (and use-database
     1148           (let* ((info (lookup-objc-message-info message-name)))
     1149             (when info
     1150               (setf (gethash message-name *objc-message-info*) info)
     1151               (postprocess-objc-message-info info)
     1152               info)))))
    4501153
    4511154(defun need-objc-message-info (message-name)
     
    6891392                      (objc-method-info-class-name m)))
    6901393             (class-name mclass))))
     1394
    6911395    (collect ((clauses))
    692       (let* ((protocol (gensym)))
     1396      (let* ((protocol (gensym))
     1397             (protocol-address (gensym)))
    6931398        (dolist (method protocol-methods)
    6941399          (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>)))))
     1400            (clauses `((let* ((,protocol (lookup-objc-protocol ,protocol-name))
     1401                              (,protocol-address (and ,protocol (protocol-address ,protocol))))
     1402                         (and ,protocol-address
     1403                              (objc-message-send ,receiver
     1404                                                 "conformsToProtocol:"
     1405                                                 :address ,protocol-address
     1406                                                 :<BOOL>)))
    7011407                       ,(build-internal-call-from-method-info
    7021408                         method args vargs receiver msg s super))))))
     
    7041410           ((null (cdr methods))
    7051411            (when ambiguous-methods
    706             (clauses `(t
    707                        ,(build-internal-call-from-method-info
    708                          (caar methods) args vargs receiver msg s super)))))
     1412              (clauses `(t
     1413                         ,(build-internal-call-from-method-info
     1414                           (caar methods) args vargs receiver msg s super)))))
    7091415        (clauses `(,(if (cdar methods)
    7101416                        `(or ,@(mapcar #'(lambda (m)
Note: See TracChangeset for help on using the changeset viewer.