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