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