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