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

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