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

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; cffi-corman.lisp --- CFFI-SYS implementation for Corman Lisp.
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, Luis Oliveira  <loliveira(@)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 ;;; This port is suffering from bitrot as of 2007-03-29.  Corman Lisp
  29 ;;; is too funky with ASDF, crashes easily, makes it very painful to
  30 ;;; do any testing.  -- luis
  31
  32 ;;;# Administrivia
  33
  34 (defpackage #:cffi-sys
  35   (:use #:common-lisp #:c-types #:cffi-utils)
  36   (:export
  37    #:canonicalize-symbol-name-case
  38    #:foreign-pointer
  39    #:pointerp
  40    #:pointer-eq
  41    #:null-pointer
  42    #:null-pointer-p
  43    #:inc-pointer
  44    #:make-pointer
  45    #:pointer-address
  46    #:%foreign-alloc
  47    #:foreign-free
  48    #:with-foreign-pointer
  49    #:%foreign-funcall
  50    #:%foreign-type-alignment
  51    #:%foreign-type-size
  52    #:%load-foreign-library
  53    #:native-namestring
  54    #:%mem-ref
  55    #:%mem-set
  56    ;#:make-shareable-byte-vector
  57    ;#:with-pointer-to-vector-data
  58    #:foreign-symbol-pointer
  59    #:defcfun-helper-forms
  60    #:%defcallback
  61    #:%callback))
  62
  63 (in-package #:cffi-sys)
  64
  65 ;;;# Features
  66
  67 (eval-when (:compile-toplevel :load-toplevel :execute)
  68   (mapc (lambda (feature) (pushnew feature *features*))
  69         '(;; Backend mis-features.
  70           cffi-features:no-long-long
  71           cffi-features:no-foreign-funcall
  72           ;; OS/CPU features.
  73           cffi-features:windows
  74           cffi-features:x86
  75           )))
  76
  77 ;;; Symbol case.
  78
  79 (defun canonicalize-symbol-name-case (name)
  80   (declare (string name))
  81   (string-upcase name))
  82
  83 ;;;# Basic Pointer Operations
  84
  85 (deftype foreign-pointer ()
  86   'cl::foreign)
  87
  88 (defun pointerp (ptr)
  89   "Return true if PTR is a foreign pointer."
  90   (cpointerp ptr))
  91
  92 (defun pointer-eq (ptr1 ptr2)
  93   "Return true if PTR1 and PTR2 point to the same address."
  94   (cpointer= ptr1 ptr2))
  95
  96 (defun null-pointer ()
  97   "Return a null pointer."
  98   (create-foreign-ptr))
  99
 100 (defun null-pointer-p (ptr)
 101   "Return true if PTR is a null pointer."
 102   (cpointer-null ptr))
 103
 104 (defun inc-pointer (ptr offset)
 105   "Return a pointer pointing OFFSET bytes past PTR."
 106   (let ((new-ptr (create-foreign-ptr)))
 107     (setf (cpointer-value new-ptr)
 108           (+ (cpointer-value ptr) offset))
 109     new-ptr))
 110
 111 (defun make-pointer (address)
 112   "Return a pointer pointing to ADDRESS."
 113   (int-to-foreign-ptr address))
 114
 115 (defun pointer-address (ptr)
 116   "Return the address pointed to by PTR."
 117   (foreign-ptr-to-int ptr))
 118
 119 ;;;# Allocation
 120 ;;;
 121 ;;; Functions and macros for allocating foreign memory on the stack
 122 ;;; and on the heap.  The main CFFI package defines macros that wrap
 123 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common usage
 124 ;;; when the memory has dynamic extent.
 125
 126 (defun %foreign-alloc (size)
 127   "Allocate SIZE bytes on the heap and return a pointer."
 128   (malloc size))
 129
 130 (defun foreign-free (ptr)
 131   "Free a PTR allocated by FOREIGN-ALLOC."
 132   (free ptr))
 133
 134 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
 135   "Bind VAR to SIZE bytes of foreign memory during BODY.  The
 136 pointer in VAR is invalid beyond the dynamic extent of BODY, and
 137 may be stack-allocated if supported by the implementation.  If
 138 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
 139   (unless size-var
 140     (setf size-var (gensym "SIZE")))
 141   `(let* ((,size-var ,size)
 142           (,var (malloc ,size-var)))
 143      (unwind-protect
 144           (progn ,@body)
 145        (free ,var))))
 146
 147 ;;;# Shareable Vectors
 148 ;;;
 149 ;;; This interface is very experimental.  WITH-POINTER-TO-VECTOR-DATA
 150 ;;; should be defined to perform a copy-in/copy-out if the Lisp
 151 ;;; implementation can't do this.
 152
 153 ;(defun make-shareable-byte-vector (size)
 154 ;  "Create a Lisp vector of SIZE bytes can passed to
 155 ;WITH-POINTER-TO-VECTOR-DATA."
 156 ;  (make-array size :element-type '(unsigned-byte 8)))
 157 ;
 158 ;(defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
 159 ;  "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
 160 ;  `(sb-sys:without-gcing
 161 ;     (let ((,ptr-var (sb-sys:vector-sap ,vector)))
 162 ;       ,@body)))
 163
 164 ;;;# Dereferencing
 165
 166 ;;; According to the docs, Corman's C Function Definition Parser
 167 ;;; converts int to long, so we'll assume that.
 168 (defun convert-foreign-type (type-keyword)
 169   "Convert a CFFI type keyword to a CormanCL type."
 170   (ecase type-keyword
 171     (:char             :char)
 172     (:unsigned-char    :unsigned-char)
 173     (:short            :short)
 174     (:unsigned-short   :unsigned-short)
 175     (:int              :long)
 176     (:unsigned-int     :unsigned-long)
 177     (:long             :long)
 178     (:unsigned-long    :unsigned-long)
 179     (:float            :single-float)
 180     (:double           :double-float)
 181     (:pointer          :handle)
 182     (:void             :void)))
 183
 184 (defun %mem-ref (ptr type &optional (offset 0))
 185   "Dereference an object of TYPE at OFFSET bytes from PTR."
 186   (unless (eql offset 0)
 187     (setq ptr (inc-pointer ptr offset)))
 188   (ecase type
 189     (:char             (cref (:char *) ptr 0))
 190     (:unsigned-char    (cref (:unsigned-char *) ptr 0))
 191     (:short            (cref (:short *) ptr 0))
 192     (:unsigned-short   (cref (:unsigned-short *) ptr 0))
 193     (:int              (cref (:long *) ptr 0))
 194     (:unsigned-int     (cref (:unsigned-long *) ptr 0))
 195     (:long             (cref (:long *) ptr 0))
 196     (:unsigned-long    (cref (:unsigned-long *) ptr 0))
 197     (:float            (cref (:single-float *) ptr 0))
 198     (:double           (cref (:double-float *) ptr 0))
 199     (:pointer          (cref (:handle *) ptr 0))))
 200
 201 ;(define-compiler-macro %mem-ref (&whole form ptr type &optional (offset 0))
 202 ;  (if (constantp type)
 203 ;      `(cref (,(convert-foreign-type type) *) ,ptr ,offset)
 204 ;      form))
 205
 206 (defun %mem-set (value ptr type &optional (offset 0))
 207   "Set the object of TYPE at OFFSET bytes from PTR."
 208   (unless (eql offset 0)
 209     (setq ptr (inc-pointer ptr offset)))
 210   (ecase type
 211     (:char             (setf (cref (:char *) ptr 0) value))
 212     (:unsigned-char    (setf (cref (:unsigned-char *) ptr 0) value))
 213     (:short            (setf (cref (:short *) ptr 0) value))
 214     (:unsigned-short   (setf (cref (:unsigned-short *) ptr 0) value))
 215     (:int              (setf (cref (:long *) ptr 0) value))
 216     (:unsigned-int     (setf (cref (:unsigned-long *) ptr 0) value))
 217     (:long             (setf (cref (:long *) ptr 0) value))
 218     (:unsigned-long    (setf (cref (:unsigned-long *) ptr 0) value))
 219     (:float            (setf (cref (:single-float *) ptr 0) value))
 220     (:double           (setf (cref (:double-float *) ptr 0) value))
 221     (:pointer          (setf (cref (:handle *) ptr 0) value))))
 222
 223 ;;;# Calling Foreign Functions
 224
 225 (defun %foreign-type-size (type-keyword)
 226   "Return the size in bytes of a foreign type."
 227   (sizeof (convert-foreign-type type-keyword)))
 228
 229 ;;; Couldn't find anything in sys/ffi.lisp and the C declaration parser
 230 ;;; doesn't seem to care about alignment so we'll assume that it's the
 231 ;;; same as its size.
 232 (defun %foreign-type-alignment (type-keyword)
 233   (sizeof (convert-foreign-type type-keyword)))
 234
 235 (defun find-dll-containing-function (name)
 236   "Searches for NAME in the loaded DLLs. If found, returns
 237 the DLL's name (a string), else returns NIL."
 238   (dolist (dll ct::*dlls-loaded*)
 239     (when (ignore-errors
 240             (ct::get-dll-proc-address name (ct::dll-record-handle dll)))
 241       (return (ct::dll-record-name dll)))))
 242
 243 ;;; This won't work at all...
 244 #||
 245 (defmacro %foreign-funcall (name &rest args)
 246   (let ((sym (gensym)))
 247     `(let (,sym)
 248        (ct::install-dll-function ,(find-dll-containing-function name)
 249                                  ,name ,sym)
 250        (funcall ,sym ,@(loop for (type arg) on args by #'cddr
 251                              if arg collect arg)))))
 252 ||#
 253
 254 ;;; It *might* be possible to implement by copying most of the code
 255 ;;; from Corman's DEFUN-DLL.  Alternatively, it could implemented the
 256 ;;; same way as Lispworks' foreign-funcall.  In practice, nobody uses
 257 ;;; Corman with CFFI, apparently. :)
 258 (defmacro %foreign-funcall (name &rest args)
 259   "Call a foreign function NAME passing arguments ARGS."
 260   `(format t "~&;; Calling ~A with args ~S.~%" ,name ',args))
 261
 262 (defun defcfun-helper-forms (name lisp-name rettype args types)
 263   "Return 2 values for DEFCFUN. A prelude form and a caller form."
 264   (let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name)))
 265         ;; XXX This will only work if the dll is already loaded, fix this.
 266         (dll (find-dll-containing-function name)))
 267     (values
 268      `(defun-dll ,ff-name
 269           ,(mapcar (lambda (type)
 270                      (list (gensym) (convert-foreign-type type)))
 271                    types)
 272         :return-type ,(convert-foreign-type rettype)
 273         :library-name ,dll
 274         :entry-name ,name
 275         ;; we want also :pascal linkage type to access
 276         ;; the win32 api for instance..
 277         :linkage-type :c)
 278      `(,ff-name ,@args))))
 279
 280 ;;;# Callbacks
 281
 282 ;;; defun-c-callback vs. defun-direct-c-callback?
 283 ;;; same issue as Allegro, no return type declaration, should we coerce?
 284 (defmacro %defcallback (name rettype arg-names arg-types body-form)
 285   (declare (ignore rettype))
 286   (with-unique-names (cb-sym)
 287     `(progn
 288        (defun-c-callback ,cb-sym
 289            ,(mapcar (lambda (sym type) (list sym (convert-foreign-type type)))
 290                             arg-names arg-types)
 291          ,body-form)
 292        (setf (get ',name 'callback-ptr)
 293              (get-callback-procinst ',cb-sym)))))
 294
 295 ;;; Just continue to use the plist for now even though this really
 296 ;;; should use a *CALLBACKS* hash table and not define the callbacks
 297 ;;; as gensyms.  Someone with access to Corman should update this.
 298 (defun %callback (name)
 299   (get name 'callback-ptr))
 300
 301 ;;;# Loading Foreign Libraries
 302
 303 (defun %load-foreign-library (name)
 304   "Load the foreign library NAME."
 305   (ct::get-dll-record name))
 306
 307 (defun %close-foreign-library (name)
 308   "Close the foreign library NAME."
 309   (error "Not implemented."))
 310
 311 (defun native-namestring (pathname)
 312   (namestring pathname)) ; TODO: confirm
 313
 314 ;;;# Foreign Globals
 315
 316 ;;; FFI to GetProcAddress from the Win32 API.
 317 ;;; "The GetProcAddress function retrieves the address of an exported
 318 ;;; function or variable from the specified dynamic-link library (DLL)."
 319 (defun-dll get-proc-address
 320     ((module HMODULE)
 321      (name LPCSTR))
 322   :return-type FARPROC
 323   :library-name "Kernel32.dll"
 324   :entry-name "GetProcAddress"
 325   :linkage-type :pascal)
 326
 327 (defun foreign-symbol-pointer (name)
 328   "Returns a pointer to a foreign symbol NAME."
 329   (let ((str (lisp-string-to-c-string name)))
 330     (unwind-protect
 331          (dolist (dll ct::*dlls-loaded*)
 332            (let ((ptr (get-proc-address
 333                        (int-to-foreign-ptr (ct::dll-record-handle dll))
 334                        str)))
 335              (when (not (cpointer-null ptr))
 336                (return ptr))))
 337       (free str))))