chiark - git - mdw - clg/blob - gffi/basic-types.lisp

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: basic-types.lisp,v 1.5 2007-01-02 15:20:32 espen Exp $
  24
  25 (in-package "GFFI")
  26
  27
  28 (deftype int ()
  29   '(signed-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:int)
  30                 #+clisp #.(ffi:bitsizeof 'ffi:int)
  31                 #-(or sbcl clisp) 32))
  32 (deftype unsigned-int ()
  33   '(unsigned-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:int)
  34                   #+clisp #.(ffi:bitsizeof 'ffi:int)
  35                   #-(or sbcl clisp) 32))
  36 (deftype long ()
  37   '(signed-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:long)
  38                 #+clisp #.(ffi:bitsizeof 'ffi:long)
  39                 #-(or sbcl clisp) 32))
  40 (deftype unsigned-long ()
  41   '(unsigned-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:long)
  42                   #+clisp #.(ffi:bitsizeof 'ffi:long)
  43                   #-(or sbcl clisp) 32))
  44 (deftype short ()
  45   '(signed-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:short)
  46                 #+clisp #.(ffi:bitsizeof 'ffi:short)
  47                 #-(or sbcl clisp) 16))
  48 (deftype unsigned-short ()
  49   '(unsigned-byte #+sbcl #.(sb-sizeof-bits 'sb-alien:short)
  50                   #+clisp #.(ffi:bitsizeof 'ffi:short)
  51                   #-(or sbcl clisp) 16))
  52 (deftype signed (&optional (size '*)) `(signed-byte ,size))
  53 (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
  54 (deftype char () 'base-char)
  55 (deftype pointer ()
  56   #+(or cmu sbcl) 'system-area-pointer
  57   #+clisp 'ffi:foreign-address)
  58 (deftype bool (&optional (size '*)) (declare (ignore size)) 'boolean)
  59 (deftype copy-of (type) type)
  60 (deftype static (type) type)
  61 (deftype inlined (type) type)
  62
  63
  64
  65 (define-type-generic alien-type (type)
  66   "Returns the foreign type corresponding to TYPE")
  67 (define-type-generic size-of (type &key inlined)
  68   "Returns the foreign size of TYPE. The default value of INLINED is
  69 T for basic C types and NIL for other types.")
  70 (define-type-generic type-alignment (type &key inlined)
  71   "Returns the alignment of TYPE. The default value of INLINED is
  72 T for basic C types and NIL for other types.")
  73 (define-type-generic alien-arg-wrapper (type var arg style form &optional copy-p)
  74   "Creates a wrapper around FORM which binds the alien translation of
  75 ARG to VAR in a way which makes it possible to pass the location of
  76 VAR in a foreign function call. It should also do any necessary clean
  77 up before returning the value of FORM.")
  78 (define-type-generic to-alien-form (type form &optional copy-p)
  79   "Returns a form which translates FORM to alien representation. If
  80 COPY-P is non NIL then any allocated foreign memory must not be
  81 reclaimed later.")
  82 (define-type-generic from-alien-form (type form &key ref)
  83   "Returns a form which translates FORM from alien to lisp
  84 representation. REF should be :FREE, :COPY, :STATIC or :TEMP")
  85 (define-type-generic to-alien-function (type &optional copy-p)
  86   "Returns a function of one argument which will translate objects of the given type to alien repesentation. An optional function, taking the origional object and the alien representation as arguments, to clean up after the alien value is not needed any more may be returned as a second argument.")
  87 (define-type-generic from-alien-function (type &key ref)
  88   "Returns a function of one argument which will translate alien objects of the given type to lisp representation. REF should be :FREE, :COPY, :STATIC or :TEMP")
  89 (define-type-generic callback-wrapper (type var arg form)
  90   "Creates a wrapper around FORM which binds the lisp translation of
  91 ARG to VAR during a C callback.")
  92
  93 (define-type-generic writer-function (type &key temp inlined)
  94   "Returns a function taking a value, an address and an optional
  95 offset which when called will write a reference an object at the given
  96 location. If TEMP is non NIL then the object is expected to be valid
  97 as long as the reference exists.")
  98 (define-type-generic reader-function (type &key ref inlined)
  99   "Returns a function taking an address and optional offset which when
 100 called will return the object at given location. REF should be :READ,
 101 :PEEK or :GET")
 102 (define-type-generic destroy-function (type &key temp inlined)
 103   "Returns a function taking an address and optional offset which when
 104 called will destroy the reference at the given location. This may
 105 involve freeing the foreign object being referenced or decreasing it's
 106 ref. count. If TEMP is non NIL then the reference is expected to
 107 have been written as temporal.")
 108 (define-type-generic copy-function (type &key inlined))
 109
 110 (define-type-generic unbound-value (type-spec)
 111   "Returns a value which should be interpreted as unbound for slots with virtual allocation")
 112
 113 (defun assert-inlined (type inlined-p)
 114   (unless inlined-p
 115     (error "Type ~A can only be inlined" type)))
 116
 117 (defun assert-not-inlined (type inlined-p)
 118   (when inlined-p
 119     (error "Type ~A can not be inlined" type)))
 120
 121
 122 (define-type-method alien-arg-wrapper ((type t) var arg style form &optional
 123                                        (copy-in-p nil copy-in-given-p))
 124   (let ((alien-type (alien-type type)))
 125     (cond
 126       ((in-arg-p style)
 127        (let ((to-alien (if copy-in-given-p
 128                            (to-alien-form type arg copy-in-p)
 129                          (to-alien-form type arg))))
 130          #+(or cmu sbcl)
 131          `(with-alien ((,var ,alien-type ,to-alien))
 132             ,form)
 133          #+clisp
 134          `(ffi:with-c-var (,var ',alien-type ,to-alien)
 135             ,form)))
 136       ((out-arg-p style)
 137        #+(or cmu sbcl)
 138        `(with-alien ((,var ,alien-type))
 139           (clear-memory (alien-sap (addr ,var)) ,(size-of type))
 140           ,form)
 141        #+clisp
 142        `(ffi:with-c-var (,var ',alien-type)
 143           ,form)))))
 144
 145 (define-type-method callback-wrapper ((type t) var arg form)
 146   `(let ((,var ,(from-alien-form type arg :ref :temp)))
 147      ,form))
 148
 149 (define-type-method alien-type ((type t))
 150   (error "No alien type corresponding to the type specifier ~A" type))
 151
 152 (define-type-method to-alien-form ((type t) form &optional copy-p)
 153   (declare (ignore form copy-p))
 154   (error "Not a valid type specifier for arguments: ~A" type))
 155
 156 (define-type-method to-alien-function ((type t) &optional copy-p)
 157   (declare (ignore copy-p))
 158   (error "Not a valid type specifier for arguments: ~A" type))
 159
 160 (define-type-method from-alien-form ((type t) form &key ref)
 161   (declare (ignore form ref))
 162   (error "Not a valid type specifier for return values: ~A" type))
 163
 164 (define-type-method from-alien-function ((type t) &key ref)
 165   (declare (ignore ref))
 166   (error "Not a valid type specifier for return values: ~A" type))
 167
 168 (define-type-method destroy-function ((type t) &key temp (inlined t inlined-p))
 169   (declare (ignore temp))
 170   (let ((size (if inlined-p
 171                   (size-of type :inlined inlined)
 172                 (size-of type))))
 173     #'(lambda (location &optional (offset 0))
 174         (clear-memory location size offset))))
 175
 176 (define-type-method copy-function ((type t) &key (inlined t inlined-p))
 177   (let ((size (if inlined-p
 178                   (size-of type :inlined inlined)
 179                 (size-of type))))
 180     #'(lambda (from to &optional (offset 0))
 181         (copy-memory (pointer+ from offset) size (pointer+ to offset)))))
 182
 183 (define-type-method to-alien-form ((type real) form &optional copy-p)
 184   (declare (ignore type copy-p))
 185   form)
 186
 187 (define-type-method to-alien-function ((type real) &optional copy-p)
 188   (declare (ignore type copy-p))
 189   #'identity)
 190
 191 (define-type-method from-alien-form ((type real) form &key ref)
 192   (declare (ignore type ref))
 193   form)
 194
 195 (define-type-method from-alien-function ((type real) &key ref)
 196   (declare (ignore type ref))
 197   #'identity)
 198
 199
 200 (define-type-method alien-type ((type integer))
 201   (declare (ignore type))
 202   (alien-type 'signed-byte))
 203
 204 (define-type-method size-of ((type integer) &key (inlined t))
 205   (declare (ignore type))
 206   (size-of 'signed-byte :inlined inlined))
 207
 208 (define-type-method type-alignment ((type integer) &key (inlined t))
 209   (declare (ignore type))
 210   (type-alignment 'signed-byte :inlined inlined))
 211
 212 (define-type-method writer-function ((type integer) &key temp (inlined t))
 213   (declare (ignore temp))
 214   (assert-inlined type inlined)
 215   (writer-function 'signed-byte))
 216
 217 (define-type-method reader-function ((type integer) &key ref (inlined t))
 218   (declare (ignore ref))
 219   (assert-inlined type inlined)
 220   (reader-function 'signed-byte))
 221
 222
 223 ;;; Signed Byte
 224
 225 (define-type-method alien-type ((type signed-byte))
 226   (destructuring-bind (&optional (size '*))
 227       (rest (mklist (type-expand-to 'signed-byte type)))
 228     (let ((size (if (eq size '*)
 229                     (second (type-expand-to 'signed-byte 'int))
 230                   size)))
 231       #+cmu
 232       (ecase size
 233         ( 8 '(alien:signed 8))
 234         (16 '(alien:signed 16))
 235         (32 '(alien:signed 32))
 236         (64 '(alien:signed 64)))
 237       #+sbcl
 238       (ecase size
 239         ( 8 '(sb-alien:signed  8))
 240         (16 '(sb-alien:signed 16))
 241         (32 '(sb-alien:signed 32))
 242         (64 '(sb-alien:signed 64)))
 243       #+clisp
 244       (ecase size
 245         ( 8 'ffi:sint8)
 246         (16 'ffi:sint16)
 247         (32 'ffi:sint32)
 248         (64 'ffi:sint64)))))
 249
 250 (define-type-method size-of ((type signed-byte) &key (inlined t))
 251   (assert-inlined type inlined)
 252   (destructuring-bind (&optional (size '*))
 253       (rest (mklist (type-expand-to 'signed-byte type)))
 254     (let ((size (if (eq size '*)
 255                     (second (type-expand-to 'signed-byte 'int))
 256                   size)))
 257       (ecase size
 258         ( 8 1)
 259         (16 2)
 260         (32 4)
 261         (64 8)))))
 262
 263 (define-type-method type-alignment ((type signed-byte) &key (inlined t))
 264   (assert-inlined type inlined)
 265   (destructuring-bind (&optional (size '*))
 266       (rest (mklist (type-expand-to 'signed-byte type)))
 267     (let ((size (if (eq size '*)
 268                     (second (type-expand-to 'signed-byte 'int))
 269                   size)))
 270       #+sbcl(sb-alignment `(sb-alien:signed ,size))
 271       #+clisp(ecase size
 272                ( 8 (nth-value 1 (ffi:sizeof 'ffi:sint8)))
 273                (16 (nth-value 1 (ffi:sizeof 'ffi:sint16)))
 274                (32 (nth-value 1 (ffi:sizeof 'ffi:sint32)))
 275                (64 (nth-value 1 (ffi:sizeof 'ffi:sint64))))
 276       #-(or sbcl clisp) 4)))
 277
 278 (define-type-method writer-function ((type signed-byte) &key temp (inlined t))
 279   (declare (ignore temp))
 280   (assert-inlined type inlined)
 281   (destructuring-bind (&optional (size '*))
 282       (rest (mklist (type-expand-to 'signed-byte type)))
 283     (let ((size (if (eq size '*)
 284                     (second (type-expand-to 'signed-byte 'int))
 285                   size)))
 286       (ecase size
 287         ( 8 #'(lambda (value location &optional (offset 0))
 288                 (setf
 289                  #+(or cmu sbcl)(signed-sap-ref-8 location offset)
 290                  #+clisp(ffi:memory-as location 'ffi:sint8 offset)
 291                  value)))
 292         (16 #'(lambda (value location &optional (offset 0))
 293                 (setf
 294                  #+(or cmu sbcl)(signed-sap-ref-16 location offset)
 295                  #+clisp(ffi:memory-as location 'ffi:sint16 offset)
 296                  value)))
 297         (32 #'(lambda (value location &optional (offset 0))
 298                 (setf
 299                  #+(or cmu sbcl)(signed-sap-ref-32 location offset)
 300                  #+clisp(ffi:memory-as location 'ffi:sint32 offset)
 301                  value)))
 302         (64 #'(lambda (value location &optional (offset 0))
 303                 (setf
 304                  #+(or cmu sbcl)(signed-sap-ref-64 location offset)
 305                  #+clisp(ffi:memory-as location 'ffi:sint64 offset)
 306                  value)))))))
 307
 308 (define-type-method reader-function ((type signed-byte) &key ref (inlined t))
 309   (declare (ignore ref))
 310   (assert-inlined type inlined)
 311   (destructuring-bind (&optional (size '*))
 312       (rest (mklist (type-expand-to 'signed-byte type)))
 313     (let ((size (if (eq size '*)
 314                     (second (type-expand-to 'signed-byte 'int))
 315                   size)))
 316       (ecase size
 317         ( 8 #'(lambda (location &optional (offset 0))
 318                 #+(or cmu sbcl)(signed-sap-ref-8 location offset)
 319                 #+clisp(ffi:memory-as location 'ffi:sint8 offset)))
 320         (16 #'(lambda (location &optional (offset 0))
 321                 #+(or cmu sbcl)(signed-sap-ref-16 location offset)
 322                 #+clisp(ffi:memory-as location 'ffi:sint16 offset)))
 323         (32 #'(lambda (location &optional (offset 0))
 324                 #+(or cmu sbcl)(signed-sap-ref-32 location offset)
 325                 #+clisp(ffi:memory-as location 'ffi:sint32 offset)))
 326         (64 #'(lambda (location &optional (offset 0))
 327                 #+(or cmu sbcl)(signed-sap-ref-64 location offset)
 328                 #+clisp(ffi:memory-as location 'ffi:sint64 offset)))))))
 329
 330
 331
 332 ;;; Unsigned Byte
 333
 334 (define-type-method alien-type ((type unsigned-byte))
 335   (destructuring-bind (&optional (size '*))
 336       (rest (mklist (type-expand-to 'unsigned-byte type)))
 337     (let ((size (if (eq size '*)
 338                     (second (type-expand-to 'signed-byte 'int))
 339                   size)))
 340       #+cmu
 341       (ecase size
 342         ( 8 '(alien:unsigned 8))
 343         (16 '(alien:unsigned 16))
 344         (32 '(alien:unsigned 32))
 345         (64 '(alien:unsigned 64)))
 346       #+sbcl
 347       (ecase size
 348         ( 8 '(sb-alien:unsigned  8))
 349         (16 '(sb-alien:unsigned 16))
 350         (32 '(sb-alien:unsigned 32))
 351         (64 '(sb-alien:unsigned 64)))
 352       #+clisp
 353       (ecase size
 354         ( 8 'ffi:uint8)
 355         (16 'ffi:uint16)
 356         (32 'ffi:uint32)
 357         (64 'ffi:uint64)))))
 358
 359 (define-type-method size-of ((type unsigned-byte) &key (inlined t))
 360   (assert-inlined type inlined)
 361   (destructuring-bind (&optional (size '*))
 362       (rest (mklist (type-expand-to 'unsigned-byte type)))
 363     (size-of `(signed ,size))))
 364
 365 (define-type-method type-alignment ((type unsigned-byte) &key (inlined t))
 366   (assert-inlined type inlined)
 367   (destructuring-bind (&optional (size '*))
 368       (rest (mklist (type-expand-to 'unsigned-byte type)))
 369     (type-alignment `(signed ,size))))
 370
 371 (define-type-method writer-function ((type unsigned-byte) &key temp (inlined t))
 372   (declare (ignore temp))
 373   (assert-inlined type inlined)
 374   (destructuring-bind (&optional (size '*))
 375       (rest (mklist (type-expand-to 'unsigned-byte type)))
 376     (let ((size (if (eq size '*)
 377                     (second (type-expand-to 'signed-byte 'int))
 378                   size)))
 379       (ecase size
 380         ( 8 #'(lambda (value location &optional (offset 0))
 381                 (setf
 382                  #+(or cmu sbcl)(sap-ref-8 location offset)
 383                  #+clisp(ffi:memory-as location 'ffi:uint8 offset)
 384                  value)))
 385         (16 #'(lambda (value location &optional (offset 0))
 386                 (setf
 387                  #+(or cmu sbcl)(sap-ref-16 location offset)
 388                  #+clisp(ffi:memory-as location 'ffi:uint16 offset)
 389                  value)))
 390         (32 #'(lambda (value location &optional (offset 0))
 391                 (setf
 392                  #+(or cmu sbcl)(sap-ref-32 location offset)
 393                  #+clisp(ffi:memory-as location 'ffi:uint32 offset)
 394                  value)))
 395         (64 #'(lambda (value location &optional (offset 0))
 396                 (setf
 397                  #+(or cmu sbcl)(sap-ref-64 location offset)
 398                  #+clisp(ffi:memory-as location 'ffi:uint64 offset)
 399                  value)))))))
 400
 401 (define-type-method reader-function ((type unsigned-byte) &key ref (inlined t))
 402   (declare (ignore ref))
 403   (assert-inlined type inlined)
 404   (destructuring-bind (&optional (size '*))
 405       (rest (mklist (type-expand-to 'unsigned-byte type)))
 406     (let ((size (if (eq size '*)
 407                     (second (type-expand-to 'signed-byte 'int))
 408                   size)))
 409       (ecase size
 410         ( 8 #'(lambda (location &optional (offset 0))
 411                 #+(or cmu sbcl)(sap-ref-8 location offset)
 412                 #+clisp(ffi:memory-as location 'ffi:uint8 offset)))
 413         (16 #'(lambda (location &optional (offset 0))
 414                 #+(or cmu sbcl)(sap-ref-16 location offset)
 415                 #+clisp(ffi:memory-as location 'ffi:uint16 offset)))
 416         (32 #'(lambda (location &optional (offset 0))
 417                 #+(or cmu sbcl)(sap-ref-32 location offset)
 418                 #+clisp(ffi:memory-as location 'ffi:uint32 offset)))
 419         (64 #'(lambda (location &optional (offset 0))
 420                 #+(or cmu sbcl)(sap-ref-64 location offset)
 421                 #+clisp(ffi:memory-as location 'ffi:uint64 offset)))))))
 422
 423
 424
 425 ;;; Single Float
 426
 427 (define-type-method alien-type ((type single-float))
 428   (declare (ignore type))
 429   #+cmu 'alien:single-float
 430   #+sbcl 'sb-alien:single-float
 431   #+clisp 'single-float)
 432
 433 (define-type-method size-of ((type single-float) &key (inlined t))
 434   (assert-inlined type inlined)
 435   #+sbcl (sb-sizeof 'sb-alien:float)
 436   #+clisp (ffi:sizeof 'single-float)
 437   #-(or sbcl clisp) 4)
 438
 439 (define-type-method type-alignment ((type single-float) &key (inlined t))
 440   (assert-inlined type inlined)
 441   #+sbcl (sb-alignment 'single-float)
 442   #+clisp (nth-value 1 (ffi:sizeof 'single-float))
 443   #-(or sbcl clisp) 4)
 444
 445 (define-type-method to-alien-form ((type single-float) form &optional copy-p)
 446   (declare (ignore type copy-p))
 447   `(coerce ,form 'single-float))
 448
 449 (define-type-method to-alien-function ((type single-float) &optional copy-p)
 450   (declare (ignore type copy-p))
 451   #'(lambda (number)
 452       (coerce number 'single-float)))
 453
 454 (define-type-method writer-function ((type single-float) &key temp (inlined t))
 455   (declare (ignore temp))
 456   (assert-inlined type inlined)
 457   #'(lambda (value location &optional (offset 0))
 458       (setf
 459        #+(or cmu sbcl)(sap-ref-single location offset)
 460        #+clisp(ffi:memory-as location 'single-float offset)
 461        (coerce value 'single-float))))
 462
 463 (define-type-method reader-function ((type single-float) &key ref (inlined t))
 464   (declare (ignore ref))
 465   (assert-inlined type inlined)
 466   #'(lambda (location &optional (offset 0))
 467       #+(or cmu sbcl)(sap-ref-single location offset)
 468       #+clisp(ffi:memory-as location 'single-float offset)))
 469
 470
 471
 472 ;;; Double Float
 473
 474 (define-type-method alien-type ((type double-float))
 475   (declare (ignore type))
 476   #+cmu 'alien:double-float
 477   #+sbcl 'sb-alien:double-float
 478   #+clisp 'double-float)
 479
 480 (define-type-method size-of ((type double-float) &key (inlined t))
 481   (assert-inlined type inlined)
 482   #+sbcl (sb-sizeof 'sb-alien:double)
 483   #+clisp (ffi:sizeof 'double-float)
 484   #-(or sbcl clisp) 8)
 485
 486 (define-type-method type-alignment ((type double-float) &key (inlined t))
 487   (assert-inlined type inlined)
 488   #+sbcl (sb-alignment 'double-float)
 489   #+clisp (nth-value 1 (ffi:sizeof 'double-float))
 490   #-(or sbcl clisp) 4)
 491
 492 (define-type-method to-alien-form ((type double-float) form &optional copy-p)
 493   (declare (ignore type copy-p))
 494   `(coerce ,form 'double-float))
 495
 496 (define-type-method to-alien-function ((type double-float) &optional copy-p)
 497   (declare (ignore type copy-p))
 498   #'(lambda (number)
 499       (coerce number 'double-float)))
 500
 501 (define-type-method writer-function ((type double-float) &key temp (inlined t))
 502   (declare (ignore temp))
 503   (assert-inlined type inlined)
 504   #'(lambda (value location &optional (offset 0))
 505       (setf
 506        #+(or cmu sbcl)(sap-ref-double location offset)
 507        #+clisp(ffi:memory-as location 'double-float offset)
 508        (coerce value 'double-float))))
 509
 510 (define-type-method reader-function ((type double-float) &key ref (inlined t))
 511   (declare (ignore ref))
 512   (assert-inlined type inlined)
 513   #'(lambda (location &optional (offset 0))
 514       #+(or cmu sbcl)(sap-ref-double location offset)
 515       #+clisp(ffi:memory-as location 'double-float offset)))
 516
 517 (deftype optimized-double-float () 'double-float)
 518
 519 (define-type-method to-alien-form ((type optimized-double-float) form &optional copy-p)
 520   (declare (ignore type copy-p))
 521   form)
 522
 523
 524
 525 ;;; Character
 526
 527 (define-type-method alien-type ((type base-char))
 528   (declare (ignore type))
 529   #+cmu 'c-call:char
 530   #+sbcl 'sb-alien:char
 531   #+clisp 'ffi:character)
 532
 533 (define-type-method size-of ((type base-char) &key (inlined t))
 534   (assert-inlined type inlined)
 535   1)
 536
 537 (define-type-method type-alignment ((type base-char) &key (inlined t))
 538   (assert-inlined type inlined)
 539   #+sbcl (sb-alignment 'sb-alien:char)
 540   #+clisp (nth-value 1 (ffi:sizeof 'ffi:character))
 541   #-(or sbcl clisp) 4)
 542
 543 (define-type-method to-alien-form ((type base-char) form &optional copy-p)
 544   (declare (ignore type copy-p))
 545   form)
 546
 547 (define-type-method to-alien-function ((type base-char) &optional copy-p)
 548   (declare (ignore type copy-p))
 549   #'identity)
 550
 551 (define-type-method from-alien-form ((type base-char) form &key ref)
 552   (declare (ignore type ref))
 553   form)
 554
 555 (define-type-method from-alien-function ((type base-char) &key ref)
 556   (declare (ignore type ref))
 557   #'identity)
 558
 559 (define-type-method writer-function ((type base-char) &key temp (inlined t))
 560   (declare (ignore temp))
 561   (assert-inlined type inlined)
 562   #'(lambda (char location &optional (offset 0))
 563       #+(or cmu sbcl)
 564       (setf (sap-ref-8 location offset) (char-code char))
 565       #+clisp(setf (ffi:memory-as location 'ffi:character offset) char)))
 566
 567 (define-type-method reader-function ((type base-char) &key ref (inlined t))
 568   (declare (ignore ref))
 569   (assert-inlined type inlined)
 570   #'(lambda (location &optional (offset 0))
 571       #+(or cmu sbcl)(code-char (sap-ref-8 location offset))
 572       #+clisp(ffi:memory-as location 'ffi:character offset)))
 573
 574
 575
 576 ;;; String
 577
 578 (defun utf8-length (string)
 579   "Returns the length including the trailing zero, of STRING encoded as UTF8"
 580   (1+ (loop
 581        for char across string
 582        as char-code = (char-code char)
 583        sum (cond
 584             ((< char-code #x7F) 1)
 585             ((< char-code #x7FF) 2)
 586             ((< char-code #xFFFF) 3)
 587             ((< char-code #x1FFFFF) 4)))))
 588
 589 (defun encode-utf8-string (string &optional location)
 590   (let* ((len (utf8-length string))
 591          (location (or location (allocate-memory len))))
 592     (loop
 593      for char across string
 594      for i from 0
 595      as char-code = (char-code char)
 596      do (flet ((encode (size)
 597                  (let ((rem (mod size 6)))
 598                    (setf (ref-byte location i)
 599                     (deposit-field
 600                      #xFF (byte (- 7 rem) (1+ rem))
 601                      (ldb (byte rem (- size rem)) char-code)))
 602                    (loop
 603                     for pos from (- size rem 6) downto 0 by 6
 604                     do (setf (ref-byte location (incf i))
 605                         (+ 128 (ldb (byte 6 pos) char-code)))))))
 606           (cond
 607            ((< char-code #x80) (setf (ref-byte location i) char-code))
 608            ((< char-code #x800) (encode 11))
 609            ((< char-code #x10000) (encode 16))
 610            ((< char-code #x200000) (encode 21)))))
 611     (setf (ref-byte location (1- len)) 0)
 612     location))
 613
 614 (defun decode-utf8-string (c-string)
 615   (with-output-to-string (string)
 616     (loop
 617      for i from 0
 618      as octet = (ref-byte c-string i)
 619      until (zerop octet)
 620      do (flet ((decode (size)
 621                  (loop
 622                   with rem = (mod size 6)
 623                   for pos from (- size rem) downto 0 by 6
 624                   as code = (dpb (ldb (byte rem 0) octet) (byte rem pos) 0)
 625                   then (dpb
 626                         (ldb (byte 6 0) (ref-byte c-string (incf i)))
 627                         (byte 6 pos) code)
 628                   finally (write-char (code-char code) string))))
 629           (cond
 630            ((< octet 128) (write-char (code-char octet) string))
 631            ((< octet 224) (decode 11))
 632            ((< octet 240) (decode 16))
 633            ((< octet 248) (decode 21)))))))
 634
 635
 636 (define-type-method alien-arg-wrapper ((type string) var string style form &optional copy-in-p)
 637   (declare (ignore type))
 638   (cond
 639    ((and (in-arg-p style) copy-in-p)
 640     `(with-pointer (,var (encode-utf8-string ,string))
 641        ,form))
 642    ((and (in-arg-p style) (not (out-arg-p style)))
 643     `(with-memory (,var (utf8-length ,string))
 644        (encode-utf8-string ,string ,var)
 645        ,form))
 646    ((and (in-arg-p style) (out-arg-p style))
 647     (let ((c-string (make-symbol "C-STRING")))
 648       `(with-memory (,c-string (utf8-length ,string))
 649          (encode-utf8-string ,string ,c-string)
 650          (with-pointer (,var ,c-string)
 651            ,form))))
 652    ((and (out-arg-p style) (not (in-arg-p style)))
 653     `(with-pointer (,var)
 654        ,form))))
 655
 656 (define-type-method alien-type ((type string))
 657   (declare (ignore type))
 658   (alien-type 'pointer))
 659
 660 (define-type-method size-of ((type string) &key inlined)
 661   (assert-not-inlined type inlined)
 662   (size-of 'pointer))
 663
 664 (define-type-method type-alignment ((type string) &key inlined)
 665   (assert-not-inlined type inlined)
 666   (type-alignment 'pointer))
 667
 668 (define-type-method to-alien-form ((type string) string &optional copy-p)
 669   (declare (ignore type copy-p))
 670   `(encode-utf8-string ,string))
 671
 672 (define-type-method to-alien-function ((type string) &optional copy-p)
 673   (declare (ignore type))
 674   (values
 675    #'encode-utf8-string
 676    (unless copy-p
 677      #'(lambda (string c-string)
 678          (declare (ignore string))
 679          (deallocate-memory c-string)))))
 680
 681 (define-type-method from-alien-form ((type string) form &key (ref :free))
 682   (declare (ignore type))
 683   `(let ((c-string ,form))
 684      (unless (null-pointer-p c-string)
 685        (prog1
 686            (decode-utf8-string c-string)
 687          ,(when (eq ref :free)
 688             `(deallocate-memory c-string))))))
 689
 690 (define-type-method from-alien-function ((type string) &key (ref :free))
 691   (declare (ignore type))
 692   (if (eq ref :free)
 693       #'(lambda (c-string)
 694           (unless (null-pointer-p c-string)
 695             (prog1
 696                 (decode-utf8-string c-string)
 697               (deallocate-memory c-string))))
 698     #'(lambda (c-string)
 699         (unless (null-pointer-p c-string)
 700           (decode-utf8-string c-string)))))
 701
 702 (define-type-method writer-function ((type string) &key temp inlined)
 703   (declare (ignore temp))
 704   (assert-not-inlined type inlined)
 705   #'(lambda (string location &optional (offset 0))
 706       (assert (null-pointer-p (ref-pointer location offset)))
 707       (setf (ref-pointer location offset) (encode-utf8-string string))))
 708
 709 (define-type-method reader-function ((type string) &key (ref :read) inlined)
 710   (assert-not-inlined type inlined)
 711   (ecase ref
 712     ((:read :peek)
 713      #'(lambda (location &optional (offset 0))
 714          (unless (null-pointer-p (ref-pointer location offset))
 715            (decode-utf8-string (ref-pointer location offset)))))
 716     (:get
 717      #'(lambda (location &optional (offset 0))
 718          (unless (null-pointer-p (ref-pointer location offset))
 719            (prog1
 720                (decode-utf8-string (ref-pointer location offset))
 721              (deallocate-memory (ref-pointer location offset))
 722              (setf (ref-pointer location offset) (make-pointer 0))))))))
 723
 724 (define-type-method destroy-function ((type string) &key temp inlined)
 725   (declare (ignore temp))
 726   (assert-not-inlined type inlined)
 727   #'(lambda (location &optional (offset 0))
 728       (unless (null-pointer-p (ref-pointer location offset))
 729         (deallocate-memory (ref-pointer location offset))
 730         (setf (ref-pointer location offset) (make-pointer 0)))))
 731
 732 (define-type-method copy-function ((type string) &key inlined)
 733   (assert-not-inlined type inlined)
 734   (lambda (from to &optional (offset 0))
 735     (let* ((string (ref-pointer from offset))
 736            (length (loop
 737                     for i from 0
 738                     until (zerop (ref-byte string i))
 739                     finally (return (1+ i)))))
 740       (setf (ref-pointer to offset) (copy-memory string length)))))
 741
 742 (define-type-method unbound-value ((type string))
 743   (declare (ignore type))
 744   nil)
 745
 746
 747
 748 ;;; Pathname
 749
 750 (define-type-method alien-type ((type pathname))
 751   (declare (ignore type))
 752   (alien-type 'string))
 753
 754 (define-type-method size-of ((type pathname) &key inlined)
 755   (assert-not-inlined type inlined)
 756   (size-of 'string))
 757
 758 (define-type-method type-alignment ((type pathname) &key inlined)
 759   (assert-not-inlined type inlined)
 760   (type-alignment 'string))
 761
 762 (define-type-method alien-arg-wrapper ((type pathname) var pathname style form &optional copy-in-p)
 763   (declare (ignore type))
 764   (alien-arg-wrapper 'string var `(namestring (translate-logical-pathname ,pathname)) style form copy-in-p))
 765
 766 (define-type-method to-alien-form ((type pathname) path)
 767   (declare (ignore type))
 768   (to-alien-form 'string `(namestring (translate-logical-pathname ,path))))
 769
 770 (define-type-method to-alien-function ((type pathname) &optional copy-p)
 771   (declare (ignore type))
 772   (let ((string-function (to-alien-function 'string copy-p)))
 773     #'(lambda (path)
 774         (funcall string-function (namestring path)))))
 775
 776 (define-type-method from-alien-form ((type pathname) form &key (ref :free))
 777   (declare (ignore type))
 778   `(parse-namestring ,(from-alien-form 'string form :ref ref)))
 779
 780 (define-type-method from-alien-function ((type pathname) &key (ref :free))
 781   (declare (ignore type))
 782   (let ((string-function (from-alien-function 'string :ref ref)))
 783     #'(lambda (string)
 784         (parse-namestring (funcall string-function string)))))
 785
 786 (define-type-method writer-function ((type pathname) &key temp inlined)
 787   (declare (ignore temp))
 788   (assert-not-inlined type inlined)
 789   (let ((string-writer (writer-function 'string)))
 790     #'(lambda (path location &optional (offset 0))
 791         (funcall string-writer (namestring path) location offset))))
 792
 793 (define-type-method reader-function ((type pathname) &key ref inlined)
 794   (declare (ignore ref))
 795   (assert-not-inlined type inlined)
 796   (let ((string-reader (reader-function 'string)))
 797   #'(lambda (location &optional (offset 0))
 798       (let ((string (funcall string-reader location offset)))
 799         (when string
 800           (parse-namestring string))))))
 801
 802 (define-type-method destroy-function ((type pathname) &key temp inlined)
 803   (declare (ignore temp))
 804   (assert-not-inlined type inlined)
 805   (destroy-function 'string))
 806
 807 (define-type-method copy-function ((type pathname) &key inlined)
 808   (assert-not-inlined type inlined)
 809   (copy-function 'string))
 810
 811 (define-type-method unbound-value ((type pathname))
 812   (declare (ignore type))
 813   (unbound-value 'string))
 814
 815
 816
 817 ;;; Bool
 818
 819 (define-type-method alien-type ((type bool))
 820   (destructuring-bind (&optional (size '*))
 821       (rest (mklist (type-expand-to 'bool type)))
 822     (alien-type `(signed-byte ,size))))
 823
 824 (define-type-method size-of ((type bool) &key (inlined t))
 825   (assert-inlined type inlined)
 826   (destructuring-bind (&optional (size '*))
 827       (rest (mklist (type-expand-to 'bool type)))
 828     (size-of `(signed-byte ,size))))
 829
 830 (define-type-method type-alignment ((type bool) &key (inlined t))
 831   (assert-inlined type inlined)
 832   (destructuring-bind (&optional (size '*))
 833       (rest (mklist (type-expand-to 'bool type)))
 834     (type-alignment `(signed-byte ,size))))
 835
 836 (define-type-method to-alien-form ((type bool) bool &optional copy-p)
 837   (declare (ignore type copy-p))
 838   `(if ,bool 1 0))
 839
 840 (define-type-method to-alien-function ((type bool) &optional copy-p)
 841   (declare (ignore type copy-p))
 842   #'(lambda (bool)
 843       (if bool 1 0)))
 844
 845 (define-type-method from-alien-form ((type bool) form &key ref)
 846   (declare (ignore type ref))
 847   `(not (zerop ,form)))
 848
 849 (define-type-method from-alien-function ((type bool) &key ref)
 850   (declare (ignore type ref))
 851   #'(lambda (bool)
 852       (not (zerop bool))))
 853
 854 (define-type-method writer-function ((type bool) &key temp (inlined t))
 855   (declare (ignore temp))
 856   (assert-inlined type inlined)
 857   (destructuring-bind (&optional (size '*))
 858       (rest (mklist (type-expand-to 'bool type)))
 859     (let ((writer (writer-function `(signed-byte ,size))))
 860       #'(lambda (bool location &optional (offset 0))
 861           (funcall writer (if bool 1 0) location offset)))))
 862
 863 (define-type-method reader-function ((type bool) &key ref (inlined t))
 864   (declare (ignore ref))
 865   (assert-inlined type inlined)
 866   (destructuring-bind (&optional (size '*))
 867       (rest (mklist (type-expand-to 'bool type)))
 868     (let ((reader (reader-function `(signed-byte ,size))))
 869       #'(lambda (location &optional (offset 0))
 870           (not (zerop (funcall reader location offset)))))))
 871
 872
 873
 874 ;;; Boolean
 875
 876 (define-type-method alien-type ((type boolean))
 877   (declare (ignore type))
 878   (alien-type 'bool))
 879
 880 (define-type-method size-of ((type boolean) &key (inlined t))
 881   (assert-inlined type inlined)
 882   (size-of 'bool))
 883
 884 (define-type-method type-alignment ((type boolean) &key (inlined t))
 885   (assert-inlined type inlined)
 886   (type-alignment 'bool))
 887
 888 (define-type-method to-alien-form ((type boolean) boolean &optional copy-p)
 889   (declare (ignore type copy-p))
 890   (to-alien-form 'bool boolean))
 891
 892 (define-type-method to-alien-function ((type boolean) &optional copy-p)
 893   (declare (ignore type copy-p))
 894   (to-alien-function 'bool))
 895
 896 (define-type-method from-alien-form ((type boolean) form &key ref)
 897   (declare (ignore type ref))
 898   (from-alien-form 'bool form))
 899
 900 (define-type-method from-alien-function ((type boolean) &key ref)
 901   (declare (ignore type ref))
 902   (from-alien-function 'bool))
 903
 904 (define-type-method writer-function ((type boolean) &key temp (inlined t))
 905   (declare (ignore temp))
 906   (assert-inlined type inlined)
 907   (writer-function 'bool))
 908
 909 (define-type-method reader-function ((type boolean) &key ref (inlined t))
 910   (declare (ignore ref))
 911   (assert-inlined type inlined)
 912   (reader-function 'bool))
 913
 914
 915 ;;; Or
 916
 917 (define-type-method alien-type ((type or))
 918   (let* ((expanded-type (type-expand-to 'or type))
 919          (alien-type (alien-type (second expanded-type))))
 920     (unless (every #'(lambda (type)
 921                        (eq alien-type (alien-type type)))
 922                    (cddr expanded-type))
 923       (error "No common alien type specifier for union type: ~A" type))
 924     alien-type))
 925
 926 (define-type-method size-of ((type or) &key (inlined nil inlined-p))
 927   (loop
 928    for subtype in (type-expand-to 'or type)
 929    maximize (if inlined-p
 930                 (size-of subtype inlined)
 931               (size-of subtype))))
 932
 933 (define-type-method type-alignment ((type or) &key (inlined nil inlined-p))
 934   (loop
 935    for subtype in (type-expand-to 'or type)
 936    maximize (if inlined-p
 937                 (type-alignment subtype inlined)
 938               (type-alignment subtype))))
 939
 940 (define-type-method alien-arg-wrapper ((type or) var value style form &optional copy-in-p)
 941   (cond
 942    ((and (in-arg-p style) (out-arg-p style))
 943     `(etypecase ,value
 944        ,@(mapcar
 945           #'(lambda (type)
 946               `(,type ,(alien-arg-wrapper type var value style form copy-in-p)))
 947           (rest (type-expand-to 'or type)))))
 948    ((in-arg-p style)
 949     (let ((body (make-symbol "BODY")))
 950       `(flet ((,body (,var)
 951                  ,form))
 952          (etypecase ,value
 953            ,@(mapcar
 954               #'(lambda (type)
 955                   `(,type ,(alien-arg-wrapper type var value style `(,body ,var) copy-in-p)))
 956               (rest (type-expand-to 'or type)))))))
 957    ((out-arg-p style)
 958     #+(or cmu sbcl)
 959     `(with-alien ((,var ,(alien-type type)))
 960        (clear-memory (alien-sap (addr ,var)) ,(size-of type))
 961          ,form)
 962     #+clisp
 963     `(ffi:with-c-var (,var ',(alien-type type))
 964        ,form))))
 965
 966 (define-type-method to-alien-form ((type or) form &optional copy-p)
 967   `(let ((value ,form))
 968      (etypecase value
 969        ,@(mapcar
 970           #'(lambda (type)
 971               `(,type ,(to-alien-form type 'value copy-p)))
 972           (rest (type-expand-to 'or type))))))
 973
 974 (define-type-method to-alien-function ((type or) &optional copy-p)
 975   (let* ((expanded-type (type-expand-to 'or type))
 976          (functions (loop
 977                      for type in (rest expanded-type)
 978                      collect (to-alien-function type copy-p))))
 979     #'(lambda (value)
 980         (loop
 981          for function in functions
 982          for alt-type in (rest expanded-type)
 983          when (typep value alt-type)
 984          do (return (funcall function value))
 985          finally (error "~S is not of type ~A" value type)))))
 986
 987
 988 ;;; Pointer
 989
 990 (define-type-method alien-type ((type pointer))
 991   (declare (ignore type))
 992   #+(or cmu sbcl) 'system-area-pointer
 993   #+clisp 'ffi:c-pointer)
 994
 995 (define-type-method size-of ((type pointer) &key (inlined t))
 996   (assert-inlined type inlined)
 997   #+sbcl (sb-sizeof 'sb-alien:system-area-pointer)
 998   #+clisp (ffi:sizeof 'ffi:c-pointer)
 999   #-(or sbcl clisp) 4)
1000
1001 (define-type-method type-alignment ((type pointer) &key (inlined t))
1002   (assert-inlined type inlined)
1003   #+sbcl (sb-alignment 'system-area-pointer)
1004   #+clisp (ffi:sizeof 'ffi:c-pointer)
1005   #-(or sbcl clisp) (size-of 'pointer))
1006
1007 (define-type-method to-alien-form ((type pointer) form &optional copy-p)
1008   (declare (ignore type copy-p))
1009   form)
1010
1011 (define-type-method to-alien-function ((type pointer) &optional copy-p)
1012   (declare (ignore type copy-p))
1013   #'identity)
1014
1015 (define-type-method from-alien-form ((type pointer) form &key ref)
1016   (declare (ignore type ref))
1017   form)
1018
1019 (define-type-method from-alien-function ((type pointer) &key ref)
1020   (declare (ignore type ref))
1021   #'identity)
1022
1023 (define-type-method writer-function ((type pointer) &key temp (inlined t))
1024   (declare (ignore temp))
1025   (assert-inlined type inlined)
1026   #'(setf ref-pointer))
1027
1028 (define-type-method reader-function ((type pointer) &key ref (inlined t))
1029   (declare (ignore ref))
1030   (assert-inlined type inlined)
1031   #'ref-pointer)
1032
1033
1034 (define-type-method alien-type ((type null))
1035   (declare (ignore type))
1036   (alien-type 'pointer))
1037
1038 (define-type-method size-of ((type null) &key (inlined t))
1039   (assert-inlined type inlined)
1040   (size-of 'pointer))
1041
1042 (define-type-method to-alien-form ((type null) null &optional copy-p)
1043   (declare (ignore type copy-p))
1044   `(progn ,null (make-pointer 0)))
1045
1046 (define-type-method to-alien-function ((type null) &optional copy-p)
1047   (declare (ignore type copy-p))
1048   #'(lambda (null)
1049       (declare (ignore null))
1050       (make-pointer 0)))
1051
1052
1053 (define-type-method alien-type ((type nil))
1054   (declare (ignore type))
1055   #+(or cmu sbcl) 'void
1056   #+clisp nil)
1057
1058 (define-type-method from-alien-form ((type nil) form &key ref)
1059   (declare (ignore type ref))
1060   form)
1061
1062 (define-type-method from-alien-function ((type nil) &key ref)
1063   (declare (ignore type ref))
1064   #'(lambda (value)
1065       (declare (ignore value))
1066       (values)))
1067
1068 (define-type-method to-alien-form ((type nil) form &optional copy-p)
1069   (declare (ignore type copy-p))
1070   form)
1071
1072
1073
1074 ;;; Callbacks
1075
1076 (define-type-method alien-type ((type callback))
1077   (declare (ignore type))
1078   (alien-type 'pointer))
1079
1080 (define-type-method to-alien-form ((type callback) callback &optional copy-p)
1081   (declare (ignore type copy-p))
1082   `(callback-address ,callback))
1083
1084
1085
1086 ;;; Copy-of
1087
1088 (define-type-method from-alien-form ((type copy-of) form &key (ref :copy))
1089   (if (eq ref :copy)
1090       (from-alien-form (second (type-expand-to 'copy-of type)) form :ref ref)
1091     (error "Keyword arg :REF to FROM-ALIEN-FORM should be :COPY for type ~A. It was give ~A" type ref)))
1092
1093 (define-type-method from-alien-function ((type copy-of) &key (ref :copy))
1094   (if (eq ref :copy)
1095       (from-alien-function (second (type-expand-to 'copy-of type)) :ref ref)
1096     (error "Keyword arg :REF to FROM-ALIEN-FORM should be :COPY for type ~A. It was give ~A" type ref)))
1097
1098 (define-type-method to-alien-form ((type copy-of) form &optional (copy-p t))
1099   (if copy-p
1100       (to-alien-form (second (type-expand-to 'copy-of type)) form t)
1101     (error "COPY-P argument to TO-ALIEN-FORM should always be non NIL for type ~A" type)))
1102
1103 (define-type-method to-alien-function ((type copy-of) &optional (copy-p t))
1104   (if copy-p
1105       (to-alien-function (second (type-expand-to 'copy-of type)) t)
1106     (error "COPY-P argument to TO-ALIEN-FUNCTION should always be non NIL for type ~A" type)))
1107
1108 (define-type-method reader-function ((type copy-of) &key (ref :read) (inlined nil inlined-p))
1109   (if inlined-p
1110       (reader-function (second (type-expand-to 'copy-of type))
1111        :ref (if (eq ref :get) :read ref) :inlined inlined)
1112     (reader-function (second (type-expand-to 'copy-of type))
1113      :ref (if (eq ref :get) :read ref))))
1114
1115 (define-type-method destroy-function ((type copy-of) &key temp inlined)
1116   (declare (ignore type temp inlined))
1117   #'(lambda (location &optional offset)
1118       (declare (ignore location offset))))
1119
1120 (define-type-method copy-function ((type copy-of) &key (inlined nil inlined-p))
1121   (let ((size (if inlined-p
1122                   (size-of type :inlined inlined)
1123                 (size-of type))))
1124     #'(lambda (from to &optional (offset 0))
1125         (copy-memory (pointer+ from offset) size (pointer+ to offset)))))
1126
1127
1128
1129 ;;; Static
1130
1131 (define-type-method from-alien-form ((type static) form &key (ref :static))
1132   (if (eq ref :static)
1133       (from-alien-form (second (type-expand-to 'static type)) form :ref ref)
1134     (error "Keyword arg :REF to FROM-ALIEN-FORM should be :STATIC for type ~A. It was give ~A" type ref)))
1135
1136 (define-type-method from-alien-function ((type static) &key (ref :static))
1137   (if (eq ref :static)
1138       (from-alien-function (second (type-expand-to 'static type)) :ref ref)
1139     (error "Keyword arg :REF to FROM-ALIEN-FORM should be :STATIC for type ~A. It was give ~A" type ref)))
1140
1141 (define-type-method to-alien-function ((type static) &optional copy-p)
1142   (if (not copy-p)
1143       (to-alien-function (second (type-expand-to 'static type)) t)
1144   (error "COPY-P argument to TO-ALIEN-FUNCTION should always be NIL for type ~A" type)))
1145
1146 (define-type-method to-alien-form ((type static) &optional copy-p)
1147   (if (not copy-p)
1148       (to-alien-function (second (type-expand-to 'static type)) t)
1149   (error "COPY-P argument to TO-ALIEN-FUNCTION should always be NIL for type ~A" type)))
1150
1151 (define-type-method reader-function ((type static) &key (ref :read) (inlined nil inlined-p))
1152   (if inlined-p
1153       (reader-function (second (type-expand-to 'static type))
1154        :ref (if (eq ref :get) :read ref) :inlined inlined)
1155     (reader-function (second (type-expand-to 'static type))
1156      :ref (if (eq ref :get) :read ref))))
1157
1158 (define-type-method writer-function ((type static) &key temp inlined)
1159   (declare (ignore type temp inlined))
1160   (error "Can't overwrite a static (const) reference"))
1161
1162 (define-type-method destroy-function ((type static) &key temp inlined)
1163   (declare (ignore type temp inlined))
1164   #'(lambda (location &optional offset)
1165       (declare (ignore location offset))))
1166
1167 (define-type-method copy-function ((type static) &key (inlined nil inlined-p))
1168   (let ((size (if inlined-p
1169                   (size-of type :inlined inlined)
1170                 (size-of type))))
1171     #'(lambda (from to &optional (offset 0))
1172         (copy-memory (pointer+ from offset) size (pointer+ to offset)))))
1173
1174
1175
1176 ;;; Pseudo type for inlining of types which are not inlined by default
1177
1178 (define-type-method size-of ((type inlined) &key (inlined t))
1179   (assert-inlined type inlined)
1180   (size-of (second (type-expand-to 'inlined type)) :inlined t))
1181
1182 (define-type-method type-alignment ((type inlined) &key (inlined t))
1183   (assert-inlined type inlined)
1184   (type-alignment (second (type-expand-to 'inlined type)) :inlined t))
1185
1186 (define-type-method reader-function ((type inlined) &key (ref :read) (inlined t))
1187   (assert-inlined type inlined)
1188   (reader-function (second (type-expand-to 'inlined type)) :ref ref :inlined t))
1189
1190 (define-type-method writer-function ((type inlined) &key temp (inlined t))
1191   (assert-inlined type inlined)
1192   (writer-function (second (type-expand-to 'inlined type)) :temp temp :inlined t))
1193
1194 (define-type-method destroy-function ((type inlined) &key temp (inlined t))
1195   (assert-inlined type inlined)
1196   (destroy-function (second (type-expand-to 'inlined type)) :temp temp :inlined t))
1197
1198 (define-type-method copy-function ((type inlined) &key (inlined t))
1199   (assert-inlined type inlined)
1200   (copy-function (second (type-expand-to 'inlined type)) :inlined t))