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