1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; cffi-corman.lisp --- CFFI-SYS implementation for Corman Lisp.
5 ;;; Copyright (C) 2005-2006, Luis Oliveira <loliveira(@)common-lisp.net>
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:
15 ;;; The above copyright notice and this permission notice shall be
16 ;;; included in all copies or substantial portions of the Software.
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.
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
34 (defpackage #:cffi-sys
35 (:use
#:common-lisp
#:c-types
#:cffi-utils
)
37 #:canonicalize-symbol-name-case
48 #:with-foreign-pointer
50 #:%foreign-type-alignment
52 #:%load-foreign-library
56 ;#:make-shareable-byte-vector
57 ;#:with-pointer-to-vector-data
58 #:foreign-symbol-pointer
59 #:defcfun-helper-forms
63 (in-package #:cffi-sys
)
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
79 (defun canonicalize-symbol-name-case (name)
80 (declare (string name
))
83 ;;;# Basic Pointer Operations
85 (deftype foreign-pointer
()
89 "Return true if PTR is a foreign pointer."
92 (defun pointer-eq (ptr1 ptr2
)
93 "Return true if PTR1 and PTR2 point to the same address."
94 (cpointer= ptr1 ptr2
))
96 (defun null-pointer ()
97 "Return a null pointer."
100 (defun null-pointer-p (ptr)
101 "Return true if PTR is a null pointer."
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
))
111 (defun make-pointer (address)
112 "Return a pointer pointing to ADDRESS."
113 (int-to-foreign-ptr address
))
115 (defun pointer-address (ptr)
116 "Return the address pointed to by PTR."
117 (foreign-ptr-to-int ptr
))
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.
126 (defun %foreign-alloc
(size)
127 "Allocate SIZE bytes on the heap and return a pointer."
130 (defun foreign-free (ptr)
131 "Free a PTR allocated by FOREIGN-ALLOC."
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."
140 (setf size-var
(gensym "SIZE")))
141 `(let* ((,size-var
,size
)
142 (,var
(malloc ,size-var
)))
147 ;;;# Shareable Vectors
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.
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)))
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)))
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."
172 (:unsigned-char
:unsigned-char
)
174 (:unsigned-short
:unsigned-short
)
176 (:unsigned-int
:unsigned-long
)
178 (:unsigned-long
:unsigned-long
)
179 (:float
:single-float
)
180 (:double
:double-float
)
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
)))
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))))
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)
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
)))
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
))))
223 ;;;# Calling Foreign Functions
225 (defun %foreign-type-size
(type-keyword)
226 "Return the size in bytes of a foreign type."
227 (sizeof (convert-foreign-type type-keyword
)))
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
)))
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
*)
240 (ct::get-dll-proc-address name
(ct::dll-record-handle dll
)))
241 (return (ct::dll-record-name dll
)))))
243 ;;; This won't work at all...
245 (defmacro %foreign-funcall
(name &rest args
)
246 (let ((sym (gensym)))
248 (ct::install-dll-function
,(find-dll-containing-function name
)
250 (funcall ,sym
,@(loop for
(type arg
) on args by
#'cddr
251 if arg collect arg
)))))
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
))
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
)))
269 ,(mapcar (lambda (type)
270 (list (gensym) (convert-foreign-type type
)))
272 :return-type
,(convert-foreign-type rettype
)
275 ;; we want also :pascal linkage type to access
276 ;; the win32 api for instance..
278 `(,ff-name
,@args
))))
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)
288 (defun-c-callback ,cb-sym
289 ,(mapcar (lambda (sym type
) (list sym
(convert-foreign-type type
)))
292 (setf (get ',name
'callback-ptr
)
293 (get-callback-procinst ',cb-sym
)))))
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
))
301 ;;;# Loading Foreign Libraries
303 (defun %load-foreign-library
(name)
304 "Load the foreign library NAME."
305 (ct::get-dll-record name
))
307 (defun %close-foreign-library
(name)
308 "Close the foreign library NAME."
309 (error "Not implemented."))
311 (defun native-namestring (pathname)
312 (namestring pathname
)) ; TODO: confirm
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
323 :library-name
"Kernel32.dll"
324 :entry-name
"GetProcAddress"
325 :linkage-type
:pascal
)
327 (defun foreign-symbol-pointer (name)
328 "Returns a pointer to a foreign symbol NAME."
329 (let ((str (lisp-string-to-c-string name
)))
331 (dolist (dll ct
::*dlls-loaded
*)
332 (let ((ptr (get-proc-address
333 (int-to-foreign-ptr (ct::dll-record-handle dll
))
335 (when (not (cpointer-null ptr
))