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.9 2004-12-19 15:31:26 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
 107                (list (if (namep expr)
 108                          (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
 254 ;; Sizes of fundamental C types in bytes (8 bits)
 255 (defconstant +size-of-short+ 2)
 256 (defconstant +size-of-int+ 4)
 257 (defconstant +size-of-long+ 4)
 258 (defconstant +size-of-pointer+ 4)
 259 (defconstant +size-of-float+ 4)
 260 (defconstant +size-of-double+ 8)
 261
 262 ;; Sizes of fundamental C types in bits
 263 (defconstant +bits-of-byte+ 8)
 264 (defconstant +bits-of-short+ 16)
 265 (defconstant +bits-of-int+ 32)
 266 (defconstant +bits-of-long+ 32)
 267
 268
 269 (deftype int () '(signed-byte #.+bits-of-int+))
 270 (deftype unsigned-int () '(unsigned-byte #.+bits-of-int+))
 271 (deftype long () '(signed-byte #.+bits-of-long+))
 272 (deftype unsigned-long () '(unsigned-byte #.+bits-of-long+))
 273 (deftype short () '(signed-byte #.+bits-of-short+))
 274 (deftype unsigned-short () '(unsigned-byte #.+bits-of-short+))
 275 (deftype signed (&optional (size '*)) `(signed-byte ,size))
 276 (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
 277 (deftype char () 'base-char)
 278 (deftype pointer () 'system-area-pointer)
 279 (deftype boolean (&optional (size '*)) (declare (ignore size)) `(member t nil))
 280 ;(deftype invalid () nil)
 281
 282
 283 (defmethod to-alien-form (form (type t) &rest args)
 284   (declare (ignore type args))
 285   form)
 286
 287 (defmethod to-alien-function ((type t) &rest args)
 288   (declare (ignore type args))
 289   #'identity)
 290
 291 (defmethod from-alien-form (form (type t) &rest args)
 292   (declare (ignore type args))
 293   form)
 294
 295 (defmethod from-alien-function ((type t) &rest args)
 296   (declare (ignore type args))
 297   #'identity)
 298
 299 (defmethod cleanup-form (form (type t) &rest args)
 300   (declare (ignore form type args))
 301   nil)
 302
 303 (defmethod cleanup-function ((type t) &rest args)
 304   (declare (ignore type args))
 305   #'identity)
 306
 307 (defmethod destroy-function ((type t) &rest args)
 308   (declare (ignore type args))
 309   #'(lambda (location &optional offset)
 310       (declare (ignore location offset))))
 311
 312 (defmethod copy-to-alien-form  (form (type t) &rest args)
 313   (apply #'to-alien-form form type args))
 314
 315 (defmethod copy-to-alien-function  ((type t) &rest args)
 316   (apply #'to-alien-function type args))
 317
 318 (defmethod copy-from-alien-form  (form (type t) &rest args)
 319   (apply #'from-alien-form form type args))
 320
 321 (defmethod copy-from-alien-function  ((type t) &rest args)
 322   (apply #'from-alien-function type args))
 323
 324
 325 (defmethod alien-type ((type (eql 'signed-byte)) &rest args)
 326   (declare (ignore type))
 327   (destructuring-bind (&optional (size '*)) args
 328     (ecase size
 329       (#.+bits-of-byte+ '(signed-byte 8))
 330       (#.+bits-of-short+ 'c-call:short)
 331       ((* #.+bits-of-int+) 'c-call:int)
 332       (#.+bits-of-long+ 'c-call:long))))
 333
 334 (defmethod size-of ((type (eql 'signed-byte)) &rest args)
 335   (declare (ignore type))
 336   (destructuring-bind (&optional (size '*)) args
 337     (ecase size
 338       (#.+bits-of-byte+ 1)
 339       (#.+bits-of-short+ +size-of-short+)
 340       ((* #.+bits-of-int+) +size-of-int+)
 341       (#.+bits-of-long+ +size-of-long+))))
 342
 343 (defmethod writer-function ((type (eql 'signed-byte)) &rest args)
 344   (declare (ignore type))
 345   (destructuring-bind (&optional (size '*)) args
 346     (let ((size (if (eq size '*) +bits-of-int+ size)))
 347       (ecase size
 348         (8 #'(lambda (value location &optional (offset 0))
 349                (setf (signed-sap-ref-8 location offset) value)))
 350         (16 #'(lambda (value location &optional (offset 0))
 351                 (setf (signed-sap-ref-16 location offset) value)))
 352         (32 #'(lambda (value location &optional (offset 0))
 353                 (setf (signed-sap-ref-32 location offset) value)))
 354         (64 #'(lambda (value location &optional (offset 0))
 355                 (setf (signed-sap-ref-64 location offset) value)))))))
 356
 357 (defmethod reader-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 (sap &optional (offset 0))
 363                (signed-sap-ref-8 sap offset)))
 364         (16 #'(lambda (sap &optional (offset 0))
 365                 (signed-sap-ref-16 sap offset)))
 366         (32 #'(lambda (sap &optional (offset 0))
 367                 (signed-sap-ref-32 sap offset)))
 368         (64 #'(lambda (sap &optional (offset 0))
 369                 (signed-sap-ref-64 sap offset)))))))
 370
 371 (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args)
 372   (destructuring-bind (&optional (size '*)) args
 373     (ecase size
 374       (#.+bits-of-byte+ '(unsigned-byte 8))
 375       (#.+bits-of-short+ 'c-call:unsigned-short)
 376       ((* #.+bits-of-int+) 'c-call:unsigned-int)
 377       (#.+bits-of-long+ 'c-call:unsigned-long))))
 378
 379 (defmethod size-of ((type (eql 'unsigned-byte)) &rest args)
 380   (apply #'size-of 'signed args))
 381
 382 (defmethod writer-function ((type (eql 'unsigned-byte)) &rest args)
 383   (declare (ignore type))
 384   (destructuring-bind (&optional (size '*)) args
 385     (let ((size (if (eq size '*) +bits-of-int+ size)))
 386       (ecase size
 387         (8 #'(lambda (value location &optional (offset 0))
 388                (setf (sap-ref-8 location offset) value)))
 389         (16 #'(lambda (value location &optional (offset 0))
 390                 (setf (sap-ref-16 location offset) value)))
 391         (32 #'(lambda (value location &optional (offset 0))
 392                 (setf (sap-ref-32 location offset) value)))
 393         (64 #'(lambda (value location &optional (offset 0))
 394                 (setf (sap-ref-64 location offset) value)))))))
 395
 396 (defmethod reader-function ((type (eql 'unsigned-byte)) &rest args)
 397   (declare (ignore type))
 398   (destructuring-bind (&optional (size '*)) args
 399     (let ((size (if (eq size '*) +bits-of-int+ size)))
 400       (ecase size
 401         (8 #'(lambda (sap &optional (offset 0))
 402                (sap-ref-8 sap offset)))
 403         (16 #'(lambda (sap &optional (offset 0))
 404                 (sap-ref-16 sap offset)))
 405         (32 #'(lambda (sap &optional (offset 0))
 406                 (sap-ref-32 sap offset)))
 407         (64 #'(lambda (sap &optional (offset 0))
 408                 (sap-ref-64 sap offset)))))))
 409
 410
 411 (defmethod alien-type ((type (eql 'integer)) &rest args)
 412   (declare (ignore type args))
 413   (alien-type 'signed-byte))
 414
 415 (defmethod size-of ((type (eql 'integer)) &rest args)
 416   (declare (ignore type args))
 417   (size-of 'signed-byte))
 418
 419 (defmethod writer-function ((type (eql 'integer)) &rest args)
 420   (declare (ignore type args))
 421   (writer-function 'signed-byte))
 422
 423 (defmethod reader-function ((type (eql 'integer)) &rest args)
 424   (declare (ignore type args))
 425   (reader-function 'signed-byte))
 426
 427
 428 (defmethod alien-type ((type (eql 'fixnum)) &rest args)
 429   (declare (ignore type args))
 430   (alien-type 'signed-byte))
 431
 432 (defmethod size-of ((type (eql 'fixnum)) &rest args)
 433   (declare (ignore type args))
 434   (size-of 'signed-byte))
 435
 436
 437 (defmethod alien-type ((type (eql 'single-float)) &rest args)
 438   (declare (ignore type args))
 439   'alien:single-float)
 440
 441 (defmethod size-of ((type (eql 'single-float)) &rest args)
 442   (declare (ignore type args))
 443   +size-of-float+)
 444
 445 (defmethod writer-function ((type (eql 'single-float)) &rest args)
 446   (declare (ignore type args))
 447   #'(lambda (value location &optional (offset 0))
 448       (setf (sap-ref-single location offset) (coerce value 'single-float))))
 449
 450 (defmethod reader-function ((type (eql 'single-float)) &rest args)
 451   (declare (ignore type args))
 452   #'(lambda (sap &optional (offset 0))
 453       (sap-ref-single sap offset)))
 454
 455
 456 (defmethod alien-type ((type (eql 'double-float)) &rest args)
 457   (declare (ignore type args))
 458   'alien:double-float)
 459
 460 (defmethod size-of ((type (eql 'double-float)) &rest args)
 461   (declare (ignore type args))
 462   +size-of-double+)
 463
 464 (defmethod writer-function ((type (eql 'double-float)) &rest args)
 465   (declare (ignore type args))
 466   #'(lambda (value location &optional (offset 0))
 467       (setf (sap-ref-double location offset) (coerce value 'double-float))))
 468
 469 (defmethod reader-function ((type (eql 'double-float)) &rest args)
 470   (declare (ignore type args))
 471   #'(lambda (sap &optional (offset 0))
 472       (sap-ref-double sap offset)))
 473
 474
 475 (defmethod alien-type ((type (eql 'base-char)) &rest args)
 476   (declare (ignore type args))
 477   'c-call:char)
 478
 479 (defmethod size-of ((type (eql 'base-char)) &rest args)
 480   (declare (ignore type args))
 481   1)
 482
 483 (defmethod writer-function ((type (eql 'base-char)) &rest args)
 484   (declare (ignore type args))
 485   #'(lambda (char location &optional (offset 0))
 486       (setf (sap-ref-8 location offset) (char-code char))))
 487
 488 (defmethod reader-function ((type (eql 'base-char)) &rest args)
 489   (declare (ignore type args))
 490   #'(lambda (location &optional (offset 0))
 491       (code-char (sap-ref-8 location offset))))
 492
 493
 494 (defmethod alien-type ((type (eql 'string)) &rest args)
 495   (declare (ignore type args))
 496   (alien-type 'pointer))
 497
 498 (defmethod size-of ((type (eql 'string)) &rest args)
 499   (declare (ignore type args))
 500   (size-of 'pointer))
 501
 502 (defmethod to-alien-form (string (type (eql 'string)) &rest args)
 503   (declare (ignore type args))
 504   `(let ((string ,string))
 505      ;; Always copy strings to prevent seg fault due to GC
 506      (copy-memory
 507       (make-pointer (1+ (kernel:get-lisp-obj-address string)))
 508       (1+ (length string)))))
 509
 510 (defmethod to-alien-function ((type (eql 'string)) &rest args)
 511   (declare (ignore type args))
 512   #'(lambda (string)
 513       (copy-memory
 514        (make-pointer (1+ (kernel:get-lisp-obj-address string)))
 515        (1+ (length string)))))
 516
 517 (defmethod from-alien-form (string (type (eql 'string)) &rest args)
 518   (declare (ignore type args))
 519   `(let ((string ,string))
 520     (unless (null-pointer-p string)
 521       (prog1
 522           (c-call::%naturalize-c-string string)
 523         (deallocate-memory string)))))
 524
 525 (defmethod from-alien-function ((type (eql 'string)) &rest args)
 526   (declare (ignore type args))
 527   #'(lambda (string)
 528       (unless (null-pointer-p string)
 529         (prog1
 530             (c-call::%naturalize-c-string string)
 531           (deallocate-memory string)))))
 532
 533 (defmethod cleanup-form (string (type (eql 'string)) &rest args)
 534   (declare (ignore type args))
 535   `(let ((string ,string))
 536     (unless (null-pointer-p string)
 537       (deallocate-memory string))))
 538
 539 (defmethod cleanup-function ((type (eql 'string)) &rest args)
 540   (declare (ignore args))
 541   #'(lambda (string)
 542       (unless (null-pointer-p string)
 543         (deallocate-memory string))))
 544
 545 (defmethod copy-from-alien-form (string (type (eql 'string)) &rest args)
 546   (declare (ignore type args))
 547   `(let ((string ,string))
 548     (unless (null-pointer-p string)
 549       (c-call::%naturalize-c-string string))))
 550
 551 (defmethod copy-from-alien-function ((type (eql 'string)) &rest args)
 552   (declare (ignore type args))
 553   #'(lambda (string)
 554       (unless (null-pointer-p string)
 555         (c-call::%naturalize-c-string string))))
 556
 557 (defmethod writer-function ((type (eql 'string)) &rest args)
 558   (declare (ignore type args))
 559   #'(lambda (string location &optional (offset 0))
 560       (assert (null-pointer-p (sap-ref-sap location offset)))
 561       (setf (sap-ref-sap location offset)
 562        (copy-memory
 563         (make-pointer (1+ (kernel:get-lisp-obj-address string)))
 564         (1+ (length string))))))
 565
 566 (defmethod reader-function ((type (eql 'string)) &rest args)
 567   (declare (ignore type args))
 568   #'(lambda (location &optional (offset 0))
 569       (unless (null-pointer-p (sap-ref-sap location offset))
 570         (c-call::%naturalize-c-string (sap-ref-sap location offset)))))
 571
 572 (defmethod destroy-function ((type (eql 'string)) &rest args)
 573   (declare (ignore type args))
 574   #'(lambda (location &optional (offset 0))
 575       (unless (null-pointer-p (sap-ref-sap location offset))
 576         (deallocate-memory (sap-ref-sap location offset))
 577         (setf (sap-ref-sap location offset) (make-pointer 0)))))
 578
 579
 580 (defmethod alien-type ((type (eql 'pathname)) &rest args)
 581   (declare (ignore type args))
 582   (alien-type 'string))
 583
 584 (defmethod size-of ((type (eql 'pathname)) &rest args)
 585   (declare (ignore type args))
 586   (size-of 'string))
 587
 588 (defmethod to-alien-form (path (type (eql 'pathname)) &rest args)
 589   (declare (ignore type args))
 590   (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string))
 591
 592 (defmethod to-alien-function ((type (eql 'pathname)) &rest args)
 593   (declare (ignore type args))
 594   (let ((string-function (to-alien-function 'string)))
 595     #'(lambda (path)
 596         (funcall string-function (namestring path)))))
 597
 598 (defmethod from-alien-form (string (type (eql 'pathname)) &rest args)
 599   (declare (ignore type args))
 600   `(parse-namestring ,(from-alien-form string 'string)))
 601
 602 (defmethod from-alien-function ((type (eql 'pathname)) &rest args)
 603   (declare (ignore type args))
 604   (let ((string-function (from-alien-function 'string)))
 605     #'(lambda (string)
 606         (parse-namestring (funcall string-function string)))))
 607
 608 (defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args)
 609   (declare (ignore type args))
 610   (cleanup-form string 'string))
 611
 612 (defmethod cleanup-function ((type (eql 'pathnanme)) &rest args)
 613   (declare (ignore type args))
 614   (cleanup-function 'string))
 615
 616 (defmethod writer-function ((type (eql 'pathname)) &rest args)
 617   (declare (ignore type args))
 618   (let ((string-writer (writer-function 'string)))
 619     #'(lambda (path location &optional (offset 0))
 620         (funcall string-writer (namestring path) location offset))))
 621
 622 (defmethod reader-function ((type (eql 'pathname)) &rest args)
 623   (declare (ignore type args))
 624   (let ((string-reader (reader-function 'string)))
 625   #'(lambda (location &optional (offset 0))
 626       (let ((string (funcall string-reader location offset)))
 627         (when string
 628           (parse-namestring string))))))
 629
 630 (defmethod destroy-function ((type (eql 'pathname)) &rest args)
 631   (declare (ignore type args))
 632   (destroy-function 'string))
 633
 634
 635 (defmethod alien-type ((type (eql 'boolean)) &rest args)
 636   (apply #'alien-type 'signed-byte args))
 637
 638 (defmethod size-of ((type (eql 'boolean)) &rest args)
 639   (apply #'size-of 'signed-byte args))
 640
 641 (defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args)
 642   (declare (ignore type args))
 643   `(if ,boolean 1 0))
 644
 645 (defmethod to-alien-function ((type (eql 'boolean)) &rest args)
 646   (declare (ignore type args))
 647   #'(lambda (boolean)
 648       (if boolean 1 0)))
 649
 650 (defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args)
 651   (declare (ignore type args))
 652   `(not (zerop ,boolean)))
 653
 654 (defmethod from-alien-function ((type (eql 'boolean)) &rest args)
 655   (declare (ignore type args))
 656   #'(lambda (boolean)
 657       (not (zerop boolean))))
 658
 659 (defmethod writer-function ((type (eql 'boolean)) &rest args)
 660   (declare (ignore type))
 661   (let ((writer (apply #'writer-function 'signed-byte args)))
 662     #'(lambda (boolean location &optional (offset 0))
 663         (funcall writer (if boolean 1 0) location offset))))
 664
 665 (defmethod reader-function ((type (eql 'boolean)) &rest args)
 666   (declare (ignore type))
 667   (let ((reader (apply #'reader-function 'signed-byte args)))
 668   #'(lambda (location &optional (offset 0))
 669       (not (zerop (funcall reader location offset))))))
 670
 671
 672 (defmethod alien-type ((type (eql 'or)) &rest args)
 673   (let ((alien-type (alien-type (first args))))
 674     (unless (every #'(lambda (type)
 675                        (eq alien-type (alien-type type)))
 676                    (rest args))
 677       (error "No common alien type specifier for union type: ~A"
 678        (cons type args)))
 679     alien-type))
 680
 681 (defmethod size-of ((type (eql 'or)) &rest args)
 682   (declare (ignore type))
 683   (size-of (first args)))
 684
 685 (defmethod to-alien-form (form (type (eql 'or)) &rest args)
 686   (declare (ignore type))
 687   `(let ((value ,form))
 688     (etypecase value
 689       ,@(mapcar
 690          #'(lambda (type)
 691              `(,type ,(to-alien-form 'value type)))
 692          args))))
 693
 694 (defmethod to-alien-function ((type (eql 'or)) &rest types)
 695   (declare (ignore type))
 696   (let ((functions (mapcar #'to-alien-function types)))
 697     #'(lambda (value)
 698         (loop
 699          for function in functions
 700          for type in types
 701          when (typep value type)
 702          do (return (funcall function value))
 703          finally (error "~S is not of type ~A" value `(or ,@types))))))
 704
 705 (defmethod alien-type ((type (eql 'system-area-pointer)) &rest args)
 706   (declare (ignore type args))
 707   'system-area-pointer)
 708
 709 (defmethod size-of ((type (eql 'system-area-pointer)) &rest args)
 710   (declare (ignore type args))
 711   +size-of-pointer+)
 712
 713 (defmethod writer-function ((type (eql 'system-area-pointer)) &rest args)
 714   (declare (ignore type args))
 715   #'(lambda (sap location &optional (offset 0))
 716       (setf (sap-ref-sap location offset) sap)))
 717
 718 (defmethod reader-function ((type (eql 'system-area-pointer)) &rest args)
 719   (declare (ignore type args))
 720   #'(lambda (location &optional (offset 0))
 721       (sap-ref-sap location offset)))
 722
 723
 724 (defmethod alien-type ((type (eql 'null)) &rest args)
 725   (declare (ignore type args))
 726   (alien-type 'pointer))
 727
 728 (defmethod size-of ((type (eql 'null)) &rest args)
 729   (declare (ignore type args))
 730   (size-of 'pointer))
 731
 732 (defmethod to-alien-form (null (type (eql 'null)) &rest args)
 733   (declare (ignore null type args))
 734   `(make-pointer 0))
 735
 736 (defmethod to-alien-function ((type (eql 'null)) &rest args)
 737   (declare (ignore type args))
 738   #'(lambda (null)
 739       (declare (ignore null))
 740       (make-pointer 0)))
 741
 742
 743 (defmethod alien-type ((type (eql 'nil)) &rest args)
 744   (declare (ignore type args))
 745   'c-call:void)
 746
 747 (defmethod from-alien-function ((type (eql 'nil)) &rest args)
 748   (declare (ignore type args))
 749   #'(lambda (value)
 750       (declare (ignore value))
 751       (values)))
 752
 753
 754 (defmethod alien-type ((type (eql 'copy-of)) &rest args)
 755   (declare (ignore type))
 756   (alien-type (first args)))
 757
 758 (defmethod size-of ((type (eql 'copy-of)) &rest args)
 759   (declare (ignore type))
 760   (size-of (first args)))
 761
 762 (defmethod to-alien-form (form (type (eql 'copy-of)) &rest args)
 763   (declare (ignore type))
 764   (copy-to-alien-form form (first args)))
 765
 766 (defmethod to-alien-function ((type (eql 'copy-of)) &rest args)
 767   (declare (ignore type))
 768   (copy-to-alien-function (first args)))
 769
 770 (defmethod from-alien-form (form (type (eql 'copy-of)) &rest args)
 771   (declare (ignore type))
 772   (copy-from-alien-form form (first args)))
 773
 774 (defmethod from-alien-function ((type (eql 'copy-of)) &rest args)
 775   (declare (ignore type))
 776   (copy-from-alien-function (first args)))
 777
 778 (defmethod reader-function ((type (eql 'copy-of)) &rest args)
 779   (declare (ignore type))
 780   (reader-function (first args)))
 781
 782 (defmethod writer-function ((type (eql 'copy-of)) &rest args)
 783   (declare (ignore type))
 784   (writer-function (first args)))
 785
 786 (export 'copy-of)