libffi/functions.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; functions.lisp -- Calling foreign functions
   4 ;;;
   5 ;;; Copyright (C) 2009, 2010, 2011 Liam M. Healy  <lhealy@common-lisp.net>
   6 ;;;
   7 ;;; Permission is hereby granted, free of charge, to any person
   8 ;;; obtaining a copy of this software and associated documentation
   9 ;;; files (the "Software"), to deal in the Software without
  10 ;;; restriction, including without limitation the rights to use, copy,
  11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  12 ;;; of the Software, and to permit persons to whom the Software is
  13 ;;; furnished to do so, subject to the following conditions:
  14 ;;;
  15 ;;; The above copyright notice and this permission notice shall be
  16 ;;; included in all copies or substantial portions of the Software.
  17 ;;;
  18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  25 ;;; DEALINGS IN THE SOFTWARE.
  26 ;;;
  27
  28 (in-package #:cffi)
  29
  30 (defvar *cif-table* (make-hash-table :test 'equal)
  31   "A hash table of foreign functions and pointers to the foreign cif (Call InterFace) structure for that function.")
  32
  33 (define-condition foreign-function-not-prepared (error)
  34   ((foreign-function-name
  35     :initarg :foreign-function-name :reader foreign-function-name))
  36   (:report
  37    (lambda (condition stream)
  38      (format stream "Foreign function ~a did not prepare correctly"
  39              (foreign-function-name condition))))
  40   (:documentation
  41    "Preparation of foreign function did not succeed, according to return from libffi library."))
  42
  43 (defun prepare-function
  44     (foreign-function-name return-type argument-types &optional (abi :default-abi))
  45   "Generate or retrieve the CIF needed to call the function through libffi."
  46   (or (gethash foreign-function-name *cif-table*)
  47       (let* ((number-of-arguments (length argument-types))
  48              (cif (cffi:foreign-alloc '(:struct ffi-cif)))
  49              (ffi-argtypes (cffi:foreign-alloc :pointer :count number-of-arguments)))
  50         (loop for type in argument-types
  51               for i from 0
  52               do
  53                  (setf (cffi:mem-aref ffi-argtypes :pointer i)
  54                        (libffi-type-pointer (parse-type type))))
  55         (unless
  56             (eql :OK
  57                  (prep-cif cif abi number-of-arguments
  58                            (libffi-type-pointer (parse-type return-type))
  59                            ffi-argtypes))
  60           (error
  61            'foreign-function-not-prepared
  62            :foreign-function-name foreign-function-name))
  63         (setf (gethash foreign-function-name *cif-table*) cif)
  64         cif)))
  65
  66 (defun unprepare-function (foreign-function-name)
  67   "Remove prepared definitions for the named foreign function.  Returns foreign-function-name if function had been prepared, NIL otherwise."
  68   (let ((ptr (gethash foreign-function-name *cif-table*)))
  69     (when ptr
  70       (cffi:foreign-free
  71        (cffi:foreign-slot-value ptr '(:struct ffi-cif) 'argument-types))
  72       (cffi:foreign-free ptr)
  73       (remhash foreign-function-name *cif-table*)
  74       foreign-function-name)))
  75
  76 (defun ffcall-body-libffi
  77     (function symbols return-type argument-types &optional pointerp (abi :default-abi))
  78   "A body of foreign-funcall calling the libffi function #'call (ffi_call)."
  79   (let ((number-of-arguments (length argument-types)))
  80     `(cffi:with-foreign-objects
  81          ((argvalues :pointer ,number-of-arguments)
  82           ,@(unless (eql return-type :void)
  83               `((result ',return-type))))
  84        (loop :for arg :in (list ,@symbols)
  85              :for count :from 0
  86              :do (setf (cffi:mem-aref argvalues :pointer count) arg))
  87        (call
  88         (prepare-function ,function ',return-type ',argument-types ',abi)
  89         ,(if pointerp
  90              function
  91              `(cffi:foreign-symbol-pointer ,function))
  92         ,(if (eql return-type :void) '(cffi:null-pointer) 'result)
  93         argvalues)
  94        ,(if (eql return-type :void)
  95             '(values)
  96             (if (typep (parse-type return-type) 'cffi::translatable-foreign-type)
  97                 ;; just return the pointer so that expand-from-foreign
  98                 ;; can apply translate-from-foreign
  99                 'result
 100                 ;; built-in types won't be translated by
 101                 ;; expand-from-foreign, we have to do it here
 102                 `(cffi:mem-aref result ',return-type))))))
 103
 104 (setf *foreign-structures-by-value* 'ffcall-body-libffi)
 105
 106 (pushnew :fsbv *features*)