mdw@git.distorted.org.uk Git - clg/blob - gffi/interface.lisp

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 1999-2006 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: interface.lisp,v 1.6 2007-09-07 07:28:42 espen Exp $
  24
  25 (in-package "GFFI")
  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     (setq *package-prefix* (delete package *package-prefix* :key #'car))
  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          (start (position-if-not #'(lambda (char) (char= char #\%)) name))
  57          (end (if (string= "_p" name :start2 (- (length name) 2))
  58                   (- (length name) 2)
  59                 (length name)))
  60          (stripped-name (subseq name start end))
  61          (prefix (package-prefix *package*)))
  62     (if (or (not prefix) (string= prefix ""))
  63         stripped-name
  64       (format nil "~A_~A" prefix stripped-name))))
  65
  66 (defun default-alien-type-name (type-name)
  67   (let ((prefix (package-prefix *package*)))
  68     (apply
  69      #'concatenate
  70      'string
  71      (mapcar
  72       #'string-capitalize
  73       (cons prefix (split-string (symbol-name type-name) :delimiter #\-))))))
  74
  75 (defun default-type-name (alien-name)
  76   (let ((parts
  77          (mapcar
  78           #'string-upcase
  79           (split-string-if alien-name #'upper-case-p))))
  80     (intern
  81      (concatenate-strings (rest parts) #\-)
  82      (find-prefix-package (first parts)))))
  83
  84
  85 (defun in-arg-p (style)
  86   (find style '(:in :in/out :in/return :in-out :return)))
  87
  88 (defun out-arg-p (style)
  89   (find style '(:out :in/out :in-out)))
  90
  91 (defun return-arg-p (style)
  92   (find style '(:in/return :return)))
  93
  94 (defmacro defbinding (name lambda-list return-type &rest args)
  95   (multiple-value-bind (lisp-name c-name)
  96       (if (atom name)
  97           (values name (default-alien-fname name))
  98         (values-list name))
  99
 100     (let* ((lambda-list-supplied-p lambda-list)
 101            (lambda-list (unless (equal lambda-list '(nil)) lambda-list))
 102            (arg-types ())
 103            (aux-bindings ())
 104            (doc-string (when (stringp (first args)) (pop args)))
 105            (parsed-args
 106             (mapcar
 107              #'(lambda (arg)
 108                  (destructuring-bind
 109                      (expr type &optional (style :in) (out-type type))
 110                      (if (atom arg)
 111                          (list arg arg)
 112                        arg)
 113                    (cond
 114                     ((find style '(:in-out :return))
 115                      (warn "Deprecated argument style: ~S" style))
 116                     ((not (find style '(:in :out :in/out :in/return)))
 117                      (error "Bogus argument style: ~S" style)))
 118                    (when (and
 119                           (not lambda-list-supplied-p)
 120                           (namep expr) (in-arg-p style)
 121                           (not (find expr lambda-list)))
 122                      (push expr lambda-list)
 123                      (push type arg-types))
 124                    (let ((aux (unless (or (not (in-arg-p style)) (namep expr))
 125                                 (gensym))))
 126                      (when aux
 127                        (push (list aux expr) aux-bindings))
 128                      (list
 129                       (cond
 130                        ((and (namep expr) (not (in-arg-p style))) expr)
 131                        ((namep expr) (make-symbol (string expr)))
 132                        ((gensym)))
 133                       (or aux expr) type style out-type))))
 134              args)))
 135
 136       (%defbinding c-name lisp-name
 137        (if lambda-list-supplied-p lambda-list (nreverse lambda-list))
 138        (not lambda-list-supplied-p) (nreverse arg-types)
 139        aux-bindings return-type doc-string parsed-args))))
 140
 141
 142 #+(or cmu sbcl)
 143 (defun foreign-funcall (cname args return-type)
 144   (let ((fparams (loop
 145                   for (var expr type style out-type) in args
 146                   collect (if (out-arg-p style)
 147                               `(addr ,var)
 148                             var)))
 149         (ftypes (loop
 150                  for (var expr type style out-type) in args
 151                  collect (if (out-arg-p style)
 152                              `(* ,(alien-type out-type))
 153                            (alien-type out-type))))
 154         (fname (make-symbol cname)))
 155     `(with-alien ((,fname (function ,(alien-type return-type) ,@ftypes) :extern ,cname))
 156       (alien-funcall ,fname ,@fparams))))
 157
 158 #+clisp
 159 (defun foreign-funcall (cname args return-type)
 160   (let* ((fparams (loop
 161                    for (var expr type style out-type) in args
 162                    collect (if (out-arg-p style)
 163                                `(ffi:c-var-address ,var)
 164                              var)))
 165          (fargs (loop
 166                  for (var expr type style out-type) in args
 167                  collect (list var (if (out-arg-p style)
 168                                        'ffi:c-pointer
 169                                      (alien-type out-type)))))
 170          (c-function `(ffi:c-function
 171                        (:arguments ,@fargs)
 172                        (:return-type ,(alien-type return-type))
 173                        (:language :stdc))))
 174     `(funcall
 175       (load-time-value
 176        (ffi::foreign-library-function
 177         ,cname (ffi::foreign-library :default) #?(clisp>= 2 40)nil
 178         nil (ffi:parse-c-type ',c-function)))
 179       ,@fparams)))
 180
 181
 182 ;; TODO: check if in and out types (if different) translates to same
 183 ;; alien type
 184 (defun %defbinding (cname lisp-name lambda-list declare-p arg-types aux-bindings return-type doc args)
 185   (let ((out (loop
 186               for (var expr type style out-type) in args
 187               when (or (out-arg-p style) (return-arg-p style))
 188               collect (from-alien-form out-type var)))
 189         (fcall (from-alien-form return-type
 190                 (foreign-funcall cname args return-type))))
 191
 192     (labels ((create-wrapper (args body)
 193                (if args
 194                    (destructuring-bind (var expr type style out-type) (first args)
 195                      (declare (ignore out-type))
 196                      (alien-arg-wrapper type var expr style
 197                       (create-wrapper (rest args) body)))
 198                  body)))
 199        `(progn
 200           ,(when declare-p
 201              `(declaim
 202                (ftype
 203                 (function
 204                  ,(mapcar #'argument-type arg-types)
 205                  (values
 206                   ,@(when return-type (list (return-type return-type)))
 207                   ,@(loop
 208                      for (var expr type style out-type) in args
 209                      when (out-arg-p style)
 210                      collect (return-type out-type)
 211                      when (return-arg-p style)
 212                      collect (return-type type)))))))
 213           (defun ,lisp-name ,lambda-list
 214           ,doc
 215           (let ,aux-bindings
 216             ,(if return-type
 217                  (create-wrapper args `(values ,fcall ,@out))
 218                (create-wrapper args `(progn ,fcall (values ,@out))))))))))
 219
 220
 221
 222 ;;;; Dynamic (runtime) bindings
 223
 224 (defun mkbinding (name return-type &rest arg-types)
 225   #+cmu(declare (optimize (inhibit-warnings 3)))
 226   #+sbcl(declare (muffle-conditions compiler-note))
 227   (let* ((c-function
 228           #+(or cmu sbcl)
 229           `(function ,@(mapcar #'alien-type (cons return-type arg-types)))
 230           #+clisp
 231           `(ffi:c-function
 232             (:arguments ,@(mapcar
 233                            #'(lambda (type)
 234                                (list (gensym) (alien-type type)))
 235                            arg-types))
 236             (:return-type ,(alien-type return-type))
 237             (:language :stdc)))
 238          (foreign
 239           #+(or cmu sbcl)
 240           (handler-bind (#+sbcl(compiler-note #'(lambda (condition)
 241                                                   (declare (ignore condition))
 242                                                   (muffle-warning))))
 243             (%heap-alien
 244              (make-heap-alien-info
 245               :type (parse-alien-type c-function #+sbcl nil)
 246               :sap-form (let ((address (foreign-symbol-address name)))
 247                           (etypecase address
 248                             (integer (int-sap address))
 249                             (system-area-pointer address))))))
 250           #+clisp
 251           (ffi::foreign-library-function name
 252            (ffi::foreign-library :default) #?(clisp>= 2 40)nil
 253            nil (ffi:parse-c-type c-function)))
 254          (return-value-translator (from-alien-function return-type)))
 255     (multiple-value-bind (arg-translators cleanup-funcs)
 256         (let ((translator/cleanup-pairs
 257                (mapcar
 258                 #'(lambda (type)
 259                     (multiple-value-list (to-alien-function type)))
 260                 arg-types)))
 261           (values
 262            (mapcar #'first translator/cleanup-pairs)
 263            (mapcar #'second translator/cleanup-pairs)))
 264       #'(lambda (&rest args)
 265           (let ((translated-args (mapcar #'funcall arg-translators args)))
 266             (prog1
 267                 (funcall return-value-translator
 268                  #+(or cmu sbcl)(apply #'alien-funcall foreign translated-args)
 269                  #+clisp(apply foreign translated-args))
 270               (mapc
 271                #'(lambda (cleanup arg translated-arg)
 272                    (when cleanup
 273                      (funcall cleanup arg translated-arg)))
 274                cleanup-funcs args translated-args)))))))
 275
 276
 277
 278 ;;;; C Callbacks
 279
 280 (defun callback-body (args return-type body)
 281   (labels ((create-wrappers (args body)
 282              (if args
 283                  (destructuring-bind (var type) (first args)
 284                    (callback-wrapper type var var
 285                     (create-wrappers (rest args) body)))
 286                body))
 287            (create-body (args body)
 288              (to-alien-form return-type
 289               (create-wrappers args `(progn ,@body)))))
 290     (if (and (consp (first body)) (eq (caar body) 'declare))
 291         (let ((ignored (loop
 292                         for declaration in (cdar body)
 293                         when (eq (first declaration) 'ignore)
 294                         nconc (rest declaration))))
 295           `(,(first body)
 296             ,(create-body
 297               (remove-if #'(lambda (arg)
 298                              (find (first arg) ignored))
 299                          args)
 300               (rest body))))
 301       (list (create-body args body)))))
 302
 303
 304 #+(or cmu sbcl)
 305 (defmacro define-callback (name return-type args &body body)
 306   (let ((define-callback
 307           #+cmu'alien:def-callback
 308           #+(and sbcl alien-callbacks)'sb-alien::define-alien-callback
 309           #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function))
 310     `(progn
 311        #+cmu(defparameter ,name nil)
 312        (,define-callback ,name
 313            #+(and sbcl alien-callbacks) ,(alien-type return-type)
 314            (#+(or cmu (and sbcl (not alien-callbacks))),(alien-type return-type)
 315             ,@(loop
 316                for (name type) in args
 317                collect `(,name ,(alien-type type))))
 318          ,@(callback-body args return-type body)))))
 319
 320 #+(or cmu sbcl)
 321 (defun callback-address (callback)
 322   #+cmu(alien::callback-trampoline callback)
 323   #+(and sbcl (not alien-callbacks))(sb-alien:alien-function-sap callback)
 324   #+(and sbcl alien-callbacks)(sb-alien:alien-sap callback))
 325
 326 #+sbcl
 327 (deftype callback ()
 328   #-alien-callbacks'sb-alien:alien-function
 329   #+alien-callbacks'sb-alien:alien)
 330
 331
 332 ;;; The callback code for CLISP is based on code from CFFI
 333 ;;; Copyright (C) 2005, James Bielman  <jamesjb@jamesjb.com>
 334 ;;;           (C) 2005, Joerg Hoehle  <hoehle@users.sourceforge.net>
 335
 336
 337 ;;; *CALLBACKS* contains the callbacks defined by the %DEFCALLBACK
 338 ;;; macro.  The symbol naming the callback is the key, and the value
 339 ;;; is a list containing a Lisp function, the parsed CLISP FFI type of
 340 ;;; the callback, and a saved pointer that should not persist across
 341 ;;; saved images.
 342 #+clisp
 343 (progn
 344   (defvar *callbacks* (make-hash-table))
 345
 346   ;;; Return a CLISP FFI function type for a CFFI callback function
 347   ;;; given a return type and list of argument names and types.
 348   (eval-when (:compile-toplevel :load-toplevel :execute)
 349     (defun callback-type (return-type arg-names arg-types)
 350       (ffi:parse-c-type
 351        `(ffi:c-function
 352          (:arguments ,@(mapcar (lambda (sym type)
 353                                  (list sym (alien-type type)))
 354                                arg-names arg-types))
 355          (:return-type ,(alien-type return-type))
 356          (:language :stdc)))))
 357
 358   ;;; Register and create a callback function.
 359   (defun register-callback (name function parsed-type)
 360     (setf (gethash name *callbacks*)
 361           (list function parsed-type
 362                 (ffi:with-foreign-object (ptr 'ffi:c-pointer)
 363                  ;; Create callback by converting Lisp function to foreign
 364                  (setf (ffi:memory-as ptr parsed-type) function)
 365                  (ffi:foreign-value ptr)))))
 366
 367   ;;; Restore all saved callback pointers when restarting the Lisp
 368   ;;; image.  This is pushed onto CUSTOM:*INIT-HOOKS*.
 369   ;;; Needs clisp > 2.35, bugfix 2005-09-29
 370   (defun restore-callback-pointers ()
 371     (maphash
 372      (lambda (name list)
 373        (register-callback name (first list) (second list)))
 374      *callbacks*))
 375
 376   ;;; Add RESTORE-CALLBACK-POINTERS to the lists of functions to run
 377   ;;; when an image is restarted.
 378   (eval-when (:load-toplevel :execute)
 379     (pushnew 'restore-callback-pointers custom:*init-hooks*))
 380
 381   ;;; Define a callback function NAME to run BODY with arguments
 382   ;;; ARG-NAMES translated according to ARG-TYPES and the return type
 383   ;;; translated according to RETTYPE.  Obtain a pointer that can be
 384   ;;; passed to C code for this callback by calling %CALLBACK.
 385   (defmacro define-callback (name return-type args &body body)
 386     (let ((arg-names (mapcar #'first args))
 387           (arg-types (mapcar #'second args)))
 388       `(progn
 389          (defvar ,name ',name)
 390          (register-callback ',name
 391           (lambda ,arg-names ,@(callback-body args return-type body))
 392           ,(callback-type return-type arg-names arg-types)))))
 393
 394   ;;; Look up the name of a callback and return a pointer that can be
 395   ;;; passed to a C function.  Signals an error if no callback is
 396   ;;; defined called NAME.
 397   (defun callback-address (name)
 398     (multiple-value-bind (list winp) (gethash name *callbacks*)
 399       (unless winp
 400         (error "Undefined callback: ~S" name))
 401       (third list)))
 402
 403   (deftype callback () 'symbol))
 404
 405
 406
 407 ;;;; Type expansion
 408
 409 (defun type-expand-1 (form)
 410   #+(or cmu sbcl)
 411   (let ((def (cond ((symbolp form)
 412                     #+cmu(kernel::info type expander form)
 413                     #+sbcl(sb-impl::info :type :expander form))
 414                    ((and (consp form) (symbolp (car form)))
 415                     #+cmu(kernel::info type expander (car form))
 416                     #+sbcl(sb-impl::info :type :expander (car form)))
 417                    (t nil))))
 418     (if def
 419         (values (funcall def (if (consp form) form (list form))) t)
 420       (values form nil)))
 421   #+clisp(ext:type-expand form t))
 422
 423 (defun type-expand-to (type form)
 424   (labels ((expand (form0)
 425              (if (eq (first (mklist form0)) type)
 426                  form0
 427                (multiple-value-bind (expanded-form expanded-p)
 428                    (type-expand-1 form0)
 429                  (if expanded-p
 430                      (expand expanded-form)
 431                    (error "~A can not be expanded to ~A" form type))))))
 432     (expand form)))
 433
 434
 435
 436 ;;;; Type methods
 437
 438 (defun find-type-method (name type-spec &optional (error-p t))
 439   (let ((type-methods (get name 'type-methods))
 440         (specifier (if (atom type-spec)
 441                        type-spec
 442                      (first type-spec))))
 443     (or
 444      (gethash specifier type-methods)
 445      (when error-p
 446        (error
 447         "No explicit type method for ~A when call width type specifier ~A found"
 448         name type-spec)))))
 449
 450 (defun find-next-type-method (name type-spec &optional (error-p t))
 451   (let ((type-methods (get name 'type-methods)))
 452     (labels ((search-method-in-cpl-order (classes)
 453                (when classes
 454                  (or
 455                   (gethash (class-name (first classes)) type-methods)
 456                   (search-method-in-cpl-order (rest classes)))))
 457              (lookup-method (type-spec)
 458                (if (and (symbolp type-spec) (find-class type-spec nil))
 459                    (let ((class (find-class type-spec)))
 460                      #?(or (sbcl>= 0 9 15) (featurep :clisp))
 461                      (unless (class-finalized-p class)
 462                        (finalize-inheritance class))
 463                      (search-method-in-cpl-order
 464                       (rest (class-precedence-list class))))
 465                  (multiple-value-bind (expanded-type expanded-p)
 466                       (type-expand-1 type-spec)
 467                    (when expanded-p
 468                      (or
 469                       (let ((specifier (etypecase expanded-type
 470                                          (symbol expanded-type)
 471                                          (list (first expanded-type)))))
 472                         (gethash specifier type-methods))
 473                       (lookup-method expanded-type))))))
 474              (search-built-in-type-hierarchy (sub-tree)
 475                (when (subtypep type-spec (first sub-tree))
 476                  (or
 477                   (search-nodes (cddr sub-tree))
 478                   (second sub-tree))))
 479              (search-nodes (nodes)
 480                (loop
 481                 for node in nodes
 482                 as method = (search-built-in-type-hierarchy node)
 483                 until method
 484                 finally (return method))))
 485       (or
 486        (lookup-method type-spec)
 487        ;; This is to handle unexpandable types whichs doesn't name a
 488        ;; class.  It may cause infinite loops with illegal
 489        ;; call-next-method calls
 490        (unless (or
 491                 (null type-spec)
 492                 (and (symbolp type-spec) (find-class type-spec nil)))
 493          (search-nodes (get name 'built-in-type-hierarchy)))
 494        (when error-p
 495          (error "No next type method ~A for type specifier ~A"
 496           name type-spec))))))
 497
 498 (defun find-applicable-type-method (name type-spec &optional (error-p t))
 499   (or
 500    (find-type-method name type-spec nil)
 501    (find-next-type-method name type-spec nil)
 502    (when error-p
 503      (error
 504       "No applicable type method for ~A when call width type specifier ~A"
 505       name type-spec))))
 506
 507
 508 (defun insert-type-in-hierarchy (specifier function nodes)
 509   (cond
 510    ((let ((node (find specifier nodes :key #'first)))
 511       (when node
 512         (setf (second node) function)
 513         nodes)))
 514    ((let ((node
 515            (find-if
 516             #'(lambda (node)
 517                 (subtypep specifier (first node)))
 518             nodes)))
 519       (when node
 520         (setf (cddr node)
 521               (insert-type-in-hierarchy specifier function (cddr node)))
 522         nodes)))
 523    ((let ((sub-nodes (remove-if-not
 524                       #'(lambda (node)
 525                           (subtypep (first node) specifier))
 526                       nodes)))
 527       (cons
 528        (list* specifier function sub-nodes)
 529        (nset-difference nodes sub-nodes))))))
 530
 531 (defun add-type-method (name specifier function)
 532   (setf (gethash specifier (get name 'type-methods)) function)
 533   (when (typep (find-class specifier nil) 'built-in-class)
 534     (setf (get name 'built-in-type-hierarchy)
 535      (insert-type-in-hierarchy specifier function
 536       (get name 'built-in-type-hierarchy)))))
 537
 538
 539 (defmacro define-type-generic (name lambda-list &optional documentation)
 540   (let ((type-spec (first lambda-list)))
 541     (if (or
 542          (not lambda-list)
 543          (find type-spec '(&optional &key &rest &allow-other-keys)))
 544         (error "A type generic needs at least one required argument")
 545       `(progn
 546          (unless (get ',name 'type-methods)
 547            (setf (get ',name 'type-methods) (make-hash-table))
 548            (setf (get ',name 'built-in-type-hierarchy) ()))
 549          ,(if (intersection '(&optional &key &rest &allow-other-keys) lambda-list)
 550               (let ((args (make-symbol "ARGS")))
 551                 `(defun ,name (,type-spec &rest ,args)
 552                    ,documentation
 553                    (apply
 554                     (find-applicable-type-method ',name ,type-spec)
 555                     ,type-spec ,args)))
 556             `(defun ,name ,lambda-list
 557                ,documentation
 558                (funcall
 559                 (find-applicable-type-method ',name ,type-spec)
 560                 ,@lambda-list)))))))
 561
 562
 563 (defmacro define-type-method (name lambda-list &body body)
 564   (let ((specifier (cadar lambda-list))
 565         (args (make-symbol "ARGS")))
 566     `(progn
 567        (add-type-method ',name ',specifier
 568         #'(lambda (&rest ,args)
 569             (flet ((call-next-method (&rest args)
 570                      (let ((next-method (find-next-type-method ',name ',specifier)))
 571                        (apply next-method (or args ,args)))))
 572               (destructuring-bind (,(caar lambda-list) ,@(rest lambda-list)) ,args
 573                 ,@body))))
 574        ',name)))
 575
 576
 577 ;;; Rules for auto-exporting symbols
 578
 579 (defexport defbinding (name &rest args)
 580   (declare (ignore args))
 581   (if (symbolp name)
 582       name
 583     (first name)))
 584
 585 (defexport define-type-generic (name &rest args)
 586   (declare (ignore args))
 587   name)