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