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.4 2004-11-09 10:04:35 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
 396 (defmethod alien-type ((type (eql 'fixnum)) &rest args)
 397   (declare (ignore type args))
 398   (alien-type 'signed-byte))
 399
 400 (defmethod size-of ((type (eql 'fixnum)) &rest args)
 401   (declare (ignore type args))
 402   (size-of 'signed-byte))
 403
 404
 405 (defmethod alien-type ((type (eql 'single-float)) &rest args)
 406   (declare (ignore type args))
 407   'alien:single-float)
 408
 409 (defmethod size-of ((type (eql 'single-float)) &rest args)
 410   (declare (ignore type args))
 411   +size-of-float+)
 412
 413 (defmethod writer-function ((type (eql 'single-float)) &rest args)
 414   (declare (ignore type args))
 415   #'(lambda (value location &optional (offset 0))
 416       (setf (sap-ref-single location offset) (coerce value 'single-float))))
 417
 418 (defmethod reader-function ((type (eql 'single-float)) &rest args)
 419   (declare (ignore type args))
 420   #'(lambda (sap &optional (offset 0))
 421       (sap-ref-single sap offset)))
 422
 423
 424 (defmethod alien-type ((type (eql 'double-float)) &rest args)
 425   (declare (ignore type args))
 426   'alien:double-float)
 427
 428 (defmethod size-of ((type (eql 'double-float)) &rest args)
 429   (declare (ignore type args))
 430   +size-of-float+)
 431
 432 (defmethod writer-function ((type (eql 'double-float)) &rest args)
 433   (declare (ignore type args))
 434   #'(lambda (value location &optional (offset 0))
 435       (setf (sap-ref-double location offset) (coerce value 'double-float))))
 436
 437 (defmethod reader-function ((type (eql 'double-float)) &rest args)
 438   (declare (ignore type args))
 439   #'(lambda (sap &optional (offset 0))
 440       (sap-ref-double sap offset)))
 441
 442
 443 (defmethod alien-type ((type (eql 'base-char)) &rest args)
 444   (declare (ignore type args))
 445   'c-call:char)
 446
 447 (defmethod size-of ((type (eql 'base-char)) &rest args)
 448   (declare (ignore type args))
 449   1)
 450
 451 (defmethod writer-function ((type (eql 'base-char)) &rest args)
 452   (declare (ignore type args))
 453   #'(lambda (char location &optional (offset 0))
 454       (setf (sap-ref-8 location offset) (char-code char))))
 455
 456 (defmethod reader-function ((type (eql 'base-char)) &rest args)
 457   (declare (ignore type args))
 458   #'(lambda (location &optional (offset 0))
 459       (code-char (sap-ref-8 location offset))))
 460
 461
 462 (defmethod alien-type ((type (eql 'string)) &rest args)
 463   (declare (ignore type args))
 464   (alien-type 'pointer))
 465
 466 (defmethod size-of ((type (eql 'string)) &rest args)
 467   (declare (ignore type args))
 468   (size-of 'pointer))
 469
 470 (defmethod to-alien-form (string (type (eql 'string)) &rest args)
 471   (declare (ignore type args))
 472   `(let ((string ,string))
 473      ;; Always copy strings to prevent seg fault due to GC
 474      (copy-memory
 475       (make-pointer (1+ (kernel:get-lisp-obj-address string)))
 476       (1+ (length string)))))
 477
 478 (defmethod to-alien-function ((type (eql 'string)) &rest args)
 479   (declare (ignore type args))
 480   #'(lambda (string)
 481       (copy-memory
 482        (make-pointer (1+ (kernel:get-lisp-obj-address string)))
 483        (1+ (length string)))))
 484
 485 (defmethod from-alien-form (string (type (eql 'string)) &rest args)
 486   (declare (ignore type args))
 487   `(let ((string ,string))
 488     (unless (null-pointer-p string)
 489       (c-call::%naturalize-c-string string))))
 490
 491 (defmethod from-alien-function ((type (eql 'string)) &rest args)
 492   (declare (ignore type args))
 493   #'(lambda (string)
 494       (unless (null-pointer-p string)
 495         (c-call::%naturalize-c-string string))))
 496
 497 (defmethod cleanup-form (string (type (eql 'string)) &rest args)
 498   (declare (ignore type args))
 499   `(let ((string ,string))
 500     (unless (null-pointer-p string)
 501       (deallocate-memory string))))
 502
 503 (defmethod cleanup-function ((type (eql 'string)) &rest args)
 504   (declare (ignore args))
 505   #'(lambda (string)
 506       (unless (null-pointer-p string)
 507         (deallocate-memory string))))
 508
 509 (defmethod writer-function ((type (eql 'string)) &rest args)
 510   (declare (ignore type args))
 511   #'(lambda (string location &optional (offset 0))
 512       (assert (null-pointer-p (sap-ref-sap location offset)))
 513       (setf (sap-ref-sap location offset)
 514        (copy-memory
 515         (make-pointer (1+ (kernel:get-lisp-obj-address string)))
 516         (1+ (length string))))))
 517
 518 (defmethod reader-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         (c-call::%naturalize-c-string (sap-ref-sap location offset)))))
 523
 524 (defmethod destroy-function ((type (eql 'string)) &rest args)
 525   (declare (ignore type args))
 526   #'(lambda (location &optional (offset 0))
 527       (unless (null-pointer-p (sap-ref-sap location offset))
 528         (deallocate-memory (sap-ref-sap location offset))
 529         (setf (sap-ref-sap location offset) (make-pointer 0)))))
 530
 531
 532 (defmethod alien-type ((type (eql 'pathname)) &rest args)
 533   (declare (ignore type args))
 534   (alien-type 'string))
 535
 536 (defmethod size-of ((type (eql 'pathname)) &rest args)
 537   (declare (ignore type args))
 538   (size-of 'string))
 539
 540 (defmethod to-alien-form (path (type (eql 'pathname)) &rest args)
 541   (declare (ignore type args))
 542   (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string))
 543
 544 (defmethod to-alien-function ((type (eql 'pathname)) &rest args)
 545   (declare (ignore type args))
 546   (let ((string-function (to-alien-function 'string)))
 547     #'(lambda (path)
 548         (funcall string-function (namestring path)))))
 549
 550 (defmethod from-alien-form (string (type (eql 'pathname)) &rest args)
 551   (declare (ignore type args))
 552   `(parse-namestring ,(from-alien-form string 'string)))
 553
 554 (defmethod from-alien-function ((type (eql 'pathname)) &rest args)
 555   (declare (ignore type args))
 556   (let ((string-function (from-alien-function 'string)))
 557     #'(lambda (string)
 558         (parse-namestring (funcall string-function string)))))
 559
 560 (defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args)
 561   (declare (ignore type args))
 562   (cleanup-form string 'string))
 563
 564 (defmethod cleanup-function ((type (eql 'pathnanme)) &rest args)
 565   (declare (ignore type args))
 566   (cleanup-function 'string))
 567
 568 (defmethod writer-function ((type (eql 'pathname)) &rest args)
 569   (declare (ignore type args))
 570   (let ((string-writer (writer-function 'string)))
 571     #'(lambda (path location &optional (offset 0))
 572         (funcall string-writer (namestring path) location offset))))
 573
 574 (defmethod reader-function ((type (eql 'pathname)) &rest args)
 575   (declare (ignore type args))
 576   (let ((string-reader (reader-function 'string)))
 577   #'(lambda (location &optional (offset 0))
 578       (let ((string (funcall string-reader location offset)))
 579         (when string
 580           (parse-namestring string))))))
 581
 582 (defmethod destroy-function ((type (eql 'pathname)) &rest args)
 583   (declare (ignore type args))
 584   (destroy-function 'string))
 585
 586
 587 (defmethod alien-type ((type (eql 'boolean)) &rest args)
 588   (apply #'alien-type 'signed-byte args))
 589
 590 (defmethod size-of ((type (eql 'boolean)) &rest args)
 591   (apply #'size-of 'signed-byte args))
 592
 593 (defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args)
 594   (declare (ignore type args))
 595   `(if ,boolean 1 0))
 596
 597 (defmethod to-alien-function ((type (eql 'boolean)) &rest args)
 598   (declare (ignore type args))
 599   #'(lambda (boolean)
 600       (if boolean 1 0)))
 601
 602 (defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args)
 603   (declare (ignore type args))
 604   `(not (zerop ,boolean)))
 605
 606 (defmethod from-alien-function ((type (eql 'boolean)) &rest args)
 607   (declare (ignore type args))
 608   #'(lambda (boolean)
 609       (not (zerop boolean))))
 610
 611 (defmethod writer-function ((type (eql 'boolean)) &rest args)
 612   (declare (ignore type))
 613   (let ((writer (apply #'writer-function 'signed-byte args)))
 614     #'(lambda (boolean location &optional (offset 0))
 615         (funcall writer (if boolean 1 0) location offset))))
 616
 617 (defmethod reader-function ((type (eql 'boolean)) &rest args)
 618   (declare (ignore type))
 619   (let ((reader (apply #'reader-function 'signed-byte args)))
 620   #'(lambda (location &optional (offset 0))
 621       (not (zerop (funcall reader location offset))))))
 622
 623
 624 (defmethod alien-type ((type (eql 'or)) &rest args)
 625   (let ((alien-type (alien-type (first args))))
 626     (unless (every #'(lambda (type)
 627                        (eq alien-type (alien-type type)))
 628                    (rest args))
 629       (error "No common alien type specifier for union type: ~A"
 630        (cons type args)))
 631     alien-type))
 632
 633 (defmethod size-of ((type (eql 'or)) &rest args)
 634   (declare (ignore type))
 635   (size-of (first args)))
 636
 637 (defmethod to-alien-form (form (type (eql 'or)) &rest args)
 638   (declare (ignore type))
 639   `(let ((value ,form))
 640     (etypecase value
 641       ,@(mapcar
 642          #'(lambda (type)
 643              `(,type ,(to-alien-form 'value type)))
 644          args))))
 645
 646 (defmethod to-alien-function ((type (eql 'or)) &rest types)
 647   (declare (ignore type))
 648   (let ((functions (mapcar #'to-alien-function types)))
 649     #'(lambda (value)
 650         (loop
 651          for function in functions
 652          for type in types
 653          when (typep value type)
 654          do (return (funcall function value))
 655          finally (error "~S is not of type ~A" value `(or ,@types))))))
 656
 657 (defmethod alien-type ((type (eql 'system-area-pointer)) &rest args)
 658   (declare (ignore type args))
 659   'system-area-pointer)
 660
 661 (defmethod size-of ((type (eql 'system-area-pointer)) &rest args)
 662   (declare (ignore type args))
 663   +size-of-pointer+)
 664
 665 (defmethod writer-function ((type (eql 'system-area-pointer)) &rest args)
 666   (declare (ignore type args))
 667   #'(lambda (sap location &optional (offset 0))
 668       (setf (sap-ref-sap location offset) sap)))
 669
 670 (defmethod reader-function ((type (eql 'system-area-pointer)) &rest args)
 671   (declare (ignore type args))
 672   #'(lambda (location &optional (offset 0))
 673       (sap-ref-sap location offset)))
 674
 675
 676 (defmethod alien-type ((type (eql 'null)) &rest args)
 677   (declare (ignore type args))
 678   (alien-type 'pointer))
 679
 680 (defmethod size-of ((type (eql 'null)) &rest args)
 681   (declare (ignore type args))
 682   (size-of 'pointer))
 683
 684 (defmethod to-alien-form (null (type (eql 'null)) &rest args)
 685   (declare (ignore null type args))
 686   `(make-pointer 0))
 687
 688 (defmethod to-alien-function ((type (eql 'null)) &rest args)
 689   (declare (ignore type args))
 690   #'(lambda (null)
 691       (declare (ignore null))
 692       (make-pointer 0)))
 693
 694
 695 (defmethod alien-type ((type (eql 'nil)) &rest args)
 696   (declare (ignore type args))
 697   'c-call:void)
 698
 699 (defmethod from-alien-function ((type (eql 'nil)) &rest args)
 700   (declare (ignore type args))
 701   #'(lambda (value)
 702       (declare (ignore value))
 703       (values)))