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