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