cffi-mkcl.lisp - clic - Clic is an command line interactive client for gopher w… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
cffi-mkcl.lisp (12048B) | |
--- | |
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- | |
2 ;;; | |
3 ;;; cffi-mkcl.lisp --- MKCL backend for CFFI. | |
4 ;;; | |
5 ;;; Copyright (C) 2010-2012, Jean-Claude Beaudoin | |
6 ;;; Copyright (C) 2005-2006, James Bielman <[email protected]> | |
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 #: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 ;;;# Mis-features | |
64 | |
65 (pushnew 'flat-namespace *features*) | |
66 | |
67 ;;;# Symbol Case | |
68 | |
69 (defun canonicalize-symbol-name-case (name) | |
70 (declare (string name)) | |
71 (string-upcase name)) | |
72 | |
73 ;;;# Allocation | |
74 | |
75 (defun %foreign-alloc (size) | |
76 "Allocate SIZE bytes of foreign-addressable memory." | |
77 (si:allocate-foreign-data :void size)) | |
78 | |
79 (defun foreign-free (ptr) | |
80 "Free a pointer PTR allocated by FOREIGN-ALLOC." | |
81 (si:free-foreign-data ptr) | |
82 nil) | |
83 | |
84 (defmacro with-foreign-pointer ((var size &optional size-var) &body body) | |
85 "Bind VAR to SIZE bytes of foreign memory during BODY. The | |
86 pointer in VAR is invalid beyond the dynamic extent of BODY, and | |
87 may be stack-allocated if supported by the implementation. If | |
88 SIZE-VAR is supplied, it will be bound to SIZE during BODY." | |
89 (unless size-var | |
90 (setf size-var (gensym "SIZE"))) | |
91 `(let* ((,size-var ,size) | |
92 (,var (%foreign-alloc ,size-var))) | |
93 (unwind-protect | |
94 (progn ,@body) | |
95 (foreign-free ,var)))) | |
96 | |
97 ;;;# Misc. Pointer Operations | |
98 | |
99 (deftype foreign-pointer () | |
100 'si:foreign) | |
101 | |
102 (defun null-pointer () | |
103 "Construct and return a null pointer." | |
104 (si:make-foreign-null-pointer)) | |
105 | |
106 (defun null-pointer-p (ptr) | |
107 "Return true if PTR is a null pointer." | |
108 (si:null-pointer-p ptr)) | |
109 | |
110 (defun inc-pointer (ptr offset) | |
111 "Return a pointer OFFSET bytes past PTR." | |
112 (ffi:make-pointer (+ (ffi:pointer-address ptr) offset) :void)) | |
113 | |
114 (defun pointerp (ptr) | |
115 "Return true if PTR is a foreign pointer." | |
116 ;;(typep ptr 'si:foreign) | |
117 (si:foreignp ptr)) | |
118 | |
119 (defun pointer-eq (ptr1 ptr2) | |
120 "Return true if PTR1 and PTR2 point to the same address." | |
121 (= (ffi:pointer-address ptr1) (ffi:pointer-address ptr2))) | |
122 | |
123 (defun make-pointer (address) | |
124 "Return a pointer pointing to ADDRESS." | |
125 (ffi:make-pointer address :void)) | |
126 | |
127 (defun pointer-address (ptr) | |
128 "Return the address pointed to by PTR." | |
129 (ffi:pointer-address ptr)) | |
130 | |
131 ;;;# Shareable Vectors | |
132 ;;; | |
133 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA | |
134 ;;; should be defined to perform a copy-in/copy-out if the Lisp | |
135 ;;; implementation can't do this. | |
136 | |
137 (defun make-shareable-byte-vector (size) | |
138 "Create a Lisp vector of SIZE bytes that can passed to | |
139 WITH-POINTER-TO-VECTOR-DATA." | |
140 (make-array size :element-type '(unsigned-byte 8))) | |
141 | |
142 ;;; MKCL, built with the Boehm GC never moves allocated data, so this | |
143 ;;; isn't nearly as hard to do. | |
144 (defun %vector-address (vector) | |
145 "Return the address of VECTOR's data." | |
146 (check-type vector (vector (unsigned-byte 8))) | |
147 #-mingw64 | |
148 (ffi:c-inline (vector) (object) | |
149 :unsigned-long | |
150 "(uintptr_t) #0->vector.self.b8" | |
151 :side-effects nil | |
152 :one-liner t) | |
153 #+mingw64 | |
154 (ffi:c-inline (vector) (object) | |
155 :unsigned-long-long | |
156 "(uintptr_t) #0->vector.self.b8" | |
157 :side-effects nil | |
158 :one-liner t)) | |
159 | |
160 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) | |
161 "Bind PTR-VAR to a foreign pointer to the data in VECTOR." | |
162 `(let ((,ptr-var (make-pointer (%vector-address ,vector)))) | |
163 ,@body)) | |
164 | |
165 ;;;# Dereferencing | |
166 | |
167 (defun %mem-ref (ptr type &optional (offset 0)) | |
168 "Dereference an object of TYPE at OFFSET bytes from PTR." | |
169 (let* ((type (cffi-type->mkcl-type type)) | |
170 (type-size (ffi:size-of-foreign-type type))) | |
171 (si:foreign-ref-elt | |
172 (si:foreign-recast ptr (+ offset type-size) :void) offset type))) | |
173 | |
174 (defun %mem-set (value ptr type &optional (offset 0)) | |
175 "Set an object of TYPE at OFFSET bytes from PTR." | |
176 (let* ((type (cffi-type->mkcl-type type)) | |
177 (type-size (ffi:size-of-foreign-type type))) | |
178 (si:foreign-set-elt | |
179 (si:foreign-recast ptr (+ offset type-size) :void) | |
180 offset type value))) | |
181 | |
182 ;;;# Type Operations | |
183 | |
184 (defconstant +translation-table+ | |
185 '((:char :byte "char") | |
186 (:unsigned-char :unsigned-byte "unsigned char") | |
187 (:short :short "short") | |
188 (:unsigned-short :unsigned-short "unsigned short") | |
189 (:int :int "int") | |
190 (:unsigned-int :unsigned-int "unsigned int") | |
191 (:long :long "long") | |
192 (:unsigned-long :unsigned-long "unsigned long") | |
193 (:long-long :long-long "long long") | |
194 (:unsigned-long-long :unsigned-long-long "unsigned long long") | |
195 (:float :float "float") | |
196 (:double :double "double") | |
197 (:pointer :pointer-void "void*") | |
198 (:void :void "void"))) | |
199 | |
200 (defun cffi-type->mkcl-type (type-keyword) | |
201 "Convert a CFFI type keyword to an MKCL type keyword." | |
202 (or (second (find type-keyword +translation-table+ :key #'first)) | |
203 (error "~S is not a valid CFFI type" type-keyword))) | |
204 | |
205 (defun mkcl-type->c-type (type-keyword) | |
206 "Convert a CFFI type keyword to an valid C type keyword." | |
207 (or (third (find type-keyword +translation-table+ :key #'second)) | |
208 (error "~S is not a valid CFFI type" type-keyword))) | |
209 | |
210 (defun %foreign-type-size (type-keyword) | |
211 "Return the size in bytes of a foreign type." | |
212 (nth-value 0 (ffi:size-of-foreign-type | |
213 (cffi-type->mkcl-type type-keyword)))) | |
214 | |
215 (defun %foreign-type-alignment (type-keyword) | |
216 "Return the alignment in bytes of a foreign type." | |
217 (nth-value 1 (ffi:size-of-foreign-type | |
218 (cffi-type->mkcl-type type-keyword)))) | |
219 | |
220 ;;;# Calling Foreign Functions | |
221 | |
222 #| | |
223 (defconstant +mkcl-inline-codes+ "#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#a,#b,#c… | |
224 |# | |
225 | |
226 (defun produce-function-pointer-call (pointer types values return-type) | |
227 #| | |
228 (if (stringp pointer) | |
229 (produce-function-pointer-call | |
230 `(%foreign-symbol-pointer ,pointer nil) types values return-type) | |
231 `(ffi:c-inline | |
232 ,(list* pointer values) | |
233 ,(list* :pointer-void types) ,return-type | |
234 ,(with-output-to-string (s) | |
235 (let ((types (mapcar #'mkcl-type->c-type types))) | |
236 ;; On AMD64, the following code only works with the extra | |
237 ;; argument ",...". If this is not present, functions | |
238 ;; like sprintf do not work | |
239 (format s "((~A (*)(~@[~{~A,~}...~]))(#0))(~A)" | |
240 (mkcl-type->c-type return-type) types | |
241 (subseq +mkcl-inline-codes+ 3 | |
242 (max 3 (+ 2 (* (length values) 3))))))) | |
243 :one-liner t :side-effects t)) | |
244 |# | |
245 ;; The version here below is definitely not as efficient as the one ab… | |
246 ;; but it has the great vertue of working in all cases, (contrary to t… | |
247 ;; silent and unsafe limitations of the one above). JCB | |
248 ;; I should re-optimize this one day, when I get time... JCB | |
249 (progn | |
250 (when (stringp pointer) | |
251 (setf pointer `(%foreign-symbol-pointer ,pointer nil))) | |
252 `(si:call-cfun ,pointer ,return-type (list ,@types) (list ,@values))… | |
253 | |
254 | |
255 (defun foreign-funcall-parse-args (args) | |
256 "Return three values, lists of arg types, values, and result type." | |
257 (let ((return-type :void)) | |
258 (loop for (type arg) on args by #'cddr | |
259 if arg collect (cffi-type->mkcl-type type) into types | |
260 and collect arg into values | |
261 else do (setf return-type (cffi-type->mkcl-type type)) | |
262 finally (return (values types values return-type))))) | |
263 | |
264 (defmacro %foreign-funcall (name args &key library convention) | |
265 "Call a foreign function." | |
266 (declare (ignore library convention)) | |
267 (multiple-value-bind (types values return-type) | |
268 (foreign-funcall-parse-args args) | |
269 (produce-function-pointer-call name types values return-type))) | |
270 | |
271 (defmacro %foreign-funcall-pointer (ptr args &key convention) | |
272 "Funcall a pointer to a foreign function." | |
273 (declare (ignore convention)) | |
274 (multiple-value-bind (types values return-type) | |
275 (foreign-funcall-parse-args args) | |
276 (produce-function-pointer-call ptr types values return-type))) | |
277 | |
278 ;;;# Foreign Libraries | |
279 | |
280 (defun %load-foreign-library (name path) | |
281 "Load a foreign library." | |
282 (declare (ignore name)) | |
283 (handler-case (si:load-foreign-module path) | |
284 (file-error () | |
285 (error "file error while trying to load `~A'" path)))) | |
286 | |
287 (defun %close-foreign-library (handle) | |
288 ;;(declare (ignore handle)) | |
289 ;;(error "%CLOSE-FOREIGN-LIBRARY unimplemented.") | |
290 (si:unload-foreign-module handle)) | |
291 | |
292 (defun native-namestring (pathname) | |
293 (namestring pathname)) | |
294 | |
295 ;;;# Callbacks | |
296 | |
297 ;;; Create a package to contain the symbols for callback functions. | |
298 ;;; We want to redefine callbacks with the same symbol so the internal | |
299 ;;; data structures are reused. | |
300 (defpackage #:cffi-callbacks | |
301 (:use)) | |
302 | |
303 (defvar *callbacks* (make-hash-table)) | |
304 | |
305 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the | |
306 ;;; internal callback for NAME. | |
307 (eval-when (:compile-toplevel :load-toplevel :execute) | |
308 (defun intern-callback (name) | |
309 (intern (format nil "~A::~A" | |
310 (if-let (package (symbol-package name)) | |
311 (package-name package) | |
312 "#") | |
313 (symbol-name name)) | |
314 '#:cffi-callbacks))) | |
315 | |
316 (defmacro %defcallback (name rettype arg-names arg-types body | |
317 &key convention) | |
318 (declare (ignore convention)) | |
319 (let ((cb-name (intern-callback name))) | |
320 `(progn | |
321 (ffi:defcallback (,cb-name :cdecl) | |
322 ,(cffi-type->mkcl-type rettype) | |
323 ,(mapcar #'list arg-names | |
324 (mapcar #'cffi-type->mkcl-type arg-type… | |
325 ;;(block ,cb-name ,@body) | |
326 (block ,cb-name ,body)) | |
327 (setf (gethash ',name *callbacks*) ',cb-name)))) | |
328 | |
329 (defun %callback (name) | |
330 (multiple-value-bind (symbol winp) | |
331 (gethash name *callbacks*) | |
332 (unless winp | |
333 (error "Undefined callback: ~S" name)) | |
334 (ffi:callback symbol))) | |
335 | |
336 ;;;# Foreign Globals | |
337 | |
338 (defun %foreign-symbol-pointer (name library) | |
339 "Returns a pointer to a foreign symbol NAME." | |
340 (declare (ignore library)) | |
341 (values (ignore-errors (si:find-foreign-symbol name :default :pointer-… | |
342 |