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.21 2005-09-26 21:27: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 (defmacro defcallback (name (return-type &rest args) &body body)
 209   (let ((def-callback #+cmu'alien:def-callback
 210                       #+sbcl'sb-alien:define-alien-function))
 211     `(,def-callback ,name
 212          (,(alien-type return-type)
 213           ,@(mapcar #'(lambda (arg)
 214                         (destructuring-bind (name type) arg
 215                           `(,name ,(alien-type type))))
 216                     args))
 217        ,(to-alien-form
 218          `(let (,@(delete nil
 219                      (mapcar #'(lambda (arg)
 220                                  (destructuring-bind (name type) arg
 221                                    (let ((from-alien
 222                                           (from-alien-form name type)))
 223                                      (unless (eq name from-alien)
 224                                        `(,name ,from-alien)))))
 225                       args)))
 226             ,@body)
 227          return-type))))
 228
 229 #+sbcl
 230 (defun callback (af)
 231   (sb-alien:alien-function-sap af))
 232
 233 #+sbcl
 234 (deftype callback () 'sb-alien:alien-function)
 235
 236 ;;;; Definitons and translations of fundamental types
 237
 238 (defmacro def-type-method (name args &optional documentation)
 239   `(progn
 240     (defgeneric ,name (,@args type &rest args)
 241       ,@(when documentation `((:documentation ,documentation))))
 242     (defmethod ,name (,@args (type symbol) &rest args)
 243       (let ((class (find-class type nil)))
 244         (if class
 245             (apply #',name ,@args class args)
 246           (multiple-value-bind (super-type expanded-p)
 247               (type-expand-1 (cons type args))
 248             (if expanded-p
 249                 (,name ,@args super-type)
 250               (call-next-method))))))
 251     (defmethod ,name (,@args (type cons) &rest args)
 252       (declare (ignore args))
 253       (apply #',name ,@args (first type) (rest type)))))
 254
 255
 256 (def-type-method alien-type ())
 257 (def-type-method size-of ())
 258 (def-type-method to-alien-form (form))
 259 (def-type-method from-alien-form (form))
 260 (def-type-method cleanup-form (form)
 261   "Creates a form to clean up after the alien call has finished.")
 262
 263 (def-type-method to-alien-function ())
 264 (def-type-method from-alien-function ())
 265 (def-type-method cleanup-function ())
 266
 267 (def-type-method copy-to-alien-form (form))
 268 (def-type-method copy-to-alien-function ())
 269 (def-type-method copy-from-alien-form (form))
 270 (def-type-method copy-from-alien-function ())
 271
 272 (def-type-method writer-function ())
 273 (def-type-method reader-function ())
 274 (def-type-method destroy-function ())
 275
 276 (def-type-method unbound-value ()
 277   "First return value is true if the type has an unbound value, second return value is the actual unbound value")
 278
 279
 280 ;; Sizes of fundamental C types in bytes (8 bits)
 281 (defconstant +size-of-short+ 2)
 282 (defconstant +size-of-int+ 4)
 283 (defconstant +size-of-long+ 4)
 284 (defconstant +size-of-pointer+ 4)
 285 (defconstant +size-of-float+ 4)
 286 (defconstant +size-of-double+ 8)
 287
 288 ;; Sizes of fundamental C types in bits
 289 (defconstant +bits-of-byte+ 8)
 290 (defconstant +bits-of-short+ 16)
 291 (defconstant +bits-of-int+ 32)
 292 (defconstant +bits-of-long+ 32)
 293
 294
 295 (deftype int () '(signed-byte #.+bits-of-int+))
 296 (deftype unsigned-int () '(unsigned-byte #.+bits-of-int+))
 297 (deftype long () '(signed-byte #.+bits-of-long+))
 298 (deftype unsigned-long () '(unsigned-byte #.+bits-of-long+))
 299 (deftype short () '(signed-byte #.+bits-of-short+))
 300 (deftype unsigned-short () '(unsigned-byte #.+bits-of-short+))
 301 (deftype signed (&optional (size '*)) `(signed-byte ,size))
 302 (deftype unsigned (&optional (size '*)) `(unsigned-byte ,size))
 303 (deftype char () 'base-char)
 304 (deftype pointer () 'system-area-pointer)
 305 (deftype boolean (&optional (size '*)) (declare (ignore size)) `(member t nil))
 306 ;(deftype invalid () nil)
 307
 308
 309 (defmethod to-alien-form (form (type t) &rest args)
 310   (declare (ignore type args))
 311   form)
 312
 313 (defmethod to-alien-function ((type t) &rest args)
 314   (declare (ignore type args))
 315   #'identity)
 316
 317 (defmethod from-alien-form (form (type t) &rest args)
 318   (declare (ignore type args))
 319   form)
 320
 321 (defmethod from-alien-function ((type t) &rest args)
 322   (declare (ignore type args))
 323   #'identity)
 324
 325 (defmethod cleanup-form (form (type t) &rest args)
 326   (declare (ignore form type args))
 327   nil)
 328
 329 (defmethod cleanup-function ((type t) &rest args)
 330   (declare (ignore type args))
 331   #'identity)
 332
 333 (defmethod destroy-function ((type t) &rest args)
 334   (declare (ignore type args))
 335   #'(lambda (location &optional offset)
 336       (declare (ignore location offset))))
 337
 338 (defmethod copy-to-alien-form  (form (type t) &rest args)
 339   (apply #'to-alien-form form type args))
 340
 341 (defmethod copy-to-alien-function  ((type t) &rest args)
 342   (apply #'to-alien-function type args))
 343
 344 (defmethod copy-from-alien-form  (form (type t) &rest args)
 345   (apply #'from-alien-form form type args))
 346
 347 (defmethod copy-from-alien-function  ((type t) &rest args)
 348   (apply #'from-alien-function type args))
 349
 350
 351 (defmethod alien-type ((type (eql 'signed-byte)) &rest args)
 352   (declare (ignore type))
 353   (destructuring-bind (&optional (size '*)) args
 354     (ecase size
 355       (#.+bits-of-byte+ #+cmu'(alien:signed 8) #+sbcl'(sb-alien:signed 8))
 356       (#.+bits-of-short+ #+cmu 'c-call:short #+sbcl 'sb-alien:short)
 357       ((* #.+bits-of-int+) #+cmu 'c-call:int #+sbcl 'sb-alien:int)
 358       (#.+bits-of-long+ #+cmu 'c-call:long #+sbcl 'sb-alien:long))))
 359
 360 (defmethod size-of ((type (eql 'signed-byte)) &rest args)
 361   (declare (ignore type))
 362   (destructuring-bind (&optional (size '*)) args
 363     (ecase size
 364       (#.+bits-of-byte+ 1)
 365       (#.+bits-of-short+ +size-of-short+)
 366       ((* #.+bits-of-int+) +size-of-int+)
 367       (#.+bits-of-long+ +size-of-long+))))
 368
 369 (defmethod unbound-value ((type t) &rest args)
 370   (declare (ignore type args))
 371   nil)
 372
 373 (defmethod writer-function ((type (eql 'signed-byte)) &rest args)
 374   (declare (ignore type))
 375   (destructuring-bind (&optional (size '*)) args
 376     (let ((size (if (eq size '*) +bits-of-int+ size)))
 377       (ecase size
 378         (8 #'(lambda (value location &optional (offset 0))
 379                (setf (signed-sap-ref-8 location offset) value)))
 380         (16 #'(lambda (value location &optional (offset 0))
 381                 (setf (signed-sap-ref-16 location offset) value)))
 382         (32 #'(lambda (value location &optional (offset 0))
 383                 (setf (signed-sap-ref-32 location offset) value)))
 384         (64 #'(lambda (value location &optional (offset 0))
 385                 (setf (signed-sap-ref-64 location offset) value)))))))
 386
 387 (defmethod reader-function ((type (eql 'signed-byte)) &rest args)
 388   (declare (ignore type))
 389   (destructuring-bind (&optional (size '*)) args
 390     (let ((size (if (eq size '*) +bits-of-int+ size)))
 391       (ecase size
 392         (8 #'(lambda (sap &optional (offset 0))
 393                (signed-sap-ref-8 sap offset)))
 394         (16 #'(lambda (sap &optional (offset 0))
 395                 (signed-sap-ref-16 sap offset)))
 396         (32 #'(lambda (sap &optional (offset 0))
 397                 (signed-sap-ref-32 sap offset)))
 398         (64 #'(lambda (sap &optional (offset 0))
 399                 (signed-sap-ref-64 sap offset)))))))
 400
 401 (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args)
 402   (destructuring-bind (&optional (size '*)) args
 403     (ecase size
 404       (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8))
 405       (#.+bits-of-short+ #+cmu 'c-call:unsigned-short
 406                          #+sbcl 'sb-alien:unsigned-short)
 407       ((* #.+bits-of-int+) #+cmu 'c-call:unsigned-int
 408                            #+sbcl 'sb-alien:unsigned-int)
 409       (#.+bits-of-long+ #+cmu 'c-call:unsigned-long
 410                         #+sbcl 'sb-alien:unsigned-long))))
 411
 412 (defmethod size-of ((type (eql 'unsigned-byte)) &rest args)
 413   (apply #'size-of 'signed args))
 414
 415 (defmethod writer-function ((type (eql 'unsigned-byte)) &rest args)
 416   (declare (ignore type))
 417   (destructuring-bind (&optional (size '*)) args
 418     (let ((size (if (eq size '*) +bits-of-int+ size)))
 419       (ecase size
 420         (8 #'(lambda (value location &optional (offset 0))
 421                (setf (sap-ref-8 location offset) value)))
 422         (16 #'(lambda (value location &optional (offset 0))
 423                 (setf (sap-ref-16 location offset) value)))
 424         (32 #'(lambda (value location &optional (offset 0))
 425                 (setf (sap-ref-32 location offset) value)))
 426         (64 #'(lambda (value location &optional (offset 0))
 427                 (setf (sap-ref-64 location offset) value)))))))
 428
 429 (defmethod reader-function ((type (eql 'unsigned-byte)) &rest args)
 430   (declare (ignore type))
 431   (destructuring-bind (&optional (size '*)) args
 432     (let ((size (if (eq size '*) +bits-of-int+ size)))
 433       (ecase size
 434         (8 #'(lambda (sap &optional (offset 0))
 435                (sap-ref-8 sap offset)))
 436         (16 #'(lambda (sap &optional (offset 0))
 437                 (sap-ref-16 sap offset)))
 438         (32 #'(lambda (sap &optional (offset 0))
 439                 (sap-ref-32 sap offset)))
 440         (64 #'(lambda (sap &optional (offset 0))
 441                 (sap-ref-64 sap offset)))))))
 442
 443
 444 (defmethod alien-type ((type (eql 'integer)) &rest args)
 445   (declare (ignore type args))
 446   (alien-type 'signed-byte))
 447
 448 (defmethod size-of ((type (eql 'integer)) &rest args)
 449   (declare (ignore type args))
 450   (size-of 'signed-byte))
 451
 452 (defmethod writer-function ((type (eql 'integer)) &rest args)
 453   (declare (ignore type args))
 454   (writer-function 'signed-byte))
 455
 456 (defmethod reader-function ((type (eql 'integer)) &rest args)
 457   (declare (ignore type args))
 458   (reader-function 'signed-byte))
 459
 460
 461 (defmethod alien-type ((type (eql 'fixnum)) &rest args)
 462   (declare (ignore type args))
 463   (alien-type 'signed-byte))
 464
 465 (defmethod size-of ((type (eql 'fixnum)) &rest args)
 466   (declare (ignore type args))
 467   (size-of 'signed-byte))
 468
 469
 470 (defmethod alien-type ((type (eql 'single-float)) &rest args)
 471   (declare (ignore type args))
 472   #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float)
 473
 474 (defmethod size-of ((type (eql 'single-float)) &rest args)
 475   (declare (ignore type args))
 476   +size-of-float+)
 477
 478 (defmethod to-alien-form (form (type (eql 'single-float)) &rest args)
 479   (declare (ignore type args))
 480   `(coerce ,form 'single-float))
 481
 482 (defmethod to-alien-function ((type (eql 'single-float)) &rest args)
 483   (declare (ignore type args))
 484   #'(lambda (number)
 485       (coerce number 'single-float)))
 486
 487 (defmethod writer-function ((type (eql 'single-float)) &rest args)
 488   (declare (ignore type args))
 489   #'(lambda (value location &optional (offset 0))
 490       (setf (sap-ref-single location offset) (coerce value 'single-float))))
 491
 492 (defmethod reader-function ((type (eql 'single-float)) &rest args)
 493   (declare (ignore type args))
 494   #'(lambda (sap &optional (offset 0))
 495       (sap-ref-single sap offset)))
 496
 497
 498 (defmethod alien-type ((type (eql 'double-float)) &rest args)
 499   (declare (ignore type args))
 500   #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float)
 501
 502 (defmethod size-of ((type (eql 'double-float)) &rest args)
 503   (declare (ignore type args))
 504   +size-of-double+)
 505
 506 (defmethod to-alien-form (form (type (eql 'double-float)) &rest args)
 507   (declare (ignore type args))
 508   `(coerce ,form 'double-float))
 509
 510 (defmethod to-alien-function ((type (eql 'double-float)) &rest args)
 511   (declare (ignore type args))
 512   #'(lambda (number)
 513       (coerce number 'double-float)))
 514
 515 (defmethod writer-function ((type (eql 'double-float)) &rest args)
 516   (declare (ignore type args))
 517   #'(lambda (value location &optional (offset 0))
 518       (setf (sap-ref-double location offset) (coerce value 'double-float))))
 519
 520 (defmethod reader-function ((type (eql 'double-float)) &rest args)
 521   (declare (ignore type args))
 522   #'(lambda (sap &optional (offset 0))
 523       (sap-ref-double sap offset)))
 524
 525
 526 (defmethod alien-type ((type (eql 'base-char)) &rest args)
 527   (declare (ignore type args))
 528   #+cmu 'c-call:char #+sbcl 'sb-alien:char)
 529
 530 (defmethod size-of ((type (eql 'base-char)) &rest args)
 531   (declare (ignore type args))
 532   1)
 533
 534 (defmethod writer-function ((type (eql 'base-char)) &rest args)
 535   (declare (ignore type args))
 536   #'(lambda (char location &optional (offset 0))
 537       (setf (sap-ref-8 location offset) (char-code char))))
 538
 539 (defmethod reader-function ((type (eql 'base-char)) &rest args)
 540   (declare (ignore type args))
 541   #'(lambda (location &optional (offset 0))
 542       (code-char (sap-ref-8 location offset))))
 543
 544
 545 (defmethod alien-type ((type (eql 'string)) &rest args)
 546   (declare (ignore type args))
 547   (alien-type 'pointer))
 548
 549 (defmethod size-of ((type (eql 'string)) &rest args)
 550   (declare (ignore type args))
 551   (size-of 'pointer))
 552
 553 (defmethod to-alien-form (string (type (eql 'string)) &rest args)
 554   (declare (ignore type args))
 555   `(let ((string ,string))
 556      ;; Always copy strings to prevent seg fault due to GC
 557      #+cmu
 558      (copy-memory
 559       (vector-sap (coerce string 'simple-base-string))
 560       (1+ (length string)))
 561      #+sbcl
 562      (let ((utf8 (%deport-utf8-string string)))
 563        (copy-memory (vector-sap utf8) (length utf8)))))
 564
 565 (defmethod to-alien-function ((type (eql 'string)) &rest args)
 566   (declare (ignore type args))
 567   #'(lambda (string)
 568       #+cmu
 569       (copy-memory
 570        (vector-sap (coerce string 'simple-base-string))
 571        (1+ (length string)))
 572       #+sbcl
 573       (let ((utf8 (%deport-utf8-string string)))
 574         (copy-memory (vector-sap utf8) (length utf8)))))
 575
 576 (defmethod from-alien-form (string (type (eql 'string)) &rest args)
 577   (declare (ignore type args))
 578   `(let ((string ,string))
 579     (unless (null-pointer-p string)
 580       (prog1
 581           #+cmu(%naturalize-c-string string)
 582           #+sbcl(%naturalize-utf8-string string)
 583         (deallocate-memory string)))))
 584
 585 (defmethod from-alien-function ((type (eql 'string)) &rest args)
 586   (declare (ignore type args))
 587   #'(lambda (string)
 588       (unless (null-pointer-p string)
 589         (prog1
 590             #+cmu(%naturalize-c-string string)
 591             #+sbcl(%naturalize-utf8-string string)
 592           (deallocate-memory string)))))
 593
 594 (defmethod cleanup-form (string (type (eql 'string)) &rest args)
 595   (declare (ignore type args))
 596   `(let ((string ,string))
 597     (unless (null-pointer-p string)
 598       (deallocate-memory string))))
 599
 600 (defmethod cleanup-function ((type (eql 'string)) &rest args)
 601   (declare (ignore args))
 602   #'(lambda (string)
 603       (unless (null-pointer-p string)
 604         (deallocate-memory string))))
 605
 606 (defmethod copy-from-alien-form (string (type (eql 'string)) &rest args)
 607   (declare (ignore type args))
 608   `(let ((string ,string))
 609     (unless (null-pointer-p string)
 610       #+cmu(%naturalize-c-string string)
 611       #+sbcl(%naturalize-utf8-string string))))
 612
 613 (defmethod copy-from-alien-function ((type (eql 'string)) &rest args)
 614   (declare (ignore type args))
 615   #'(lambda (string)
 616       (unless (null-pointer-p string)
 617         #+cmu(%naturalize-c-string string)
 618         #+sbcl(%naturalize-utf8-string string))))
 619
 620 (defmethod writer-function ((type (eql 'string)) &rest args)
 621   (declare (ignore type args))
 622   #'(lambda (string location &optional (offset 0))
 623       (assert (null-pointer-p (sap-ref-sap location offset)))
 624       (setf (sap-ref-sap location offset)
 625        #+cmu
 626        (copy-memory
 627         (vector-sap (coerce string 'simple-base-string))
 628         (1+ (length string)))
 629        #+sbcl
 630        (let ((utf8 (%deport-utf8-string string)))
 631          (copy-memory (vector-sap utf8) (length utf8))))))
 632
 633 (defmethod reader-function ((type (eql 'string)) &rest args)
 634   (declare (ignore type args))
 635   #'(lambda (location &optional (offset 0))
 636       (unless (null-pointer-p (sap-ref-sap location offset))
 637         #+cmu(%naturalize-c-string (sap-ref-sap location offset))
 638         #+sbcl(%naturalize-utf8-string (sap-ref-sap location offset)))))
 639
 640 (defmethod destroy-function ((type (eql 'string)) &rest args)
 641   (declare (ignore type args))
 642   #'(lambda (location &optional (offset 0))
 643       (unless (null-pointer-p (sap-ref-sap location offset))
 644         (deallocate-memory (sap-ref-sap location offset))
 645         (setf (sap-ref-sap location offset) (make-pointer 0)))))
 646
 647 (defmethod unbound-value ((type (eql 'string)) &rest args)
 648   (declare (ignore type args))
 649   (values t nil))
 650
 651
 652 (defmethod alien-type ((type (eql 'pathname)) &rest args)
 653   (declare (ignore type args))
 654   (alien-type 'string))
 655
 656 (defmethod size-of ((type (eql 'pathname)) &rest args)
 657   (declare (ignore type args))
 658   (size-of 'string))
 659
 660 (defmethod to-alien-form (path (type (eql 'pathname)) &rest args)
 661   (declare (ignore type args))
 662   (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string))
 663
 664 (defmethod to-alien-function ((type (eql 'pathname)) &rest args)
 665   (declare (ignore type args))
 666   (let ((string-function (to-alien-function 'string)))
 667     #'(lambda (path)
 668         (funcall string-function (namestring path)))))
 669
 670 (defmethod from-alien-form (string (type (eql 'pathname)) &rest args)
 671   (declare (ignore type args))
 672   `(parse-namestring ,(from-alien-form string 'string)))
 673
 674 (defmethod from-alien-function ((type (eql 'pathname)) &rest args)
 675   (declare (ignore type args))
 676   (let ((string-function (from-alien-function 'string)))
 677     #'(lambda (string)
 678         (parse-namestring (funcall string-function string)))))
 679
 680 (defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args)
 681   (declare (ignore type args))
 682   (cleanup-form string 'string))
 683
 684 (defmethod cleanup-function ((type (eql 'pathnanme)) &rest args)
 685   (declare (ignore type args))
 686   (cleanup-function 'string))
 687
 688 (defmethod writer-function ((type (eql 'pathname)) &rest args)
 689   (declare (ignore type args))
 690   (let ((string-writer (writer-function 'string)))
 691     #'(lambda (path location &optional (offset 0))
 692         (funcall string-writer (namestring path) location offset))))
 693
 694 (defmethod reader-function ((type (eql 'pathname)) &rest args)
 695   (declare (ignore type args))
 696   (let ((string-reader (reader-function 'string)))
 697   #'(lambda (location &optional (offset 0))
 698       (let ((string (funcall string-reader location offset)))
 699         (when string
 700           (parse-namestring string))))))
 701
 702 (defmethod destroy-function ((type (eql 'pathname)) &rest args)
 703   (declare (ignore type args))
 704   (destroy-function 'string))
 705
 706 (defmethod unbound-value ((type (eql 'pathname)) &rest args)
 707   (declare (ignore type args))
 708   (unbound-value 'string))
 709
 710
 711 (defmethod alien-type ((type (eql 'boolean)) &rest args)
 712   (apply #'alien-type 'signed-byte args))
 713
 714 (defmethod size-of ((type (eql 'boolean)) &rest args)
 715   (apply #'size-of 'signed-byte args))
 716
 717 (defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args)
 718   (declare (ignore type args))
 719   `(if ,boolean 1 0))
 720
 721 (defmethod to-alien-function ((type (eql 'boolean)) &rest args)
 722   (declare (ignore type args))
 723   #'(lambda (boolean)
 724       (if boolean 1 0)))
 725
 726 (defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args)
 727   (declare (ignore type args))
 728   `(not (zerop ,boolean)))
 729
 730 (defmethod from-alien-function ((type (eql 'boolean)) &rest args)
 731   (declare (ignore type args))
 732   #'(lambda (boolean)
 733       (not (zerop boolean))))
 734
 735 (defmethod writer-function ((type (eql 'boolean)) &rest args)
 736   (declare (ignore type))
 737   (let ((writer (apply #'writer-function 'signed-byte args)))
 738     #'(lambda (boolean location &optional (offset 0))
 739         (funcall writer (if boolean 1 0) location offset))))
 740
 741 (defmethod reader-function ((type (eql 'boolean)) &rest args)
 742   (declare (ignore type))
 743   (let ((reader (apply #'reader-function 'signed-byte args)))
 744   #'(lambda (location &optional (offset 0))
 745       (not (zerop (funcall reader location offset))))))
 746
 747
 748 (defmethod alien-type ((type (eql 'or)) &rest args)
 749   (let ((alien-type (alien-type (first args))))
 750     (unless (every #'(lambda (type)
 751                        (eq alien-type (alien-type type)))
 752                    (rest args))
 753       (error "No common alien type specifier for union type: ~A"
 754        (cons type args)))
 755     alien-type))
 756
 757 (defmethod size-of ((type (eql 'or)) &rest args)
 758   (declare (ignore type))
 759   (size-of (first args)))
 760
 761 (defmethod to-alien-form (form (type (eql 'or)) &rest args)
 762   (declare (ignore type))
 763   `(let ((value ,form))
 764     (etypecase value
 765       ,@(mapcar
 766          #'(lambda (type)
 767              `(,type ,(to-alien-form 'value type)))
 768          args))))
 769
 770 (defmethod to-alien-function ((type (eql 'or)) &rest types)
 771   (declare (ignore type))
 772   (let ((functions (mapcar #'to-alien-function types)))
 773     #'(lambda (value)
 774         (loop
 775          for function in functions
 776          for type in types
 777          when (typep value type)
 778          do (return (funcall function value))
 779          finally (error "~S is not of type ~A" value `(or ,@types))))))
 780
 781 (defmethod alien-type ((type (eql 'system-area-pointer)) &rest args)
 782   (declare (ignore type args))
 783   'system-area-pointer)
 784
 785 (defmethod size-of ((type (eql 'system-area-pointer)) &rest args)
 786   (declare (ignore type args))
 787   +size-of-pointer+)
 788
 789 (defmethod writer-function ((type (eql 'system-area-pointer)) &rest args)
 790   (declare (ignore type args))
 791   #'(lambda (sap location &optional (offset 0))
 792       (setf (sap-ref-sap location offset) sap)))
 793
 794 (defmethod reader-function ((type (eql 'system-area-pointer)) &rest args)
 795   (declare (ignore type args))
 796   #'(lambda (location &optional (offset 0))
 797       (sap-ref-sap location offset)))
 798
 799
 800 (defmethod alien-type ((type (eql 'null)) &rest args)
 801   (declare (ignore type args))
 802   (alien-type 'pointer))
 803
 804 (defmethod size-of ((type (eql 'null)) &rest args)
 805   (declare (ignore type args))
 806   (size-of 'pointer))
 807
 808 (defmethod to-alien-form (null (type (eql 'null)) &rest args)
 809   (declare (ignore null type args))
 810   `(make-pointer 0))
 811
 812 (defmethod to-alien-function ((type (eql 'null)) &rest args)
 813   (declare (ignore type args))
 814   #'(lambda (null)
 815       (declare (ignore null))
 816       (make-pointer 0)))
 817
 818
 819 (defmethod alien-type ((type (eql 'nil)) &rest args)
 820   (declare (ignore type args))
 821   'void)
 822
 823 (defmethod from-alien-function ((type (eql 'nil)) &rest args)
 824   (declare (ignore type args))
 825   #'(lambda (value)
 826       (declare (ignore value))
 827       (values)))
 828
 829
 830 (defmethod alien-type ((type (eql 'copy-of)) &rest args)
 831   (declare (ignore type))
 832   (alien-type (first args)))
 833
 834 (defmethod size-of ((type (eql 'copy-of)) &rest args)
 835   (declare (ignore type))
 836   (size-of (first args)))
 837
 838 (defmethod to-alien-form (form (type (eql 'copy-of)) &rest args)
 839   (declare (ignore type))
 840   (copy-to-alien-form form (first args)))
 841
 842 (defmethod to-alien-function ((type (eql 'copy-of)) &rest args)
 843   (declare (ignore type))
 844   (copy-to-alien-function (first args)))
 845
 846 (defmethod from-alien-form (form (type (eql 'copy-of)) &rest args)
 847   (declare (ignore type))
 848   (copy-from-alien-form form (first args)))
 849
 850 (defmethod from-alien-function ((type (eql 'copy-of)) &rest args)
 851   (declare (ignore type))
 852   (copy-from-alien-function (first args)))
 853
 854 (defmethod reader-function ((type (eql 'copy-of)) &rest args)
 855   (declare (ignore type))
 856   (reader-function (first args)))
 857
 858 (defmethod writer-function ((type (eql 'copy-of)) &rest args)
 859   (declare (ignore type))
 860   (writer-function (first args)))
 861
 862
 863 (defmethod alien-type ((type (eql 'callback)) &rest args)
 864   (declare (ignore type args))
 865   (alien-type 'pointer))
 866
 867 (defmethod size-of ((type (eql 'callback)) &rest args)
 868   (declare (ignore type args))
 869   (size-of 'pointer))
 870
 871 (defmethod to-alien-form (callback (type (eql 'callback)) &rest args)
 872   (declare (ignore type args))
 873   #+cmu `(callback ,callback)
 874   #+sbcl `(sb-alien:alien-function-sap ,callback))
 875
 876 (defmethod to-alien-function ((type (eql 'callback)) &rest args)
 877   (declare (ignore type args))
 878   #+cmu #'(lambda (callback) (callback callback))
 879   #+sbcl #'sb-alien:alien-function-sap)
 880
 881 #+cmu
 882 (defun find-callback (pointer)
 883   (find pointer alien::*callbacks* :key #'callback-trampoline :test #'sap=))
 884
 885 (defmethod from-alien-form (pointer (type (eql 'callback)) &rest args)
 886   (declare (ignore type args))
 887   #+cmu  `(find-callback ,pointer)
 888   #+sbcl `(sb-alien::%find-alien-function ,pointer))
 889
 890 (defmethod from-alien-function ((type (eql 'callback)) &rest args)
 891   (declare (ignore type args))
 892   #+cmu  #'find-callback
 893   #+sbcl #'sb-alien::%find-alien-function)
 894
 895 (defmethod writer-function ((type (eql 'callback)) &rest args)
 896   (declare (ignore type args))
 897   (let ((writer (writer-function 'pointer))
 898         (to-alien (to-alien-function 'callback)))
 899     #'(lambda (callback location &optional (offset 0))
 900         (funcall writer (funcall to-alien callback) location offset))))
 901
 902 (defmethod reader-function ((type (eql 'callback)) &rest args)
 903   (declare (ignore type args))
 904   (let ((reader (reader-function 'pointer))
 905         (from-alien (from-alien-function 'callback)))
 906   #'(lambda (location &optional (offset 0))
 907       (let ((pointer (funcall reader location offset)))
 908         (unless (null-pointer-p pointer)
 909           (funcall from-alien pointer))))))
 910
 911 (defmethod unbound-value ((type (eql 'callback)) &rest args)
 912   (declare (ignore type args))
 913   (values t nil))