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