mdw@git.distorted.org.uk Git - clg/blob - glib/ffi.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
   3 ;;
   4 ;; This library is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the GNU Lesser General Public
   6 ;; License as published by the Free Software Foundation; either
   7 ;; version 2 of the License, or (at your option) any later version.
   8 ;;
   9 ;; This library is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;; Lesser General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU Lesser General Public
  15 ;; License along with this library; if not, write to the Free Software
  16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18 ;; $Id: ffi.lisp,v 1.13 2005-02-03 23:09:03 espen Exp $
  19
  20 (in-package "GLIB")
  21
  22
  23 ;;;; Foreign function call interface
  24
  25 (defvar *package-prefix* nil)
  26
  27 (defun set-package-prefix (prefix &optional (package *package*))
  28   (let ((package (find-package package)))
  29     (delete-if #'(lambda (assoc) (eq (car assoc) package)) *package-prefix*)
  30     (push (cons package prefix) *package-prefix*))
  31   prefix)
  32
  33 (defun package-prefix (&optional (package *package*))
  34   (let ((package (find-package package)))
  35     (or
  36      (cdr (assoc package *package-prefix*))
  37      (substitute #\_ #\- (string-downcase (package-name package))))))
  38
  39 (defun find-prefix-package (prefix)
  40   (or
  41    (car (rassoc (string-downcase prefix) *package-prefix* :test #'string=))
  42    (find-package (string-upcase prefix))))
  43
  44 (defmacro use-prefix (prefix &optional (package *package*))
  45   `(eval-when (:compile-toplevel :load-toplevel :execute)
  46      (set-package-prefix ,prefix ,package)))
  47
  48
  49 (defun default-alien-fname (lisp-name)
  50   (let* ((name (substitute #\_ #\- (string-downcase lisp-name)))
  51          (stripped-name
  52           (cond
  53            ((and
  54              (char= (char name 0) #\%)
  55              (string= "_p" name :start2 (- (length name) 2)))
  56             (subseq name 1 (- (length name) 2)))
  57            ((char= (char name 0) #\%)
  58             (subseq name 1))
  59            ((string= "_p" name :start2 (- (length name) 2))
  60             (subseq name 0 (- (length name) 2)))
  61            (name)))
  62          (prefix (package-prefix *package*)))
  63     (if (or (not prefix) (string= prefix ""))
  64         stripped-name
  65       (format nil "~A_~A" prefix stripped-name))))
  66
  67 (defun default-alien-type-name (type-name)
  68   (let ((prefix (package-prefix *package*)))
  69     (apply
  70      #'concatenate
  71      'string
  72      (mapcar
  73       #'string-capitalize
  74       (cons prefix (split-string (symbol-name type-name) #\-))))))
  75
  76 (defun default-type-name (alien-name)
  77   (let ((parts
  78          (mapcar
  79           #'string-upcase
  80           (split-string-if alien-name #'upper-case-p))))
  81     (intern
  82      (concatenate-strings
  83       (rest parts) #\-) (find-prefix-package (first parts)))))
  84
  85
  86 (defmacro defbinding (name lambda-list return-type &rest docs/args)
  87   (multiple-value-bind (lisp-name c-name)
  88       (if (atom name)
  89           (values name (default-alien-fname name))
  90         (values-list name))
  91
  92     (let ((supplied-lambda-list lambda-list)
  93           (docs nil)
  94           (args nil))
  95       (dolist (doc/arg docs/args)
  96         (if (stringp doc/arg)
  97             (push doc/arg docs)
  98           (progn
  99             (destructuring-bind (expr type &optional (style :in)) doc/arg
 100               (unless (member style '(:in :out :in-out :return))
 101                 (error "Bogus argument style ~S in ~S." style doc/arg))
 102               (when (and
 103                      (not supplied-lambda-list)
 104                      (namep expr) (member style '(:in :in-out :return)))
 105                 (push expr lambda-list))
 106               (push (list (cond
 107                            ((and (namep expr) (eq style :out)) expr)
 108                            ((namep expr) (make-symbol (string expr)))
 109                            ((gensym)))
 110                           expr (mklist type) style) args)))))
 111
 112       (%defbinding
 113        c-name lisp-name (or supplied-lambda-list (nreverse lambda-list))
 114        return-type (reverse docs) (reverse args)))))
 115
 116 #+(or cmu sbcl)
 117 (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args)
 118   (collect ((alien-types) (alien-bindings) (alien-parameters)
 119             (return-values) (cleanup-forms))
 120     (dolist (arg args)
 121       (destructuring-bind (var expr type style) arg
 122         (let ((declaration (alien-type type))
 123               (cleanup (cleanup-form var type)))
 124
 125           (cond
 126             ((member style '(:out :in-out))
 127              (alien-types `(* ,declaration))
 128              (alien-parameters `(addr ,var))
 129              (alien-bindings
 130               `(,var ,declaration
 131                 ,@(when (eq style :in-out)
 132                     (list (to-alien-form expr type)))))
 133              (return-values (from-alien-form var type)))
 134             ((eq style :return)
 135              (alien-types declaration)
 136              (alien-bindings
 137               `(,var ,declaration ,(to-alien-form expr type)))
 138              (alien-parameters var)
 139              (return-values (from-alien-form var type)))
 140             (cleanup
 141              (alien-types declaration)
 142              (alien-bindings
 143               `(,var ,declaration ,(to-alien-form expr type)))
 144              (alien-parameters var)
 145              (cleanup-forms cleanup))
 146             (t
 147              (alien-types declaration)
 148              (alien-parameters (to-alien-form expr type)))))))
 149
 150     (let* ((alien-name (make-symbol (string lisp-name)))
 151            (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters))))
 152       `(defun ,lisp-name ,lambda-list
 153          ,@docs
 154          #+cmu(declare (optimize (inhibit-warnings 3)))
 155          #+sbcl(declare (muffle-conditions compiler-note))
 156          (with-alien ((,alien-name
 157                        (function
 158                         ,(alien-type return-type)
 159                         ,@(alien-types))
 160                        :extern ,foreign-name)
 161                       ,@(alien-bindings))
 162            ,(if return-type
 163                 `(values
 164                   (unwind-protect
 165                       ,(from-alien-form alien-funcall return-type)
 166                     ,@(cleanup-forms))
 167                   ,@(return-values))
 168               `(progn
 169                 (unwind-protect
 170                      ,alien-funcall
 171                   ,@(cleanup-forms))
 172                 (values ,@(return-values)))))))))
 173
 174
 175 ;;; Creates bindings at runtime
 176 (defun mkbinding (name return-type &rest arg-types)
 177   #+cmu(declare (optimize (inhibit-warnings 3)))
 178   #+sbcl(declare (muffle-conditions compiler-note))
 179   (let* ((ftype
 180           `(function ,@(mapcar #'alien-type (cons return-type arg-types))))
 181          (alien
 182           (%heap-alien
 183            (make-heap-alien-info
 184             :type (parse-alien-type ftype #+sbcl nil)
 185             :sap-form (foreign-symbol-address name))))
 186          (translate-arguments (mapcar #'to-alien-function arg-types))
 187          (translate-return-value (from-alien-function return-type))
 188          (cleanup-arguments (mapcar #'cleanup-function arg-types)))
 189
 190     #'(lambda (&rest args)
 191         (map-into args #'funcall translate-arguments args)
 192         (prog1
 193             (funcall translate-return-value
 194              (apply #'alien-funcall alien args))
 195           (mapc #'funcall cleanup-arguments args)))))
 196
 197
 198 (defmacro defcallback (name (return-type &rest args) &body body)
 199   (let ((def-callback #+cmu'alien:def-callback
 200                       #+sbcl'sb-alien:define-alien-function))
 201     `(,def-callback ,name
 202          (,(alien-type return-type)
 203           ,@(mapcar #'(lambda (arg)
 204                         (destructuring-bind (name type) arg
 205                           `(,name ,(alien-type type))))
 206                     args))
 207        ,(to-alien-form
 208          `(let (,@(mapcar #'(lambda (arg)
 209                               (destructuring-bind (name type) arg
 210                                 `(,name ,(from-alien-form name type))))
 211                           args))
 212             ,@body)
 213          return-type))))
 214
 215 #+sbcl
 216 (defun callback (af)
 217   (sb-alien:alien-function-sap af))
 218
 219
 220 ;;;; Definitons and translations of fundamental types
 221
 222 (defmacro def-type-method (name args &optional documentation)
 223   `(progn
 224     (defgeneric ,name (,@args type &rest args)
 225       ,@(when documentation `((:documentation ,documentation))))
 226     (defmethod ,name (,@args (type symbol) &rest args)
 227       (let ((class (find-class type nil)))
 228         (if class
 229             (apply #',name ,@args class args)
 230           (multiple-value-bind (super-type expanded-p)
 231               (type-expand-1 (cons type args))
 232             (if expanded-p
 233                 (,name ,@args super-type)
 234               (call-next-method))))))
 235     (defmethod ,name (,@args (type cons) &rest args)
 236       (declare (ignore args))
 237       (apply #',name ,@args (first type) (rest type)))))
 238
 239
 240 (def-type-method alien-type ())
 241 (def-type-method size-of ())
 242 (def-type-method to-alien-form (form))
 243 (def-type-method from-alien-form (form))
 244 (def-type-method cleanup-form (form)
 245   "Creates a form to clean up after the alien call has finished.")
 246
 247 (def-type-method to-alien-function ())
 248 (def-type-method from-alien-function ())
 249 (def-type-method cleanup-function ())
 250
 251 (def-type-method copy-to-alien-form (form))
 252 (def-type-method copy-to-alien-function ())
 253 (def-type-method copy-from-alien-form (form))
 254 (def-type-method copy-from-alien-function ())
 255
 256 (def-type-method writer-function ())
 257 (def-type-method reader-function ())
 258 (def-type-method destroy-function ())
 259
 260 (def-type-method unbound-value ()
 261   "First return value is true if the type has an unbound value, second return value is the actual unbound value")
 262
 263
 264 ;; Sizes of fundamental C types in bytes (8 bits)
 265 (defconstant +size-of-short+ 2)
 266 (defconstant +size-of-int+ 4)
 267 (defconstant +size-of-long+ 4)
 268 (defconstant +size-of-pointer+ 4)
 269 (defconstant +size-of-float+ 4)
 270 (defconstant +size-of-double+ 8)
 271
 272 ;; Sizes of fundamental C types in bits
 273 (defconstant +bits-of-byte+ 8)
 274 (defconstant +bits-of-short+ 16)
 275 (defconstant +bits-of-int+ 32)
 276 (defconstant +bits-of-long+ 32)
 277
 278
 279 (deftype int () '(signed-byte #.+bits-of-int+))
 280 (deftype unsigned-int () '(unsigned-byte #.+bits-of-int+))
 281 (deftype long () '(signed-byte #.+bits-of-long+))
 282 (deftype unsigned-long () '(unsigned-byte #.+bits-of-long+))
 283 (deftype short () '(signed-byte #.+bits-of-short+))
 284 (deftype unsigned-short () '(unsigned-byte #.+bits-of-short+))
 285 (deftype signed (&optional (size '*)) `(signed-byte ,size))
 286 (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
 287 (deftype char () 'base-char)
 288 (deftype pointer () 'system-area-pointer)
 289 (deftype boolean (&optional (size '*)) (declare (ignore size)) `(member t nil))
 290 ;(deftype invalid () nil)
 291
 292
 293 (defmethod to-alien-form (form (type t) &rest args)
 294   (declare (ignore type args))
 295   form)
 296
 297 (defmethod to-alien-function ((type t) &rest args)
 298   (declare (ignore type args))
 299   #'identity)
 300
 301 (defmethod from-alien-form (form (type t) &rest args)
 302   (declare (ignore type args))
 303   form)
 304
 305 (defmethod from-alien-function ((type t) &rest args)
 306   (declare (ignore type args))
 307   #'identity)
 308
 309 (defmethod cleanup-form (form (type t) &rest args)
 310   (declare (ignore form type args))
 311   nil)
 312
 313 (defmethod cleanup-function ((type t) &rest args)
 314   (declare (ignore type args))
 315   #'identity)
 316
 317 (defmethod destroy-function ((type t) &rest args)
 318   (declare (ignore type args))
 319   #'(lambda (location &optional offset)
 320       (declare (ignore location offset))))
 321
 322 (defmethod copy-to-alien-form  (form (type t) &rest args)
 323   (apply #'to-alien-form form type args))
 324
 325 (defmethod copy-to-alien-function  ((type t) &rest args)
 326   (apply #'to-alien-function type args))
 327
 328 (defmethod copy-from-alien-form  (form (type t) &rest args)
 329   (apply #'from-alien-form form type args))
 330
 331 (defmethod copy-from-alien-function  ((type t) &rest args)
 332   (apply #'from-alien-function type args))
 333
 334
 335 (defmethod alien-type ((type (eql 'signed-byte)) &rest args)
 336   (declare (ignore type))
 337   (destructuring-bind (&optional (size '*)) args
 338     (ecase size
 339       (#.+bits-of-byte+ #+cmu'(alien:signed 8) #+sbcl'(sb-alien:signed 8))
 340       (#.+bits-of-short+ #+cmu 'c-call:short #+sbcl 'sb-alien:short)
 341       ((* #.+bits-of-int+) #+cmu 'c-call:int #+sbcl 'sb-alien:int)
 342       (#.+bits-of-long+ #+cmu 'c-call:long #+sbcl 'sb-alien:long))))
 343
 344 (defmethod size-of ((type (eql 'signed-byte)) &rest args)
 345   (declare (ignore type))
 346   (destructuring-bind (&optional (size '*)) args
 347     (ecase size
 348       (#.+bits-of-byte+ 1)
 349       (#.+bits-of-short+ +size-of-short+)
 350       ((* #.+bits-of-int+) +size-of-int+)
 351       (#.+bits-of-long+ +size-of-long+))))
 352
 353 (defmethod unbound-value ((type t) &rest args)
 354   (declare (ignore type args))
 355   nil)
 356
 357 (defmethod writer-function ((type (eql 'signed-byte)) &rest args)
 358   (declare (ignore type))
 359   (destructuring-bind (&optional (size '*)) args
 360     (let ((size (if (eq size '*) +bits-of-int+ size)))
 361       (ecase size
 362         (8 #'(lambda (value location &optional (offset 0))
 363                (setf (signed-sap-ref-8 location offset) value)))
 364         (16 #'(lambda (value location &optional (offset 0))
 365                 (setf (signed-sap-ref-16 location offset) value)))
 366         (32 #'(lambda (value location &optional (offset 0))
 367                 (setf (signed-sap-ref-32 location offset) value)))
 368         (64 #'(lambda (value location &optional (offset 0))
 369                 (setf (signed-sap-ref-64 location offset) value)))))))
 370
 371 (defmethod reader-function ((type (eql 'signed-byte)) &rest args)
 372   (declare (ignore type))
 373   (destructuring-bind (&optional (size '*)) args
 374     (let ((size (if (eq size '*) +bits-of-int+ size)))
 375       (ecase size
 376         (8 #'(lambda (sap &optional (offset 0))
 377                (signed-sap-ref-8 sap offset)))
 378         (16 #'(lambda (sap &optional (offset 0))
 379                 (signed-sap-ref-16 sap offset)))
 380         (32 #'(lambda (sap &optional (offset 0))
 381                 (signed-sap-ref-32 sap offset)))
 382         (64 #'(lambda (sap &optional (offset 0))
 383                 (signed-sap-ref-64 sap offset)))))))
 384
 385 (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args)
 386   (destructuring-bind (&optional (size '*)) args
 387     (ecase size
 388       (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8))
 389       (#.+bits-of-short+ #+cmu 'c-call:unsigned-short
 390                          #+sbcl 'sb-alien:unsigned-short)
 391       ((* #.+bits-of-int+) #+cmu 'c-call:unsigned-int
 392                            #+sbcl 'sb-alien:unsigned-int)
 393       (#.+bits-of-long+ #+cmu 'c-call:unsigned-long
 394                         #+sbcl 'sb-alien:unsigned-long))))
 395
 396 (defmethod size-of ((type (eql 'unsigned-byte)) &rest args)
 397   (apply #'size-of 'signed args))
 398
 399 (defmethod writer-function ((type (eql 'unsigned-byte)) &rest args)
 400   (declare (ignore type))
 401   (destructuring-bind (&optional (size '*)) args
 402     (let ((size (if (eq size '*) +bits-of-int+ size)))
 403       (ecase size
 404         (8 #'(lambda (value location &optional (offset 0))
 405                (setf (sap-ref-8 location offset) value)))
 406         (16 #'(lambda (value location &optional (offset 0))
 407                 (setf (sap-ref-16 location offset) value)))
 408         (32 #'(lambda (value location &optional (offset 0))
 409                 (setf (sap-ref-32 location offset) value)))
 410         (64 #'(lambda (value location &optional (offset 0))
 411                 (setf (sap-ref-64 location offset) value)))))))
 412
 413 (defmethod reader-function ((type (eql 'unsigned-byte)) &rest args)
 414   (declare (ignore type))
 415   (destructuring-bind (&optional (size '*)) args
 416     (let ((size (if (eq size '*) +bits-of-int+ size)))
 417       (ecase size
 418         (8 #'(lambda (sap &optional (offset 0))
 419                (sap-ref-8 sap offset)))
 420         (16 #'(lambda (sap &optional (offset 0))
 421                 (sap-ref-16 sap offset)))
 422         (32 #'(lambda (sap &optional (offset 0))
 423                 (sap-ref-32 sap offset)))
 424         (64 #'(lambda (sap &optional (offset 0))
 425                 (sap-ref-64 sap offset)))))))
 426
 427
 428 (defmethod alien-type ((type (eql 'integer)) &rest args)
 429   (declare (ignore type args))
 430   (alien-type 'signed-byte))
 431
 432 (defmethod size-of ((type (eql 'integer)) &rest args)
 433   (declare (ignore type args))
 434   (size-of 'signed-byte))
 435
 436 (defmethod writer-function ((type (eql 'integer)) &rest args)
 437   (declare (ignore type args))
 438   (writer-function 'signed-byte))
 439
 440 (defmethod reader-function ((type (eql 'integer)) &rest args)
 441   (declare (ignore type args))
 442   (reader-function 'signed-byte))
 443
 444
 445 (defmethod alien-type ((type (eql 'fixnum)) &rest args)
 446   (declare (ignore type args))
 447   (alien-type 'signed-byte))
 448
 449 (defmethod size-of ((type (eql 'fixnum)) &rest args)
 450   (declare (ignore type args))
 451   (size-of 'signed-byte))
 452
 453
 454 (defmethod alien-type ((type (eql 'single-float)) &rest args)
 455   (declare (ignore type args))
 456   #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float)
 457
 458 (defmethod size-of ((type (eql 'single-float)) &rest args)
 459   (declare (ignore type args))
 460   +size-of-float+)
 461
 462 (defmethod writer-function ((type (eql 'single-float)) &rest args)
 463   (declare (ignore type args))
 464   #'(lambda (value location &optional (offset 0))
 465       (setf (sap-ref-single location offset) (coerce value 'single-float))))
 466
 467 (defmethod reader-function ((type (eql 'single-float)) &rest args)
 468   (declare (ignore type args))
 469   #'(lambda (sap &optional (offset 0))
 470       (sap-ref-single sap offset)))
 471
 472
 473 (defmethod alien-type ((type (eql 'double-float)) &rest args)
 474   (declare (ignore type args))
 475   #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float)
 476
 477 (defmethod size-of ((type (eql 'double-float)) &rest args)
 478   (declare (ignore type args))
 479   +size-of-double+)
 480
 481 (defmethod writer-function ((type (eql 'double-float)) &rest args)
 482   (declare (ignore type args))
 483   #'(lambda (value location &optional (offset 0))
 484       (setf (sap-ref-double location offset) (coerce value 'double-float))))
 485
 486 (defmethod reader-function ((type (eql 'double-float)) &rest args)
 487   (declare (ignore type args))
 488   #'(lambda (sap &optional (offset 0))
 489       (sap-ref-double sap offset)))
 490
 491
 492 (defmethod alien-type ((type (eql 'base-char)) &rest args)
 493   (declare (ignore type args))
 494   #+cmu 'c-call:char #+sbcl 'sb-alien:char)
 495
 496 (defmethod size-of ((type (eql 'base-char)) &rest args)
 497   (declare (ignore type args))
 498   1)
 499
 500 (defmethod writer-function ((type (eql 'base-char)) &rest args)
 501   (declare (ignore type args))
 502   #'(lambda (char location &optional (offset 0))
 503       (setf (sap-ref-8 location offset) (char-code char))))
 504
 505 (defmethod reader-function ((type (eql 'base-char)) &rest args)
 506   (declare (ignore type args))
 507   #'(lambda (location &optional (offset 0))
 508       (code-char (sap-ref-8 location offset))))
 509
 510
 511 (defmethod alien-type ((type (eql 'string)) &rest args)
 512   (declare (ignore type args))
 513   (alien-type 'pointer))
 514
 515 (defmethod size-of ((type (eql 'string)) &rest args)
 516   (declare (ignore type args))
 517   (size-of 'pointer))
 518
 519 (defmethod to-alien-form (string (type (eql 'string)) &rest args)
 520   (declare (ignore type args))
 521   `(let ((string ,string))
 522      ;; Always copy strings to prevent seg fault due to GC
 523      (copy-memory
 524       (vector-sap (coerce string 'simple-base-string))
 525       (1+ (length string)))))
 526
 527 (defmethod to-alien-function ((type (eql 'string)) &rest args)
 528   (declare (ignore type args))
 529   #'(lambda (string)
 530       (copy-memory
 531        (vector-sap (coerce string 'simple-base-string))
 532        (1+ (length string)))))
 533
 534 (defmethod from-alien-form (string (type (eql 'string)) &rest args)
 535   (declare (ignore type args))
 536   `(let ((string ,string))
 537     (unless (null-pointer-p string)
 538       (prog1
 539           (%naturalize-c-string string)
 540         (deallocate-memory string)))))
 541
 542 (defmethod from-alien-function ((type (eql 'string)) &rest args)
 543   (declare (ignore type args))
 544   #'(lambda (string)
 545       (unless (null-pointer-p string)
 546         (prog1
 547             (%naturalize-c-string string)
 548           (deallocate-memory string)))))
 549
 550 (defmethod cleanup-form (string (type (eql 'string)) &rest args)
 551   (declare (ignore type args))
 552   `(let ((string ,string))
 553     (unless (null-pointer-p string)
 554       (deallocate-memory string))))
 555
 556 (defmethod cleanup-function ((type (eql 'string)) &rest args)
 557   (declare (ignore args))
 558   #'(lambda (string)
 559       (unless (null-pointer-p string)
 560         (deallocate-memory string))))
 561
 562 (defmethod copy-from-alien-form (string (type (eql 'string)) &rest args)
 563   (declare (ignore type args))
 564   `(let ((string ,string))
 565     (unless (null-pointer-p string)
 566       (%naturalize-c-string string))))
 567
 568
 569 (defmethod copy-from-alien-function ((type (eql 'string)) &rest args)
 570   (declare (ignore type args))
 571   #'(lambda (string)
 572       (unless (null-pointer-p string)
 573         (%naturalize-c-string string))))
 574
 575 (defmethod writer-function ((type (eql 'string)) &rest args)
 576   (declare (ignore type args))
 577   #'(lambda (string location &optional (offset 0))
 578       (assert (null-pointer-p (sap-ref-sap location offset)))
 579       (setf (sap-ref-sap location offset)
 580        (copy-memory
 581         (vector-sap (coerce string 'simple-base-string))
 582         (1+ (length string))))))
 583
 584 (defmethod reader-function ((type (eql 'string)) &rest args)
 585   (declare (ignore type args))
 586   #'(lambda (location &optional (offset 0))
 587       (unless (null-pointer-p (sap-ref-sap location offset))
 588         (%naturalize-c-string (sap-ref-sap location offset)))))
 589
 590 (defmethod destroy-function ((type (eql 'string)) &rest args)
 591   (declare (ignore type args))
 592   #'(lambda (location &optional (offset 0))
 593       (unless (null-pointer-p (sap-ref-sap location offset))
 594         (deallocate-memory (sap-ref-sap location offset))
 595         (setf (sap-ref-sap location offset) (make-pointer 0)))))
 596
 597 (defmethod unbound-value ((type (eql 'string)) &rest args)
 598   (declare (ignore type args))
 599   (values t nil))
 600
 601 (defmethod alien-type ((type (eql 'pathname)) &rest args)
 602   (declare (ignore type args))
 603   (alien-type 'string))
 604
 605 (defmethod size-of ((type (eql 'pathname)) &rest args)
 606   (declare (ignore type args))
 607   (size-of 'string))
 608
 609 (defmethod to-alien-form (path (type (eql 'pathname)) &rest args)
 610   (declare (ignore type args))
 611   (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string))
 612
 613 (defmethod to-alien-function ((type (eql 'pathname)) &rest args)
 614   (declare (ignore type args))
 615   (let ((string-function (to-alien-function 'string)))
 616     #'(lambda (path)
 617         (funcall string-function (namestring path)))))
 618
 619 (defmethod from-alien-form (string (type (eql 'pathname)) &rest args)
 620   (declare (ignore type args))
 621   `(parse-namestring ,(from-alien-form string 'string)))
 622
 623 (defmethod from-alien-function ((type (eql 'pathname)) &rest args)
 624   (declare (ignore type args))
 625   (let ((string-function (from-alien-function 'string)))
 626     #'(lambda (string)
 627         (parse-namestring (funcall string-function string)))))
 628
 629 (defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args)
 630   (declare (ignore type args))
 631   (cleanup-form string 'string))
 632
 633 (defmethod cleanup-function ((type (eql 'pathnanme)) &rest args)
 634   (declare (ignore type args))
 635   (cleanup-function 'string))
 636
 637 (defmethod writer-function ((type (eql 'pathname)) &rest args)
 638   (declare (ignore type args))
 639   (let ((string-writer (writer-function 'string)))
 640     #'(lambda (path location &optional (offset 0))
 641         (funcall string-writer (namestring path) location offset))))
 642
 643 (defmethod reader-function ((type (eql 'pathname)) &rest args)
 644   (declare (ignore type args))
 645   (let ((string-reader (reader-function 'string)))
 646   #'(lambda (location &optional (offset 0))
 647       (let ((string (funcall string-reader location offset)))
 648         (when string
 649           (parse-namestring string))))))
 650
 651 (defmethod destroy-function ((type (eql 'pathname)) &rest args)
 652   (declare (ignore type args))
 653   (destroy-function 'string))
 654
 655 (defmethod unbound-value ((type (eql 'pathname)) &rest args)
 656   (declare (ignore type args))
 657   (unbound-value 'string))
 658
 659
 660 (defmethod alien-type ((type (eql 'boolean)) &rest args)
 661   (apply #'alien-type 'signed-byte args))
 662
 663 (defmethod size-of ((type (eql 'boolean)) &rest args)
 664   (apply #'size-of 'signed-byte args))
 665
 666 (defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args)
 667   (declare (ignore type args))
 668   `(if ,boolean 1 0))
 669
 670 (defmethod to-alien-function ((type (eql 'boolean)) &rest args)
 671   (declare (ignore type args))
 672   #'(lambda (boolean)
 673       (if boolean 1 0)))
 674
 675 (defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args)
 676   (declare (ignore type args))
 677   `(not (zerop ,boolean)))
 678
 679 (defmethod from-alien-function ((type (eql 'boolean)) &rest args)
 680   (declare (ignore type args))
 681   #'(lambda (boolean)
 682       (not (zerop boolean))))
 683
 684 (defmethod writer-function ((type (eql 'boolean)) &rest args)
 685   (declare (ignore type))
 686   (let ((writer (apply #'writer-function 'signed-byte args)))
 687     #'(lambda (boolean location &optional (offset 0))
 688         (funcall writer (if boolean 1 0) location offset))))
 689
 690 (defmethod reader-function ((type (eql 'boolean)) &rest args)
 691   (declare (ignore type))
 692   (let ((reader (apply #'reader-function 'signed-byte args)))
 693   #'(lambda (location &optional (offset 0))
 694       (not (zerop (funcall reader location offset))))))
 695
 696
 697 (defmethod alien-type ((type (eql 'or)) &rest args)
 698   (let ((alien-type (alien-type (first args))))
 699     (unless (every #'(lambda (type)
 700                        (eq alien-type (alien-type type)))
 701                    (rest args))
 702       (error "No common alien type specifier for union type: ~A"
 703        (cons type args)))
 704     alien-type))
 705
 706 (defmethod size-of ((type (eql 'or)) &rest args)
 707   (declare (ignore type))
 708   (size-of (first args)))
 709
 710 (defmethod to-alien-form (form (type (eql 'or)) &rest args)
 711   (declare (ignore type))
 712   `(let ((value ,form))
 713     (etypecase value
 714       ,@(mapcar
 715          #'(lambda (type)
 716              `(,type ,(to-alien-form 'value type)))
 717          args))))
 718
 719 (defmethod to-alien-function ((type (eql 'or)) &rest types)
 720   (declare (ignore type))
 721   (let ((functions (mapcar #'to-alien-function types)))
 722     #'(lambda (value)
 723         (loop
 724          for function in functions
 725          for type in types
 726          when (typep value type)
 727          do (return (funcall function value))
 728          finally (error "~S is not of type ~A" value `(or ,@types))))))
 729
 730 (defmethod alien-type ((type (eql 'system-area-pointer)) &rest args)
 731   (declare (ignore type args))
 732   'system-area-pointer)
 733
 734 (defmethod size-of ((type (eql 'system-area-pointer)) &rest args)
 735   (declare (ignore type args))
 736   +size-of-pointer+)
 737
 738 (defmethod writer-function ((type (eql 'system-area-pointer)) &rest args)
 739   (declare (ignore type args))
 740   #'(lambda (sap location &optional (offset 0))
 741       (setf (sap-ref-sap location offset) sap)))
 742
 743 (defmethod reader-function ((type (eql 'system-area-pointer)) &rest args)
 744   (declare (ignore type args))
 745   #'(lambda (location &optional (offset 0))
 746       (sap-ref-sap location offset)))
 747
 748
 749 (defmethod alien-type ((type (eql 'null)) &rest args)
 750   (declare (ignore type args))
 751   (alien-type 'pointer))
 752
 753 (defmethod size-of ((type (eql 'null)) &rest args)
 754   (declare (ignore type args))
 755   (size-of 'pointer))
 756
 757 (defmethod to-alien-form (null (type (eql 'null)) &rest args)
 758   (declare (ignore null type args))
 759   `(make-pointer 0))
 760
 761 (defmethod to-alien-function ((type (eql 'null)) &rest args)
 762   (declare (ignore type args))
 763   #'(lambda (null)
 764       (declare (ignore null))
 765       (make-pointer 0)))
 766
 767
 768 (defmethod alien-type ((type (eql 'nil)) &rest args)
 769   (declare (ignore type args))
 770   'void)
 771
 772 (defmethod from-alien-function ((type (eql 'nil)) &rest args)
 773   (declare (ignore type args))
 774   #'(lambda (value)
 775       (declare (ignore value))
 776       (values)))
 777
 778
 779 (defmethod alien-type ((type (eql 'copy-of)) &rest args)
 780   (declare (ignore type))
 781   (alien-type (first args)))
 782
 783 (defmethod size-of ((type (eql 'copy-of)) &rest args)
 784   (declare (ignore type))
 785   (size-of (first args)))
 786
 787 (defmethod to-alien-form (form (type (eql 'copy-of)) &rest args)
 788   (declare (ignore type))
 789   (copy-to-alien-form form (first args)))
 790
 791 (defmethod to-alien-function ((type (eql 'copy-of)) &rest args)
 792   (declare (ignore type))
 793   (copy-to-alien-function (first args)))
 794
 795 (defmethod from-alien-form (form (type (eql 'copy-of)) &rest args)
 796   (declare (ignore type))
 797   (copy-from-alien-form form (first args)))
 798
 799 (defmethod from-alien-function ((type (eql 'copy-of)) &rest args)
 800   (declare (ignore type))
 801   (copy-from-alien-function (first args)))
 802
 803 (defmethod reader-function ((type (eql 'copy-of)) &rest args)
 804   (declare (ignore type))
 805   (reader-function (first args)))
 806
 807 (defmethod writer-function ((type (eql 'copy-of)) &rest args)
 808   (declare (ignore type))
 809   (writer-function (first args)))