Changeset 6080


Ignore:
Timestamp:
Mar 21, 2007, 10:32:22 AM (13 years ago)
Author:
gb
Message:

Lose the concept of foreign-struct encapsulations.

Build up some similar infrastructure around built-in-classes for
(some) foreign structure types.

File:
1 edited

Legend:

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

    r6064 r6080  
    4949  #-(and apple-objc-2.0 64-bit-target) '(signed-byte 32))
    5050
    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))
     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
    119129
    120130;;; AEDesc (Apple Event Descriptor)
    121131
    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 
     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").
    158146#+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)
     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)
    259160  (print-unreadable-object (transform stream :type t :identity t)
    260161    (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)
     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
    273172
    274173
     
    276175;;; (:struct :<GGA>ffine<T>ransform), except for the names of its fields.
    277176
    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)
     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
    282187
    283188;;; 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))
     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))
    298201    (let* ((v (coerce mantissa '(vector (unsigned-byte 16) 8))))
    299202      (declare (type (simple-array (unsigned-byte 16) (8)) v))
    300203      (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)
     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)
    355233  (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))))
     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)))
    357236
    358237
    359238
    360239   
    361 (create-foreign-struct-association-for-encapsulation
    362  (parse-foreign-type :<NSD>ecimal)
    363  '%make-ns-decimal
    364  'ns-decimal-p)   
    365 
    366240;;; NSRect
    367241
    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)
     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.width wrap-cg-float))
     247
     248
     249(defmethod print-object ((r ns::ns-rect) stream)
    415250  (print-unreadable-object (r stream :type t :identity t)
    416251    (flet ((maybe-round (x)
     
    418253               (if (zerop r) q x))))
    419254      (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)
     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
    429262
    430263;;; 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)
     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.width wrap-cg-float))
     267
     268
     269(defmethod print-object ((s ns::ns-size) stream)
    461270  (flet ((maybe-round (x)
    462271           (multiple-value-bind (q r) (round x)
     
    464273    (print-unreadable-object (s stream :type t :identity t)
    465274      (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)
     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
    474279
    475280;;; 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)
     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)
    504286  (flet ((maybe-round (x)
    505287           (multiple-value-bind (q r) (round x)
     
    507289    (print-unreadable-object (p stream :type t :identity t)
    508290      (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)
     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
    517295
    518296;;; 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)
     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)
    551302  (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 
     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 
    562325(set-dispatch-macro-character #\# #\/
    563326                              (lambda (stream subchar numarg)
     
    576339                                    (unless (> (length token) 0)
    577340                                      (signal-reader-error stream "Invalid token after #/."))
     341                                    (check-objc-message-name token)
    578342                                    (let* ((symbol (intern token "NS")))
    579343                                      (get-objc-message-info (symbol-name symbol))
Note: See TracChangeset for help on using the changeset viewer.