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