external/cffi.darcs/_darcs/pristine/src/cffi-clisp.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; cffi-clisp.lisp --- CFFI-SYS implementation for CLISP.
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, James Bielman  <jamesjb@jamesjb.com>
   6 ;;;           (C) 2005-2006, Joerg Hoehle  <hoehle@users.sourceforge.net>
   7 ;;;
   8 ;;; Permission is hereby granted, free of charge, to any person
   9 ;;; obtaining a copy of this software and associated documentation
  10 ;;; files (the "Software"), to deal in the Software without
  11 ;;; restriction, including without limitation the rights to use, copy,
  12 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  13 ;;; of the Software, and to permit persons to whom the Software is
  14 ;;; furnished to do so, subject to the following conditions:
  15 ;;;
  16 ;;; The above copyright notice and this permission notice shall be
  17 ;;; included in all copies or substantial portions of the Software.
  18 ;;;
  19 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  20 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  21 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  22 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  23 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  24 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  25 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  26 ;;; DEALINGS IN THE SOFTWARE.
  27 ;;;
  28
  29 ;;;# Administrivia
  30
  31 (defpackage #:cffi-sys
  32   (:use #:common-lisp #:cffi-utils)
  33   (:export
  34    #:canonicalize-symbol-name-case
  35    #:foreign-pointer
  36    #:pointerp
  37    #:pointer-eq
  38    #:null-pointer
  39    #:null-pointer-p
  40    #:inc-pointer
  41    #:make-pointer
  42    #:pointer-address
  43    #:%foreign-alloc
  44    #:foreign-free
  45    #:with-foreign-pointer
  46    #:%foreign-funcall
  47    #:%foreign-funcall-pointer
  48    #:%foreign-type-alignment
  49    #:%foreign-type-size
  50    #:%load-foreign-library
  51    #:%close-foreign-library
  52    #:native-namestring
  53    #:%mem-ref
  54    #:%mem-set
  55    #:make-shareable-byte-vector
  56    #:with-pointer-to-vector-data
  57    #:%foreign-symbol-pointer
  58    #:%defcallback
  59    #:%callback))
  60
  61 (in-package #:cffi-sys)
  62
  63 ;;; FIXME: long-long could be supported anyway on 64-bit machines. --luis
  64
  65 ;;;# Features
  66
  67 (eval-when (:compile-toplevel :load-toplevel :execute)
  68   (mapc (lambda (feature) (pushnew feature *features*))
  69         '(;; OS/CPU features.
  70           #+:macos  cffi-features:darwin
  71           #+:unix   cffi-features:unix
  72           #+:win32  cffi-features:windows
  73           ))
  74   (cond ((string-equal (machine-type) "X86_64")
  75          (pushnew 'cffi-features:x86-64 *features*))
  76         ((member :pc386 *features*)
  77          (pushnew 'cffi-features:x86 *features*))
  78         ;; FIXME: probably catches PPC64 as well
  79         ((string-equal (machine-type) "POWER MACINTOSH")
  80          (pushnew 'cffi-features:ppc32 *features*))))
  81
  82 ;;; Symbol case.
  83
  84 (defun canonicalize-symbol-name-case (name)
  85   (declare (string name))
  86   (string-upcase name))
  87
  88 ;;;# Built-In Foreign Types
  89
  90 (defun convert-foreign-type (type)
  91   "Convert a CFFI built-in type keyword to a CLisp FFI type."
  92   (ecase type
  93     (:char 'ffi:char)
  94     (:unsigned-char 'ffi:uchar)
  95     (:short 'ffi:short)
  96     (:unsigned-short 'ffi:ushort)
  97     (:int 'ffi:int)
  98     (:unsigned-int 'ffi:uint)
  99     (:long 'ffi:long)
 100     (:unsigned-long 'ffi:ulong)
 101     (:long-long 'ffi:sint64)
 102     (:unsigned-long-long 'ffi:uint64)
 103     (:float 'ffi:single-float)
 104     (:double 'ffi:double-float)
 105     ;; Clisp's FFI:C-POINTER converts NULL to NIL. For now
 106     ;; we have a workaround in the pointer operations...
 107     (:pointer 'ffi:c-pointer)
 108     (:void nil)))
 109
 110 (defun %foreign-type-size (type)
 111   "Return the size in bytes of objects having foreign type TYPE."
 112   (nth-value 0 (ffi:sizeof (convert-foreign-type type))))
 113
 114 ;; Remind me to buy a beer for whoever made getting the alignment
 115 ;; of foreign types part of the public interface in CLisp. :-)
 116 (defun %foreign-type-alignment (type)
 117   "Return the structure alignment in bytes of foreign TYPE."
 118   #+(and cffi-features:darwin cffi-features:ppc32)
 119   (case type
 120     ((:double :long-long :unsigned-long-long)
 121      (return-from %foreign-type-alignment 8)))
 122   ;; Override not necessary for the remaining types...
 123   (nth-value 1 (ffi:sizeof (convert-foreign-type type))))
 124
 125 ;;;# Basic Pointer Operations
 126
 127 (deftype foreign-pointer ()
 128   '(or null ffi:foreign-address))
 129
 130 (defun pointerp (ptr)
 131   "Return true if PTR is a foreign pointer."
 132   (or (null ptr) (typep ptr 'ffi:foreign-address)))
 133
 134 (defun pointer-eq (ptr1 ptr2)
 135   "Return true if PTR1 and PTR2 point to the same address."
 136   (eql (ffi:foreign-address-unsigned ptr1)
 137        (ffi:foreign-address-unsigned ptr2)))
 138
 139 (defun null-pointer ()
 140   "Return a null foreign pointer."
 141   (ffi:unsigned-foreign-address 0))
 142
 143 (defun null-pointer-p (ptr)
 144   "Return true if PTR is a null foreign pointer."
 145   (or (null ptr) (zerop (ffi:foreign-address-unsigned ptr))))
 146
 147 (defun inc-pointer (ptr offset)
 148   "Return a pointer pointing OFFSET bytes past PTR."
 149   (ffi:unsigned-foreign-address
 150    (+ offset (if (null ptr) 0 (ffi:foreign-address-unsigned ptr)))))
 151
 152 (defun make-pointer (address)
 153   "Return a pointer pointing to ADDRESS."
 154   (ffi:unsigned-foreign-address address))
 155
 156 (defun pointer-address (ptr)
 157   "Return the address pointed to by PTR."
 158   (ffi:foreign-address-unsigned ptr))
 159
 160 ;;;# Foreign Memory Allocation
 161
 162 (defun %foreign-alloc (size)
 163   "Allocate SIZE bytes of foreign-addressable memory and return a
 164 pointer to the allocated block.  An implementation-specific error
 165 is signalled if the memory cannot be allocated."
 166   (ffi:foreign-address (ffi:allocate-shallow 'ffi:uint8 :count size)))
 167
 168 (defun foreign-free (ptr)
 169   "Free a pointer PTR allocated by FOREIGN-ALLOC.  The results
 170 are undefined if PTR is used after being freed."
 171   (ffi:foreign-free ptr))
 172
 173 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
 174   "Bind VAR to a pointer to SIZE bytes of foreign-addressable
 175 memory during BODY.  Both PTR and the memory block pointed to
 176 have dynamic extent and may be stack allocated if supported by
 177 the implementation.  If SIZE-VAR is supplied, it will be bound to
 178 SIZE during BODY."
 179   (unless size-var
 180     (setf size-var (gensym "SIZE")))
 181   (let ((obj-var (gensym)))
 182     `(let ((,size-var ,size))
 183        (ffi:with-foreign-object
 184            (,obj-var `(ffi:c-array ffi:uint8 ,,size-var))
 185          (let ((,var (ffi:foreign-address ,obj-var)))
 186            ,@body)))))
 187
 188 ;;;# Memory Access
 189
 190 (defun %mem-ref (ptr type &optional (offset 0))
 191   "Dereference a pointer OFFSET bytes from PTR to an object of
 192 built-in foreign TYPE.  Returns the object as a foreign pointer
 193 or Lisp number."
 194   (ffi:memory-as ptr (convert-foreign-type type) offset))
 195
 196 (define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0))
 197   "Compiler macro to open-code when TYPE is constant."
 198   (if (constantp type)
 199       `(ffi:memory-as ,ptr ',(convert-foreign-type (eval type)) ,offset)
 200       form))
 201
 202 (defun %mem-set (value ptr type &optional (offset 0))
 203   "Set a pointer OFFSET bytes from PTR to an object of built-in
 204 foreign TYPE to VALUE."
 205   (setf (ffi:memory-as ptr (convert-foreign-type type) offset) value))
 206
 207 (define-compiler-macro %mem-set
 208     (&whole form value ptr type &optional (offset 0))
 209   (if (constantp type)
 210       ;; (setf (ffi:memory-as) value) is exported, but not so nice
 211       ;; w.r.t. the left to right evaluation rule
 212       `(ffi::write-memory-as
 213         ,value ,ptr ',(convert-foreign-type (eval type)) ,offset)
 214       form))
 215
 216 ;;;# Shareable Vectors
 217 ;;;
 218 ;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
 219 ;;; should be defined to perform a copy-in/copy-out if the Lisp
 220 ;;; implementation can't do this.
 221
 222 (declaim (inline make-shareable-byte-vector))
 223 (defun make-shareable-byte-vector (size)
 224   "Create a Lisp vector of SIZE bytes can passed to
 225 WITH-POINTER-TO-VECTOR-DATA."
 226   (make-array size :element-type '(unsigned-byte 8)))
 227
 228 (deftype shareable-byte-vector ()
 229   `(vector (unsigned-byte 8)))
 230
 231 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 232   "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
 233   (with-unique-names (vector-var size-var)
 234     `(let ((,vector-var ,vector))
 235        (check-type ,vector-var shareable-byte-vector)
 236        (with-foreign-pointer (,ptr-var (length ,vector-var) ,size-var)
 237          ;; copy-in
 238          (loop for i below ,size-var do
 239                (%mem-set (aref ,vector-var i) ,ptr-var :unsigned-char i))
 240          (unwind-protect (progn ,@body)
 241            ;; copy-out
 242            (loop for i below ,size-var do
 243                  (setf (aref ,vector-var i)
 244                        (%mem-ref ,ptr-var :unsigned-char i))))))))
 245
 246 ;;;# Foreign Function Calling
 247
 248 (defun parse-foreign-funcall-args (args)
 249   "Return three values, a list of CLISP FFI types, a list of
 250 values to pass to the function, and the CLISP FFI return type."
 251   (let ((return-type nil))
 252     (loop for (type arg) on args by #'cddr
 253           if arg collect (list (gensym) (convert-foreign-type type)) into types
 254           and collect arg into fargs
 255           else do (setf return-type (convert-foreign-type type))
 256           finally (return (values types fargs return-type)))))
 257
 258 (defun convert-cconv (calling-convention)
 259   (ecase calling-convention
 260     (:stdcall :stdc-stdcall)
 261     (:cdecl :stdc)))
 262
 263 (defun c-function-type (arg-types rettype calling-convention)
 264   "Generate the apropriate CLISP foreign type specification. Also
 265 takes care of converting the calling convention names."
 266   `(ffi:c-function (:arguments ,@arg-types)
 267                    (:return-type ,rettype)
 268                    (:language ,(convert-cconv calling-convention))))
 269
 270 ;;; Quick hack around the fact that the CFFI package is not yet
 271 ;;; defined when this file is loaded.  I suppose we could arrange for
 272 ;;; the CFFI package to be defined a bit earlier, though.
 273 (defun library-handle-form (name)
 274   (flet ((find-cffi-symbol (symbol)
 275            (find-symbol (symbol-name symbol) '#:cffi)))
 276     `(,(find-cffi-symbol '#:foreign-library-handle)
 277        (,(find-cffi-symbol '#:get-foreign-library) ',name))))
 278
 279 (eval-when (:compile-toplevel :load-toplevel :execute)
 280   ;; version 2.40 (CVS 2006-09-03, to be more precise) added a
 281   ;; PROPERTIES argument to FFI::FOREIGN-LIBRARY-FUNCTION.
 282   (defun post-2.40-ffi-interface-p ()
 283     (let ((f-l-f (find-symbol (string '#:foreign-library-function) '#:ffi)))
 284       (if (and f-l-f (= (length (ext:arglist f-l-f)) 5))
 285           '(:and)
 286           '(:or))))
 287   ;; FFI::FOREIGN-LIBRARY-FUNCTION and FFI::FOREIGN-LIBRARY-VARIABLE
 288   ;; were deprecated in 2.41 and removed in 2.45.
 289   (defun post-2.45-ffi-interface-p ()
 290     (if (find-symbol (string '#:foreign-library-function) '#:ffi)
 291         '(:or)
 292         '(:and))))
 293
 294 #+#.(cffi-sys::post-2.45-ffi-interface-p)
 295 (defun %foreign-funcall-aux (name type library)
 296   `(ffi::find-foreign-function ,name ,type nil ,library nil nil))
 297
 298 #-#.(cffi-sys::post-2.45-ffi-interface-p)
 299 (defun %foreign-funcall-aux (name type library)
 300   `(ffi::foreign-library-function
 301     ,name ,library nil
 302     #+#.(cffi-sys::post-2.40-ffi-interface-p)
 303     nil
 304     ,type))
 305
 306 (defmacro %foreign-funcall (name args &key library calling-convention)
 307   "Invoke a foreign function called NAME, taking pairs of
 308 foreign-type/value pairs from ARGS.  If a single element is left
 309 over at the end of ARGS, it specifies the foreign return type of
 310 the function call."
 311   (multiple-value-bind (types fargs rettype)
 312       (parse-foreign-funcall-args args)
 313     `(funcall
 314       (load-time-value
 315        (handler-case
 316            ,(%foreign-funcall-aux
 317              name
 318              `(ffi:parse-c-type
 319                ',(c-function-type types rettype calling-convention))
 320              (if (eq library :default)
 321                  :default
 322                  (library-handle-form library)))
 323          (error (err)
 324            (warn "~A" err))))
 325       ,@fargs)))
 326
 327 (defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
 328   "Similar to %foreign-funcall but takes a pointer instead of a string."
 329   (multiple-value-bind (types fargs rettype)
 330       (parse-foreign-funcall-args args)
 331     `(funcall (ffi:foreign-function
 332                ,ptr (load-time-value
 333                      (ffi:parse-c-type ',(c-function-type
 334                                           types rettype calling-convention))))
 335               ,@fargs)))
 336
 337 ;;;# Callbacks
 338
 339 ;;; *CALLBACKS* contains the callbacks defined by the CFFI DEFCALLBACK
 340 ;;; macro.  The symbol naming the callback is the key, and the value
 341 ;;; is a list containing a Lisp function, the parsed CLISP FFI type of
 342 ;;; the callback, and a saved pointer that should not persist across
 343 ;;; saved images.
 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 (rettype arg-names arg-types calling-convention)
 350     (ffi:parse-c-type
 351      `(ffi:c-function
 352        (:arguments ,@(mapcar (lambda (sym type)
 353                                (list sym (convert-foreign-type type)))
 354                              arg-names arg-types))
 355        (:return-type ,(convert-foreign-type rettype))
 356        (:language ,(convert-cconv calling-convention))))))
 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 %defcallback (name rettype arg-names arg-types body
 386                         &key calling-convention)
 387   `(register-callback ',name (lambda ,arg-names ,body)
 388                       ,(callback-type rettype arg-names arg-types
 389                                       calling-convention)))
 390
 391 ;;; Look up the name of a callback and return a pointer that can be
 392 ;;; passed to a C function.  Signals an error if no callback is
 393 ;;; defined called NAME.
 394 (defun %callback (name)
 395   (multiple-value-bind (list winp) (gethash name *callbacks*)
 396     (unless winp
 397       (error "Undefined callback: ~S" name))
 398     (third list)))
 399
 400 ;;;# Loading and Closing Foreign Libraries
 401
 402 (defun %load-foreign-library (name path)
 403   "Load a foreign library from PATH."
 404   (declare (ignore name))
 405   #+#.(cffi-sys::post-2.45-ffi-interface-p)
 406   (ffi:open-foreign-library path)
 407   #-#.(cffi-sys::post-2.45-ffi-interface-p)
 408   (ffi::foreign-library path))
 409
 410 (defun %close-foreign-library (handle)
 411   "Close a foreign library."
 412   (ffi:close-foreign-library handle))
 413
 414 (defun native-namestring (pathname)
 415   (namestring pathname))
 416
 417 ;;;# Foreign Globals
 418
 419 (defun %foreign-symbol-pointer (name library)
 420   "Returns a pointer to a foreign symbol NAME."
 421   (prog1 (ignore-errors
 422            (ffi:foreign-address
 423             #+#.(cffi-sys::post-2.45-ffi-interface-p)
 424             (ffi::find-foreign-variable name nil library nil nil)
 425             #-#.(cffi-sys::post-2.45-ffi-interface-p)
 426             (ffi::foreign-library-variable name library nil nil)))))