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