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