mdw@git.distorted.org.uk Git - clg/blob - glib/ffi.lisp

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