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