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.23 2006-02-06 18:12:19 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 (defmethod alien-type ((type (eql 'signed-byte)) &rest args)
 351   (declare (ignore type))
 352   (destructuring-bind (&optional (size '*)) args
 353     (ecase size
 354       (#.+bits-of-byte+ #+cmu'(alien:signed 8) #+sbcl'(sb-alien:signed 8))
 355       (#.+bits-of-short+ #+cmu 'c-call:short #+sbcl 'sb-alien:short)
 356       ((* #.+bits-of-int+) #+cmu 'c-call:int #+sbcl 'sb-alien:int)
 357       (#.+bits-of-long+ #+cmu 'c-call:long #+sbcl 'sb-alien:long))))
 358
 359 (defmethod size-of ((type (eql 'signed-byte)) &rest args)
 360   (declare (ignore type))
 361   (destructuring-bind (&optional (size '*)) args
 362     (ecase size
 363       (#.+bits-of-byte+ 1)
 364       (#.+bits-of-short+ +size-of-short+)
 365       ((* #.+bits-of-int+) +size-of-int+)
 366       (#.+bits-of-long+ +size-of-long+))))
 367
 368 (defmethod unbound-value ((type t) &rest args)
 369   (declare (ignore type args))
 370   nil)
 371
 372 (defmethod writer-function ((type (eql 'signed-byte)) &rest args)
 373   (declare (ignore type))
 374   (destructuring-bind (&optional (size '*)) args
 375     (let ((size (if (eq size '*) +bits-of-int+ size)))
 376       (ecase size
 377         (8 #'(lambda (value location &optional (offset 0))
 378                (setf (signed-sap-ref-8 location offset) value)))
 379         (16 #'(lambda (value location &optional (offset 0))
 380                 (setf (signed-sap-ref-16 location offset) value)))
 381         (32 #'(lambda (value location &optional (offset 0))
 382                 (setf (signed-sap-ref-32 location offset) value)))
 383         (64 #'(lambda (value location &optional (offset 0))
 384                 (setf (signed-sap-ref-64 location offset) value)))))))
 385
 386 (defmethod reader-function ((type (eql 'signed-byte)) &rest args)
 387   (declare (ignore type))
 388   (destructuring-bind (&optional (size '*)) args
 389     (let ((size (if (eq size '*) +bits-of-int+ size)))
 390       (ecase size
 391         (8 #'(lambda (sap &optional (offset 0) weak-p)
 392                (declare (ignore weak-p))
 393                (signed-sap-ref-8 sap offset)))
 394         (16 #'(lambda (sap &optional (offset 0) weak-p)
 395                 (declare (ignore weak-p))
 396                 (signed-sap-ref-16 sap offset)))
 397         (32 #'(lambda (sap &optional (offset 0) weak-p)
 398                 (declare (ignore weak-p))
 399                 (signed-sap-ref-32 sap offset)))
 400         (64 #'(lambda (sap &optional (offset 0) weak-p)
 401                 (declare (ignore weak-p))
 402                 (signed-sap-ref-64 sap offset)))))))
 403
 404 (defmethod alien-type ((type (eql 'unsigned-byte)) &rest args)
 405   (destructuring-bind (&optional (size '*)) args
 406     (ecase size
 407       (#.+bits-of-byte+ #+cmu'(alien:unsigned 8) #+sbcl'(sb-alien:unsigned 8))
 408       (#.+bits-of-short+ #+cmu 'c-call:unsigned-short
 409                          #+sbcl 'sb-alien:unsigned-short)
 410       ((* #.+bits-of-int+) #+cmu 'c-call:unsigned-int
 411                            #+sbcl 'sb-alien:unsigned-int)
 412       (#.+bits-of-long+ #+cmu 'c-call:unsigned-long
 413                         #+sbcl 'sb-alien:unsigned-long))))
 414
 415 (defmethod size-of ((type (eql 'unsigned-byte)) &rest args)
 416   (apply #'size-of 'signed args))
 417
 418 (defmethod writer-function ((type (eql 'unsigned-byte)) &rest args)
 419   (declare (ignore type))
 420   (destructuring-bind (&optional (size '*)) args
 421     (let ((size (if (eq size '*) +bits-of-int+ size)))
 422       (ecase size
 423         (8 #'(lambda (value location &optional (offset 0))
 424                (setf (sap-ref-8 location offset) value)))
 425         (16 #'(lambda (value location &optional (offset 0))
 426                 (setf (sap-ref-16 location offset) value)))
 427         (32 #'(lambda (value location &optional (offset 0))
 428                 (setf (sap-ref-32 location offset) value)))
 429         (64 #'(lambda (value location &optional (offset 0))
 430                 (setf (sap-ref-64 location offset) value)))))))
 431
 432 (defmethod reader-function ((type (eql 'unsigned-byte)) &rest args)
 433   (declare (ignore type))
 434   (destructuring-bind (&optional (size '*)) args
 435     (let ((size (if (eq size '*) +bits-of-int+ size)))
 436       (ecase size
 437         (8 #'(lambda (sap &optional (offset 0) weak-p)
 438                (declare (ignore weak-p))
 439                (sap-ref-8 sap offset)))
 440         (16 #'(lambda (sap &optional (offset 0) weak-p)
 441                 (declare (ignore weak-p))
 442                 (sap-ref-16 sap offset)))
 443         (32 #'(lambda (sap &optional (offset 0) weak-p)
 444                 (declare (ignore weak-p))
 445                 (sap-ref-32 sap offset)))
 446         (64 #'(lambda (sap &optional (offset 0) weak-p)
 447                 (declare (ignore weak-p))
 448                 (sap-ref-64 sap offset)))))))
 449
 450
 451 (defmethod alien-type ((type (eql 'integer)) &rest args)
 452   (declare (ignore type args))
 453   (alien-type 'signed-byte))
 454
 455 (defmethod size-of ((type (eql 'integer)) &rest args)
 456   (declare (ignore type args))
 457   (size-of 'signed-byte))
 458
 459 (defmethod writer-function ((type (eql 'integer)) &rest args)
 460   (declare (ignore type args))
 461   (writer-function 'signed-byte))
 462
 463 (defmethod reader-function ((type (eql 'integer)) &rest args)
 464   (declare (ignore type args))
 465   (reader-function 'signed-byte))
 466
 467
 468 (defmethod alien-type ((type (eql 'fixnum)) &rest args)
 469   (declare (ignore type args))
 470   (alien-type 'signed-byte))
 471
 472 (defmethod size-of ((type (eql 'fixnum)) &rest args)
 473   (declare (ignore type args))
 474   (size-of 'signed-byte))
 475
 476
 477 (defmethod alien-type ((type (eql 'single-float)) &rest args)
 478   (declare (ignore type args))
 479   #+cmu 'alien:single-float #+sbcl 'sb-alien:single-float)
 480
 481 (defmethod size-of ((type (eql 'single-float)) &rest args)
 482   (declare (ignore type args))
 483   +size-of-float+)
 484
 485 (defmethod to-alien-form (form (type (eql 'single-float)) &rest args)
 486   (declare (ignore type args))
 487   `(coerce ,form 'single-float))
 488
 489 (defmethod to-alien-function ((type (eql 'single-float)) &rest args)
 490   (declare (ignore type args))
 491   #'(lambda (number)
 492       (coerce number 'single-float)))
 493
 494 (defmethod writer-function ((type (eql 'single-float)) &rest args)
 495   (declare (ignore type args))
 496   #'(lambda (value location &optional (offset 0))
 497       (setf (sap-ref-single location offset) (coerce value 'single-float))))
 498
 499 (defmethod reader-function ((type (eql 'single-float)) &rest args)
 500   (declare (ignore type args))
 501   #'(lambda (sap &optional (offset 0) weak-p)
 502       (declare (ignore weak-p))
 503       (sap-ref-single sap offset)))
 504
 505
 506 (defmethod alien-type ((type (eql 'double-float)) &rest args)
 507   (declare (ignore type args))
 508   #+cmu 'alien:double-float #+sbcl 'sb-alien:double-float)
 509
 510 (defmethod size-of ((type (eql 'double-float)) &rest args)
 511   (declare (ignore type args))
 512   +size-of-double+)
 513
 514 (defmethod to-alien-form (form (type (eql 'double-float)) &rest args)
 515   (declare (ignore type args))
 516   `(coerce ,form 'double-float))
 517
 518 (defmethod to-alien-function ((type (eql 'double-float)) &rest args)
 519   (declare (ignore type args))
 520   #'(lambda (number)
 521       (coerce number 'double-float)))
 522
 523 (defmethod writer-function ((type (eql 'double-float)) &rest args)
 524   (declare (ignore type args))
 525   #'(lambda (value location &optional (offset 0))
 526       (setf (sap-ref-double location offset) (coerce value 'double-float))))
 527
 528 (defmethod reader-function ((type (eql 'double-float)) &rest args)
 529   (declare (ignore type args))
 530   #'(lambda (sap &optional (offset 0) weak-p)
 531       (declare (ignore weak-p))
 532       (sap-ref-double sap offset)))
 533
 534
 535 (defmethod alien-type ((type (eql 'base-char)) &rest args)
 536   (declare (ignore type args))
 537   #+cmu 'c-call:char #+sbcl 'sb-alien:char)
 538
 539 (defmethod size-of ((type (eql 'base-char)) &rest args)
 540   (declare (ignore type args))
 541   1)
 542
 543 (defmethod writer-function ((type (eql 'base-char)) &rest args)
 544   (declare (ignore type args))
 545   #'(lambda (char location &optional (offset 0))
 546       (setf (sap-ref-8 location offset) (char-code char))))
 547
 548 (defmethod reader-function ((type (eql 'base-char)) &rest args)
 549   (declare (ignore type args))
 550   #'(lambda (location &optional (offset 0) weak-p)
 551       (declare (ignore weak-p))
 552       (code-char (sap-ref-8 location offset))))
 553
 554
 555 (defmethod alien-type ((type (eql 'string)) &rest args)
 556   (declare (ignore type args))
 557   (alien-type 'pointer))
 558
 559 (defmethod size-of ((type (eql 'string)) &rest args)
 560   (declare (ignore type args))
 561   (size-of 'pointer))
 562
 563 (defmethod to-alien-form (string (type (eql 'string)) &rest args)
 564   (declare (ignore type args))
 565   `(let ((string ,string))
 566      ;; Always copy strings to prevent seg fault due to GC
 567      #+cmu
 568      (copy-memory
 569       (vector-sap (coerce string 'simple-base-string))
 570       (1+ (length string)))
 571      #+sbcl
 572      (let ((utf8 (%deport-utf8-string string)))
 573        (copy-memory (vector-sap utf8) (length utf8)))))
 574
 575 (defmethod to-alien-function ((type (eql 'string)) &rest args)
 576   (declare (ignore type args))
 577   #'(lambda (string)
 578       #+cmu
 579       (copy-memory
 580        (vector-sap (coerce string 'simple-base-string))
 581        (1+ (length string)))
 582       #+sbcl
 583       (let ((utf8 (%deport-utf8-string string)))
 584         (copy-memory (vector-sap utf8) (length utf8)))))
 585
 586 (defmethod from-alien-form (string (type (eql 'string)) &rest args)
 587   (declare (ignore type args))
 588   `(let ((string ,string))
 589     (unless (null-pointer-p string)
 590       (prog1
 591           #+cmu(%naturalize-c-string string)
 592           #+sbcl(%naturalize-utf8-string string)
 593         (deallocate-memory string)))))
 594
 595 (defmethod from-alien-function ((type (eql 'string)) &rest args)
 596   (declare (ignore type args))
 597   #'(lambda (string)
 598       (unless (null-pointer-p string)
 599         (prog1
 600             #+cmu(%naturalize-c-string string)
 601             #+sbcl(%naturalize-utf8-string string)
 602           (deallocate-memory string)))))
 603
 604 (defmethod cleanup-form (string (type (eql 'string)) &rest args)
 605   (declare (ignore type args))
 606   `(let ((string ,string))
 607     (unless (null-pointer-p string)
 608       (deallocate-memory string))))
 609
 610 (defmethod cleanup-function ((type (eql 'string)) &rest args)
 611   (declare (ignore args))
 612   #'(lambda (string)
 613       (unless (null-pointer-p string)
 614         (deallocate-memory string))))
 615
 616 (defmethod copy-from-alien-form (string (type (eql 'string)) &rest args)
 617   (declare (ignore type args))
 618   `(let ((string ,string))
 619     (unless (null-pointer-p string)
 620       #+cmu(%naturalize-c-string string)
 621       #+sbcl(%naturalize-utf8-string string))))
 622
 623 (defmethod copy-from-alien-function ((type (eql 'string)) &rest args)
 624   (declare (ignore type args))
 625   #'(lambda (string)
 626       (unless (null-pointer-p string)
 627         #+cmu(%naturalize-c-string string)
 628         #+sbcl(%naturalize-utf8-string string))))
 629
 630 (defmethod writer-function ((type (eql 'string)) &rest args)
 631   (declare (ignore type args))
 632   #'(lambda (string location &optional (offset 0))
 633       (assert (null-pointer-p (sap-ref-sap location offset)))
 634       (setf (sap-ref-sap location offset)
 635        #+cmu
 636        (copy-memory
 637         (vector-sap (coerce string 'simple-base-string))
 638         (1+ (length string)))
 639        #+sbcl
 640        (let ((utf8 (%deport-utf8-string string)))
 641          (copy-memory (vector-sap utf8) (length utf8))))))
 642
 643 (defmethod reader-function ((type (eql 'string)) &rest args)
 644   (declare (ignore type args))
 645   #'(lambda (location &optional (offset 0) weak-p)
 646       (declare (ignore weak-p))
 647       (unless (null-pointer-p (sap-ref-sap location offset))
 648         #+cmu(%naturalize-c-string (sap-ref-sap location offset))
 649         #+sbcl(%naturalize-utf8-string (sap-ref-sap location offset)))))
 650
 651 (defmethod destroy-function ((type (eql 'string)) &rest args)
 652   (declare (ignore type args))
 653   #'(lambda (location &optional (offset 0))
 654       (unless (null-pointer-p (sap-ref-sap location offset))
 655         (deallocate-memory (sap-ref-sap location offset))
 656         (setf (sap-ref-sap location offset) (make-pointer 0)))))
 657
 658 (defmethod unbound-value ((type (eql 'string)) &rest args)
 659   (declare (ignore type args))
 660   (values t nil))
 661
 662
 663 (defmethod alien-type ((type (eql 'pathname)) &rest args)
 664   (declare (ignore type args))
 665   (alien-type 'string))
 666
 667 (defmethod size-of ((type (eql 'pathname)) &rest args)
 668   (declare (ignore type args))
 669   (size-of 'string))
 670
 671 (defmethod to-alien-form (path (type (eql 'pathname)) &rest args)
 672   (declare (ignore type args))
 673   (to-alien-form `(namestring (translate-logical-pathname ,path)) 'string))
 674
 675 (defmethod to-alien-function ((type (eql 'pathname)) &rest args)
 676   (declare (ignore type args))
 677   (let ((string-function (to-alien-function 'string)))
 678     #'(lambda (path)
 679         (funcall string-function (namestring path)))))
 680
 681 (defmethod from-alien-form (string (type (eql 'pathname)) &rest args)
 682   (declare (ignore type args))
 683   `(parse-namestring ,(from-alien-form string 'string)))
 684
 685 (defmethod from-alien-function ((type (eql 'pathname)) &rest args)
 686   (declare (ignore type args))
 687   (let ((string-function (from-alien-function 'string)))
 688     #'(lambda (string)
 689         (parse-namestring (funcall string-function string)))))
 690
 691 (defmethod cleanup-form (string (type (eql 'pathnanme)) &rest args)
 692   (declare (ignore type args))
 693   (cleanup-form string 'string))
 694
 695 (defmethod cleanup-function ((type (eql 'pathnanme)) &rest args)
 696   (declare (ignore type args))
 697   (cleanup-function 'string))
 698
 699 (defmethod writer-function ((type (eql 'pathname)) &rest args)
 700   (declare (ignore type args))
 701   (let ((string-writer (writer-function 'string)))
 702     #'(lambda (path location &optional (offset 0))
 703         (funcall string-writer (namestring path) location offset))))
 704
 705 (defmethod reader-function ((type (eql 'pathname)) &rest args)
 706   (declare (ignore type args))
 707   (let ((string-reader (reader-function 'string)))
 708   #'(lambda (location &optional (offset 0) weak-p)
 709       (declare (ignore weak-p))
 710       (let ((string (funcall string-reader location offset)))
 711         (when string
 712           (parse-namestring string))))))
 713
 714 (defmethod destroy-function ((type (eql 'pathname)) &rest args)
 715   (declare (ignore type args))
 716   (destroy-function 'string))
 717
 718 (defmethod unbound-value ((type (eql 'pathname)) &rest args)
 719   (declare (ignore type args))
 720   (unbound-value 'string))
 721
 722
 723 (defmethod alien-type ((type (eql 'boolean)) &rest args)
 724   (apply #'alien-type 'signed-byte args))
 725
 726 (defmethod size-of ((type (eql 'boolean)) &rest args)
 727   (apply #'size-of 'signed-byte args))
 728
 729 (defmethod to-alien-form (boolean (type (eql 'boolean)) &rest args)
 730   (declare (ignore type args))
 731   `(if ,boolean 1 0))
 732
 733 (defmethod to-alien-function ((type (eql 'boolean)) &rest args)
 734   (declare (ignore type args))
 735   #'(lambda (boolean)
 736       (if boolean 1 0)))
 737
 738 (defmethod from-alien-form (boolean (type (eql 'boolean)) &rest args)
 739   (declare (ignore type args))
 740   `(not (zerop ,boolean)))
 741
 742 (defmethod from-alien-function ((type (eql 'boolean)) &rest args)
 743   (declare (ignore type args))
 744   #'(lambda (boolean)
 745       (not (zerop boolean))))
 746
 747 (defmethod writer-function ((type (eql 'boolean)) &rest args)
 748   (declare (ignore type))
 749   (let ((writer (apply #'writer-function 'signed-byte args)))
 750     #'(lambda (boolean location &optional (offset 0))
 751         (funcall writer (if boolean 1 0) location offset))))
 752
 753 (defmethod reader-function ((type (eql 'boolean)) &rest args)
 754   (declare (ignore type))
 755   (let ((reader (apply #'reader-function 'signed-byte args)))
 756   #'(lambda (location &optional (offset 0) weak-p)
 757       (declare (ignore weak-p))
 758       (not (zerop (funcall reader location offset))))))
 759
 760
 761 (defmethod alien-type ((type (eql 'or)) &rest args)
 762   (let ((alien-type (alien-type (first args))))
 763     (unless (every #'(lambda (type)
 764                        (eq alien-type (alien-type type)))
 765                    (rest args))
 766       (error "No common alien type specifier for union type: ~A"
 767        (cons type args)))
 768     alien-type))
 769
 770 (defmethod size-of ((type (eql 'or)) &rest args)
 771   (declare (ignore type))
 772   (size-of (first args)))
 773
 774 (defmethod to-alien-form (form (type (eql 'or)) &rest args)
 775   (declare (ignore type))
 776   `(let ((value ,form))
 777     (etypecase value
 778       ,@(mapcar
 779          #'(lambda (type)
 780              `(,type ,(to-alien-form 'value type)))
 781          args))))
 782
 783 (defmethod to-alien-function ((type (eql 'or)) &rest types)
 784   (declare (ignore type))
 785   (let ((functions (mapcar #'to-alien-function types)))
 786     #'(lambda (value)
 787         (loop
 788          for function in functions
 789          for type in types
 790          when (typep value type)
 791          do (return (funcall function value))
 792          finally (error "~S is not of type ~A" value `(or ,@types))))))
 793
 794 (defmethod alien-type ((type (eql 'system-area-pointer)) &rest args)
 795   (declare (ignore type args))
 796   'system-area-pointer)
 797
 798 (defmethod size-of ((type (eql 'system-area-pointer)) &rest args)
 799   (declare (ignore type args))
 800   +size-of-pointer+)
 801
 802 (defmethod writer-function ((type (eql 'system-area-pointer)) &rest args)
 803   (declare (ignore type args))
 804   #'(lambda (sap location &optional (offset 0))
 805       (setf (sap-ref-sap location offset) sap)))
 806
 807 (defmethod reader-function ((type (eql 'system-area-pointer)) &rest args)
 808   (declare (ignore type args))
 809   #'(lambda (location &optional (offset 0) weak-p)
 810       (declare (ignore weak-p))
 811       (sap-ref-sap location offset)))
 812
 813
 814 (defmethod alien-type ((type (eql 'null)) &rest args)
 815   (declare (ignore type args))
 816   (alien-type 'pointer))
 817
 818 (defmethod size-of ((type (eql 'null)) &rest args)
 819   (declare (ignore type args))
 820   (size-of 'pointer))
 821
 822 (defmethod to-alien-form (null (type (eql 'null)) &rest args)
 823   (declare (ignore null type args))
 824   `(make-pointer 0))
 825
 826 (defmethod to-alien-function ((type (eql 'null)) &rest args)
 827   (declare (ignore type args))
 828   #'(lambda (null)
 829       (declare (ignore null))
 830       (make-pointer 0)))
 831
 832
 833 (defmethod alien-type ((type (eql 'nil)) &rest args)
 834   (declare (ignore type args))
 835   'void)
 836
 837 (defmethod from-alien-function ((type (eql 'nil)) &rest args)
 838   (declare (ignore type args))
 839   #'(lambda (value)
 840       (declare (ignore value))
 841       (values)))
 842
 843
 844 (defmethod alien-type ((type (eql 'copy-of)) &rest args)
 845   (declare (ignore type))
 846   (alien-type (first args)))
 847
 848 (defmethod size-of ((type (eql 'copy-of)) &rest args)
 849   (declare (ignore type))
 850   (size-of (first args)))
 851
 852 (defmethod to-alien-form (form (type (eql 'copy-of)) &rest args)
 853   (declare (ignore type))
 854   (copy-to-alien-form form (first args)))
 855
 856 (defmethod to-alien-function ((type (eql 'copy-of)) &rest args)
 857   (declare (ignore type))
 858   (copy-to-alien-function (first args)))
 859
 860 (defmethod from-alien-form (form (type (eql 'copy-of)) &rest args)
 861   (declare (ignore type))
 862   (copy-from-alien-form form (first args)))
 863
 864 (defmethod from-alien-function ((type (eql 'copy-of)) &rest args)
 865   (declare (ignore type))
 866   (copy-from-alien-function (first args)))
 867
 868 (defmethod reader-function ((type (eql 'copy-of)) &rest args)
 869   (declare (ignore type))
 870   (reader-function (first args)))
 871
 872 (defmethod writer-function ((type (eql 'copy-of)) &rest args)
 873   (declare (ignore type))
 874   (writer-function (first args)))
 875
 876
 877 (defmethod alien-type ((type (eql 'callback)) &rest args)
 878   (declare (ignore type args))
 879   (alien-type 'pointer))
 880
 881 (defmethod size-of ((type (eql 'callback)) &rest args)
 882   (declare (ignore type args))
 883   (size-of 'pointer))
 884
 885 (defmethod to-alien-form (callback (type (eql 'callback)) &rest args)
 886   (declare (ignore type args))
 887   #+cmu `(callback ,callback)
 888   #+sbcl `(sb-alien:alien-function-sap ,callback))
 889
 890 (defmethod to-alien-function ((type (eql 'callback)) &rest args)
 891   (declare (ignore type args))
 892   #+cmu #'(lambda (callback) (callback callback))
 893   #+sbcl #'sb-alien:alien-function-sap)
 894
 895 #+cmu
 896 (defun find-callback (pointer)
 897   (find pointer alien::*callbacks* :key #'callback-trampoline :test #'sap=))
 898
 899 (defmethod from-alien-form (pointer (type (eql 'callback)) &rest args)
 900   (declare (ignore type args))
 901   #+cmu  `(find-callback ,pointer)
 902   #+sbcl `(sb-alien::%find-alien-function ,pointer))
 903
 904 (defmethod from-alien-function ((type (eql 'callback)) &rest args)
 905   (declare (ignore type args))
 906   #+cmu  #'find-callback
 907   #+sbcl #'sb-alien::%find-alien-function)
 908
 909 (defmethod writer-function ((type (eql 'callback)) &rest args)
 910   (declare (ignore type args))
 911   (let ((writer (writer-function 'pointer))
 912         (to-alien (to-alien-function 'callback)))
 913     #'(lambda (callback location &optional (offset 0))
 914         (funcall writer (funcall to-alien callback) location offset))))
 915
 916 (defmethod reader-function ((type (eql 'callback)) &rest args)
 917   (declare (ignore type args))
 918   (let ((reader (reader-function 'pointer))
 919         (from-alien (from-alien-function 'callback)))
 920   #'(lambda (location &optional (offset 0) weak-p)
 921       (declare (ignore weak-p))
 922       (let ((pointer (funcall reader location offset)))
 923         (unless (null-pointer-p pointer)
 924           (funcall from-alien pointer))))))
 925
 926 (defmethod unbound-value ((type (eql 'callback)) &rest args)
 927   (declare (ignore type args))
 928   (values t nil))