chiark - git - mdw - clg/blob - glib/ffi.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: ffi.lisp,v 1.30 2006/03/03 20:31:24 espen Exp $
  24
  25 (in-package "GLIB")
  26
  27
  28 ;;;; Foreign function call interface
  29
  30 (defvar *package-prefix* nil)
  31
  32 (defun set-package-prefix (prefix &optional (package *package*))
  33   (let ((package (find-package package)))
  34     (setq *package-prefix* (delete package *package-prefix* :key #'car))
  35     (push (cons package prefix) *package-prefix*))
  36   prefix)
  37
  38 (defun package-prefix (&optional (package *package*))
  39   (let ((package (find-package package)))
  40     (or
  41      (cdr (assoc package *package-prefix*))
  42      (substitute #\_ #\- (string-downcase (package-name package))))))
  43
  44 (defun find-prefix-package (prefix)
  45   (or
  46    (car (rassoc (string-downcase prefix) *package-prefix* :test #'string=))
  47    (find-package (string-upcase prefix))))
  48
  49 (defmacro use-prefix (prefix &optional (package *package*))
  50   `(eval-when (:compile-toplevel :load-toplevel :execute)
  51      (set-package-prefix ,prefix ,package)))
  52
  53
  54 (defun default-alien-fname (lisp-name)
  55   (let* ((name (substitute #\_ #\- (string-downcase lisp-name)))
  56          (stripped-name
  57           (cond
  58            ((and
  59              (char= (char name 0) #\%)
  60              (string= "_p" name :start2 (- (length name) 2)))
  61             (subseq name 1 (- (length name) 2)))
  62            ((char= (char name 0) #\%)
  63             (subseq name 1))
  64            ((string= "_p" name :start2 (- (length name) 2))
  65             (subseq name 0 (- (length name) 2)))
  66            (name)))
  67          (prefix (package-prefix *package*)))
  68     (if (or (not prefix) (string= prefix ""))
  69         stripped-name
  70       (format nil "~A_~A" prefix stripped-name))))
  71
  72 (defun default-alien-type-name (type-name)
  73   (let ((prefix (package-prefix *package*)))
  74     (apply
  75      #'concatenate
  76      'string
  77      (mapcar
  78       #'string-capitalize
  79       (cons prefix (split-string (symbol-name type-name) #\-))))))
  80
  81 (defun default-type-name (alien-name)
  82   (let ((parts
  83          (mapcar
  84           #'string-upcase
  85           (split-string-if alien-name #'upper-case-p))))
  86     (intern
  87      (concatenate-strings
  88       (rest parts) #\-) (find-prefix-package (first parts)))))
  89
  90
  91 (defmacro defbinding (name lambda-list return-type &rest docs/args)
  92   (multiple-value-bind (lisp-name c-name)
  93       (if (atom name)
  94           (values name (default-alien-fname name))
  95         (values-list name))
  96
  97     (let ((supplied-lambda-list lambda-list)
  98           (docs nil)
  99           (args nil))
 100       (dolist (doc/arg docs/args)
 101         (if (stringp doc/arg)
 102             (push doc/arg docs)
 103           (progn
 104             (destructuring-bind (expr type &optional (style :in)) doc/arg
 105               (unless (member style '(:in :out :in-out :return))
 106                 (error "Bogus argument style ~S in ~S." style doc/arg))
 107               (when (and
 108                      (not supplied-lambda-list)
 109                      (namep expr) (member style '(:in :in-out :return)))
 110                 (push expr lambda-list))
 111               (push (list (cond
 112                            ((and (namep expr) (eq style :out)) expr)
 113                            ((namep expr) (make-symbol (string expr)))
 114                            ((gensym)))
 115                           expr type style) args)))))
 116
 117       (%defbinding
 118        c-name lisp-name (or supplied-lambda-list (nreverse lambda-list))
 119        return-type (reverse docs) (reverse args)))))
 120
 121 #+(or cmu sbcl)
 122 (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args)
 123   (collect ((alien-types) (alien-bindings) (alien-parameters)
 124             (return-values) (cleanup-forms))
 125     (dolist (arg args)
 126       (destructuring-bind (var expr type style) arg
 127         (let ((declaration (alien-type type))
 128               (cleanup (cleanup-form type var)))
 129
 130           (cond
 131             ((member style '(:out :in-out))
 132              (alien-types `(* ,declaration))
 133              (alien-parameters `(addr ,var))
 134              (alien-bindings
 135               `(,var ,declaration
 136                 ,@(cond
 137                    ((eq style :in-out) (list (to-alien-form type expr)))
 138                    ((eq declaration 'system-area-pointer)
 139                     (list '(make-pointer 0))))))
 140              (return-values (from-alien-form type var)))
 141             ((eq style :return)
 142              (alien-types declaration)
 143              (alien-bindings
 144               `(,var ,declaration ,(to-alien-form type expr)))
 145              (alien-parameters var)
 146              (return-values (from-alien-form type var)))
 147             (cleanup
 148              (alien-types declaration)
 149              (alien-bindings
 150               `(,var ,declaration ,(to-alien-form type expr)))
 151              (alien-parameters var)
 152              (cleanup-forms cleanup))
 153             (t
 154              (alien-types declaration)
 155              (alien-parameters (to-alien-form type expr)))))))
 156
 157     (let* ((alien-name (make-symbol (string lisp-name)))
 158            (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters))))
 159       `(defun ,lisp-name ,lambda-list
 160          ,@docs
 161          #+cmu(declare (optimize (inhibit-warnings 3)))
 162          #+sbcl(declare (muffle-conditions compiler-note))
 163          (with-alien ((,alien-name
 164                        (function
 165                         ,(alien-type return-type)
 166                         ,@(alien-types))
 167                        :extern ,foreign-name)
 168                       ,@(alien-bindings))
 169            ,(if return-type
 170                 `(values
 171                   (unwind-protect
 172                       ,(from-alien-form return-type alien-funcall)
 173                     ,@(cleanup-forms))
 174                   ,@(return-values))
 175               `(progn
 176                 (unwind-protect
 177                      ,alien-funcall
 178                   ,@(cleanup-forms))
 179                 (values ,@(return-values)))))))))
 180
 181
 182 ;;; Creates bindings at runtime
 183 (defun mkbinding (name return-type &rest arg-types)
 184   #+cmu(declare (optimize (inhibit-warnings 3)))
 185   #+sbcl(declare (muffle-conditions compiler-note))
 186   (let* ((ftype
 187           `(function ,@(mapcar #'alien-type (cons return-type arg-types))))
 188          (alien
 189           (%heap-alien
 190            (make-heap-alien-info
 191             :type (parse-alien-type ftype #+sbcl nil)
 192             :sap-form (let ((address (foreign-symbol-address name)))
 193                         (etypecase address
 194                           (integer (int-sap address))
 195                           (system-area-pointer address))))))
 196          (translate-arguments (mapcar #'to-alien-function arg-types))
 197          (translate-return-value (from-alien-function return-type))
 198          (cleanup-arguments (mapcar #'cleanup-function arg-types)))
 199
 200     #'(lambda (&rest args)
 201         (map-into args #'funcall translate-arguments args)
 202         (prog1
 203             (funcall translate-return-value
 204              (apply #'alien-funcall alien args))
 205           (mapc #'funcall cleanup-arguments args)))))
 206
 207
 208
 209 ;;;; C callbacks
 210
 211 (defmacro define-callback (name return-type args &body body)
 212   (let ((define-callback
 213           #+cmu'alien:def-callback
 214           #+(and sbcl alien-callbacks)'sb-alien::define-alien-callback
 215           #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function))
 216     (multiple-value-bind (doc declaration body)
 217         (cond
 218          ((and (stringp (first body)) (eq (cadr body) 'declare))
 219           (values (first body) (second body) (cddr body)))
 220          ((stringp (first body))
 221           (values (first body) nil (rest body)))
 222          ((eq (caar body) 'declare)
 223           (values nil (first body) (rest body)))
 224          (t (values nil nil body)))
 225       `(progn
 226          #+cmu(defparameter ,name nil)
 227          (,define-callback ,name
 228            #+(and sbcl alien-callbacks),(alien-type return-type)
 229            (#+(or cmu (and sbcl (not alien-callbacks))),(alien-type return-type)
 230            ,@(mapcar #'(lambda (arg)
 231                          (destructuring-bind (name type) arg
 232                            `(,name ,(alien-type type))))
 233                      args))
 234            ,@(when doc (list doc))
 235            ,(to-alien-form return-type
 236              `(let (,@(loop
 237                        for (name type) in args
 238                        as from-alien-form = (callback-from-alien-form type name)
 239                        collect `(,name ,from-alien-form)))
 240                 ,@(when declaration (list declaration))
 241                 (unwind-protect
 242                     (progn ,@body)
 243                   ,@(loop
 244                      for (name type) in args
 245                      do (callback-cleanup-form type name))))))))))
 246
 247 (defun callback-address (callback)
 248   #+cmu(alien::callback-trampoline callback)
 249   #+(and sbcl (not alien-callbacks))(sb-alien:alien-function-sap callback)
 250   #+(and sbcl alien-callbacks)(sb-alien:alien-sap callback))
 251
 252 #+sbcl
 253 (deftype callback ()
 254   #-alien-callbacks'sb-alien:alien-function
 255   #+alien-callbacks'sb-alien:alien)
 256
 257
 258 ;;; These are for backward compatibility
 259
 260 (defmacro defcallback (name (return-type &rest args) &body body)
 261   `(define-callback ,name ,return-type ,args ,@body))
 262
 263 #-cmu
 264 (defun callback (callback)
 265   (callback-address callback))
 266
 267
 268
 269 ;;;; The "type method" system
 270
 271 (defun find-applicable-type-method (name type-spec &optional (error-p t))
 272   (let ((type-methods (get name 'type-methods)))
 273     (labels ((search-method-in-cpl-order (classes)
 274                (when classes
 275                  (or
 276                   (gethash (class-name (first classes)) type-methods)
 277                   (search-method-in-cpl-order (rest classes)))))
 278              (lookup-method (type-spec)
 279                (if (and (symbolp type-spec) (find-class type-spec nil))
 280                    (search-method-in-cpl-order
 281                     (class-precedence-list (find-class type-spec)))
 282                  (or
 283                   (let ((specifier (etypecase type-spec
 284                                      (symbol type-spec)
 285                                      (list (first type-spec)))))
 286                     (gethash specifier type-methods))
 287                   (multiple-value-bind (expanded-type expanded-p)
 288                       (type-expand-1 type-spec)
 289                     (when expanded-p
 290                       (lookup-method expanded-type))))))
 291              (search-built-in-type-hierarchy (sub-tree)
 292                (when (subtypep type-spec (first sub-tree))
 293                  (or
 294                   (search-nodes (cddr sub-tree))
 295                   (second sub-tree))))
 296              (search-nodes (nodes)
 297                (loop
 298                 for node in nodes
 299                 as function = (search-built-in-type-hierarchy node)
 300                 until function
 301                 finally (return function))))
 302     (or
 303      (lookup-method type-spec)
 304      ;; This is to handle unexpandable types whichs doesn't name a class
 305      (unless (and (symbolp type-spec) (find-class type-spec nil))
 306        (search-nodes (get name 'built-in-type-hierarchy)))
 307      (and
 308       error-p
 309       (error "No applicable type method for ~A when call width type specifier ~A" name type-spec))))))
 310
 311
 312 (defun insert-type-in-hierarchy (specifier function nodes)
 313   (cond
 314    ((let ((node (find specifier nodes :key #'first)))
 315       (when node
 316         (setf (second node) function)
 317         nodes)))
 318    ((let ((node
 319            (find-if
 320             #'(lambda (node)
 321                 (subtypep specifier (first node)))
 322             nodes)))
 323       (when node
 324         (setf (cddr node)
 325          (insert-type-in-hierarchy specifier function (cddr node)))
 326         nodes)))
 327    ((let ((sub-nodes (remove-if-not
 328                       #'(lambda (node)
 329                           (subtypep (first node) specifier))
 330                       nodes)))
 331       (cons
 332        (list* specifier function sub-nodes)
 333        (nset-difference nodes sub-nodes))))))
 334
 335
 336 (defun add-type-method (name specifier function)
 337   (setf (gethash specifier (get name 'type-methods)) function)
 338   (when (typep (find-class specifier nil) 'built-in-class)
 339     (setf (get name 'built-in-type-hierarchy)
 340      (insert-type-in-hierarchy specifier function
 341       (get name 'built-in-type-hierarchy)))))
 342
 343
 344 ;; TODO: handle optional, key and rest arguments
 345 (defmacro define-type-generic (name lambda-list &optional documentation)
 346   (if (or
 347        (not lambda-list)
 348        (find (first lambda-list) '(&optional &key &rest &allow-other-keys)))
 349       (error "A type generic needs at least one required argument")
 350     `(progn
 351        (unless (get ',name 'type-methods)
 352          (setf (get ',name 'type-methods) (make-hash-table))
 353          (setf (get ',name 'built-in-type-hierarchy) ()))
 354        (defun ,name ,lambda-list
 355          ,documentation
 356          (funcall
 357           (find-applicable-type-method ',name ,(first lambda-list))
 358           ,@lambda-list)))))
 359
 360
 361 (defmacro define-type-method (name lambda-list &body body)
 362   (let ((specifier (cadar lambda-list))
 363         (args (cons (caar lambda-list) (rest lambda-list))))
 364     `(progn
 365        (add-type-method ',name ',specifier #'(lambda ,args ,@body))
 366        ',name)))
 367
 368
 369
 370 ;;;; Definitons and translations of fundamental types
 371
 372 (define-type-generic alien-type (type-spec))
 373 (define-type-generic size-of (type-spec))
 374 (define-type-generic to-alien-form (type-spec form))
 375 (define-type-generic from-alien-form (type-spec form))
 376 (define-type-generic cleanup-form (type-spec form)
 377   "Creates a form to clean up after the alien call has finished.")
 378 (define-type-generic callback-from-alien-form (type-spec form))
 379 (define-type-generic callback-cleanup-form (type-spec form))
 380
 381 (define-type-generic to-alien-function (type-spec))
 382 (define-type-generic from-alien-function (type-spec))
 383 (define-type-generic cleanup-function (type-spec))
 384
 385 (define-type-generic copy-to-alien-form (type-spec form))
 386 (define-type-generic copy-to-alien-function (type-spec))
 387 (define-type-generic copy-from-alien-form (type-spec form))
 388 (define-type-generic copy-from-alien-function (type-spec))
 389 (define-type-generic writer-function (type-spec))
 390 (define-type-generic reader-function (type-spec))
 391 (define-type-generic destroy-function (type-spec))
 392
 393 (define-type-generic unbound-value (type-spec)
 394   "Returns a value which should be intepreted as unbound for slots with virtual allocation")
 395
 396
 397 #+sbcl
 398 (eval-when (:compile-toplevel :load-toplevel :execute)
 399   (defun sb-sizeof-bits (type)
 400     (sb-alien-internals:alien-type-bits
 401      (sb-alien-internals:parse-alien-type type nil)))
 402
 403   (defun sb-sizeof (type)
 404     (/ (sb-sizeof-bits type) 8)))
 405
 406
 407 ;; Sizes of fundamental C types in bytes (8 bits)
 408 (defconstant +size-of-short+
 409   #+sbcl (sb-sizeof 'sb-alien:short)
 410   #-sbcl 2)
 411 (defconstant +size-of-int+
 412   #+sbcl (sb-sizeof 'sb-alien:int)
 413   #-sbcl 4)
 414 (defconstant +size-of-long+
 415   #+sbcl (sb-sizeof 'sb-alien:long)
 416   #-sbcl 4)
 417 (defconstant +size-of-pointer+
 418   #+sbcl (sb-sizeof 'sb-alien:system-area-pointer)
 419   #-sbcl 4)
 420 (defconstant +size-of-float+
 421   #+sbcl (sb-sizeof 'sb-alien:float)
 422   #-sbcl 4)
 423 (defconstant +size-of-double+
 424   #+sbcl (sb-sizeof 'sb-alien:double)
 425   #-sbcl 8)
 426
 427
 428 ;; Sizes of fundamental C types in bits
 429 (defconstant +bits-of-byte+ 8)
 430 (defconstant +bits-of-short+
 431   #+sbcl (sb-sizeof-bits 'sb-alien:short)
 432   #-sbcl 16)
 433 (defconstant +bits-of-int+
 434   #+sbcl (sb-sizeof-bits 'sb-alien:int)
 435   #-sbcl 32)
 436 (defconstant +bits-of-long+
 437   #+sbcl (sb-sizeof-bits 'sb-alien:long)
 438   #-sbcl 32)
 439
 440
 441 (deftype int () '(signed-byte #.+bits-of-int+))
 442 (deftype unsigned-int () '(unsigned-byte #.+bits-of-int+))
 443 (deftype long () '(signed-byte #.+bits-of-long+))
 444 (deftype unsigned-long () '(unsigned-byte #.+bits-of-long+))
 445 (deftype short () '(signed-byte #.+bits-of-short+))
 446 (deftype unsigned-short () '(unsigned-byte #.+bits-of-short+))
 447 (deftype signed (&optional (size '*)) `(signed-byte ,size))
 448 (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
 449 (deftype char () 'base-char)
 450 (deftype pointer () 'system-area-pointer)
 451 (deftype boolean (&optional (size '*)) (declare (ignore size)) t)
 452 (deftype copy-of (type) type)
 453
 454 (define-type-method alien-type ((type t))
 455   (error "No alien type corresponding to the type specifier ~A" type))
 456
 457 (define-type-method to-alien-form ((type t) form)
 458   (declare (ignore form))
 459   (error "Not a valid type specifier for arguments: ~A" type))
 460
 461 (define-type-method to-alien-function ((type t))
 462   (error "Not a valid type specifier for arguments: ~A" type))
 463
 464 (define-type-method from-alien-form ((type t) form)
 465   (declare (ignore form))
 466   (error "Not a valid type specifier for return values: ~A" type))
 467
 468 (define-type-method from-alien-function ((type t))
 469   (error "Not a valid type specifier for return values: ~A" type))
 470
 471 (define-type-method cleanup-form ((type t) form)
 472   (declare (ignore form type))
 473   nil)
 474
 475 (define-type-method cleanup-function ((type t))
 476   (declare (ignore type))
 477   #'identity)
 478
 479 (define-type-method callback-from-alien-form ((type t) form)
 480   (copy-from-alien-form type form))
 481
 482 (define-type-method callback-cleanup-form ((type t) form)
 483   (declare (ignore form type))
 484   nil)
 485
 486 (define-type-method destroy-function ((type t))
 487   (declare (ignore type))
 488   #'(lambda (location &optional offset)
 489       (declare (ignore location offset))))
 490
 491 (define-type-method copy-to-alien-form ((type t) form)
 492   (to-alien-form type form))
 493
 494 (define-type-method copy-to-alien-function ((type t))
 495   (to-alien-function type))
 496
 497 (define-type-method copy-from-alien-form ((type t) form)
 498   (from-alien-form type  form))
 499
 500 (define-type-method copy-from-alien-function ((type t))
 501   (from-alien-function type))
 502
 503
 504 (define-type-method to-alien-form ((type real) form)
 505   (declare (ignore type))
 506   form)
 507
 508 (define-type-method to-alien-function ((type real))
 509   (declare (ignore type))
 510   #'identity)
 511
 512 (define-type-method from-alien-form ((type real) form)
 513   (declare (ignore type))
 514   form)
 515
 516 (define-type-method from-alien-function ((type real))
 517   (declare (ignore type))
 518   #'identity)
 519
 520
 521 (define-type-method alien-type ((type integer))
 522   (declare (ignore type))
 523   (alien-type 'signed-byte))
 524
 525 (define-type-method size-of ((type integer))
 526   (declare (ignore type))
 527   (size-of 'signed-byte))
 528
 529 (define-type-method writer-function ((type integer))
 530   (declare (ignore type))
 531   (writer-function 'signed-byte))
 532
 533 (define-type-method reader-function ((type integer))
 534   (declare (ignore type))
 535   (reader-function 'signed-byte))
 536
 537
 538 (define-type-method alien-type ((type signed-byte))
 539   (destructuring-bind (&optional (size '*))
 540       (rest (mklist (type-expand-to 'signed-byte type)))
 541     (ecase size
 542       (#.+bits-of-byte+ #+cmu'(alien:signed 8) #+sbcl'(sb-alien:signed 8))
 543       (#.+bits-of-short+ #+cmu 'c-call:short #+sbcl 'sb-alien:short)
 544       ((* #.+bits-of-int+) #+cmu 'c-call:int #+sbcl 'sb-alien:int)
 545       (#.+bits-of-long+ #+cmu 'c-call:long #+sbcl 'sb-alien:long))))
 546
 547 (define-type-method size-of ((type signed-byte))
 548   (destructuring-bind (&optional (size '*))
 549       (rest (mklist (type-expand-to 'signed-byte type)))
 550     (ecase size
 551       (#.+bits-of-byte+ 1)
 552       (#.+bits-of-short+ +size-of-short+)
 553       ((* #.+bits-of-int+) +size-of-int+)
 554       (#.+bits-of-long+ +size-of-long+))))
 555
 556 (define-type-method writer-function ((type signed-byte))
 557   (destructuring-bind (&optional (size '*))
 558       (rest (mklist (type-expand-to 'signed-byte type)))
 559     (let ((size (if (eq size '*) +bits-of-int+ size)))
 560       (ecase size
 561         (8 #'(lambda (value location &optional (offset 0))
 562                (setf (signed-sap-ref-8 location offset) value)))
 563         (16 #'(lambda (value location &optional (offset 0))
 564                 (setf (signed-sap-ref-16 location offset) value)))
 565         (32 #'(lambda (value location &optional (offset 0))
 566                 (setf (signed-sap-ref-32 location offset) value)))
 567         (64 #'(lambda (value location &optional (offset 0))
 568                 (setf (signed-sap-ref-64 location offset) value)))))))
 569
 570 (define-type-method reader-function ((type signed-byte))
 571   (destructuring-bind (&optional (size '*))
 572       (rest (mklist (type-expand-to 'signed-byte type)))
 573     (let ((size (if (eq size '*) +bits-of-int+ size)))
 574       (ecase size
 575         (8 #'(lambda (sap &optional (offset 0) weak-p)
 576                (declare (ignore weak-p))
 577                (signed-sap-ref-8 sap offset)))
 578         (16 #'(lambda (sap &optional (offset 0) weak-p)
 579                 (declare (ignore weak-p))
 580                 (signed-sap-ref-16 sap offset)))
 581         (32 #'(lambda (sap &optional (offset 0) weak-p)
 582                 (declare (ignore weak-p))
 583                 (signed-sap-ref-32 sap offset)))
 584         (64 #'(lambda (sap &optional (offset 0) weak-p)
 585                 (declare (ignore weak-p))
 586                 (signed-sap-ref-64 sap offset)))))))
 587
 588
 589 (define-type-method alien-type ((type unsigned-byte))
 590   (destructuring-bind (&optional (size '*))
 591       (rest (mklist (type-expand-to 'unsigned-byte type)))
 592     (ecase size
 593       (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8))
 594       (#.+bits-of-short+ #+cmu 'c-call:unsigned-short
 595                          #+sbcl 'sb-alien:unsigned-short)
 596       ((* #.+bits-of-int+) #+cmu 'c-call:unsigned-int
 597                            #+sbcl 'sb-alien:unsigned-int)
 598       (#.+bits-of-long+ #+cmu 'c-call:unsigned-long
 599                         #+sbcl 'sb-alien:unsigned-long))))
 600
 601
 602 (define-type-method size-of ((type unsigned-byte))
 603   (destructuring-bind (&optional (size '*))
 604       (rest (mklist (type-expand-to 'unsigned-byte type)))
 605   (size-of `(signed ,size))))
 606
 607 (define-type-method writer-function ((type unsigned-byte))
 608   (destructuring-bind (&optional (size '*))
 609       (rest (mklist (type-expand-to 'unsigned-byte type)))
 610     (let ((size (if (eq size '*) +bits-of-int+ size)))
 611       (ecase size
 612         (8 #'(lambda (value location &optional (offset 0))
 613                (setf (sap-ref-8 location offset) value)))
 614         (16 #'(lambda (value location &optional (offset 0))
 615                 (setf (sap-ref-16 location offset) value)))
 616         (32 #'(lambda (value location &optional (offset 0))
 617                 (setf (sap-ref-32 location offset) value)))
 618         (64 #'(lambda (value location &optional (offset 0))
 619                 (setf (sap-ref-64 location offset) value)))))))
 620
 621 (define-type-method reader-function ((type unsigned-byte))
 622   (destructuring-bind (&optional (size '*))
 623       (rest (mklist (type-expand-to 'unsigned-byte type)))
 624     (let ((size (if (eq size '*) +bits-of-int+ size)))
 625       (ecase size
 626         (8 #'(lambda (sap &optional (offset 0) weak-p)
 627                (declare (ignore weak-p))
 628                (sap-ref-8 sap offset)))
 629         (16 #'(lambda (sap &optional (offset 0) weak-p)
 630                 (declare (ignore weak-p))
 631                 (sap-ref-16 sap offset)))
 632         (32 #'(lambda (sap &optional (offset 0) weak-p)
 633                 (declare (ignore weak-p))
 634                 (sap-ref-32 sap offset)))
 635         (64 #'(lambda (sap &optional (offset 0) weak-p)
 636                 (declare (ignore weak-p))
 637                 (sap-ref-64 sap offset)))))))
 638
 639 (define-type-method alien-type ((type single-float))
 640   (declare (ignore type))
 641   #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float)
 642
 643 (define-type-method size-of ((type single-float))
 644   (declare (ignore type))
 645   +size-of-float+)
 646
 647 (define-type-method to-alien-form ((type single-float) form)
 648   (declare (ignore type))
 649   `(coerce ,form 'single-float))
 650
 651 (define-type-method to-alien-function ((type single-float))
 652   (declare (ignore type))
 653   #'(lambda (number)
 654       (coerce number 'single-float)))
 655
 656 (define-type-method writer-function ((type single-float))
 657   (declare (ignore type))
 658   #'(lambda (value location &optional (offset 0))
 659       (setf (sap-ref-single location offset) (coerce value 'single-float))))
 660
 661 (define-type-method reader-function ((type single-float))
 662   (declare (ignore type))
 663   #'(lambda (sap &optional (offset 0) weak-p)
 664       (declare (ignore weak-p))
 665       (sap-ref-single sap offset)))
 666
 667
 668 (define-type-method alien-type ((type double-float))
 669   (declare (ignore type))
 670   #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float)
 671
 672 (define-type-method size-of ((type double-float))
 673   (declare (ignore type))
 674   +size-of-double+)
 675
 676 (define-type-method to-alien-form ((type double-float) form)
 677   (declare (ignore type))
 678   `(coerce ,form 'double-float))
 679
 680 (define-type-method to-alien-function ((type double-float))
 681   (declare (ignore type))
 682   #'(lambda (number)
 683       (coerce number 'double-float)))
 684
 685 (define-type-method writer-function ((type double-float))
 686   (declare (ignore type))
 687   #'(lambda (value location &optional (offset 0))
 688       (setf (sap-ref-double location offset) (coerce value 'double-float))))
 689
 690 (define-type-method reader-function ((type double-float))
 691   (declare (ignore type))
 692   #'(lambda (sap &optional (offset 0) weak-p)
 693       (declare (ignore weak-p))
 694       (sap-ref-double sap offset)))
 695
 696
 697 (define-type-method alien-type ((type base-char))
 698   (declare (ignore type))
 699   #+cmu 'c-call:char #+sbcl 'sb-alien:char)
 700
 701 (define-type-method size-of ((type base-char))
 702   (declare (ignore type))
 703   1)
 704
 705 (define-type-method to-alien-form ((type base-char) form)
 706   (declare (ignore type))
 707   form)
 708
 709 (define-type-method to-alien-function ((type base-char))
 710   (declare (ignore type))
 711   #'identity)
 712
 713 (define-type-method from-alien-form ((type base-char) form)
 714   (declare (ignore type))
 715   form)
 716
 717 (define-type-method from-alien-function ((type base-char))
 718   (declare (ignore type))
 719   #'identity)
 720
 721 (define-type-method writer-function ((type base-char))
 722   (declare (ignore type))
 723   #'(lambda (char location &optional (offset 0))
 724       (setf (sap-ref-8 location offset) (char-code char))))
 725
 726 (define-type-method reader-function ((type base-char))
 727   (declare (ignore type))
 728   #'(lambda (location &optional (offset 0) weak-p)
 729       (declare (ignore weak-p))
 730       (code-char (sap-ref-8 location offset))))
 731
 732
 733 (define-type-method alien-type ((type string))
 734   (declare (ignore type))
 735   (alien-type 'pointer))
 736
 737 (define-type-method size-of ((type string))
 738   (declare (ignore type))
 739   (size-of 'pointer))
 740
 741 (define-type-method to-alien-form ((type string) string)
 742   (declare (ignore type))
 743   `(let ((string ,string))
 744      ;; Always copy strings to prevent seg fault due to GC
 745      #+cmu
 746      (copy-memory
 747       (vector-sap (coerce string 'simple-base-string))
 748       (1+ (length string)))
 749      #+sbcl
 750      (let ((utf8 (%deport-utf8-string string)))
 751        (copy-memory (vector-sap utf8) (length utf8)))))
 752
 753 (define-type-method to-alien-function ((type string))
 754   (declare (ignore type))
 755   #'(lambda (string)
 756       #+cmu
 757       (copy-memory
 758        (vector-sap (coerce string 'simple-base-string))
 759        (1+ (length string)))
 760       #+sbcl
 761       (let ((utf8 (%deport-utf8-string string)))
 762         (copy-memory (vector-sap utf8) (length utf8)))))
 763
 764 (define-type-method from-alien-form ((type string) string)
 765   (declare (ignore type))
 766   `(let ((string ,string))
 767     (unless (null-pointer-p string)
 768       (prog1
 769           #+cmu(%naturalize-c-string string)
 770           #+sbcl(%naturalize-utf8-string string)
 771         (deallocate-memory string)))))
 772
 773 (define-type-method from-alien-function ((type string))
 774   (declare (ignore type))
 775   #'(lambda (string)
 776       (unless (null-pointer-p string)
 777         (prog1
 778             #+cmu(%naturalize-c-string string)
 779             #+sbcl(%naturalize-utf8-string string)
 780           (deallocate-memory string)))))
 781
 782 (define-type-method cleanup-form ((type string) string)
 783   (declare (ignore type))
 784   `(let ((string ,string))
 785     (unless (null-pointer-p string)
 786       (deallocate-memory string))))
 787
 788 (define-type-method cleanup-function ((type string))
 789   (declare (ignore type))
 790   #'(lambda (string)
 791       (unless (null-pointer-p string)
 792         (deallocate-memory string))))
 793
 794 (define-type-method copy-from-alien-form ((type string) string)
 795   (declare (ignore type))
 796   `(let ((string ,string))
 797     (unless (null-pointer-p string)
 798       #+cmu(%naturalize-c-string string)
 799       #+sbcl(%naturalize-utf8-string string))))
 800
 801 (define-type-method copy-from-alien-function ((type string))
 802   (declare (ignore type))
 803   #'(lambda (string)
 804       (unless (null-pointer-p string)
 805         #+cmu(%naturalize-c-string string)
 806         #+sbcl(%naturalize-utf8-string string))))
 807
 808 (define-type-method writer-function ((type string))
 809   (declare (ignore type))
 810   #'(lambda (string location &optional (offset 0))
 811       (assert (null-pointer-p (sap-ref-sap location offset)))
 812       (setf (sap-ref-sap location offset)
 813        #+cmu
 814        (copy-memory
 815         (vector-sap (coerce string 'simple-base-string))
 816         (1+ (length string)))
 817        #+sbcl
 818        (let ((utf8 (%deport-utf8-string string)))
 819          (copy-memory (vector-sap utf8) (length utf8))))))
 820
 821 (define-type-method reader-function ((type string))
 822   (declare (ignore type))
 823   #'(lambda (location &optional (offset 0) weak-p)
 824       (declare (ignore weak-p))
 825       (unless (null-pointer-p (sap-ref-sap location offset))
 826         #+cmu(%naturalize-c-string (sap-ref-sap location offset))
 827         #+sbcl(%naturalize-utf8-string (sap-ref-sap location offset)))))
 828
 829 (define-type-method destroy-function ((type string))
 830   (declare (ignore type))
 831   #'(lambda (location &optional (offset 0))
 832       (unless (null-pointer-p (sap-ref-sap location offset))
 833         (deallocate-memory (sap-ref-sap location offset))
 834         (setf (sap-ref-sap location offset) (make-pointer 0)))))
 835
 836 (define-type-method unbound-value ((type string))
 837   (declare (ignore type))
 838   nil)
 839
 840
 841 (define-type-method alien-type ((type pathname))
 842   (declare (ignore type))
 843   (alien-type 'string))
 844
 845 (define-type-method size-of ((type pathname))
 846   (declare (ignore type))
 847   (size-of 'string))
 848
 849 (define-type-method to-alien-form ((type pathname) path)
 850   (declare (ignore type))
 851   (to-alien-form 'string `(namestring (translate-logical-pathname ,path))))
 852
 853 (define-type-method to-alien-function ((type pathname))
 854   (declare (ignore type))
 855   (let ((string-function (to-alien-function 'string)))
 856     #'(lambda (path)
 857         (funcall string-function (namestring path)))))
 858
 859 (define-type-method from-alien-form ((type pathname) string)
 860   (declare (ignore type))
 861   `(parse-namestring ,(from-alien-form 'string string)))
 862
 863 (define-type-method from-alien-function ((type pathname))
 864   (declare (ignore type))
 865   (let ((string-function (from-alien-function 'string)))
 866     #'(lambda (string)
 867         (parse-namestring (funcall string-function string)))))
 868
 869 (define-type-method cleanup-form ((type pathnanme) string)
 870   (declare (ignore type))
 871   (cleanup-form 'string string))
 872
 873 (define-type-method cleanup-function ((type pathnanme))
 874   (declare (ignore type))
 875   (cleanup-function 'string))
 876
 877 (define-type-method writer-function ((type pathname))
 878   (declare (ignore type))
 879   (let ((string-writer (writer-function 'string)))
 880     #'(lambda (path location &optional (offset 0))
 881         (funcall string-writer (namestring path) location offset))))
 882
 883 (define-type-method reader-function ((type pathname))
 884   (declare (ignore type))
 885   (let ((string-reader (reader-function 'string)))
 886   #'(lambda (location &optional (offset 0) weak-p)
 887       (declare (ignore weak-p))
 888       (let ((string (funcall string-reader location offset)))
 889         (when string
 890           (parse-namestring string))))))
 891
 892 (define-type-method destroy-function ((type pathname))
 893   (declare (ignore type))
 894   (destroy-function 'string))
 895
 896 (define-type-method unbound-value ((type pathname))
 897   (declare (ignore type))
 898   (unbound-value 'string))
 899
 900
 901 (define-type-method alien-type ((type boolean))
 902   (destructuring-bind (&optional (size '*))
 903       (rest (mklist (type-expand-to 'boolean type)))
 904     (alien-type `(signed-byte ,size))))
 905
 906 (define-type-method size-of ((type boolean))
 907   (destructuring-bind (&optional (size '*))
 908       (rest (mklist (type-expand-to 'boolean type)))
 909     (size-of `(signed-byte ,size))))
 910
 911 (define-type-method to-alien-form ((type boolean) boolean)
 912   (declare (ignore type))
 913   `(if ,boolean 1 0))
 914
 915 (define-type-method to-alien-function ((type boolean))
 916   (declare (ignore type))
 917   #'(lambda (boolean)
 918       (if boolean 1 0)))
 919
 920 (define-type-method from-alien-form ((type boolean) boolean)
 921   (declare (ignore type))
 922   `(not (zerop ,boolean)))
 923
 924 (define-type-method from-alien-function ((type boolean))
 925   (declare (ignore type))
 926   #'(lambda (boolean)
 927       (not (zerop boolean))))
 928
 929 (define-type-method writer-function ((type boolean))
 930   (destructuring-bind (&optional (size '*))
 931       (rest (mklist (type-expand-to 'boolean type)))
 932     (let ((writer (writer-function `(signed-byte ,size))))
 933       #'(lambda (boolean location &optional (offset 0))
 934           (funcall writer (if boolean 1 0) location offset)))))
 935
 936 (define-type-method reader-function ((type boolean))
 937   (destructuring-bind (&optional (size '*))
 938       (rest (mklist (type-expand-to 'boolean type)))
 939     (let ((reader (reader-function `(signed-byte ,size))))
 940       #'(lambda (location &optional (offset 0) weak-p)
 941           (declare (ignore weak-p))
 942           (not (zerop (funcall reader location offset)))))))
 943
 944
 945 (define-type-method alien-type ((type or))
 946   (let* ((expanded-type (type-expand-to 'or type))
 947          (alien-type (alien-type (second expanded-type))))
 948     (unless (every #'(lambda (type)
 949                        (eq alien-type (alien-type type)))
 950                    (cddr expanded-type))
 951       (error "No common alien type specifier for union type: ~A" type))
 952     alien-type))
 953
 954 (define-type-method size-of ((type or))
 955   (size-of (second (type-expand-to 'or type))))
 956
 957 (define-type-method to-alien-form ((type or) form)
 958   `(let ((value ,form))
 959      (etypecase value
 960        ,@(mapcar
 961           #'(lambda (type)
 962               `(,type ,(to-alien-form type 'value)))
 963           (rest (type-expand-to 'or type))))))
 964
 965 (define-type-method to-alien-function ((type or))
 966   (let* ((expanded-type (type-expand-to 'or type))
 967          (functions (mapcar #'to-alien-function (rest expanded-type))))
 968     #'(lambda (value)
 969         (loop
 970          for function in functions
 971          for alt-type in (rest expanded-type)
 972          when (typep value alt-type)
 973          do (return (funcall function value))
 974          finally (error "~S is not of type ~A" value type)))))
 975
 976
 977 (define-type-method alien-type ((type pointer))
 978   (declare (ignore type))
 979   'system-area-pointer)
 980
 981 (define-type-method size-of ((type pointer))
 982   (declare (ignore type))
 983   +size-of-pointer+)
 984
 985 (define-type-method to-alien-form ((type pointer) form)
 986   (declare (ignore type))
 987   form)
 988
 989 (define-type-method to-alien-function ((type pointer))
 990   (declare (ignore type))
 991   #'identity)
 992
 993 (define-type-method from-alien-form ((type pointer) form)
 994   (declare (ignore type))
 995   form)
 996
 997 (define-type-method from-alien-function ((type pointer))
 998   (declare (ignore type))
 999   #'identity)
1000
1001 (define-type-method writer-function ((type pointer))
1002   (declare (ignore type))
1003   #'(lambda (sap location &optional (offset 0))
1004       (setf (sap-ref-sap location offset) sap)))
1005
1006 (define-type-method reader-function ((type pointer))
1007   (declare (ignore type))
1008   #'(lambda (location &optional (offset 0) weak-p)
1009       (declare (ignore weak-p))
1010       (sap-ref-sap location offset)))
1011
1012
1013 (define-type-method alien-type ((type null))
1014   (declare (ignore type))
1015   (alien-type 'pointer))
1016
1017 (define-type-method size-of ((type null))
1018   (declare (ignore type))
1019   (size-of 'pointer))
1020
1021 (define-type-method to-alien-form ((type null) null)
1022   (declare (ignore null type))
1023   `(make-pointer 0))
1024
1025 (define-type-method to-alien-function ((type null))
1026   (declare (ignore type))
1027   #'(lambda (null)
1028       (declare (ignore null))
1029       (make-pointer 0)))
1030
1031
1032 (define-type-method alien-type ((type nil))
1033   (declare (ignore type))
1034   'void)
1035
1036 (define-type-method from-alien-function ((type nil))
1037   (declare (ignore type))
1038   #'(lambda (value)
1039       (declare (ignore value))
1040       (values)))
1041
1042 (define-type-method to-alien-form ((type nil) form)
1043   (declare (ignore type))
1044   form)
1045
1046
1047 (define-type-method to-alien-form ((type copy-of) form)
1048   (copy-to-alien-form (second (type-expand-to 'copy-of type)) form))
1049
1050 (define-type-method to-alien-function ((type copy-of))
1051   (copy-to-alien-function (second (type-expand-to 'copy-of type))))
1052
1053 (define-type-method from-alien-form ((type copy-of) form)
1054   (copy-from-alien-form (second (type-expand-to 'copy-of type)) form))
1055
1056 (define-type-method from-alien-function ((type copy-of))
1057   (copy-from-alien-function (second (type-expand-to 'copy-of type))))
1058
1059 (define-type-method cleanup-function ((type copy-of))
1060   (declare (ignore type))
1061   #'identity)
1062
1063 (define-type-method destroy-function ((type copy-of))
1064   (declare (ignore type))
1065   #'(lambda (location &optional offset)
1066       (declare (ignore location offset))))
1067
1068
1069 (define-type-method alien-type ((type callback))
1070   (declare (ignore type))
1071   (alien-type 'pointer))
1072
1073 (define-type-method to-alien-form ((type callback) callback)
1074   (declare (ignore type ))
1075   `(callback-address ,callback))