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