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.26 2006-02-26 15:30:00 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     (delete-if #'(lambda (assoc) (eq (car assoc) package)) *package-prefix*)
  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        (setf (get ',name 'type-methods) (make-hash-table))
 352        (setf (get ',name 'built-in-type-hierarchy) ())
 353        (defun ,name ,lambda-list
 354          ,documentation
 355          (funcall
 356           (find-applicable-type-method ',name ,(first lambda-list))
 357           ,@lambda-list)))))
 358
 359
 360 (defmacro define-type-method (name lambda-list &body body)
 361   (let ((specifier (cadar lambda-list))
 362         (args (cons (caar lambda-list) (rest lambda-list))))
 363     `(progn
 364        (add-type-method ',name ',specifier #'(lambda ,args ,@body))
 365        ',name)))
 366
 367
 368
 369 ;;;; Definitons and translations of fundamental types
 370
 371 (define-type-generic alien-type (type-spec))
 372 (define-type-generic size-of (type-spec))
 373 (define-type-generic to-alien-form (type-spec form))
 374 (define-type-generic from-alien-form (type-spec form))
 375 (define-type-generic cleanup-form (type-spec form)
 376   "Creates a form to clean up after the alien call has finished.")
 377 (define-type-generic callback-from-alien-form (type-spec form))
 378 (define-type-generic callback-cleanup-form (type-spec form))
 379
 380 (define-type-generic to-alien-function (type-spec))
 381 (define-type-generic from-alien-function (type-spec))
 382 (define-type-generic cleanup-function (type-spec))
 383
 384 (define-type-generic copy-to-alien-form (type-spec form))
 385 (define-type-generic copy-to-alien-function (type-spec))
 386 (define-type-generic copy-from-alien-form (type-spec form))
 387 (define-type-generic copy-from-alien-function (type-spec))
 388 (define-type-generic writer-function (type-spec))
 389 (define-type-generic reader-function (type-spec))
 390 (define-type-generic destroy-function (type-spec))
 391
 392 (define-type-generic unbound-value (type-spec)
 393   "Returns a value which should be intepreted as unbound for slots with virtual allocation")
 394
 395
 396 ;; Sizes of fundamental C types in bytes (8 bits)
 397 (defconstant +size-of-short+ 2)
 398 (defconstant +size-of-int+ 4)
 399 (defconstant +size-of-long+ 4)
 400 (defconstant +size-of-pointer+ 4)
 401 (defconstant +size-of-float+ 4)
 402 (defconstant +size-of-double+ 8)
 403
 404 ;; Sizes of fundamental C types in bits
 405 (defconstant +bits-of-byte+ 8)
 406 (defconstant +bits-of-short+ 16)
 407 (defconstant +bits-of-int+ 32)
 408 (defconstant +bits-of-long+ 32)
 409
 410
 411 (deftype int () '(signed-byte #.+bits-of-int+))
 412 (deftype unsigned-int () '(unsigned-byte #.+bits-of-int+))
 413 (deftype long () '(signed-byte #.+bits-of-long+))
 414 (deftype unsigned-long () '(unsigned-byte #.+bits-of-long+))
 415 (deftype short () '(signed-byte #.+bits-of-short+))
 416 (deftype unsigned-short () '(unsigned-byte #.+bits-of-short+))
 417 (deftype signed (&optional (size '*)) `(signed-byte ,size))
 418 (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
 419 (deftype char () 'base-char)
 420 (deftype pointer () 'system-area-pointer)
 421 (deftype boolean (&optional (size '*)) (declare (ignore size)) t)
 422 (deftype copy-of (type) type)
 423
 424 (define-type-method alien-type ((type t))
 425   (error "No alien type corresponding to the type specifier ~A" type))
 426
 427 (define-type-method to-alien-form ((type t) form)
 428   (declare (ignore form))
 429   (error "Not a valid type specifier for arguments: ~A" type))
 430
 431 (define-type-method to-alien-function ((type t))
 432   (error "Not a valid type specifier for arguments: ~A" type))
 433
 434 (define-type-method from-alien-form ((type t) form)
 435   (declare (ignore form))
 436   (error "Not a valid type specifier for return values: ~A" type))
 437
 438 (define-type-method from-alien-function ((type t))
 439   (error "Not a valid type specifier for return values: ~A" type))
 440
 441 (define-type-method cleanup-form ((type t) form)
 442   (declare (ignore form type))
 443   nil)
 444
 445 (define-type-method cleanup-function ((type t))
 446   (declare (ignore type))
 447   #'identity)
 448
 449 (define-type-method callback-from-alien-form ((type t) form)
 450   (copy-from-alien-form type form))
 451
 452 (define-type-method callback-cleanup-form ((type t) form)
 453   (declare (ignore form type))
 454   nil)
 455
 456 (define-type-method destroy-function ((type t))
 457   (declare (ignore type))
 458   #'(lambda (location &optional offset)
 459       (declare (ignore location offset))))
 460
 461 (define-type-method copy-to-alien-form ((type t) form)
 462   (to-alien-form type form))
 463
 464 (define-type-method copy-to-alien-function ((type t))
 465   (to-alien-function type))
 466
 467 (define-type-method copy-from-alien-form ((type t) form)
 468   (from-alien-form type  form))
 469
 470 (define-type-method copy-from-alien-function ((type t))
 471   (from-alien-function type))
 472
 473
 474 (define-type-method to-alien-form ((type real) form)
 475   (declare (ignore type))
 476   form)
 477
 478 (define-type-method to-alien-function ((type real))
 479   (declare (ignore type))
 480   #'identity)
 481
 482 (define-type-method from-alien-form ((type real) form)
 483   (declare (ignore type))
 484   form)
 485
 486 (define-type-method from-alien-function ((type real))
 487   (declare (ignore type))
 488   #'identity)
 489
 490
 491 (define-type-method alien-type ((type integer))
 492   (declare (ignore type))
 493   (alien-type 'signed-byte))
 494
 495 (define-type-method size-of ((type integer))
 496   (declare (ignore type))
 497   (size-of 'signed-byte))
 498
 499 (define-type-method writer-function ((type integer))
 500   (declare (ignore type))
 501   (writer-function 'signed-byte))
 502
 503 (define-type-method reader-function ((type integer))
 504   (declare (ignore type))
 505   (reader-function 'signed-byte))
 506
 507
 508 (define-type-method alien-type ((type signed-byte))
 509   (destructuring-bind (&optional (size '*))
 510       (rest (mklist (type-expand-to 'signed-byte type)))
 511     (ecase size
 512       (#.+bits-of-byte+ #+cmu'(alien:signed 8) #+sbcl'(sb-alien:signed 8))
 513       (#.+bits-of-short+ #+cmu 'c-call:short #+sbcl 'sb-alien:short)
 514       ((* #.+bits-of-int+) #+cmu 'c-call:int #+sbcl 'sb-alien:int)
 515       (#.+bits-of-long+ #+cmu 'c-call:long #+sbcl 'sb-alien:long))))
 516
 517 (define-type-method size-of ((type signed-byte))
 518   (destructuring-bind (&optional (size '*))
 519       (rest (mklist (type-expand-to 'signed-byte type)))
 520     (ecase size
 521       (#.+bits-of-byte+ 1)
 522       (#.+bits-of-short+ +size-of-short+)
 523       ((* #.+bits-of-int+) +size-of-int+)
 524       (#.+bits-of-long+ +size-of-long+))))
 525
 526 (define-type-method writer-function ((type signed-byte))
 527   (destructuring-bind (&optional (size '*))
 528       (rest (mklist (type-expand-to 'signed-byte type)))
 529     (let ((size (if (eq size '*) +bits-of-int+ size)))
 530       (ecase size
 531         (8 #'(lambda (value location &optional (offset 0))
 532                (setf (signed-sap-ref-8 location offset) value)))
 533         (16 #'(lambda (value location &optional (offset 0))
 534                 (setf (signed-sap-ref-16 location offset) value)))
 535         (32 #'(lambda (value location &optional (offset 0))
 536                 (setf (signed-sap-ref-32 location offset) value)))
 537         (64 #'(lambda (value location &optional (offset 0))
 538                 (setf (signed-sap-ref-64 location offset) value)))))))
 539
 540 (define-type-method reader-function ((type signed-byte))
 541   (destructuring-bind (&optional (size '*))
 542       (rest (mklist (type-expand-to 'signed-byte type)))
 543     (let ((size (if (eq size '*) +bits-of-int+ size)))
 544       (ecase size
 545         (8 #'(lambda (sap &optional (offset 0) weak-p)
 546                (declare (ignore weak-p))
 547                (signed-sap-ref-8 sap offset)))
 548         (16 #'(lambda (sap &optional (offset 0) weak-p)
 549                 (declare (ignore weak-p))
 550                 (signed-sap-ref-16 sap offset)))
 551         (32 #'(lambda (sap &optional (offset 0) weak-p)
 552                 (declare (ignore weak-p))
 553                 (signed-sap-ref-32 sap offset)))
 554         (64 #'(lambda (sap &optional (offset 0) weak-p)
 555                 (declare (ignore weak-p))
 556                 (signed-sap-ref-64 sap offset)))))))
 557
 558
 559 (define-type-method alien-type ((type unsigned-byte))
 560   (destructuring-bind (&optional (size '*))
 561       (rest (mklist (type-expand-to 'unsigned-byte type)))
 562     (ecase size
 563       (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8))
 564       (#.+bits-of-short+ #+cmu 'c-call:unsigned-short
 565                          #+sbcl 'sb-alien:unsigned-short)
 566       ((* #.+bits-of-int+) #+cmu 'c-call:unsigned-int
 567                            #+sbcl 'sb-alien:unsigned-int)
 568       (#.+bits-of-long+ #+cmu 'c-call:unsigned-long
 569                         #+sbcl 'sb-alien:unsigned-long))))
 570
 571
 572 (define-type-method size-of ((type unsigned-byte))
 573   (destructuring-bind (&optional (size '*))
 574       (rest (mklist (type-expand-to 'unsigned-byte type)))
 575   (size-of `(signed ,size))))
 576
 577 (define-type-method writer-function ((type unsigned-byte))
 578   (destructuring-bind (&optional (size '*))
 579       (rest (mklist (type-expand-to 'unsigned-byte type)))
 580     (let ((size (if (eq size '*) +bits-of-int+ size)))
 581       (ecase size
 582         (8 #'(lambda (value location &optional (offset 0))
 583                (setf (sap-ref-8 location offset) value)))
 584         (16 #'(lambda (value location &optional (offset 0))
 585                 (setf (sap-ref-16 location offset) value)))
 586         (32 #'(lambda (value location &optional (offset 0))
 587                 (setf (sap-ref-32 location offset) value)))
 588         (64 #'(lambda (value location &optional (offset 0))
 589                 (setf (sap-ref-64 location offset) value)))))))
 590
 591 (define-type-method reader-function ((type unsigned-byte))
 592   (destructuring-bind (&optional (size '*))
 593       (rest (mklist (type-expand-to 'unsigned-byte type)))
 594     (let ((size (if (eq size '*) +bits-of-int+ size)))
 595       (ecase size
 596         (8 #'(lambda (sap &optional (offset 0) weak-p)
 597                (declare (ignore weak-p))
 598                (sap-ref-8 sap offset)))
 599         (16 #'(lambda (sap &optional (offset 0) weak-p)
 600                 (declare (ignore weak-p))
 601                 (sap-ref-16 sap offset)))
 602         (32 #'(lambda (sap &optional (offset 0) weak-p)
 603                 (declare (ignore weak-p))
 604                 (sap-ref-32 sap offset)))
 605         (64 #'(lambda (sap &optional (offset 0) weak-p)
 606                 (declare (ignore weak-p))
 607                 (sap-ref-64 sap offset)))))))
 608
 609 (define-type-method alien-type ((type single-float))
 610   (declare (ignore type))
 611   #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float)
 612
 613 (define-type-method size-of ((type single-float))
 614   (declare (ignore type))
 615   +size-of-float+)
 616
 617 (define-type-method to-alien-form ((type single-float) form)
 618   (declare (ignore type))
 619   `(coerce ,form 'single-float))
 620
 621 (define-type-method to-alien-function ((type single-float))
 622   (declare (ignore type))
 623   #'(lambda (number)
 624       (coerce number 'single-float)))
 625
 626 (define-type-method writer-function ((type single-float))
 627   (declare (ignore type))
 628   #'(lambda (value location &optional (offset 0))
 629       (setf (sap-ref-single location offset) (coerce value 'single-float))))
 630
 631 (define-type-method reader-function ((type single-float))
 632   (declare (ignore type))
 633   #'(lambda (sap &optional (offset 0) weak-p)
 634       (declare (ignore weak-p))
 635       (sap-ref-single sap offset)))
 636
 637
 638 (define-type-method alien-type ((type double-float))
 639   (declare (ignore type))
 640   #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float)
 641
 642 (define-type-method size-of ((type double-float))
 643   (declare (ignore type))
 644   +size-of-double+)
 645
 646 (define-type-method to-alien-form ((type double-float) form)
 647   (declare (ignore type))
 648   `(coerce ,form 'double-float))
 649
 650 (define-type-method to-alien-function ((type double-float))
 651   (declare (ignore type))
 652   #'(lambda (number)
 653       (coerce number 'double-float)))
 654
 655 (define-type-method writer-function ((type double-float))
 656   (declare (ignore type))
 657   #'(lambda (value location &optional (offset 0))
 658       (setf (sap-ref-double location offset) (coerce value 'double-float))))
 659
 660 (define-type-method reader-function ((type double-float))
 661   (declare (ignore type))
 662   #'(lambda (sap &optional (offset 0) weak-p)
 663       (declare (ignore weak-p))
 664       (sap-ref-double sap offset)))
 665
 666
 667 (define-type-method alien-type ((type base-char))
 668   (declare (ignore type))
 669   #+cmu 'c-call:char #+sbcl 'sb-alien:char)
 670
 671 (define-type-method size-of ((type base-char))
 672   (declare (ignore type))
 673   1)
 674
 675 (define-type-method to-alien-form ((type base-char) form)
 676   (declare (ignore type))
 677   form)
 678
 679 (define-type-method to-alien-function ((type base-char))
 680   (declare (ignore type))
 681   #'identity)
 682
 683 (define-type-method from-alien-form ((type base-char) form)
 684   (declare (ignore type))
 685   form)
 686
 687 (define-type-method from-alien-function ((type base-char))
 688   (declare (ignore type))
 689   #'identity)
 690
 691 (define-type-method writer-function ((type base-char))
 692   (declare (ignore type))
 693   #'(lambda (char location &optional (offset 0))
 694       (setf (sap-ref-8 location offset) (char-code char))))
 695
 696 (define-type-method reader-function ((type base-char))
 697   (declare (ignore type))
 698   #'(lambda (location &optional (offset 0) weak-p)
 699       (declare (ignore weak-p))
 700       (code-char (sap-ref-8 location offset))))
 701
 702
 703 (define-type-method alien-type ((type string))
 704   (declare (ignore type))
 705   (alien-type 'pointer))
 706
 707 (define-type-method size-of ((type string))
 708   (declare (ignore type))
 709   (size-of 'pointer))
 710
 711 (define-type-method to-alien-form ((type string) string)
 712   (declare (ignore type))
 713   `(let ((string ,string))
 714      ;; Always copy strings to prevent seg fault due to GC
 715      #+cmu
 716      (copy-memory
 717       (vector-sap (coerce string 'simple-base-string))
 718       (1+ (length string)))
 719      #+sbcl
 720      (let ((utf8 (%deport-utf8-string string)))
 721        (copy-memory (vector-sap utf8) (length utf8)))))
 722
 723 (define-type-method to-alien-function ((type string))
 724   (declare (ignore type))
 725   #'(lambda (string)
 726       #+cmu
 727       (copy-memory
 728        (vector-sap (coerce string 'simple-base-string))
 729        (1+ (length string)))
 730       #+sbcl
 731       (let ((utf8 (%deport-utf8-string string)))
 732         (copy-memory (vector-sap utf8) (length utf8)))))
 733
 734 (define-type-method from-alien-form ((type string) string)
 735   (declare (ignore type))
 736   `(let ((string ,string))
 737     (unless (null-pointer-p string)
 738       (prog1
 739           #+cmu(%naturalize-c-string string)
 740           #+sbcl(%naturalize-utf8-string string)
 741         (deallocate-memory string)))))
 742
 743 (define-type-method from-alien-function ((type string))
 744   (declare (ignore type))
 745   #'(lambda (string)
 746       (unless (null-pointer-p string)
 747         (prog1
 748             #+cmu(%naturalize-c-string string)
 749             #+sbcl(%naturalize-utf8-string string)
 750           (deallocate-memory string)))))
 751
 752 (define-type-method cleanup-form ((type string) string)
 753   (declare (ignore type))
 754   `(let ((string ,string))
 755     (unless (null-pointer-p string)
 756       (deallocate-memory string))))
 757
 758 (define-type-method cleanup-function ((type string))
 759   (declare (ignore type))
 760   #'(lambda (string)
 761       (unless (null-pointer-p string)
 762         (deallocate-memory string))))
 763
 764 (define-type-method copy-from-alien-form ((type string) string)
 765   (declare (ignore type))
 766   `(let ((string ,string))
 767     (unless (null-pointer-p string)
 768       #+cmu(%naturalize-c-string string)
 769       #+sbcl(%naturalize-utf8-string string))))
 770
 771 (define-type-method copy-from-alien-function ((type string))
 772   (declare (ignore type))
 773   #'(lambda (string)
 774       (unless (null-pointer-p string)
 775         #+cmu(%naturalize-c-string string)
 776         #+sbcl(%naturalize-utf8-string string))))
 777
 778 (define-type-method writer-function ((type string))
 779   (declare (ignore type))
 780   #'(lambda (string location &optional (offset 0))
 781       (assert (null-pointer-p (sap-ref-sap location offset)))
 782       (setf (sap-ref-sap location offset)
 783        #+cmu
 784        (copy-memory
 785         (vector-sap (coerce string 'simple-base-string))
 786         (1+ (length string)))
 787        #+sbcl
 788        (let ((utf8 (%deport-utf8-string string)))
 789          (copy-memory (vector-sap utf8) (length utf8))))))
 790
 791 (define-type-method reader-function ((type string))
 792   (declare (ignore type))
 793   #'(lambda (location &optional (offset 0) weak-p)
 794       (declare (ignore weak-p))
 795       (unless (null-pointer-p (sap-ref-sap location offset))
 796         #+cmu(%naturalize-c-string (sap-ref-sap location offset))
 797         #+sbcl(%naturalize-utf8-string (sap-ref-sap location offset)))))
 798
 799 (define-type-method destroy-function ((type string))
 800   (declare (ignore type))
 801   #'(lambda (location &optional (offset 0))
 802       (unless (null-pointer-p (sap-ref-sap location offset))
 803         (deallocate-memory (sap-ref-sap location offset))
 804         (setf (sap-ref-sap location offset) (make-pointer 0)))))
 805
 806 (define-type-method unbound-value ((type string))
 807   (declare (ignore type))
 808   nil)
 809
 810
 811 (define-type-method alien-type ((type pathname))
 812   (declare (ignore type))
 813   (alien-type 'string))
 814
 815 (define-type-method size-of ((type pathname))
 816   (declare (ignore type))
 817   (size-of 'string))
 818
 819 (define-type-method to-alien-form ((type pathname) path)
 820   (declare (ignore type))
 821   (to-alien-form 'string `(namestring (translate-logical-pathname ,path))))
 822
 823 (define-type-method to-alien-function ((type pathname))
 824   (declare (ignore type))
 825   (let ((string-function (to-alien-function 'string)))
 826     #'(lambda (path)
 827         (funcall string-function (namestring path)))))
 828
 829 (define-type-method from-alien-form ((type pathname) string)
 830   (declare (ignore type))
 831   `(parse-namestring ,(from-alien-form 'string string)))
 832
 833 (define-type-method from-alien-function ((type pathname))
 834   (declare (ignore type))
 835   (let ((string-function (from-alien-function 'string)))
 836     #'(lambda (string)
 837         (parse-namestring (funcall string-function string)))))
 838
 839 (define-type-method cleanup-form ((type pathnanme) string)
 840   (declare (ignore type))
 841   (cleanup-form 'string string))
 842
 843 (define-type-method cleanup-function ((type pathnanme))
 844   (declare (ignore type))
 845   (cleanup-function 'string))
 846
 847 (define-type-method writer-function ((type pathname))
 848   (declare (ignore type))
 849   (let ((string-writer (writer-function 'string)))
 850     #'(lambda (path location &optional (offset 0))
 851         (funcall string-writer (namestring path) location offset))))
 852
 853 (define-type-method reader-function ((type pathname))
 854   (declare (ignore type))
 855   (let ((string-reader (reader-function 'string)))
 856   #'(lambda (location &optional (offset 0) weak-p)
 857       (declare (ignore weak-p))
 858       (let ((string (funcall string-reader location offset)))
 859         (when string
 860           (parse-namestring string))))))
 861
 862 (define-type-method destroy-function ((type pathname))
 863   (declare (ignore type))
 864   (destroy-function 'string))
 865
 866 (define-type-method unbound-value ((type pathname))
 867   (declare (ignore type))
 868   (unbound-value 'string))
 869
 870
 871 (define-type-method alien-type ((type boolean))
 872   (destructuring-bind (&optional (size '*))
 873       (rest (mklist (type-expand-to 'boolean type)))
 874     (alien-type `(signed-byte ,size))))
 875
 876 (define-type-method size-of ((type boolean))
 877   (destructuring-bind (&optional (size '*))
 878       (rest (mklist (type-expand-to 'boolean type)))
 879     (size-of `(signed-byte ,size))))
 880
 881 (define-type-method to-alien-form ((type boolean) boolean)
 882   (declare (ignore type))
 883   `(if ,boolean 1 0))
 884
 885 (define-type-method to-alien-function ((type boolean))
 886   (declare (ignore type))
 887   #'(lambda (boolean)
 888       (if boolean 1 0)))
 889
 890 (define-type-method from-alien-form ((type boolean) boolean)
 891   (declare (ignore type))
 892   `(not (zerop ,boolean)))
 893
 894 (define-type-method from-alien-function ((type boolean))
 895   (declare (ignore type))
 896   #'(lambda (boolean)
 897       (not (zerop boolean))))
 898
 899 (define-type-method writer-function ((type boolean))
 900   (destructuring-bind (&optional (size '*))
 901       (rest (mklist (type-expand-to 'boolean type)))
 902     (let ((writer (writer-function `(signed-byte ,size))))
 903       #'(lambda (boolean location &optional (offset 0))
 904           (funcall writer (if boolean 1 0) location offset)))))
 905
 906 (define-type-method reader-function ((type boolean))
 907   (destructuring-bind (&optional (size '*))
 908       (rest (mklist (type-expand-to 'boolean type)))
 909     (let ((reader (reader-function `(signed-byte ,size))))
 910       #'(lambda (location &optional (offset 0) weak-p)
 911           (declare (ignore weak-p))
 912           (not (zerop (funcall reader location offset)))))))
 913
 914
 915 (define-type-method alien-type ((type or))
 916   (let* ((expanded-type (type-expand-to 'or type))
 917          (alien-type (alien-type (second expanded-type))))
 918     (unless (every #'(lambda (type)
 919                        (eq alien-type (alien-type type)))
 920                    (cddr expanded-type))
 921       (error "No common alien type specifier for union type: ~A" type))
 922     alien-type))
 923
 924 (define-type-method size-of ((type or))
 925   (size-of (second (type-expand-to 'or type))))
 926
 927 (define-type-method to-alien-form ((type or) form)
 928   `(let ((value ,form))
 929      (etypecase value
 930        ,@(mapcar
 931           #'(lambda (type)
 932               `(,type ,(to-alien-form type 'value)))
 933           (rest (type-expand-to 'or type))))))
 934
 935 (define-type-method to-alien-function ((type or))
 936   (let* ((expanded-type (type-expand-to 'or type))
 937          (functions (mapcar #'to-alien-function (rest expanded-type))))
 938     #'(lambda (value)
 939         (loop
 940          for function in functions
 941          for alt-type in (rest expanded-type)
 942          when (typep value alt-type)
 943          do (return (funcall function value))
 944          finally (error "~S is not of type ~A" value type)))))
 945
 946
 947 (define-type-method alien-type ((type pointer))
 948   (declare (ignore type))
 949   'system-area-pointer)
 950
 951 (define-type-method size-of ((type pointer))
 952   (declare (ignore type))
 953   +size-of-pointer+)
 954
 955 (define-type-method to-alien-form ((type pointer) form)
 956   (declare (ignore type))
 957   form)
 958
 959 (define-type-method to-alien-function ((type pointer))
 960   (declare (ignore type))
 961   #'identity)
 962
 963 (define-type-method from-alien-form ((type pointer) form)
 964   (declare (ignore type))
 965   form)
 966
 967 (define-type-method from-alien-function ((type pointer))
 968   (declare (ignore type))
 969   #'identity)
 970
 971 (define-type-method writer-function ((type pointer))
 972   (declare (ignore type))
 973   #'(lambda (sap location &optional (offset 0))
 974       (setf (sap-ref-sap location offset) sap)))
 975
 976 (define-type-method reader-function ((type pointer))
 977   (declare (ignore type))
 978   #'(lambda (location &optional (offset 0) weak-p)
 979       (declare (ignore weak-p))
 980       (sap-ref-sap location offset)))
 981
 982
 983 (define-type-method alien-type ((type null))
 984   (declare (ignore type))
 985   (alien-type 'pointer))
 986
 987 (define-type-method size-of ((type null))
 988   (declare (ignore type))
 989   (size-of 'pointer))
 990
 991 (define-type-method to-alien-form ((type null) null)
 992   (declare (ignore null type))
 993   `(make-pointer 0))
 994
 995 (define-type-method to-alien-function ((type null))
 996   (declare (ignore type))
 997   #'(lambda (null)
 998       (declare (ignore null))
 999       (make-pointer 0)))
1000
1001
1002 (define-type-method alien-type ((type nil))
1003   (declare (ignore type))
1004   'void)
1005
1006 (define-type-method from-alien-function ((type nil))
1007   (declare (ignore type))
1008   #'(lambda (value)
1009       (declare (ignore value))
1010       (values)))
1011
1012 (define-type-method to-alien-form ((type nil) form)
1013   (declare (ignore type))
1014   form)
1015
1016
1017 (define-type-method to-alien-form ((type copy-of) form)
1018   (copy-to-alien-form (second (type-expand-to 'copy-of type)) form))
1019
1020 (define-type-method to-alien-function ((type copy-of))
1021   (copy-to-alien-function (second (type-expand-to 'copy-of type))))
1022
1023 (define-type-method from-alien-form ((type copy-of) form)
1024   (copy-from-alien-form (second (type-expand-to 'copy-of type)) form))
1025
1026 (define-type-method from-alien-function ((type copy-of))
1027   (copy-from-alien-function (second (type-expand-to 'copy-of type))))
1028
1029
1030 (define-type-method alien-type ((type callback))
1031   (declare (ignore type))
1032   (alien-type 'pointer))
1033
1034 (define-type-method to-alien-form ((type callback) callback)
1035   (declare (ignore type ))
1036   `(callback-address ,callback))