external/cffi.darcs/src/cffi-ecl.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; cffi-ecl.lisp --- ECL backend for CFFI.
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, James Bielman  <jamesjb@jamesjb.com>
   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 ;;;# Administrivia
  29
  30 (defpackage #:cffi-sys
  31   (:use #:common-lisp #:cffi-utils)
  32   (:export
  33    #:canonicalize-symbol-name-case
  34    #:foreign-pointer
  35    #:pointerp
  36    #:pointer-eq
  37    #:%foreign-alloc
  38    #:foreign-free
  39    #:with-foreign-pointer
  40    #:null-pointer
  41    #:null-pointer-p
  42    #:inc-pointer
  43    #:make-pointer
  44    #:pointer-address
  45    #:%mem-ref
  46    #:%mem-set
  47    #:%foreign-funcall
  48    #:%foreign-funcall-pointer
  49    #:%foreign-type-alignment
  50    #:%foreign-type-size
  51    #:%load-foreign-library
  52    #:native-namestring
  53    #:make-shareable-byte-vector
  54    #:with-pointer-to-vector-data
  55    #:%defcallback
  56    #:%callback
  57    #:%foreign-symbol-pointer))
  58
  59 (in-package #:cffi-sys)
  60
  61 ;;;# Features
  62
  63 (eval-when (:compile-toplevel :load-toplevel :execute)
  64   (mapc (lambda (feature) (pushnew feature *features*))
  65         '(;; Backend mis-features.
  66           cffi-features:no-long-long
  67           cffi-features:flat-namespace
  68           ;; OS/CPU features.
  69           #+:darwin       cffi-features:darwin
  70           #+:darwin       cffi-features:unix
  71           #+:unix         cffi-features:unix
  72           #+:win32        cffi-features:windows
  73           ;; XXX: figure out a way to get a X86 feature
  74           ;;#+:athlon       cffi-features:x86
  75           #+:powerpc7450  cffi-features:ppc32
  76           )))
  77
  78 ;;; Symbol case.
  79
  80 (defun canonicalize-symbol-name-case (name)
  81   (declare (string name))
  82   (string-upcase name))
  83
  84 ;;;# Allocation
  85
  86 (defun %foreign-alloc (size)
  87   "Allocate SIZE bytes of foreign-addressable memory."
  88   (si:allocate-foreign-data :void size))
  89
  90 (defun foreign-free (ptr)
  91   "Free a pointer PTR allocated by FOREIGN-ALLOC."
  92   (si:free-foreign-data ptr))
  93
  94 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
  95   "Bind VAR to SIZE bytes of foreign memory during BODY.  The
  96 pointer in VAR is invalid beyond the dynamic extent of BODY, and
  97 may be stack-allocated if supported by the implementation.  If
  98 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
  99   (unless size-var
 100     (setf size-var (gensym "SIZE")))
 101   `(let* ((,size-var ,size)
 102           (,var (%foreign-alloc ,size-var)))
 103      (unwind-protect
 104           (progn ,@body)
 105        (foreign-free ,var))))
 106
 107 ;;;# Misc. Pointer Operations
 108
 109 (deftype foreign-pointer ()
 110   'si:foreign-data)
 111
 112 (defun null-pointer ()
 113   "Construct and return a null pointer."
 114   (si:allocate-foreign-data :void 0))
 115
 116 (defun null-pointer-p (ptr)
 117   "Return true if PTR is a null pointer."
 118   (si:null-pointer-p ptr))
 119
 120 (defun inc-pointer (ptr offset)
 121   "Return a pointer OFFSET bytes past PTR."
 122   (ffi:make-pointer (+ (ffi:pointer-address ptr) offset) :void))
 123
 124 (defun pointerp (ptr)
 125   "Return true if PTR is a foreign pointer."
 126   (typep ptr 'si:foreign-data))
 127
 128 (defun pointer-eq (ptr1 ptr2)
 129   "Return true if PTR1 and PTR2 point to the same address."
 130   (= (ffi:pointer-address ptr1) (ffi:pointer-address ptr2)))
 131
 132 (defun make-pointer (address)
 133   "Return a pointer pointing to ADDRESS."
 134   (ffi:make-pointer address :void))
 135
 136 (defun pointer-address (ptr)
 137   "Return the address pointed to by PTR."
 138   (ffi:pointer-address ptr))
 139
 140 ;;;# Dereferencing
 141
 142 (defun %mem-ref (ptr type &optional (offset 0))
 143   "Dereference an object of TYPE at OFFSET bytes from PTR."
 144   (let* ((type (cffi-type->ecl-type type))
 145          (type-size (ffi:size-of-foreign-type type)))
 146     (si:foreign-data-ref-elt
 147      (si:foreign-data-recast ptr (+ offset type-size) :void) offset type)))
 148
 149 (defun %mem-set (value ptr type &optional (offset 0))
 150   "Set an object of TYPE at OFFSET bytes from PTR."
 151   (let* ((type (cffi-type->ecl-type type))
 152          (type-size (ffi:size-of-foreign-type type)))
 153     (si:foreign-data-set-elt
 154      (si:foreign-data-recast ptr (+ offset type-size) :void)
 155      offset type value)))
 156
 157 ;;;# Type Operations
 158
 159 (defconstant +translation-table+
 160   '((:char            :byte            "char")
 161     (:unsigned-char   :unsigned-byte   "unsigned char")
 162     (:short           :short           "short")
 163     (:unsigned-short  :unsigned-short  "unsigned short")
 164     (:int             :int             "int")
 165     (:unsigned-int    :unsigned-int    "unsigned int")
 166     (:long            :long            "long")
 167     (:unsigned-long   :unsigned-long   "unsigned long")
 168     (:float           :float           "float")
 169     (:double          :double          "double")
 170     (:pointer         :pointer-void    "void*")
 171     (:void            :void            "void")))
 172
 173 (defun cffi-type->ecl-type (type-keyword)
 174   "Convert a CFFI type keyword to an ECL type keyword."
 175   (or (second (find type-keyword +translation-table+ :key #'first))
 176       (error "~S is not a valid CFFI type" type-keyword)))
 177
 178 (defun ecl-type->c-type (type-keyword)
 179   "Convert a CFFI type keyword to an valid C type keyword."
 180   (or (third (find type-keyword +translation-table+ :key #'second))
 181       (error "~S is not a valid CFFI type" type-keyword)))
 182
 183 (defun %foreign-type-size (type-keyword)
 184   "Return the size in bytes of a foreign type."
 185   (nth-value 0 (ffi:size-of-foreign-type
 186                 (cffi-type->ecl-type type-keyword))))
 187
 188 (defun %foreign-type-alignment (type-keyword)
 189   "Return the alignment in bytes of a foreign type."
 190   (nth-value 1 (ffi:size-of-foreign-type
 191                 (cffi-type->ecl-type type-keyword))))
 192
 193 ;;;# Calling Foreign Functions
 194
 195 (defconstant +ecl-inline-codes+ "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c,#d,#e,#f,#g,#h,#i,#j,#k,#l,#m,#n,#o,#p,#q,#r,#s,#t,#u,#v,#w,#x,#y,#z")
 196
 197 (defun produce-function-pointer-call (pointer types values return-type)
 198   #-dffi
 199   (if (stringp pointer)
 200 ;;       `(ffi:c-inline ,values ,types ,return-type
 201 ;;         ,(format nil "~A(~A)" pointer
 202 ;;                  (subseq +ecl-inline-codes+ 0 (max 0 (1- (* (length values) 3)))))
 203 ;;         :one-liner t :side-effects t)
 204       (produce-function-pointer-call `(foreign-symbol-pointer ,pointer) types values return-type)
 205       `(ffi:c-inline ,(list* pointer values) ,(list* :pointer-void types) ,return-type
 206         ,(with-output-to-string (s)
 207           (let ((types (mapcar #'ecl-type->c-type types)))
 208             ;; On AMD64, the following code only works with the extra argument ",..."
 209             ;; If this is not present, functions like sprintf do not work
 210             (format s "((~A (*)(~@[~{~A,~}...~]))(#0))(~A)"
 211                     (ecl-type->c-type return-type) types
 212                     (subseq +ecl-inline-codes+ 3 (max 3 (+ 2 (* (length values) 3)))))))
 213         :one-liner t :side-effects t))
 214   #+dffi
 215   (progn
 216     (when (stringp pointer)
 217       (setf pointer `(foreign-symbol-pointer ,pointer)))
 218     `(si:call-cfun ,pointer ,return-type (list ,@types) (list ,@values))))
 219
 220
 221 (defun foreign-funcall-parse-args (args)
 222   "Return three values, lists of arg types, values, and result type."
 223   (let ((return-type :void))
 224     (loop for (type arg) on args by #'cddr
 225           if arg collect (cffi-type->ecl-type type) into types
 226           and collect arg into values
 227           else do (setf return-type (cffi-type->ecl-type type))
 228           finally (return (values types values return-type)))))
 229
 230 (defmacro %foreign-funcall (name args &key library calling-convention)
 231   "Call a foreign function."
 232   (declare (ignore library calling-convention))
 233   (multiple-value-bind (types values return-type)
 234       (foreign-funcall-parse-args args)
 235     (produce-function-pointer-call name types values return-type)))
 236
 237 (defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
 238   "Funcall a pointer to a foreign function."
 239   (declare (ignore calling-convention))
 240   (multiple-value-bind (types values return-type)
 241       (foreign-funcall-parse-args args)
 242     (produce-function-pointer-call ptr types values return-type)))
 243
 244 ;;;# Foreign Libraries
 245
 246 (defun %load-foreign-library (name path)
 247   "Load a foreign library."
 248   (declare (ignore name))
 249   #-dffi (error "LOAD-FOREIGN-LIBRARY requires ECL's DFFI support. Use ~
 250                  FFI:LOAD-FOREIGN-LIBRARY with a constant argument instead.")
 251   #+dffi (si:load-foreign-module path))
 252
 253 (defun %close-foreign-library (handle)
 254   (error "%CLOSE-FOREIGN-LIBRARY unimplemented."))
 255
 256 (defun native-namestring (pathname)
 257   (namestring pathname))
 258
 259 ;;;# Callbacks
 260
 261 ;;; Create a package to contain the symbols for callback functions.
 262 ;;; We want to redefine callbacks with the same symbol so the internal
 263 ;;; data structures are reused.
 264 (defpackage #:cffi-callbacks
 265   (:use))
 266
 267 (defvar *callbacks* (make-hash-table))
 268
 269 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the
 270 ;;; internal callback for NAME.
 271 (eval-when (:compile-toplevel :load-toplevel :execute)
 272   (defun intern-callback (name)
 273     (intern (format nil "~A::~A" (package-name (symbol-package name))
 274                     (symbol-name name))
 275             '#:cffi-callbacks)))
 276
 277 (defmacro %defcallback (name rettype arg-names arg-types body
 278                         &key calling-convention)
 279   (declare (ignore calling-convention))
 280   (let ((cb-name (intern-callback name)))
 281     `(progn
 282        (ffi:defcallback (,cb-name :cdecl)
 283            ,(cffi-type->ecl-type rettype)
 284            ,(mapcar #'list arg-names
 285                     (mapcar #'cffi-type->ecl-type arg-types))
 286          ,body)
 287        (setf (gethash ',name *callbacks*) ',cb-name))))
 288
 289 (defun %callback (name)
 290   (multiple-value-bind (symbol winp)
 291       (gethash name *callbacks*)
 292     (unless winp
 293       (error "Undefined callback: ~S" name))
 294     (ffi:callback symbol)))
 295
 296 ;;;# Foreign Globals
 297
 298 (defun convert-external-name (name)
 299   "Add an underscore to NAME if necessary for the ABI."
 300   name)
 301
 302 (defun %foreign-symbol-pointer (name library)
 303   "Returns a pointer to a foreign symbol NAME."
 304   (declare (ignore library))
 305   (si:find-foreign-symbol (convert-external-name name)
 306                           :default :pointer-void 0))