chiark - git - mdw - clg/blob - glib/ffi.lisp

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: ffi.lisp,v 1.25 2006-02-19 22:25:31 espen Exp $
  24
  25 (in-package "GLIB")
  26
  27
  28 ;;;; Foreign function call interface
  29
  30 (defvar *package-prefix* nil)
  31
  32 (defun set-package-prefix (prefix &optional (package *package*))
  33   (let ((package (find-package package)))
  34     (delete-if #'(lambda (assoc) (eq (car assoc) package)) *package-prefix*)
  35     (push (cons package prefix) *package-prefix*))
  36   prefix)
  37
  38 (defun package-prefix (&optional (package *package*))
  39   (let ((package (find-package package)))
  40     (or
  41      (cdr (assoc package *package-prefix*))
  42      (substitute #\_ #\- (string-downcase (package-name package))))))
  43
  44 (defun find-prefix-package (prefix)
  45   (or
  46    (car (rassoc (string-downcase prefix) *package-prefix* :test #'string=))
  47    (find-package (string-upcase prefix))))
  48
  49 (defmacro use-prefix (prefix &optional (package *package*))
  50   `(eval-when (:compile-toplevel :load-toplevel :execute)
  51      (set-package-prefix ,prefix ,package)))
  52
  53
  54 (defun default-alien-fname (lisp-name)
  55   (let* ((name (substitute #\_ #\- (string-downcase lisp-name)))
  56          (stripped-name
  57           (cond
  58            ((and
  59              (char= (char name 0) #\%)
  60              (string= "_p" name :start2 (- (length name) 2)))
  61             (subseq name 1 (- (length name) 2)))
  62            ((char= (char name 0) #\%)
  63             (subseq name 1))
  64            ((string= "_p" name :start2 (- (length name) 2))
  65             (subseq name 0 (- (length name) 2)))
  66            (name)))
  67          (prefix (package-prefix *package*)))
  68     (if (or (not prefix) (string= prefix ""))
  69         stripped-name
  70       (format nil "~A_~A" prefix stripped-name))))
  71
  72 (defun default-alien-type-name (type-name)
  73   (let ((prefix (package-prefix *package*)))
  74     (apply
  75      #'concatenate
  76      'string
  77      (mapcar
  78       #'string-capitalize
  79       (cons prefix (split-string (symbol-name type-name) #\-))))))
  80
  81 (defun default-type-name (alien-name)
  82   (let ((parts
  83          (mapcar
  84           #'string-upcase
  85           (split-string-if alien-name #'upper-case-p))))
  86     (intern
  87      (concatenate-strings
  88       (rest parts) #\-) (find-prefix-package (first parts)))))
  89
  90
  91 (defmacro defbinding (name lambda-list return-type &rest docs/args)
  92   (multiple-value-bind (lisp-name c-name)
  93       (if (atom name)
  94           (values name (default-alien-fname name))
  95         (values-list name))
  96
  97     (let ((supplied-lambda-list lambda-list)
  98           (docs nil)
  99           (args nil))
 100       (dolist (doc/arg docs/args)
 101         (if (stringp doc/arg)
 102             (push doc/arg docs)
 103           (progn
 104             (destructuring-bind (expr type &optional (style :in)) doc/arg
 105               (unless (member style '(:in :out :in-out :return))
 106                 (error "Bogus argument style ~S in ~S." style doc/arg))
 107               (when (and
 108                      (not supplied-lambda-list)
 109                      (namep expr) (member style '(:in :in-out :return)))
 110                 (push expr lambda-list))
 111               (push (list (cond
 112                            ((and (namep expr) (eq style :out)) expr)
 113                            ((namep expr) (make-symbol (string expr)))
 114                            ((gensym)))
 115                           expr (mklist type) style) args)))))
 116
 117       (%defbinding
 118        c-name lisp-name (or supplied-lambda-list (nreverse lambda-list))
 119        return-type (reverse docs) (reverse args)))))
 120
 121 #+(or cmu sbcl)
 122 (defun %defbinding (foreign-name lisp-name lambda-list return-type docs args)
 123   (collect ((alien-types) (alien-bindings) (alien-parameters)
 124             (return-values) (cleanup-forms))
 125     (dolist (arg args)
 126       (destructuring-bind (var expr type style) arg
 127         (let ((declaration (alien-type type))
 128               (cleanup (cleanup-form var type)))
 129
 130           (cond
 131             ((member style '(:out :in-out))
 132              (alien-types `(* ,declaration))
 133              (alien-parameters `(addr ,var))
 134              (alien-bindings
 135               `(,var ,declaration
 136                 ,@(cond
 137                    ((eq style :in-out) (list (to-alien-form expr type)))
 138                    ((eq declaration 'system-area-pointer)
 139                     (list '(make-pointer 0))))))
 140              (return-values (from-alien-form var type)))
 141             ((eq style :return)
 142              (alien-types declaration)
 143              (alien-bindings
 144               `(,var ,declaration ,(to-alien-form expr type)))
 145              (alien-parameters var)
 146              (return-values (from-alien-form var type)))
 147             (cleanup
 148              (alien-types declaration)
 149              (alien-bindings
 150               `(,var ,declaration ,(to-alien-form expr type)))
 151              (alien-parameters var)
 152              (cleanup-forms cleanup))
 153             (t
 154              (alien-types declaration)
 155              (alien-parameters (to-alien-form expr type)))))))
 156
 157     (let* ((alien-name (make-symbol (string lisp-name)))
 158            (alien-funcall `(alien-funcall ,alien-name ,@(alien-parameters))))
 159       `(defun ,lisp-name ,lambda-list
 160          ,@docs
 161          #+cmu(declare (optimize (inhibit-warnings 3)))
 162          #+sbcl(declare (muffle-conditions compiler-note))
 163          (with-alien ((,alien-name
 164                        (function
 165                         ,(alien-type return-type)
 166                         ,@(alien-types))
 167                        :extern ,foreign-name)
 168                       ,@(alien-bindings))
 169            ,(if return-type
 170                 `(values
 171                   (unwind-protect
 172                       ,(from-alien-form alien-funcall return-type)
 173                     ,@(cleanup-forms))
 174                   ,@(return-values))
 175               `(progn
 176                 (unwind-protect
 177                      ,alien-funcall
 178                   ,@(cleanup-forms))
 179                 (values ,@(return-values)))))))))
 180
 181
 182 ;;; Creates bindings at runtime
 183 (defun mkbinding (name return-type &rest arg-types)
 184   #+cmu(declare (optimize (inhibit-warnings 3)))
 185   #+sbcl(declare (muffle-conditions compiler-note))
 186   (let* ((ftype
 187           `(function ,@(mapcar #'alien-type (cons return-type arg-types))))
 188          (alien
 189           (%heap-alien
 190            (make-heap-alien-info
 191             :type (parse-alien-type ftype #+sbcl nil)
 192             :sap-form (let ((address (foreign-symbol-address name)))
 193                         (etypecase address
 194                           (integer (int-sap address))
 195                           (system-area-pointer address))))))
 196          (translate-arguments (mapcar #'to-alien-function arg-types))
 197          (translate-return-value (from-alien-function return-type))
 198          (cleanup-arguments (mapcar #'cleanup-function arg-types)))
 199
 200     #'(lambda (&rest args)
 201         (map-into args #'funcall translate-arguments args)
 202         (prog1
 203             (funcall translate-return-value
 204              (apply #'alien-funcall alien args))
 205           (mapc #'funcall cleanup-arguments args)))))
 206
 207
 208
 209 ;;;; C callbacks
 210
 211 (defmacro define-callback (name return-type args &body body)
 212   (let ((define-callback
 213           #+cmu'alien:def-callback
 214           #+(and sbcl alien-callbacks)'sb-alien::define-alien-callback
 215           #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function))
 216     (multiple-value-bind (doc declaration body)
 217         (cond
 218          ((and (stringp (first body)) (eq (cadr body) 'declare))
 219           (values (first body) (second body) (cddr body)))
 220          ((stringp (first body))
 221           (values (first body) nil (rest body)))
 222          ((eq (caar body) 'declare)
 223           (values nil (first body) (rest body)))
 224          (t (values nil nil body)))
 225       `(,define-callback ,name
 226          #+(and sbcl alien-callbacks),(alien-type return-type)
 227          (#+(or cmu (and sbcl (not alien-callbacks))),(alien-type return-type)
 228          ,@(mapcar #'(lambda (arg)
 229                        (destructuring-bind (name type) arg
 230                          `(,name ,(alien-type type))))
 231                    args))
 232          ,@(when doc (list doc))
 233          ,(to-alien-form
 234            `(let (,@(loop
 235                      for (name type) in args
 236                      as from-alien-form = (callback-from-alien-form name type)
 237                      collect `(,name ,from-alien-form)))
 238               ,@(when declaration (list declaration))
 239               (unwind-protect
 240                   (progn ,@body)
 241               ,@(loop
 242                  for (name type) in args
 243                  do (callback-cleanup-form name type))))
 244
 245          return-type)))))
 246
 247 (defun callback-address (callback)
 248   #+cmu(alien::callback-trampoline callback)
 249   #+(and sbcl (not alien-callbacks))(sb-alien:alien-function-sap callback)
 250   #+(and sbcl alien-callbacks)(sb-alien:alien-sap callback))
 251
 252 #+sbcl
 253 (deftype callback ()
 254   #-alien-callbacks'sb-alien:alien-function
 255   #+alien-callbacks'sb-alien:alien)
 256
 257
 258 ;;; These are for backward compatibility
 259
 260 (defmacro defcallback (name (return-type &rest args) &body body)
 261   `(define-callback ,name ,return-type ,args ,@body))
 262
 263 #-cmu
 264 (defun callback (callback)
 265   (callback-address callback))
 266
 267
 268
 269 ;;;; Definitons and translations of fundamental types
 270
 271 (defmacro def-type-method (name args &optional documentation)
 272   `(progn
 273     (defgeneric ,name (,@args type &rest args)
 274       ,@(when documentation `((:documentation ,documentation))))
 275     (defmethod ,name (,@args (type symbol) &rest args)
 276       (let ((class (find-class type nil)))
 277         (if (typep class 'standard-class)
 278             (apply #',name ,@args class args)
 279           (multiple-value-bind (super-type expanded-p)
 280               (type-expand-1 (cons type args))
 281             (if expanded-p
 282                 (,name ,@args super-type)
 283               (call-next-method))))))
 284     (defmethod ,name (,@args (type cons) &rest args)
 285       (declare (ignore args))
 286       (apply #',name ,@args (first type) (rest type)))))
 287
 288
 289 (def-type-method alien-type ())
 290 (def-type-method size-of ())
 291 (def-type-method to-alien-form (form))
 292 (def-type-method from-alien-form (form))
 293 (def-type-method cleanup-form (form)
 294   "Creates a form to clean up after the alien call has finished.")
 295 (def-type-method callback-from-alien-form (form))
 296 (def-type-method callback-cleanup-form (form))
 297
 298 (def-type-method to-alien-function ())
 299 (def-type-method from-alien-function ())
 300 (def-type-method cleanup-function ())
 301
 302 (def-type-method copy-to-alien-form (form))
 303 (def-type-method copy-to-alien-function ())
 304 (def-type-method copy-from-alien-form (form))
 305 (def-type-method copy-from-alien-function ())
 306
 307 (def-type-method writer-function ())
 308 (def-type-method reader-function ())
 309 (def-type-method destroy-function ())
 310
 311 (def-type-method unbound-value ()
 312   "First return value is true if the type has an unbound value, second return value is the actual unbound value")
 313
 314
 315 ;; Sizes of fundamental C types in bytes (8 bits)
 316 (defconstant +size-of-short+ 2)
 317 (defconstant +size-of-int+ 4)
 318 (defconstant +size-of-long+ 4)
 319 (defconstant +size-of-pointer+ 4)
 320 (defconstant +size-of-float+ 4)
 321 (defconstant +size-of-double+ 8)
 322
 323 ;; Sizes of fundamental C types in bits
 324 (defconstant +bits-of-byte+ 8)
 325 (defconstant +bits-of-short+ 16)
 326 (defconstant +bits-of-int+ 32)
 327 (defconstant +bits-of-long+ 32)
 328
 329
 330 (deftype int () '(signed-byte #.+bits-of-int+))
 331 (deftype unsigned-int () '(unsigned-byte #.+bits-of-int+))
 332 (deftype long () '(signed-byte #.+bits-of-long+))
 333 (deftype unsigned-long () '(unsigned-byte #.+bits-of-long+))
 334 (deftype short () '(signed-byte #.+bits-of-short+))
 335 (deftype unsigned-short () '(unsigned-byte #.+bits-of-short+))
 336 (deftype signed (&optional (size '*)) `(signed-byte ,size))
 337 (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
 338 (deftype char () 'base-char)
 339 (deftype pointer () 'system-area-pointer)
 340 (deftype boolean (&optional (size '*)) (declare (ignore size)) `(member t nil))
 341 ;(deftype invalid () nil)
 342
 343
 344 (defmethod to-alien-form (form (type t) &rest args)
 345   (declare (ignore type args))
 346   form)
 347
 348 (defmethod to-alien-function ((type t) &rest args)
 349   (declare (ignore type args))
 350   #'identity)
 351
 352 (defmethod from-alien-form (form (type t) &rest args)
 353   (declare (ignore type args))
 354   form)
 355
 356 (defmethod from-alien-function ((type t) &rest args)
 357   (declare (ignore type args))
 358   #'identity)
 359
 360 (defmethod cleanup-form (form (type t) &rest args)
 361   (declare (ignore form type args))
 362   nil)
 363
 364 (defmethod cleanup-function ((type t) &rest args)
 365   (declare (ignore type args))
 366   #'identity)
 367
 368 ;; This does not really work as def-type-method is badly broken and
 369 ;; needs a redesign, so we need to add a lots of redundant methods
 370 (defmethod callback-from-alien-form (form (type t) &rest args)
 371 ;  (apply #'copy-from-alien-form form type args))
 372   (apply #'from-alien-form form type args))
 373
 374 (defmethod callback-cleanup-form (form (type t) &rest args)
 375   (declare (ignore form type args))
 376   nil)
 377
 378 (defmethod destroy-function ((type t) &rest args)
 379   (declare (ignore type args))
 380   #'(lambda (location &optional offset)
 381       (declare (ignore location offset))))
 382
 383 (defmethod copy-to-alien-form  (form (type t) &rest args)
 384   (apply #'to-alien-form form type args))
 385
 386 (defmethod copy-to-alien-function  ((type t) &rest args)
 387   (apply #'to-alien-function type args))
 388
 389 (defmethod copy-from-alien-form  (form (type t) &rest args)
 390   (apply #'from-alien-form form type args))
 391
 392 (defmethod copy-from-alien-function  ((type t) &rest args)
 393   (apply #'from-alien-function type args))
 394
 395 (defmethod alien-type ((type (eql 'signed-byte)) &rest args)
 396   (declare (ignore type))
 397   (destructuring-bind (&optional (size '*)) args
 398     (ecase size
 399       (#.+bits-of-byte+ #+cmu'(alien:signed 8) #+sbcl'(sb-alien:signed 8))
 400       (#.+bits-of-short+ #+cmu 'c-call:short #+sbcl 'sb-alien:short)
 401       ((* #.+bits-of-int+) #+cmu 'c-call:int #+sbcl 'sb-alien:int)
 402       (#.+bits-of-long+ #+cmu 'c-call:long #+sbcl 'sb-alien:long))))
 403
 404 (defmethod size-of ((type (eql 'signed-byte)) &rest args)
 405   (declare (ignore type))
 406   (destructuring-bind (&optional (size '*)) args
 407     (ecase size
 408       (#.+bits-of-byte+ 1)
 409       (#.+bits-of-short+ +size-of-short+)
 410       ((* #.+bits-of-int+) +size-of-int+)
 411       (#.+bits-of-long+ +size-of-long+))))
 412
 413 (defmethod unbound-value ((type t) &rest args)
 414   (declare (ignore type args))
 415   nil)
 416
 417 (defmethod writer-function ((type (eql 'signed-byte)) &rest args)
 418   (declare (ignore type))
 419   (destructuring-bind (&optional (size '*)) args
 420     (let ((size (if (eq size '*) +bits-of-int+ size)))
 421       (ecase size
 422         (8 #'(lambda (value location &optional (offset 0))
 423                (setf (signed-sap-ref-8 location offset) value)))
 424         (16 #'(lambda (value location &optional (offset 0))
 425                 (setf (signed-sap-ref-16 location offset) value)))
 426         (32 #'(lambda (value location &optional (offset 0))
 427                 (setf (signed-sap-ref-32 location offset) value)))
 428         (64 #'(lambda (value location &optional (offset 0))
 429                 (setf (signed-sap-ref-64 location offset) value)))))))
 430
 431 (defmethod reader-function ((type (eql 'signed-byte)) &rest args)
 432   (declare (ignore type))
 433   (destructuring-bind (&optional (size '*)) args
 434     (let ((size (if (eq size '*) +bits-of-int+ size)))
 435       (ecase size
 436         (8 #'(lambda (sap &optional (offset 0) weak-p)
 437                (declare (ignore weak-p))
 438                (signed-sap-ref-8 sap offset)))
 439         (16 #'(lambda (sap &optional (offset 0) weak-p)
 440                 (declare (ignore weak-p))
 441                 (signed-sap-ref-16 sap offset)))
 442         (32 #'(lambda (sap &optional (offset 0) weak-p)
 443                 (declare (ignore weak-p))
 444                 (signed-sap-ref-32 sap offset)))
 445         (64 #'(lambda (sap &optional (offset 0) weak-p)
 446                 (declare (ignore weak-p))
 447                 (signed-sap-ref-64 sap offset)))))))
 448
 449 (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args)
 450   (destructuring-bind (&optional (size '*)) args
 451     (ecase size
 452       (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8))
 453       (#.+bits-of-short+ #+cmu 'c-call:unsigned-short
 454                          #+sbcl 'sb-alien:unsigned-short)
 455       ((* #.+bits-of-int+) #+cmu 'c-call:unsigned-int
 456                            #+sbcl 'sb-alien:unsigned-int)
 457       (#.+bits-of-long+ #+cmu 'c-call:unsigned-long
 458                         #+sbcl 'sb-alien:unsigned-long))))
 459
 460 (defmethod size-of ((type (eql 'unsigned-byte)) &rest args)
 461   (apply #'size-of 'signed args))
 462
 463 (defmethod writer-function ((type (eql 'unsigned-byte)) &rest args)
 464   (declare (ignore type))
 465   (destructuring-bind (&optional (size '*)) args
 466     (let ((size (if (eq size '*) +bits-of-int+ size)))
 467       (ecase size
 468         (8 #'(lambda (value location &optional (offset 0))
 469                (setf (sap-ref-8 location offset) value)))
 470         (16 #'(lambda (value location &optional (offset 0))
 471                 (setf (sap-ref-16 location offset) value)))
 472         (32 #'(lambda (value location &optional (offset 0))
 473                 (setf (sap-ref-32 location offset) value)))
 474         (64 #'(lambda (value location &optional (offset 0))
 475                 (setf (sap-ref-64 location offset) value)))))))
 476
 477 (defmethod reader-function ((type (eql 'unsigned-byte)) &rest args)
 478   (declare (ignore type))
 479   (destructuring-bind (&optional (size '*)) args
 480     (let ((size (if (eq size '*) +bits-of-int+ size)))
 481       (ecase size
 482         (8 #'(lambda (sap &optional (offset 0) weak-p)
 483                (declare (ignore weak-p))
 484                (sap-ref-8 sap offset)))
 485         (16 #'(lambda (sap &optional (offset 0) weak-p)
 486                 (declare (ignore weak-p))
 487                 (sap-ref-16 sap offset)))
 488         (32 #'(lambda (sap &optional (offset 0) weak-p)
 489                 (declare (ignore weak-p))
 490                 (sap-ref-32 sap offset)))
 491         (64 #'(lambda (sap &optional (offset 0) weak-p)
 492                 (declare (ignore weak-p))
 493                 (sap-ref-64 sap offset)))))))
 494
 495
 496 (defmethod alien-type ((type (eql 'integer)) &rest args)
 497   (declare (ignore type args))
 498   (alien-type 'signed-byte))
 499
 500 (defmethod size-of ((type (eql 'integer)) &rest args)
 501   (declare (ignore type args))
 502   (size-of 'signed-byte))
 503
 504 (defmethod writer-function ((type (eql 'integer)) &rest args)
 505   (declare (ignore type args))
 506   (writer-function 'signed-byte))
 507
 508 (defmethod reader-function ((type (eql 'integer)) &rest args)
 509   (declare (ignore type args))
 510   (reader-function 'signed-byte))
 511
 512
 513 (defmethod alien-type ((type (eql 'fixnum)) &rest args)
 514   (declare (ignore type args))
 515   (alien-type 'signed-byte))
 516
 517 (defmethod size-of ((type (eql 'fixnum)) &rest args)
 518   (declare (ignore type args))
 519   (size-of 'signed-byte))
 520
 521
 522 (defmethod alien-type ((type (eql 'single-float)) &rest args)
 523   (declare (ignore type args))
 524   #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float)
 525
 526 (defmethod size-of ((type (eql 'single-float)) &rest args)
 527   (declare (ignore type args))
 528   +size-of-float+)
 529
 530 (defmethod to-alien-form (form (type (eql 'single-float)) &rest args)
 531   (declare (ignore type args))
 532   `(coerce ,form 'single-float))
 533
 534 (defmethod to-alien-function ((type (eql 'single-float)) &rest args)
 535   (declare (ignore type args))
 536   #'(lambda (number)
 537       (coerce number 'single-float)))
 538
 539 (defmethod writer-function ((type (eql 'single-float)) &rest args)
 540   (declare (ignore type args))
 541   #'(lambda (value location &optional (offset 0))
 542       (setf (sap-ref-single location offset) (coerce value 'single-float))))
 543
 544 (defmethod reader-function ((type (eql 'single-float)) &rest args)
 545   (declare (ignore type args))
 546   #'(lambda (sap &optional (offset 0) weak-p)
 547       (declare (ignore weak-p))
 548       (sap-ref-single sap offset)))
 549
 550
 551 (defmethod alien-type ((type (eql 'double-float)) &rest args)
 552   (declare (ignore type args))
 553   #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float)
 554
 555 (defmethod size-of ((type (eql 'double-float)) &rest args)
 556   (declare (ignore type args))
 557   +size-of-double+)
 558
 559 (defmethod to-alien-form (form (type (eql 'double-float)) &rest args)
 560   (declare (ignore type args))
 561   `(coerce ,form 'double-float))
 562
 563 (defmethod to-alien-function ((type (eql 'double-float)) &rest args)
 564   (declare (ignore type args))
 565   #'(lambda (number)
 566       (coerce number 'double-float)))
 567
 568 (defmethod writer-function ((type (eql 'double-float)) &rest args)
 569   (declare (ignore type args))
 570   #'(lambda (value location &optional (offset 0))
 571       (setf (sap-ref-double location offset) (coerce value 'double-float))))
 572
 573 (defmethod reader-function ((type (eql 'double-float)) &rest args)
 574   (declare (ignore type args))
 575   #'(lambda (sap &optional (offset 0) weak-p)
 576       (declare (ignore weak-p))
 577       (sap-ref-double sap offset)))
 578
 579
 580 (defmethod alien-type ((type (eql 'base-char)) &rest args)
 581   (declare (ignore type args))
 582   #+cmu 'c-call:char #+sbcl 'sb-alien:char)
 583
 584 (defmethod size-of ((type (eql 'base-char)) &rest args)
 585   (declare (ignore type args))
 586   1)
 587
 588 (defmethod writer-function ((type (eql 'base-char)) &rest args)
 589   (declare (ignore type args))
 590   #'(lambda (char location &optional (offset 0))
 591       (setf (sap-ref-8 location offset) (char-code char))))
 592
 593 (defmethod reader-function ((type (eql 'base-char)) &rest args)
 594   (declare (ignore type args))
 595   #'(lambda (location &optional (offset 0) weak-p)
 596       (declare (ignore weak-p))
 597       (code-char (sap-ref-8 location offset))))
 598
 599
 600 (defmethod alien-type ((type (eql 'string)) &rest args)
 601   (declare (ignore type args))
 602   (alien-type 'pointer))
 603
 604 (defmethod size-of ((type (eql 'string)) &rest args)
 605   (declare (ignore type args))
 606   (size-of 'pointer))
 607
 608 (defmethod to-alien-form (string (type (eql 'string)) &rest args)
 609   (declare (ignore type args))
 610   `(let ((string ,string))
 611      ;; Always copy strings to prevent seg fault due to GC
 612      #+cmu
 613      (copy-memory
 614       (vector-sap (coerce string 'simple-base-string))
 615       (1+ (length string)))
 616      #+sbcl
 617      (let ((utf8 (%deport-utf8-string string)))
 618        (copy-memory (vector-sap utf8) (length utf8)))))
 619
 620 (defmethod to-alien-function ((type (eql 'string)) &rest args)
 621   (declare (ignore type args))
 622   #'(lambda (string)
 623       #+cmu
 624       (copy-memory
 625        (vector-sap (coerce string 'simple-base-string))
 626        (1+ (length string)))
 627       #+sbcl
 628       (let ((utf8 (%deport-utf8-string string)))
 629         (copy-memory (vector-sap utf8) (length utf8)))))
 630
 631 (defmethod callback-from-alien-form (form (type (eql 'string)) &rest args)
 632   (apply #'copy-from-alien-form form type args))
 633
 634 (defmethod from-alien-form (string (type (eql 'string)) &rest args)
 635   (declare (ignore type args))
 636   `(let ((string ,string))
 637     (unless (null-pointer-p string)
 638       (prog1
 639           #+cmu(%naturalize-c-string string)
 640           #+sbcl(%naturalize-utf8-string string)
 641         (deallocate-memory string)))))
 642
 643 (defmethod from-alien-function ((type (eql 'string)) &rest args)
 644   (declare (ignore type args))
 645   #'(lambda (string)
 646       (unless (null-pointer-p string)
 647         (prog1
 648             #+cmu(%naturalize-c-string string)
 649             #+sbcl(%naturalize-utf8-string string)
 650           (deallocate-memory string)))))
 651
 652 (defmethod cleanup-form (string (type (eql 'string)) &rest args)
 653   (declare (ignore type args))
 654   `(let ((string ,string))
 655     (unless (null-pointer-p string)
 656       (deallocate-memory string))))
 657
 658 (defmethod cleanup-function ((type (eql 'string)) &rest args)
 659   (declare (ignore args))
 660   #'(lambda (string)
 661       (unless (null-pointer-p string)
 662         (deallocate-memory string))))
 663
 664 (defmethod callback-from-alien-form (form (type (eql 'string)) &rest args)
 665   (apply #'copy-from-alien-form form type args))
 666
 667 (defmethod copy-from-alien-form (string (type (eql 'string)) &rest args)
 668   (declare (ignore type args))
 669   `(let ((string ,string))
 670     (unless (null-pointer-p string)
 671       #+cmu(%naturalize-c-string string)
 672       #+sbcl(%naturalize-utf8-string string))))
 673
 674 (defmethod copy-from-alien-function ((type (eql 'string)) &rest args)
 675   (declare (ignore type args))
 676   #'(lambda (string)
 677       (unless (null-pointer-p string)
 678         #+cmu(%naturalize-c-string string)
 679         #+sbcl(%naturalize-utf8-string string))))
 680
 681 (defmethod writer-function ((type (eql 'string)) &rest args)
 682   (declare (ignore type args))
 683   #'(lambda (string location &optional (offset 0))
 684       (assert (null-pointer-p (sap-ref-sap location offset)))
 685       (setf (sap-ref-sap location offset)
 686        #+cmu
 687        (copy-memory
 688         (vector-sap (coerce string 'simple-base-string))
 689         (1+ (length string)))
 690        #+sbcl
 691        (let ((utf8 (%deport-utf8-string string)))
 692          (copy-memory (vector-sap utf8) (length utf8))))))
 693
 694 (defmethod reader-function ((type (eql 'string)) &rest args)
 695   (declare (ignore type args))
 696   #'(lambda (location &optional (offset 0) weak-p)
 697       (declare (ignore weak-p))
 698       (unless (null-pointer-p (sap-ref-sap location offset))
 699         #+cmu(%naturalize-c-string (sap-ref-sap location offset))
 700         #+sbcl(%naturalize-utf8-string (sap-ref-sap location offset)))))
 701
 702 (defmethod destroy-function ((type (eql 'string)) &rest args)
 703   (declare (ignore type args))
 704   #'(lambda (location &optional (offset 0))
 705       (unless (null-pointer-p (sap-ref-sap location offset))
 706         (deallocate-memory (sap-ref-sap location offset))
 707         (setf (sap-ref-sap location offset) (make-pointer 0)))))
 708
 709 (defmethod unbound-value ((type (eql 'string)) &rest args)
 710   (declare (ignore type args))
 711   (values t nil))
 712
 713
 714 (defmethod alien-type ((type (eql 'pathname)) &rest args)
 715   (declare (ignore type args))
 716   (alien-type 'string))
 717
 718 (defmethod size-of ((type (eql 'pathname)) &rest args)
 719   (declare (ignore type args))
 720   (size-of 'string))
 721
 722 (defmethod to-alien-form (path (type (eql 'pathname)) &rest args)
 723   (declare (ignore type args))
 724   (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string))
 725
 726 (defmethod to-alien-function ((type (eql 'pathname)) &rest args)
 727   (declare (ignore type args))
 728   (let ((string-function (to-alien-function 'string)))
 729     #'(lambda (path)
 730         (funcall string-function (namestring path)))))
 731
 732 (defmethod from-alien-form (string (type (eql 'pathname)) &rest args)
 733   (declare (ignore type args))
 734   `(parse-namestring ,(from-alien-form string 'string)))
 735
 736 (defmethod from-alien-function ((type (eql 'pathname)) &rest args)
 737   (declare (ignore type args))
 738   (let ((string-function (from-alien-function 'string)))
 739     #'(lambda (string)
 740         (parse-namestring (funcall string-function string)))))
 741
 742 (defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args)
 743   (declare (ignore type args))
 744   (cleanup-form string 'string))
 745
 746 (defmethod cleanup-function ((type (eql 'pathnanme)) &rest args)
 747   (declare (ignore type args))
 748   (cleanup-function 'string))
 749
 750 (defmethod writer-function ((type (eql 'pathname)) &rest args)
 751   (declare (ignore type args))
 752   (let ((string-writer (writer-function 'string)))
 753     #'(lambda (path location &optional (offset 0))
 754         (funcall string-writer (namestring path) location offset))))
 755
 756 (defmethod reader-function ((type (eql 'pathname)) &rest args)
 757   (declare (ignore type args))
 758   (let ((string-reader (reader-function 'string)))
 759   #'(lambda (location &optional (offset 0) weak-p)
 760       (declare (ignore weak-p))
 761       (let ((string (funcall string-reader location offset)))
 762         (when string
 763           (parse-namestring string))))))
 764
 765 (defmethod destroy-function ((type (eql 'pathname)) &rest args)
 766   (declare (ignore type args))
 767   (destroy-function 'string))
 768
 769 (defmethod unbound-value ((type (eql 'pathname)) &rest args)
 770   (declare (ignore type args))
 771   (unbound-value 'string))
 772
 773
 774 (defmethod alien-type ((type (eql 'boolean)) &rest args)
 775   (apply #'alien-type 'signed-byte args))
 776
 777 (defmethod size-of ((type (eql 'boolean)) &rest args)
 778   (apply #'size-of 'signed-byte args))
 779
 780 (defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args)
 781   (declare (ignore type args))
 782   `(if ,boolean 1 0))
 783
 784 (defmethod to-alien-function ((type (eql 'boolean)) &rest args)
 785   (declare (ignore type args))
 786   #'(lambda (boolean)
 787       (if boolean 1 0)))
 788
 789 (defmethod callback-from-alien-form (form (type (eql 'boolean)) &rest args)
 790   (apply #'from-alien-form form type args))
 791
 792 (defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args)
 793   (declare (ignore type args))
 794   `(not (zerop ,boolean)))
 795
 796 (defmethod from-alien-function ((type (eql 'boolean)) &rest args)
 797   (declare (ignore type args))
 798   #'(lambda (boolean)
 799       (not (zerop boolean))))
 800
 801 (defmethod writer-function ((type (eql 'boolean)) &rest args)
 802   (declare (ignore type))
 803   (let ((writer (apply #'writer-function 'signed-byte args)))
 804     #'(lambda (boolean location &optional (offset 0))
 805         (funcall writer (if boolean 1 0) location offset))))
 806
 807 (defmethod reader-function ((type (eql 'boolean)) &rest args)
 808   (declare (ignore type))
 809   (let ((reader (apply #'reader-function 'signed-byte args)))
 810   #'(lambda (location &optional (offset 0) weak-p)
 811       (declare (ignore weak-p))
 812       (not (zerop (funcall reader location offset))))))
 813
 814
 815 (defmethod alien-type ((type (eql 'or)) &rest args)
 816   (let ((alien-type (alien-type (first args))))
 817     (unless (every #'(lambda (type)
 818                        (eq alien-type (alien-type type)))
 819                    (rest args))
 820       (error "No common alien type specifier for union type: ~A"
 821        (cons type args)))
 822     alien-type))
 823
 824 (defmethod size-of ((type (eql 'or)) &rest args)
 825   (declare (ignore type))
 826   (size-of (first args)))
 827
 828 (defmethod to-alien-form (form (type (eql 'or)) &rest args)
 829   (declare (ignore type))
 830   `(let ((value ,form))
 831     (etypecase value
 832       ,@(mapcar
 833          #'(lambda (type)
 834              `(,type ,(to-alien-form 'value type)))
 835          args))))
 836
 837 (defmethod to-alien-function ((type (eql 'or)) &rest types)
 838   (declare (ignore type))
 839   (let ((functions (mapcar #'to-alien-function types)))
 840     #'(lambda (value)
 841         (loop
 842          for function in functions
 843          for type in types
 844          when (typep value type)
 845          do (return (funcall function value))
 846          finally (error "~S is not of type ~A" value `(or ,@types))))))
 847
 848 (defmethod alien-type ((type (eql 'system-area-pointer)) &rest args)
 849   (declare (ignore type args))
 850   'system-area-pointer)
 851
 852 (defmethod size-of ((type (eql 'system-area-pointer)) &rest args)
 853   (declare (ignore type args))
 854   +size-of-pointer+)
 855
 856 (defmethod writer-function ((type (eql 'system-area-pointer)) &rest args)
 857   (declare (ignore type args))
 858   #'(lambda (sap location &optional (offset 0))
 859       (setf (sap-ref-sap location offset) sap)))
 860
 861 (defmethod reader-function ((type (eql 'system-area-pointer)) &rest args)
 862   (declare (ignore type args))
 863   #'(lambda (location &optional (offset 0) weak-p)
 864       (declare (ignore weak-p))
 865       (sap-ref-sap location offset)))
 866
 867
 868 (defmethod alien-type ((type (eql 'null)) &rest args)
 869   (declare (ignore type args))
 870   (alien-type 'pointer))
 871
 872 (defmethod size-of ((type (eql 'null)) &rest args)
 873   (declare (ignore type args))
 874   (size-of 'pointer))
 875
 876 (defmethod to-alien-form (null (type (eql 'null)) &rest args)
 877   (declare (ignore null type args))
 878   `(make-pointer 0))
 879
 880 (defmethod to-alien-function ((type (eql 'null)) &rest args)
 881   (declare (ignore type args))
 882   #'(lambda (null)
 883       (declare (ignore null))
 884       (make-pointer 0)))
 885
 886
 887 (defmethod alien-type ((type (eql 'nil)) &rest args)
 888   (declare (ignore type args))
 889   'void)
 890
 891 (defmethod from-alien-function ((type (eql 'nil)) &rest args)
 892   (declare (ignore type args))
 893   #'(lambda (value)
 894       (declare (ignore value))
 895       (values)))
 896
 897
 898 (defmethod alien-type ((type (eql 'copy-of)) &rest args)
 899   (declare (ignore type))
 900   (alien-type (first args)))
 901
 902 (defmethod size-of ((type (eql 'copy-of)) &rest args)
 903   (declare (ignore type))
 904   (size-of (first args)))
 905
 906 (defmethod to-alien-form (form (type (eql 'copy-of)) &rest args)
 907   (declare (ignore type))
 908   (copy-to-alien-form form (first args)))
 909
 910 (defmethod to-alien-function ((type (eql 'copy-of)) &rest args)
 911   (declare (ignore type))
 912   (copy-to-alien-function (first args)))
 913
 914 (defmethod from-alien-form (form (type (eql 'copy-of)) &rest args)
 915   (declare (ignore type))
 916   (copy-from-alien-form form (first args)))
 917
 918 (defmethod from-alien-function ((type (eql 'copy-of)) &rest args)
 919   (declare (ignore type))
 920   (copy-from-alien-function (first args)))
 921
 922 (defmethod reader-function ((type (eql 'copy-of)) &rest args)
 923   (declare (ignore type))
 924   (reader-function (first args)))
 925
 926 (defmethod writer-function ((type (eql 'copy-of)) &rest args)
 927   (declare (ignore type))
 928   (writer-function (first args)))
 929
 930
 931 (defmethod alien-type ((type (eql 'callback)) &rest args)
 932   (declare (ignore type args))
 933   (alien-type 'pointer))
 934
 935 #+nil
 936 (defmethod size-of ((type (eql 'callback)) &rest args)
 937   (declare (ignore type args))
 938   (size-of 'pointer))
 939
 940 (defmethod to-alien-form (callback (type (eql 'callback)) &rest args)
 941   (declare (ignore type args))
 942   `(callback-address ,callback))
 943
 944 (defmethod to-alien-function ((type (eql 'callback)) &rest args)
 945   (declare (ignore type args))
 946   #'callback-address)
 947
 948 #+nil(
 949 #+cmu
 950 (defun find-callback (pointer)
 951   (find pointer alien::*callbacks* :key #'callback-trampoline :test #'sap=))
 952
 953 (defmethod from-alien-form (pointer (type (eql 'callback)) &rest args)
 954   (declare (ignore type args))
 955   #+cmu  `(find-callback ,pointer)
 956   #+sbcl `(sb-alien::%find-alien-function ,pointer))
 957
 958 (defmethod from-alien-function ((type (eql 'callback)) &rest args)
 959   (declare (ignore type args))
 960   #+cmu  #'find-callback
 961   #+sbcl #'sb-alien::%find-alien-function)
 962
 963 (defmethod writer-function ((type (eql 'callback)) &rest args)
 964   (declare (ignore type args))
 965   (let ((writer (writer-function 'pointer))
 966         (to-alien (to-alien-function 'callback)))
 967     #'(lambda (callback location &optional (offset 0))
 968         (funcall writer (funcall to-alien callback) location offset))))
 969
 970 (defmethod reader-function ((type (eql 'callback)) &rest args)
 971   (declare (ignore type args))
 972   (let ((reader (reader-function 'pointer))
 973         (from-alien (from-alien-function 'callback)))
 974   #'(lambda (location &optional (offset 0) weak-p)
 975       (declare (ignore weak-p))
 976       (let ((pointer (funcall reader location offset)))
 977         (unless (null-pointer-p pointer)
 978           (funcall from-alien pointer))))))
 979
 980 (defmethod unbound-value ((type (eql 'callback)) &rest args)
 981   (declare (ignore type args))
 982   (values t nil))
 983 )