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 ;;; Copyright (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 #:alexandria)
  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 ;;;# Symbol Case
  64
  65 (defun canonicalize-symbol-name-case (name)
  66   (declare (string name))
  67   (string-upcase name))
  68
  69 ;;;# Built-In Foreign Types
  70
  71 (defun convert-foreign-type (type)
  72   "Convert a CFFI built-in type keyword to a CLisp FFI type."
  73   (ecase type
  74     (:char 'ffi:char)
  75     (:unsigned-char 'ffi:uchar)
  76     (:short 'ffi:short)
  77     (:unsigned-short 'ffi:ushort)
  78     (:int 'ffi:int)
  79     (:unsigned-int 'ffi:uint)
  80     (:long 'ffi:long)
  81     (:unsigned-long 'ffi:ulong)
  82     (:long-long 'ffi:sint64)
  83     (:unsigned-long-long 'ffi:uint64)
  84     (:float 'ffi:single-float)
  85     (:double 'ffi:double-float)
  86     ;; Clisp's FFI:C-POINTER converts NULL to NIL. For now
  87     ;; we have a workaround in the pointer operations...
  88     (:pointer 'ffi:c-pointer)
  89     (:void nil)))
  90
  91 (defun %foreign-type-size (type)
  92   "Return the size in bytes of objects having foreign type TYPE."
  93   (nth-value 0 (ffi:sizeof (convert-foreign-type type))))
  94
  95 ;; Remind me to buy a beer for whoever made getting the alignment
  96 ;; of foreign types part of the public interface in CLisp. :-)
  97 (defun %foreign-type-alignment (type)
  98   "Return the structure alignment in bytes of foreign TYPE."
  99   #+(and cffi-features:darwin cffi-features:ppc32)
 100   (case type
 101     ((:double :long-long :unsigned-long-long)
 102      (return-from %foreign-type-alignment 8)))
 103   ;; Override not necessary for the remaining types...
 104   (nth-value 1 (ffi:sizeof (convert-foreign-type type))))
 105
 106 ;;;# Basic Pointer Operations
 107
 108 (deftype foreign-pointer ()
 109   '(or null ffi:foreign-address))
 110
 111 (defun pointerp (ptr)
 112   "Return true if PTR is a foreign pointer."
 113   (or (null ptr) (typep ptr 'ffi:foreign-address)))
 114
 115 (defun pointer-eq (ptr1 ptr2)
 116   "Return true if PTR1 and PTR2 point to the same address."
 117   (eql (ffi:foreign-address-unsigned ptr1)
 118        (ffi:foreign-address-unsigned ptr2)))
 119
 120 (defun null-pointer ()
 121   "Return a null foreign pointer."
 122   (ffi:unsigned-foreign-address 0))
 123
 124 (defun null-pointer-p (ptr)
 125   "Return true if PTR is a null foreign pointer."
 126   (or (null ptr) (zerop (ffi:foreign-address-unsigned ptr))))
 127
 128 (defun inc-pointer (ptr offset)
 129   "Return a pointer pointing OFFSET bytes past PTR."
 130   (ffi:unsigned-foreign-address
 131    (+ offset (if (null ptr) 0 (ffi:foreign-address-unsigned ptr)))))
 132
 133 (defun make-pointer (address)
 134   "Return a pointer pointing to ADDRESS."
 135   (ffi:unsigned-foreign-address address))
 136
 137 (defun pointer-address (ptr)
 138   "Return the address pointed to by PTR."
 139   (ffi:foreign-address-unsigned ptr))
 140
 141 ;;;# Foreign Memory Allocation
 142
 143 (defun %foreign-alloc (size)
 144   "Allocate SIZE bytes of foreign-addressable memory and return a
 145 pointer to the allocated block.  An implementation-specific error
 146 is signalled if the memory cannot be allocated."
 147   (ffi:foreign-address (ffi:allocate-shallow 'ffi:uint8 :count size)))
 148
 149 (defun foreign-free (ptr)
 150   "Free a pointer PTR allocated by FOREIGN-ALLOC.  The results
 151 are undefined if PTR is used after being freed."
 152   (ffi:foreign-free ptr))
 153
 154 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
 155   "Bind VAR to a pointer to SIZE bytes of foreign-addressable
 156 memory during BODY.  Both PTR and the memory block pointed to
 157 have dynamic extent and may be stack allocated if supported by
 158 the implementation.  If SIZE-VAR is supplied, it will be bound to
 159 SIZE during BODY."
 160   (unless size-var
 161     (setf size-var (gensym "SIZE")))
 162   (let ((obj-var (gensym)))
 163     `(let ((,size-var ,size))
 164        (ffi:with-foreign-object
 165            (,obj-var `(ffi:c-array ffi:uint8 ,,size-var))
 166          (let ((,var (ffi:foreign-address ,obj-var)))
 167            ,@body)))))
 168
 169 ;;;# Memory Access
 170
 171 (defun %mem-ref (ptr type &optional (offset 0))
 172   "Dereference a pointer OFFSET bytes from PTR to an object of
 173 built-in foreign TYPE.  Returns the object as a foreign pointer
 174 or Lisp number."
 175   (ffi:memory-as ptr (convert-foreign-type type) offset))
 176
 177 (define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0))
 178   "Compiler macro to open-code when TYPE is constant."
 179   (if (constantp type)
 180       `(ffi:memory-as ,ptr ',(convert-foreign-type (eval type)) ,offset)
 181       form))
 182
 183 (defun %mem-set (value ptr type &optional (offset 0))
 184   "Set a pointer OFFSET bytes from PTR to an object of built-in
 185 foreign TYPE to VALUE."
 186   (setf (ffi:memory-as ptr (convert-foreign-type type) offset) value))
 187
 188 (define-compiler-macro %mem-set
 189     (&whole form value ptr type &optional (offset 0))
 190   (if (constantp type)
 191       ;; (setf (ffi:memory-as) value) is exported, but not so nice
 192       ;; w.r.t. the left to right evaluation rule
 193       `(ffi::write-memory-as
 194         ,value ,ptr ',(convert-foreign-type (eval type)) ,offset)
 195       form))
 196
 197 ;;;# Shareable Vectors
 198 ;;;
 199 ;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
 200 ;;; should be defined to perform a copy-in/copy-out if the Lisp
 201 ;;; implementation can't do this.
 202
 203 (declaim (inline make-shareable-byte-vector))
 204 (defun make-shareable-byte-vector (size)
 205   "Create a Lisp vector of SIZE bytes can passed to
 206 WITH-POINTER-TO-VECTOR-DATA."
 207   (make-array size :element-type '(unsigned-byte 8)))
 208
 209 (deftype shareable-byte-vector ()
 210   `(vector (unsigned-byte 8)))
 211
 212 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 213   "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
 214   (with-unique-names (vector-var size-var)
 215     `(let ((,vector-var ,vector))
 216        (check-type ,vector-var shareable-byte-vector)
 217        (with-foreign-pointer (,ptr-var (length ,vector-var) ,size-var)
 218          ;; copy-in
 219          (loop for i below ,size-var do
 220                (%mem-set (aref ,vector-var i) ,ptr-var :unsigned-char i))
 221          (unwind-protect (progn ,@body)
 222            ;; copy-out
 223            (loop for i below ,size-var do
 224                  (setf (aref ,vector-var i)
 225                        (%mem-ref ,ptr-var :unsigned-char i))))))))
 226
 227 ;;;# Foreign Function Calling
 228
 229 (defun parse-foreign-funcall-args (args)
 230   "Return three values, a list of CLISP FFI types, a list of
 231 values to pass to the function, and the CLISP FFI return type."
 232   (let ((return-type nil))
 233     (loop for (type arg) on args by #'cddr
 234           if arg collect (list (gensym) (convert-foreign-type type)) into types
 235           and collect arg into fargs
 236           else do (setf return-type (convert-foreign-type type))
 237           finally (return (values types fargs return-type)))))
 238
 239 (defun convert-cconv (calling-convention)
 240   (ecase calling-convention
 241     (:stdcall :stdc-stdcall)
 242     (:cdecl :stdc)))
 243
 244 (defun c-function-type (arg-types rettype calling-convention)
 245   "Generate the apropriate CLISP foreign type specification. Also
 246 takes care of converting the calling convention names."
 247   `(ffi:c-function (:arguments ,@arg-types)
 248                    (:return-type ,rettype)
 249                    (:language ,(convert-cconv calling-convention))))
 250
 251 ;;; Quick hack around the fact that the CFFI package is not yet
 252 ;;; defined when this file is loaded.  I suppose we could arrange for
 253 ;;; the CFFI package to be defined a bit earlier, though.
 254 (defun library-handle-form (name)
 255   (flet ((find-cffi-symbol (symbol)
 256            (find-symbol (symbol-name symbol) '#:cffi)))
 257     `(,(find-cffi-symbol '#:foreign-library-handle)
 258        (,(find-cffi-symbol '#:get-foreign-library) ',name))))
 259
 260 (eval-when (:compile-toplevel :load-toplevel :execute)
 261   ;; version 2.40 (CVS 2006-09-03, to be more precise) added a
 262   ;; PROPERTIES argument to FFI::FOREIGN-LIBRARY-FUNCTION.
 263   (defun post-2.40-ffi-interface-p ()
 264     (let ((f-l-f (find-symbol (string '#:foreign-library-function) '#:ffi)))
 265       (if (and f-l-f (= (length (ext:arglist f-l-f)) 5))
 266           '(:and)
 267           '(:or))))
 268   ;; FFI::FOREIGN-LIBRARY-FUNCTION and FFI::FOREIGN-LIBRARY-VARIABLE
 269   ;; were deprecated in 2.41 and removed in 2.45.
 270   (defun post-2.45-ffi-interface-p ()
 271     (if (find-symbol (string '#:foreign-library-function) '#:ffi)
 272         '(:or)
 273         '(:and))))
 274
 275 #+#.(cffi-sys::post-2.45-ffi-interface-p)
 276 (defun %foreign-funcall-aux (name type library)
 277   `(ffi::find-foreign-function ,name ,type nil ,library nil nil))
 278
 279 #-#.(cffi-sys::post-2.45-ffi-interface-p)
 280 (defun %foreign-funcall-aux (name type library)
 281   `(ffi::foreign-library-function
 282     ,name ,library nil
 283     #+#.(cffi-sys::post-2.40-ffi-interface-p)
 284     nil
 285     ,type))
 286
 287 (defmacro %foreign-funcall (name args &key library calling-convention)
 288   "Invoke a foreign function called NAME, taking pairs of
 289 foreign-type/value pairs from ARGS.  If a single element is left
 290 over at the end of ARGS, it specifies the foreign return type of
 291 the function call."
 292   (multiple-value-bind (types fargs rettype)
 293       (parse-foreign-funcall-args args)
 294     `(funcall
 295       (load-time-value
 296        (handler-case
 297            ,(%foreign-funcall-aux
 298              name
 299              `(ffi:parse-c-type
 300                ',(c-function-type types rettype calling-convention))
 301              (if (eq library :default)
 302                  :default
 303                  (library-handle-form library)))
 304          (error (err)
 305            (warn "~A" err))))
 306       ,@fargs)))
 307
 308 (defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
 309   "Similar to %foreign-funcall but takes a pointer instead of a string."
 310   (multiple-value-bind (types fargs rettype)
 311       (parse-foreign-funcall-args args)
 312     `(funcall (ffi:foreign-function
 313                ,ptr (load-time-value
 314                      (ffi:parse-c-type ',(c-function-type
 315                                           types rettype calling-convention))))
 316               ,@fargs)))
 317
 318 ;;;# Callbacks
 319
 320 ;;; *CALLBACKS* contains the callbacks defined by the CFFI DEFCALLBACK
 321 ;;; macro.  The symbol naming the callback is the key, and the value
 322 ;;; is a list containing a Lisp function, the parsed CLISP FFI type of
 323 ;;; the callback, and a saved pointer that should not persist across
 324 ;;; saved images.
 325 (defvar *callbacks* (make-hash-table))
 326
 327 ;;; Return a CLISP FFI function type for a CFFI callback function
 328 ;;; given a return type and list of argument names and types.
 329 (eval-when (:compile-toplevel :load-toplevel :execute)
 330   (defun callback-type (rettype arg-names arg-types calling-convention)
 331     (ffi:parse-c-type
 332      `(ffi:c-function
 333        (:arguments ,@(mapcar (lambda (sym type)
 334                                (list sym (convert-foreign-type type)))
 335                              arg-names arg-types))
 336        (:return-type ,(convert-foreign-type rettype))
 337        (:language ,(convert-cconv calling-convention))))))
 338
 339 ;;; Register and create a callback function.
 340 (defun register-callback (name function parsed-type)
 341   (setf (gethash name *callbacks*)
 342         (list function parsed-type
 343               (ffi:with-foreign-object (ptr 'ffi:c-pointer)
 344                 ;; Create callback by converting Lisp function to foreign
 345                 (setf (ffi:memory-as ptr parsed-type) function)
 346                 (ffi:foreign-value ptr)))))
 347
 348 ;;; Restore all saved callback pointers when restarting the Lisp
 349 ;;; image.  This is pushed onto CUSTOM:*INIT-HOOKS*.
 350 ;;; Needs clisp > 2.35, bugfix 2005-09-29
 351 (defun restore-callback-pointers ()
 352   (maphash
 353    (lambda (name list)
 354      (register-callback name (first list) (second list)))
 355    *callbacks*))
 356
 357 ;;; Add RESTORE-CALLBACK-POINTERS to the lists of functions to run
 358 ;;; when an image is restarted.
 359 (eval-when (:load-toplevel :execute)
 360   (pushnew 'restore-callback-pointers custom:*init-hooks*))
 361
 362 ;;; Define a callback function NAME to run BODY with arguments
 363 ;;; ARG-NAMES translated according to ARG-TYPES and the return type
 364 ;;; translated according to RETTYPE.  Obtain a pointer that can be
 365 ;;; passed to C code for this callback by calling %CALLBACK.
 366 (defmacro %defcallback (name rettype arg-names arg-types body
 367                         &key calling-convention)
 368   `(register-callback ',name (lambda ,arg-names ,body)
 369                       ,(callback-type rettype arg-names arg-types
 370                                       calling-convention)))
 371
 372 ;;; Look up the name of a callback and return a pointer that can be
 373 ;;; passed to a C function.  Signals an error if no callback is
 374 ;;; defined called NAME.
 375 (defun %callback (name)
 376   (multiple-value-bind (list winp) (gethash name *callbacks*)
 377     (unless winp
 378       (error "Undefined callback: ~S" name))
 379     (third list)))
 380
 381 ;;;# Loading and Closing Foreign Libraries
 382
 383 (defun %load-foreign-library (name path)
 384   "Load a foreign library from PATH."
 385   (declare (ignore name))
 386   #+#.(cffi-sys::post-2.45-ffi-interface-p)
 387   (ffi:open-foreign-library path)
 388   #-#.(cffi-sys::post-2.45-ffi-interface-p)
 389   (ffi::foreign-library path))
 390
 391 (defun %close-foreign-library (handle)
 392   "Close a foreign library."
 393   (ffi:close-foreign-library handle))
 394
 395 (defun native-namestring (pathname)
 396   (namestring pathname))
 397
 398 ;;;# Foreign Globals
 399
 400 (defun %foreign-symbol-pointer (name library)
 401   "Returns a pointer to a foreign symbol NAME."
 402   (prog1 (ignore-errors
 403            (ffi:foreign-address
 404             #+#.(cffi-sys::post-2.45-ffi-interface-p)
 405             (ffi::find-foreign-variable name nil library nil nil)
 406             #-#.(cffi-sys::post-2.45-ffi-interface-p)
 407             (ffi::foreign-library-variable name library nil nil)))))