cffi-scl.lisp - clic - Clic is an command line interactive client for gopher wr… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
cffi-scl.lisp (11099B) | |
--- | |
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- | |
2 ;;; | |
3 ;;; cffi-scl.lisp --- CFFI-SYS implementation for the Scieneer Common Li… | |
4 ;;; | |
5 ;;; Copyright (C) 2005-2006, James Bielman <[email protected]> | |
6 ;;; Copyright (C) 2006-2007, Scieneer Pty Ltd. | |
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 #:alien #:c-call) | |
33 (:import-from #:alexandria #:once-only #:with-unique-names) | |
34 (:export | |
35 #:canonicalize-symbol-name-case | |
36 #:foreign-pointer | |
37 #:pointerp | |
38 #:pointer-eq | |
39 #:null-pointer | |
40 #:null-pointer-p | |
41 #:inc-pointer | |
42 #:make-pointer | |
43 #:pointer-address | |
44 #:%foreign-alloc | |
45 #:foreign-free | |
46 #:with-foreign-pointer | |
47 #:%foreign-funcall | |
48 #:%foreign-funcall-pointer | |
49 #:%foreign-type-alignment | |
50 #:%foreign-type-size | |
51 #:%load-foreign-library | |
52 #:%close-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 #:%defcallback | |
60 #:%callback)) | |
61 | |
62 (in-package #:cffi-sys) | |
63 | |
64 ;;;# Mis-features | |
65 | |
66 (pushnew 'flat-namespace *features*) | |
67 | |
68 ;;;# Symbol Case | |
69 | |
70 (defun canonicalize-symbol-name-case (name) | |
71 (declare (string name)) | |
72 (if (eq ext:*case-mode* :upper) | |
73 (string-upcase name) | |
74 (string-downcase name))) | |
75 | |
76 ;;;# Basic Pointer Operations | |
77 | |
78 (deftype foreign-pointer () | |
79 'sys:system-area-pointer) | |
80 | |
81 (declaim (inline pointerp)) | |
82 (defun pointerp (ptr) | |
83 "Return true if 'ptr is a foreign pointer." | |
84 (sys:system-area-pointer-p ptr)) | |
85 | |
86 (declaim (inline pointer-eq)) | |
87 (defun pointer-eq (ptr1 ptr2) | |
88 "Return true if 'ptr1 and 'ptr2 point to the same address." | |
89 (sys:sap= ptr1 ptr2)) | |
90 | |
91 (declaim (inline null-pointer)) | |
92 (defun null-pointer () | |
93 "Construct and return a null pointer." | |
94 (sys:int-sap 0)) | |
95 | |
96 (declaim (inline null-pointer-p)) | |
97 (defun null-pointer-p (ptr) | |
98 "Return true if 'ptr is a null pointer." | |
99 (zerop (sys:sap-int ptr))) | |
100 | |
101 (declaim (inline inc-pointer)) | |
102 (defun inc-pointer (ptr offset) | |
103 "Return a pointer pointing 'offset bytes past 'ptr." | |
104 (sys:sap+ ptr offset)) | |
105 | |
106 (declaim (inline make-pointer)) | |
107 (defun make-pointer (address) | |
108 "Return a pointer pointing to 'address." | |
109 (sys:int-sap address)) | |
110 | |
111 (declaim (inline pointer-address)) | |
112 (defun pointer-address (ptr) | |
113 "Return the address pointed to by 'ptr." | |
114 (sys:sap-int ptr)) | |
115 | |
116 (defmacro with-foreign-pointer ((var size &optional size-var) &body body) | |
117 "Bind 'var to 'size bytes of foreign memory during 'body. The | |
118 pointer in 'var is invalid beyond the dynamic extent of 'body, and | |
119 may be stack-allocated if supported by the implementation. If | |
120 'size-var is supplied, it will be bound to 'size during 'body." | |
121 (unless size-var | |
122 (setf size-var (gensym (symbol-name '#:size)))) | |
123 ;; If the size is constant we can stack-allocate. | |
124 (cond ((constantp size) | |
125 (let ((alien-var (gensym (symbol-name '#:alien)))) | |
126 `(with-alien ((,alien-var (array (unsigned 8) ,(eval size)))) | |
127 (let ((,size-var ,size) | |
128 (,var (alien-sap ,alien-var))) | |
129 (declare (ignorable ,size-var)) | |
130 ,@body)))) | |
131 (t | |
132 `(let ((,size-var ,size)) | |
133 (alien:with-bytes (,var ,size-var) | |
134 ,@body))))) | |
135 | |
136 ;;;# Allocation | |
137 ;;; | |
138 ;;; Functions and macros for allocating foreign memory on the stack and … | |
139 ;;; heap. The main CFFI package defines macros that wrap 'foreign-alloc… | |
140 ;;; 'foreign-free in 'unwind-protect for the common usage when the memor… | |
141 ;;; dynamic extent. | |
142 | |
143 (defun %foreign-alloc (size) | |
144 "Allocate 'size bytes on the heap and return a pointer." | |
145 (declare (type (unsigned-byte #-64bit 32 #+64bit 64) size)) | |
146 (alien-funcall (extern-alien "malloc" | |
147 (function system-area-pointer unsigned)) | |
148 size)) | |
149 | |
150 (defun foreign-free (ptr) | |
151 "Free a 'ptr allocated by 'foreign-alloc." | |
152 (declare (type system-area-pointer ptr)) | |
153 (alien-funcall (extern-alien "free" | |
154 (function (values) system-area-pointer)) | |
155 ptr)) | |
156 | |
157 ;;;# Shareable Vectors | |
158 | |
159 (defun make-shareable-byte-vector (size) | |
160 "Create a Lisp vector of 'size bytes that can passed to | |
161 'with-pointer-to-vector-data." | |
162 (make-array size :element-type '(unsigned-byte 8))) | |
163 | |
164 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body) | |
165 "Bind 'ptr-var to a foreign pointer to the data in 'vector." | |
166 (let ((vector-var (gensym (symbol-name '#:vector)))) | |
167 `(let ((,vector-var ,vector)) | |
168 (ext:with-pinned-object (,vector-var) | |
169 (let ((,ptr-var (sys:vector-sap ,vector-var))) | |
170 ,@body))))) | |
171 | |
172 ;;;# Dereferencing | |
173 | |
174 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler | |
175 ;;; macros that optimize the case where the type keyword is constant | |
176 ;;; at compile-time. | |
177 (defmacro define-mem-accessors (&body pairs) | |
178 `(progn | |
179 (defun %mem-ref (ptr type &optional (offset 0)) | |
180 (ecase type | |
181 ,@(loop for (keyword fn) in pairs | |
182 collect `(,keyword (,fn ptr offset))))) | |
183 (defun %mem-set (value ptr type &optional (offset 0)) | |
184 (ecase type | |
185 ,@(loop for (keyword fn) in pairs | |
186 collect `(,keyword (setf (,fn ptr offset) value))))) | |
187 (define-compiler-macro %mem-ref | |
188 (&whole form ptr type &optional (offset 0)) | |
189 (if (constantp type) | |
190 (ecase (eval type) | |
191 ,@(loop for (keyword fn) in pairs | |
192 collect `(,keyword `(,',fn ,ptr ,offset)))) | |
193 form)) | |
194 (define-compiler-macro %mem-set | |
195 (&whole form value ptr type &optional (offset 0)) | |
196 (if (constantp type) | |
197 (once-only (value) | |
198 (ecase (eval type) | |
199 ,@(loop for (keyword fn) in pairs | |
200 collect `(,keyword `(setf (,',fn ,ptr ,offset) | |
201 ,value))))) | |
202 form)))) | |
203 | |
204 (define-mem-accessors | |
205 (:char sys:signed-sap-ref-8) | |
206 (:unsigned-char sys:sap-ref-8) | |
207 (:short sys:signed-sap-ref-16) | |
208 (:unsigned-short sys:sap-ref-16) | |
209 (:int sys:signed-sap-ref-32) | |
210 (:unsigned-int sys:sap-ref-32) | |
211 (:long #-64bit sys:signed-sap-ref-32 #+64bit sys:signed-sap-ref-64) | |
212 (:unsigned-long #-64bit sys:sap-ref-32 #+64bit sys:sap-ref-64) | |
213 (:long-long sys:signed-sap-ref-64) | |
214 (:unsigned-long-long sys:sap-ref-64) | |
215 (:float sys:sap-ref-single) | |
216 (:double sys:sap-ref-double) | |
217 #+long-float (:long-double sys:sap-ref-long) | |
218 (:pointer sys:sap-ref-sap)) | |
219 | |
220 ;;;# Calling Foreign Functions | |
221 | |
222 (defun convert-foreign-type (type-keyword) | |
223 "Convert a CFFI type keyword to an ALIEN type." | |
224 (ecase type-keyword | |
225 (:char 'char) | |
226 (:unsigned-char 'unsigned-char) | |
227 (:short 'short) | |
228 (:unsigned-short 'unsigned-short) | |
229 (:int 'int) | |
230 (:unsigned-int 'unsigned-int) | |
231 (:long 'long) | |
232 (:unsigned-long 'unsigned-long) | |
233 (:long-long '(signed 64)) | |
234 (:unsigned-long-long '(unsigned 64)) | |
235 (:float 'single-float) | |
236 (:double 'double-float) | |
237 #+long-float | |
238 (:long-double 'long-float) | |
239 (:pointer 'system-area-pointer) | |
240 (:void 'void))) | |
241 | |
242 (defun %foreign-type-size (type-keyword) | |
243 "Return the size in bytes of a foreign type." | |
244 (values (truncate (alien-internals:alien-type-bits | |
245 (alien-internals:parse-alien-type | |
246 (convert-foreign-type type-keyword))) | |
247 8))) | |
248 | |
249 (defun %foreign-type-alignment (type-keyword) | |
250 "Return the alignment in bytes of a foreign type." | |
251 (values (truncate (alien-internals:alien-type-alignment | |
252 (alien-internals:parse-alien-type | |
253 (convert-foreign-type type-keyword))) | |
254 8))) | |
255 | |
256 (defun foreign-funcall-type-and-args (args) | |
257 "Return an 'alien function type for 'args." | |
258 (let ((return-type nil)) | |
259 (loop for (type arg) on args by #'cddr | |
260 if arg collect (convert-foreign-type type) into types | |
261 and collect arg into fargs | |
262 else do (setf return-type (convert-foreign-type type)) | |
263 finally (return (values types fargs return-type))))) | |
264 | |
265 (defmacro %%foreign-funcall (name types fargs rettype) | |
266 "Internal guts of '%foreign-funcall." | |
267 `(alien-funcall (extern-alien ,name (function ,rettype ,@types)) | |
268 ,@fargs)) | |
269 | |
270 (defmacro %foreign-funcall (name args &key library convention) | |
271 "Perform a foreign function call, document it more later." | |
272 (declare (ignore library convention)) | |
273 (multiple-value-bind (types fargs rettype) | |
274 (foreign-funcall-type-and-args args) | |
275 `(%%foreign-funcall ,name ,types ,fargs ,rettype))) | |
276 | |
277 (defmacro %foreign-funcall-pointer (ptr args &key convention) | |
278 "Funcall a pointer to a foreign function." | |
279 (declare (ignore convention)) | |
280 (multiple-value-bind (types fargs rettype) | |
281 (foreign-funcall-type-and-args args) | |
282 (with-unique-names (function) | |
283 `(with-alien ((,function (* (function ,rettype ,@types)) ,ptr)) | |
284 (alien-funcall ,function ,@fargs))))) | |
285 | |
286 ;;; Callbacks | |
287 | |
288 (defmacro %defcallback (name rettype arg-names arg-types body | |
289 &key convention) | |
290 (declare (ignore convention)) | |
291 `(alien:defcallback ,name | |
292 (,(convert-foreign-type rettype) | |
293 ,@(mapcar (lambda (sym type) | |
294 (list sym (convert-foreign-type type))) | |
295 arg-names arg-types)) | |
296 ,body)) | |
297 | |
298 (declaim (inline %callback)) | |
299 (defun %callback (name) | |
300 (alien:callback-sap name)) | |
301 | |
302 ;;;# Loading and Closing Foreign Libraries | |
303 | |
304 (defun %load-foreign-library (name path) | |
305 "Load the foreign library 'name." | |
306 (declare (ignore name)) | |
307 (ext:load-dynamic-object path)) | |
308 | |
309 (defun %close-foreign-library (name) | |
310 "Closes the foreign library 'name." | |
311 (ext:close-dynamic-object name)) | |
312 | |
313 (defun native-namestring (pathname) | |
314 (ext:unix-namestring pathname nil)) | |
315 | |
316 ;;;# Foreign Globals | |
317 | |
318 (defun %foreign-symbol-pointer (name library) | |
319 "Returns a pointer to a foreign symbol 'name." | |
320 (declare (ignore library)) | |
321 (let ((sap (sys:foreign-symbol-address name))) | |
322 (if (zerop (sys:sap-int sap)) nil sap))) |