chiark - git - mdw - 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.12 2005-01-03 16:35:05 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 #+cmu
 117 (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args)
 118   (ext: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          (declare (optimize (ext:inhibit-warnings 3)))
 155          (with-alien ((,alien-name
 156                        (function
 157                         ,(alien-type return-type)
 158                         ,@(alien-types))
 159                        :extern ,foreign-name)
 160                       ,@(alien-bindings))
 161            ,(if return-type
 162                 `(values
 163                   (unwind-protect
 164                       ,(from-alien-form alien-funcall return-type)
 165                     ,@(cleanup-forms))
 166                   ,@(return-values))
 167               `(progn
 168                 (unwind-protect
 169                      ,alien-funcall
 170                   ,@(cleanup-forms))
 171                 (values ,@(return-values)))))))))
 172
 173
 174 ;;; Creates bindings at runtime
 175 (defun mkbinding (name return-type &rest arg-types)
 176   (declare (optimize (ext:inhibit-warnings 3)))
 177   (let* ((ftype
 178           `(function ,@(mapcar #'alien-type (cons return-type arg-types))))
 179          (alien
 180           (alien::%heap-alien
 181            (alien::make-heap-alien-info
 182             :type (alien::parse-alien-type ftype)
 183             :sap-form (system:foreign-symbol-address name :flavor :code))))
 184          (translate-arguments (mapcar #'to-alien-function arg-types))
 185          (translate-return-value (from-alien-function return-type))
 186          (cleanup-arguments (mapcar #'cleanup-function arg-types)))
 187
 188     #'(lambda (&rest args)
 189         (map-into args #'funcall translate-arguments args)
 190         (prog1
 191             (funcall translate-return-value
 192              (apply #'alien:alien-funcall alien args))
 193           (mapc #'funcall cleanup-arguments args)))))
 194
 195
 196 (defmacro defcallback (name (return-type &rest args) &body body)
 197   `(def-callback ,name
 198        (,(alien-type return-type)
 199         ,@(mapcar #'(lambda (arg)
 200                       (destructuring-bind (name type) arg
 201                         `(,name ,(alien-type type))))
 202                   args))
 203     ,(to-alien-form
 204       `(let (,@(mapcar #'(lambda (arg)
 205                            (destructuring-bind (name type) arg
 206                              `(,name ,(from-alien-form name type))))
 207                        args))
 208         ,@body)
 209       return-type)))
 210
 211
 212
 213 ;;;; Definitons and translations of fundamental types
 214
 215 (defmacro def-type-method (name args &optional documentation)
 216   `(progn
 217     (defgeneric ,name (,@args type &rest args)
 218       ,@(when documentation `((:documentation ,documentation))))
 219     (defmethod ,name (,@args (type symbol) &rest args)
 220       (let ((class (find-class type nil)))
 221         (if class
 222             (apply #',name ,@args class args)
 223           (multiple-value-bind (super-type expanded-p)
 224               (type-expand-1 (cons type args))
 225             (if expanded-p
 226                 (,name ,@args super-type)
 227               (call-next-method))))))
 228     (defmethod ,name (,@args (type cons) &rest args)
 229       (declare (ignore args))
 230       (apply #',name ,@args (first type) (rest type)))))
 231
 232
 233 (def-type-method alien-type ())
 234 (def-type-method size-of ())
 235 (def-type-method to-alien-form (form))
 236 (def-type-method from-alien-form (form))
 237 (def-type-method cleanup-form (form)
 238   "Creates a form to clean up after the alien call has finished.")
 239
 240 (def-type-method to-alien-function ())
 241 (def-type-method from-alien-function ())
 242 (def-type-method cleanup-function ())
 243
 244 (def-type-method copy-to-alien-form (form))
 245 (def-type-method copy-to-alien-function ())
 246 (def-type-method copy-from-alien-form (form))
 247 (def-type-method copy-from-alien-function ())
 248
 249 (def-type-method writer-function ())
 250 (def-type-method reader-function ())
 251 (def-type-method destroy-function ())
 252
 253 (def-type-method unbound-value ()
 254   "First return value is true if the type has an unbound value, second return value is the actual unbound value")
 255
 256
 257 ;; Sizes of fundamental C types in bytes (8 bits)
 258 (defconstant +size-of-short+ 2)
 259 (defconstant +size-of-int+ 4)
 260 (defconstant +size-of-long+ 4)
 261 (defconstant +size-of-pointer+ 4)
 262 (defconstant +size-of-float+ 4)
 263 (defconstant +size-of-double+ 8)
 264
 265 ;; Sizes of fundamental C types in bits
 266 (defconstant +bits-of-byte+ 8)
 267 (defconstant +bits-of-short+ 16)
 268 (defconstant +bits-of-int+ 32)
 269 (defconstant +bits-of-long+ 32)
 270
 271
 272 (deftype int () '(signed-byte #.+bits-of-int+))
 273 (deftype unsigned-int () '(unsigned-byte #.+bits-of-int+))
 274 (deftype long () '(signed-byte #.+bits-of-long+))
 275 (deftype unsigned-long () '(unsigned-byte #.+bits-of-long+))
 276 (deftype short () '(signed-byte #.+bits-of-short+))
 277 (deftype unsigned-short () '(unsigned-byte #.+bits-of-short+))
 278 (deftype signed (&optional (size '*)) `(signed-byte ,size))
 279 (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
 280 (deftype char () 'base-char)
 281 (deftype pointer () 'system-area-pointer)
 282 (deftype boolean (&optional (size '*)) (declare (ignore size)) `(member t nil))
 283 ;(deftype invalid () nil)
 284
 285
 286 (defmethod to-alien-form (form (type t) &rest args)
 287   (declare (ignore type args))
 288   form)
 289
 290 (defmethod to-alien-function ((type t) &rest args)
 291   (declare (ignore type args))
 292   #'identity)
 293
 294 (defmethod from-alien-form (form (type t) &rest args)
 295   (declare (ignore type args))
 296   form)
 297
 298 (defmethod from-alien-function ((type t) &rest args)
 299   (declare (ignore type args))
 300   #'identity)
 301
 302 (defmethod cleanup-form (form (type t) &rest args)
 303   (declare (ignore form type args))
 304   nil)
 305
 306 (defmethod cleanup-function ((type t) &rest args)
 307   (declare (ignore type args))
 308   #'identity)
 309
 310 (defmethod destroy-function ((type t) &rest args)
 311   (declare (ignore type args))
 312   #'(lambda (location &optional offset)
 313       (declare (ignore location offset))))
 314
 315 (defmethod copy-to-alien-form  (form (type t) &rest args)
 316   (apply #'to-alien-form form type args))
 317
 318 (defmethod copy-to-alien-function  ((type t) &rest args)
 319   (apply #'to-alien-function type args))
 320
 321 (defmethod copy-from-alien-form  (form (type t) &rest args)
 322   (apply #'from-alien-form form type args))
 323
 324 (defmethod copy-from-alien-function  ((type t) &rest args)
 325   (apply #'from-alien-function type args))
 326
 327
 328 (defmethod alien-type ((type (eql 'signed-byte)) &rest args)
 329   (declare (ignore type))
 330   (destructuring-bind (&optional (size '*)) args
 331     (ecase size
 332       (#.+bits-of-byte+ '(signed-byte 8))
 333       (#.+bits-of-short+ 'c-call:short)
 334       ((* #.+bits-of-int+) 'c-call:int)
 335       (#.+bits-of-long+ 'c-call:long))))
 336
 337 (defmethod size-of ((type (eql 'signed-byte)) &rest args)
 338   (declare (ignore type))
 339   (destructuring-bind (&optional (size '*)) args
 340     (ecase size
 341       (#.+bits-of-byte+ 1)
 342       (#.+bits-of-short+ +size-of-short+)
 343       ((* #.+bits-of-int+) +size-of-int+)
 344       (#.+bits-of-long+ +size-of-long+))))
 345
 346 (defmethod unbound-value ((type t) &rest args)
 347   (declare (ignore type args))
 348   nil)
 349
 350 (defmethod writer-function ((type (eql 'signed-byte)) &rest args)
 351   (declare (ignore type))
 352   (destructuring-bind (&optional (size '*)) args
 353     (let ((size (if (eq size '*) +bits-of-int+ size)))
 354       (ecase size
 355         (8 #'(lambda (value location &optional (offset 0))
 356                (setf (signed-sap-ref-8 location offset) value)))
 357         (16 #'(lambda (value location &optional (offset 0))
 358                 (setf (signed-sap-ref-16 location offset) value)))
 359         (32 #'(lambda (value location &optional (offset 0))
 360                 (setf (signed-sap-ref-32 location offset) value)))
 361         (64 #'(lambda (value location &optional (offset 0))
 362                 (setf (signed-sap-ref-64 location offset) value)))))))
 363
 364 (defmethod reader-function ((type (eql 'signed-byte)) &rest args)
 365   (declare (ignore type))
 366   (destructuring-bind (&optional (size '*)) args
 367     (let ((size (if (eq size '*) +bits-of-int+ size)))
 368       (ecase size
 369         (8 #'(lambda (sap &optional (offset 0))
 370                (signed-sap-ref-8 sap offset)))
 371         (16 #'(lambda (sap &optional (offset 0))
 372                 (signed-sap-ref-16 sap offset)))
 373         (32 #'(lambda (sap &optional (offset 0))
 374                 (signed-sap-ref-32 sap offset)))
 375         (64 #'(lambda (sap &optional (offset 0))
 376                 (signed-sap-ref-64 sap offset)))))))
 377
 378 (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args)
 379   (destructuring-bind (&optional (size '*)) args
 380     (ecase size
 381       (#.+bits-of-byte+ '(unsigned #|-byte|# 8))
 382       (#.+bits-of-short+ 'c-call:unsigned-short)
 383       ((* #.+bits-of-int+) 'c-call:unsigned-int)
 384       (#.+bits-of-long+ 'c-call:unsigned-long))))
 385
 386 (defmethod size-of ((type (eql 'unsigned-byte)) &rest args)
 387   (apply #'size-of 'signed args))
 388
 389 (defmethod writer-function ((type (eql 'unsigned-byte)) &rest args)
 390   (declare (ignore type))
 391   (destructuring-bind (&optional (size '*)) args
 392     (let ((size (if (eq size '*) +bits-of-int+ size)))
 393       (ecase size
 394         (8 #'(lambda (value location &optional (offset 0))
 395                (setf (sap-ref-8 location offset) value)))
 396         (16 #'(lambda (value location &optional (offset 0))
 397                 (setf (sap-ref-16 location offset) value)))
 398         (32 #'(lambda (value location &optional (offset 0))
 399                 (setf (sap-ref-32 location offset) value)))
 400         (64 #'(lambda (value location &optional (offset 0))
 401                 (setf (sap-ref-64 location offset) value)))))))
 402
 403 (defmethod reader-function ((type (eql 'unsigned-byte)) &rest args)
 404   (declare (ignore type))
 405   (destructuring-bind (&optional (size '*)) args
 406     (let ((size (if (eq size '*) +bits-of-int+ size)))
 407       (ecase size
 408         (8 #'(lambda (sap &optional (offset 0))
 409                (sap-ref-8 sap offset)))
 410         (16 #'(lambda (sap &optional (offset 0))
 411                 (sap-ref-16 sap offset)))
 412         (32 #'(lambda (sap &optional (offset 0))
 413                 (sap-ref-32 sap offset)))
 414         (64 #'(lambda (sap &optional (offset 0))
 415                 (sap-ref-64 sap offset)))))))
 416
 417
 418 (defmethod alien-type ((type (eql 'integer)) &rest args)
 419   (declare (ignore type args))
 420   (alien-type 'signed-byte))
 421
 422 (defmethod size-of ((type (eql 'integer)) &rest args)
 423   (declare (ignore type args))
 424   (size-of 'signed-byte))
 425
 426 (defmethod writer-function ((type (eql 'integer)) &rest args)
 427   (declare (ignore type args))
 428   (writer-function 'signed-byte))
 429
 430 (defmethod reader-function ((type (eql 'integer)) &rest args)
 431   (declare (ignore type args))
 432   (reader-function 'signed-byte))
 433
 434
 435 (defmethod alien-type ((type (eql 'fixnum)) &rest args)
 436   (declare (ignore type args))
 437   (alien-type 'signed-byte))
 438
 439 (defmethod size-of ((type (eql 'fixnum)) &rest args)
 440   (declare (ignore type args))
 441   (size-of 'signed-byte))
 442
 443
 444 (defmethod alien-type ((type (eql 'single-float)) &rest args)
 445   (declare (ignore type args))
 446   'alien:single-float)
 447
 448 (defmethod size-of ((type (eql 'single-float)) &rest args)
 449   (declare (ignore type args))
 450   +size-of-float+)
 451
 452 (defmethod writer-function ((type (eql 'single-float)) &rest args)
 453   (declare (ignore type args))
 454   #'(lambda (value location &optional (offset 0))
 455       (setf (sap-ref-single location offset) (coerce value 'single-float))))
 456
 457 (defmethod reader-function ((type (eql 'single-float)) &rest args)
 458   (declare (ignore type args))
 459   #'(lambda (sap &optional (offset 0))
 460       (sap-ref-single sap offset)))
 461
 462
 463 (defmethod alien-type ((type (eql 'double-float)) &rest args)
 464   (declare (ignore type args))
 465   'alien:double-float)
 466
 467 (defmethod size-of ((type (eql 'double-float)) &rest args)
 468   (declare (ignore type args))
 469   +size-of-double+)
 470
 471 (defmethod writer-function ((type (eql 'double-float)) &rest args)
 472   (declare (ignore type args))
 473   #'(lambda (value location &optional (offset 0))
 474       (setf (sap-ref-double location offset) (coerce value 'double-float))))
 475
 476 (defmethod reader-function ((type (eql 'double-float)) &rest args)
 477   (declare (ignore type args))
 478   #'(lambda (sap &optional (offset 0))
 479       (sap-ref-double sap offset)))
 480
 481
 482 (defmethod alien-type ((type (eql 'base-char)) &rest args)
 483   (declare (ignore type args))
 484   'c-call:char)
 485
 486 (defmethod size-of ((type (eql 'base-char)) &rest args)
 487   (declare (ignore type args))
 488   1)
 489
 490 (defmethod writer-function ((type (eql 'base-char)) &rest args)
 491   (declare (ignore type args))
 492   #'(lambda (char location &optional (offset 0))
 493       (setf (sap-ref-8 location offset) (char-code char))))
 494
 495 (defmethod reader-function ((type (eql 'base-char)) &rest args)
 496   (declare (ignore type args))
 497   #'(lambda (location &optional (offset 0))
 498       (code-char (sap-ref-8 location offset))))
 499
 500
 501 (defmethod alien-type ((type (eql 'string)) &rest args)
 502   (declare (ignore type args))
 503   (alien-type 'pointer))
 504
 505 (defmethod size-of ((type (eql 'string)) &rest args)
 506   (declare (ignore type args))
 507   (size-of 'pointer))
 508
 509 (defmethod to-alien-form (string (type (eql 'string)) &rest args)
 510   (declare (ignore type args))
 511   `(let ((string ,string))
 512      ;; Always copy strings to prevent seg fault due to GC
 513      (copy-memory
 514       (make-pointer (1+ (kernel:get-lisp-obj-address string)))
 515       (1+ (length string)))))
 516
 517 (defmethod to-alien-function ((type (eql 'string)) &rest args)
 518   (declare (ignore type args))
 519   #'(lambda (string)
 520       (copy-memory
 521        (make-pointer (1+ (kernel:get-lisp-obj-address string)))
 522        (1+ (length string)))))
 523
 524 (defmethod from-alien-form (string (type (eql 'string)) &rest args)
 525   (declare (ignore type args))
 526   `(let ((string ,string))
 527     (unless (null-pointer-p string)
 528       (prog1
 529           (c-call::%naturalize-c-string string)
 530         (deallocate-memory string)))))
 531
 532 (defmethod from-alien-function ((type (eql 'string)) &rest args)
 533   (declare (ignore type args))
 534   #'(lambda (string)
 535       (unless (null-pointer-p string)
 536         (prog1
 537             (c-call::%naturalize-c-string string)
 538           (deallocate-memory string)))))
 539
 540 (defmethod cleanup-form (string (type (eql 'string)) &rest args)
 541   (declare (ignore type args))
 542   `(let ((string ,string))
 543     (unless (null-pointer-p string)
 544       (deallocate-memory string))))
 545
 546 (defmethod cleanup-function ((type (eql 'string)) &rest args)
 547   (declare (ignore args))
 548   #'(lambda (string)
 549       (unless (null-pointer-p string)
 550         (deallocate-memory string))))
 551
 552 (defmethod copy-from-alien-form (string (type (eql 'string)) &rest args)
 553   (declare (ignore type args))
 554   `(let ((string ,string))
 555     (unless (null-pointer-p string)
 556       (c-call::%naturalize-c-string string))))
 557
 558 (defmethod copy-from-alien-function ((type (eql 'string)) &rest args)
 559   (declare (ignore type args))
 560   #'(lambda (string)
 561       (unless (null-pointer-p string)
 562         (c-call::%naturalize-c-string string))))
 563
 564 (defmethod writer-function ((type (eql 'string)) &rest args)
 565   (declare (ignore type args))
 566   #'(lambda (string location &optional (offset 0))
 567       (assert (null-pointer-p (sap-ref-sap location offset)))
 568       (setf (sap-ref-sap location offset)
 569        (copy-memory
 570         (make-pointer (1+ (kernel:get-lisp-obj-address string)))
 571         (1+ (length string))))))
 572
 573 (defmethod reader-function ((type (eql 'string)) &rest args)
 574   (declare (ignore type args))
 575   #'(lambda (location &optional (offset 0))
 576       (unless (null-pointer-p (sap-ref-sap location offset))
 577         (c-call::%naturalize-c-string (sap-ref-sap location offset)))))
 578
 579 (defmethod destroy-function ((type (eql 'string)) &rest args)
 580   (declare (ignore type args))
 581   #'(lambda (location &optional (offset 0))
 582       (unless (null-pointer-p (sap-ref-sap location offset))
 583         (deallocate-memory (sap-ref-sap location offset))
 584         (setf (sap-ref-sap location offset) (make-pointer 0)))))
 585
 586 (defmethod unbound-value ((type (eql 'string)) &rest args)
 587   (declare (ignore type args))
 588   (values t nil))
 589
 590 (defmethod alien-type ((type (eql 'pathname)) &rest args)
 591   (declare (ignore type args))
 592   (alien-type 'string))
 593
 594 (defmethod size-of ((type (eql 'pathname)) &rest args)
 595   (declare (ignore type args))
 596   (size-of 'string))
 597
 598 (defmethod to-alien-form (path (type (eql 'pathname)) &rest args)
 599   (declare (ignore type args))
 600   (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string))
 601
 602 (defmethod to-alien-function ((type (eql 'pathname)) &rest args)
 603   (declare (ignore type args))
 604   (let ((string-function (to-alien-function 'string)))
 605     #'(lambda (path)
 606         (funcall string-function (namestring path)))))
 607
 608 (defmethod from-alien-form (string (type (eql 'pathname)) &rest args)
 609   (declare (ignore type args))
 610   `(parse-namestring ,(from-alien-form string 'string)))
 611
 612 (defmethod from-alien-function ((type (eql 'pathname)) &rest args)
 613   (declare (ignore type args))
 614   (let ((string-function (from-alien-function 'string)))
 615     #'(lambda (string)
 616         (parse-namestring (funcall string-function string)))))
 617
 618 (defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args)
 619   (declare (ignore type args))
 620   (cleanup-form string 'string))
 621
 622 (defmethod cleanup-function ((type (eql 'pathnanme)) &rest args)
 623   (declare (ignore type args))
 624   (cleanup-function 'string))
 625
 626 (defmethod writer-function ((type (eql 'pathname)) &rest args)
 627   (declare (ignore type args))
 628   (let ((string-writer (writer-function 'string)))
 629     #'(lambda (path location &optional (offset 0))
 630         (funcall string-writer (namestring path) location offset))))
 631
 632 (defmethod reader-function ((type (eql 'pathname)) &rest args)
 633   (declare (ignore type args))
 634   (let ((string-reader (reader-function 'string)))
 635   #'(lambda (location &optional (offset 0))
 636       (let ((string (funcall string-reader location offset)))
 637         (when string
 638           (parse-namestring string))))))
 639
 640 (defmethod destroy-function ((type (eql 'pathname)) &rest args)
 641   (declare (ignore type args))
 642   (destroy-function 'string))
 643
 644 (defmethod unbound-value ((type (eql 'pathname)) &rest args)
 645   (declare (ignore type args))
 646   (unbound-value 'string))
 647
 648
 649 (defmethod alien-type ((type (eql 'boolean)) &rest args)
 650   (apply #'alien-type 'signed-byte args))
 651
 652 (defmethod size-of ((type (eql 'boolean)) &rest args)
 653   (apply #'size-of 'signed-byte args))
 654
 655 (defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args)
 656   (declare (ignore type args))
 657   `(if ,boolean 1 0))
 658
 659 (defmethod to-alien-function ((type (eql 'boolean)) &rest args)
 660   (declare (ignore type args))
 661   #'(lambda (boolean)
 662       (if boolean 1 0)))
 663
 664 (defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args)
 665   (declare (ignore type args))
 666   `(not (zerop ,boolean)))
 667
 668 (defmethod from-alien-function ((type (eql 'boolean)) &rest args)
 669   (declare (ignore type args))
 670   #'(lambda (boolean)
 671       (not (zerop boolean))))
 672
 673 (defmethod writer-function ((type (eql 'boolean)) &rest args)
 674   (declare (ignore type))
 675   (let ((writer (apply #'writer-function 'signed-byte args)))
 676     #'(lambda (boolean location &optional (offset 0))
 677         (funcall writer (if boolean 1 0) location offset))))
 678
 679 (defmethod reader-function ((type (eql 'boolean)) &rest args)
 680   (declare (ignore type))
 681   (let ((reader (apply #'reader-function 'signed-byte args)))
 682   #'(lambda (location &optional (offset 0))
 683       (not (zerop (funcall reader location offset))))))
 684
 685
 686 (defmethod alien-type ((type (eql 'or)) &rest args)
 687   (let ((alien-type (alien-type (first args))))
 688     (unless (every #'(lambda (type)
 689                        (eq alien-type (alien-type type)))
 690                    (rest args))
 691       (error "No common alien type specifier for union type: ~A"
 692        (cons type args)))
 693     alien-type))
 694
 695 (defmethod size-of ((type (eql 'or)) &rest args)
 696   (declare (ignore type))
 697   (size-of (first args)))
 698
 699 (defmethod to-alien-form (form (type (eql 'or)) &rest args)
 700   (declare (ignore type))
 701   `(let ((value ,form))
 702     (etypecase value
 703       ,@(mapcar
 704          #'(lambda (type)
 705              `(,type ,(to-alien-form 'value type)))
 706          args))))
 707
 708 (defmethod to-alien-function ((type (eql 'or)) &rest types)
 709   (declare (ignore type))
 710   (let ((functions (mapcar #'to-alien-function types)))
 711     #'(lambda (value)
 712         (loop
 713          for function in functions
 714          for type in types
 715          when (typep value type)
 716          do (return (funcall function value))
 717          finally (error "~S is not of type ~A" value `(or ,@types))))))
 718
 719 (defmethod alien-type ((type (eql 'system-area-pointer)) &rest args)
 720   (declare (ignore type args))
 721   'system-area-pointer)
 722
 723 (defmethod size-of ((type (eql 'system-area-pointer)) &rest args)
 724   (declare (ignore type args))
 725   +size-of-pointer+)
 726
 727 (defmethod writer-function ((type (eql 'system-area-pointer)) &rest args)
 728   (declare (ignore type args))
 729   #'(lambda (sap location &optional (offset 0))
 730       (setf (sap-ref-sap location offset) sap)))
 731
 732 (defmethod reader-function ((type (eql 'system-area-pointer)) &rest args)
 733   (declare (ignore type args))
 734   #'(lambda (location &optional (offset 0))
 735       (sap-ref-sap location offset)))
 736
 737
 738 (defmethod alien-type ((type (eql 'null)) &rest args)
 739   (declare (ignore type args))
 740   (alien-type 'pointer))
 741
 742 (defmethod size-of ((type (eql 'null)) &rest args)
 743   (declare (ignore type args))
 744   (size-of 'pointer))
 745
 746 (defmethod to-alien-form (null (type (eql 'null)) &rest args)
 747   (declare (ignore null type args))
 748   `(make-pointer 0))
 749
 750 (defmethod to-alien-function ((type (eql 'null)) &rest args)
 751   (declare (ignore type args))
 752   #'(lambda (null)
 753       (declare (ignore null))
 754       (make-pointer 0)))
 755
 756
 757 (defmethod alien-type ((type (eql 'nil)) &rest args)
 758   (declare (ignore type args))
 759   'c-call:void)
 760
 761 (defmethod from-alien-function ((type (eql 'nil)) &rest args)
 762   (declare (ignore type args))
 763   #'(lambda (value)
 764       (declare (ignore value))
 765       (values)))
 766
 767
 768 (defmethod alien-type ((type (eql 'copy-of)) &rest args)
 769   (declare (ignore type))
 770   (alien-type (first args)))
 771
 772 (defmethod size-of ((type (eql 'copy-of)) &rest args)
 773   (declare (ignore type))
 774   (size-of (first args)))
 775
 776 (defmethod to-alien-form (form (type (eql 'copy-of)) &rest args)
 777   (declare (ignore type))
 778   (copy-to-alien-form form (first args)))
 779
 780 (defmethod to-alien-function ((type (eql 'copy-of)) &rest args)
 781   (declare (ignore type))
 782   (copy-to-alien-function (first args)))
 783
 784 (defmethod from-alien-form (form (type (eql 'copy-of)) &rest args)
 785   (declare (ignore type))
 786   (copy-from-alien-form form (first args)))
 787
 788 (defmethod from-alien-function ((type (eql 'copy-of)) &rest args)
 789   (declare (ignore type))
 790   (copy-from-alien-function (first args)))
 791
 792 (defmethod reader-function ((type (eql 'copy-of)) &rest args)
 793   (declare (ignore type))
 794   (reader-function (first args)))
 795
 796 (defmethod writer-function ((type (eql 'copy-of)) &rest args)
 797   (declare (ignore type))
 798   (writer-function (first args)))
 799
 800 (export 'copy-of)