cffi-mcl.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-mcl.lisp (13656B) | |
--- | |
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- | |
2 ;;; | |
3 ;;; cffi-mcl.lisp --- CFFI-SYS implementation for Digitool MCL. | |
4 ;;; | |
5 ;;; Copyright 2010 [email protected] | |
6 ;;; Copyright 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 ;;; this is a stop-gap emulation. (at least) three things are not right | |
30 ;;; - integer vector arguments are copied | |
31 ;;; - return values are not typed | |
32 ;;; - a shared library must be packaged as a framework and statically lo… | |
33 ;;; | |
34 ;;; on the topic of shared libraries, see | |
35 ;;; http://developer.apple.com/library/mac/#documentation/DeveloperTools… | |
36 ;;; which describes how to package a shared library as a framework. | |
37 ;;; once a framework exists, load it as, eg. | |
38 ;;; (ccl::add-framework-bundle "fftw.framework" :pathname "ccl:framework… | |
39 | |
40 ;;;# Administrivia | |
41 | |
42 (defpackage #:cffi-sys | |
43 (:use #:common-lisp #:ccl) | |
44 (:import-from #:alexandria #:once-only #:if-let) | |
45 (:export | |
46 #:canonicalize-symbol-name-case | |
47 #:foreign-pointer | |
48 #:pointerp ; ccl:pointerp | |
49 #:pointer-eq | |
50 #:%foreign-alloc | |
51 #:foreign-free | |
52 #:with-foreign-pointer | |
53 #:null-pointer | |
54 #:null-pointer-p | |
55 #:inc-pointer | |
56 #:make-pointer | |
57 #:pointer-address | |
58 #:%mem-ref | |
59 #:%mem-set | |
60 #:%foreign-funcall | |
61 #:%foreign-funcall-pointer | |
62 #:%foreign-type-alignment | |
63 #:%foreign-type-size | |
64 #:%load-foreign-library | |
65 #:%close-foreign-library | |
66 #:native-namestring | |
67 #:make-shareable-byte-vector | |
68 #:with-pointer-to-vector-data | |
69 #:%foreign-symbol-pointer | |
70 #:%defcallback | |
71 #:%callback)) | |
72 | |
73 (in-package #:cffi-sys) | |
74 | |
75 ;;;# Misfeatures | |
76 | |
77 (pushnew 'flat-namespace *features*) | |
78 | |
79 ;;;# Symbol Case | |
80 | |
81 (defun canonicalize-symbol-name-case (name) | |
82 (declare (string name)) | |
83 (string-upcase name)) | |
84 | |
85 ;;;# Allocation | |
86 ;;; | |
87 ;;; Functions and macros for allocating foreign memory on the stack | |
88 ;;; and on the heap. The main CFFI package defines macros that wrap | |
89 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common | |
90 ;;; usage when the memory has dynamic extent. | |
91 | |
92 (defun %foreign-alloc (size) | |
93 "Allocate SIZE bytes on the heap and return a pointer." | |
94 (#_newPtr size)) | |
95 | |
96 (defun foreign-free (ptr) | |
97 "Free a PTR allocated by FOREIGN-ALLOC." | |
98 ;; TODO: Should we make this a dead macptr? | |
99 (#_disposePtr ptr)) | |
100 | |
101 (defmacro with-foreign-pointer ((var size &optional size-var) &body body) | |
102 "Bind VAR to SIZE bytes of foreign memory during BODY. The | |
103 pointer in VAR is invalid beyond the dynamic extent of BODY, and | |
104 may be stack-allocated if supported by the implementation. If | |
105 SIZE-VAR is supplied, it will be bound to SIZE during BODY." | |
106 (unless size-var | |
107 (setf size-var (gensym "SIZE"))) | |
108 `(let ((,size-var ,size)) | |
109 (ccl:%stack-block ((,var ,size-var)) | |
110 ,@body))) | |
111 | |
112 ;;;# Misc. Pointer Operations | |
113 | |
114 (deftype foreign-pointer () | |
115 'ccl:macptr) | |
116 | |
117 (defun null-pointer () | |
118 "Construct and return a null pointer." | |
119 (ccl:%null-ptr)) | |
120 | |
121 (defun null-pointer-p (ptr) | |
122 "Return true if PTR is a null pointer." | |
123 (ccl:%null-ptr-p ptr)) | |
124 | |
125 (defun inc-pointer (ptr offset) | |
126 "Return a pointer OFFSET bytes past PTR." | |
127 (ccl:%inc-ptr ptr offset)) | |
128 | |
129 (defun pointer-eq (ptr1 ptr2) | |
130 "Return true if PTR1 and PTR2 point to the same address." | |
131 (ccl:%ptr-eql ptr1 ptr2)) | |
132 | |
133 (defun make-pointer (address) | |
134 "Return a pointer pointing to ADDRESS." | |
135 (ccl:%int-to-ptr address)) | |
136 | |
137 (defun pointer-address (ptr) | |
138 "Return the address pointed to by PTR." | |
139 (ccl:%ptr-to-int ptr)) | |
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 that can passed to | |
149 WITH-POINTER-TO-VECTOR-DATA." | |
150 (make-array size :element-type '(unsigned-byte 8))) | |
151 | |
152 ;;; from openmcl::macros.lisp | |
153 | |
154 (defmacro with-pointer-to-vector-data ((ptr ivector) &body body) | |
155 "Bind PTR-VAR to a foreign pointer to the data in VECTOR." | |
156 (let* ((v (gensym)) | |
157 (l (gensym))) | |
158 `(let* ((,v ,ivector) | |
159 (,l (length ,v))) | |
160 (unless (typep ,v 'ccl::ivector) (ccl::report-bad-arg ,v 'ccl::iv… | |
161 ;;;!!! this, unless it's possible to suppress gc | |
162 (let ((,ptr (#_newPtr ,l))) | |
163 (unwind-protect (progn (ccl::%copy-ivector-to-ptr ,v 0 ,ptr 0 ,… | |
164 (mutliple-value-prog1 | |
165 (locally ,@body) | |
166 (ccl::%copy-ptr-to-ivector ,ptr 0 ,v 0 … | |
167 (#_disposePtr ,ptr)))))) | |
168 | |
169 ;;;# Dereferencing | |
170 | |
171 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler | |
172 ;;; macros that optimize the case where the type keyword is constant | |
173 ;;; at compile-time. | |
174 (defmacro define-mem-accessors (&body pairs) | |
175 `(progn | |
176 (defun %mem-ref (ptr type &optional (offset 0)) | |
177 (ecase type | |
178 ,@(loop for (keyword fn) in pairs | |
179 collect `(,keyword (,fn ptr offset))))) | |
180 (defun %mem-set (value ptr type &optional (offset 0)) | |
181 (ecase type | |
182 ,@(loop for (keyword fn) in pairs | |
183 collect `(,keyword (setf (,fn ptr offset) value))))) | |
184 (define-compiler-macro %mem-ref | |
185 (&whole form ptr type &optional (offset 0)) | |
186 (if (constantp type) | |
187 (ecase (eval type) | |
188 ,@(loop for (keyword fn) in pairs | |
189 collect `(,keyword `(,',fn ,ptr ,offset)))) | |
190 form)) | |
191 (define-compiler-macro %mem-set | |
192 (&whole form value ptr type &optional (offset 0)) | |
193 (if (constantp type) | |
194 (once-only (value) | |
195 (ecase (eval type) | |
196 ,@(loop for (keyword fn) in pairs | |
197 collect `(,keyword `(setf (,',fn ,ptr ,offset) | |
198 ,value))))) | |
199 form)))) | |
200 | |
201 (define-mem-accessors | |
202 (:char %get-signed-byte) | |
203 (:unsigned-char %get-unsigned-byte) | |
204 (:short %get-signed-word) | |
205 (:unsigned-short %get-unsigned-word) | |
206 (:int %get-signed-long) | |
207 (:unsigned-int %get-unsigned-long) | |
208 (:long %get-signed-long) | |
209 (:unsigned-long %get-unsigned-long) | |
210 (:long-long ccl::%get-signed-long-long) | |
211 (:unsigned-long-long ccl::%get-unsigned-long-long) | |
212 (:float %get-single-float) | |
213 (:double %get-double-float) | |
214 (:pointer %get-ptr)) | |
215 | |
216 | |
217 (defun ccl::%get-unsigned-long-long (ptr offset) | |
218 (let ((value 0) (bit 0)) | |
219 (dotimes (i 8) | |
220 (setf (ldb (byte 8 (shiftf bit (+ bit 8))) value) | |
221 (ccl:%get-unsigned-byte ptr (+ offset i)))) | |
222 value)) | |
223 | |
224 (setf (fdefinition 'ccl::%get-signed-long-long) | |
225 (fdefinition 'ccl::%get-unsigned-long-long)) | |
226 | |
227 (defun (setf ccl::%get-unsigned-long-long) (value ptr offset) | |
228 (let ((bit 0)) | |
229 (dotimes (i 8) | |
230 (setf (ccl:%get-unsigned-byte ptr (+ offset i)) | |
231 (ldb (byte 8 (shiftf bit (+ bit 8))) value)))) | |
232 ptr) | |
233 | |
234 (setf (fdefinition '(setf ccl::%get-signed-long-long)) | |
235 (fdefinition '(setf ccl::%get-unsigned-long-long))) | |
236 | |
237 | |
238 ;;;# Calling Foreign Functions | |
239 | |
240 (defun convert-foreign-type (type-keyword) | |
241 "Convert a CFFI type keyword to a ppc-ff-call type." | |
242 (ecase type-keyword | |
243 (:char :signed-byte) | |
244 (:unsigned-char :unsigned-byte) | |
245 (:short :signed-short) | |
246 (:unsigned-short :unsigned-short) | |
247 (:int :signed-fullword) | |
248 (:unsigned-int :unsigned-fullword) | |
249 (:long :signed-fullword) | |
250 (:unsigned-long :unsigned-fullword) | |
251 (:long-long :signed-doubleword) | |
252 (:unsigned-long-long :unsigned-doubleword) | |
253 (:float :single-float) | |
254 (:double :double-float) | |
255 (:pointer :address) | |
256 (:void :void))) | |
257 | |
258 (defun ppc-ff-call-type=>mactype-name (type-keyword) | |
259 (ecase type-keyword | |
260 (:signed-byte :sint8) | |
261 (:unsigned-byte :uint8) | |
262 (:signed-short :sint16) | |
263 (:unsigned-short :uint16) | |
264 (:signed-halfword :sint16) | |
265 (:unsigned-halfword :uint16) | |
266 (:signed-fullword :sint32) | |
267 (:unsigned-fullword :uint32) | |
268 ;(:signed-doubleword :long-long) | |
269 ;(:unsigned-doubleword :unsigned-long-long) | |
270 (:single-float :single-float) | |
271 (:double-float :double-float) | |
272 (:address :pointer) | |
273 (:void :void))) | |
274 | |
275 | |
276 | |
277 (defun %foreign-type-size (type-keyword) | |
278 "Return the size in bytes of a foreign type." | |
279 (case type-keyword | |
280 ((:long-long :unsigned-long-long) 8) | |
281 (t (ccl::mactype-record-size | |
282 (ccl::find-mactype | |
283 (ppc-ff-call-type=>mactype-name (convert-foreign-type type-keyw… | |
284 | |
285 ;; There be dragons here. See the following thread for details: | |
286 ;; http://clozure.com/pipermail/openmcl-devel/2005-June/002777.html | |
287 (defun %foreign-type-alignment (type-keyword) | |
288 "Return the alignment in bytes of a foreign type." | |
289 (case type-keyword | |
290 ((:long-long :unsigned-long-long) 4) | |
291 (t (ccl::mactype-record-size | |
292 (ccl::find-mactype | |
293 (ppc-ff-call-type=>mactype-name (convert-foreign-type type-keyw… | |
294 | |
295 (defun convert-foreign-funcall-types (args) | |
296 "Convert foreign types for a call to FOREIGN-FUNCALL." | |
297 (loop for (type arg) on args by #'cddr | |
298 collect (convert-foreign-type type) | |
299 if arg collect arg)) | |
300 | |
301 (defun convert-external-name (name) | |
302 "no '_' is necessary here, the internal lookup operators handle it" | |
303 name) | |
304 | |
305 (defmacro %foreign-funcall (function-name args &key library convention) | |
306 "Perform a foreign function call, document it more later." | |
307 (declare (ignore library convention)) | |
308 `(ccl::ppc-ff-call | |
309 (ccl::macho-address ,(ccl::get-macho-entry-point (convert-external-n… | |
310 ,@(convert-foreign-funcall-types args))) | |
311 | |
312 (defmacro %foreign-funcall-pointer (ptr args &key convention) | |
313 (declare (ignore convention)) | |
314 `(ccl::ppc-ff-call ,ptr ,@(convert-foreign-funcall-types args))) | |
315 | |
316 ;;;# Callbacks | |
317 | |
318 ;;; The *CALLBACKS* hash table maps CFFI callback names to OpenMCL "macp… | |
319 ;;; entry points. It is safe to store the pointers directly because | |
320 ;;; OpenMCL will update the address of these pointers when a saved image | |
321 ;;; is loaded (see CCL::RESTORE-PASCAL-FUNCTIONS). | |
322 (defvar *callbacks* (make-hash-table)) | |
323 | |
324 ;;; Create a package to contain the symbols for callback functions. We | |
325 ;;; want to redefine callbacks with the same symbol so the internal data | |
326 ;;; structures are reused. | |
327 (defpackage #:cffi-callbacks | |
328 (:use)) | |
329 | |
330 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the inter… | |
331 ;;; callback for NAME. | |
332 (defun intern-callback (name) | |
333 (intern (format nil "~A::~A" | |
334 (if-let (package (symbol-package name)) | |
335 (package-name package) | |
336 "#") | |
337 (symbol-name name)) | |
338 '#:cffi-callbacks)) | |
339 | |
340 (defmacro %defcallback (name rettype arg-names arg-types body | |
341 &key convention) | |
342 (declare (ignore convention)) | |
343 (let ((cb-name (intern-callback name))) | |
344 `(progn | |
345 (ccl::ppc-defpascal ,cb-name | |
346 (;; ? ,@(when (eq convention :stdcall) '(:discard-stack-args)) | |
347 ,@(mapcan (lambda (sym type) | |
348 (list (ppc-ff-call-type=>mactype-name (convert-f… | |
349 arg-names arg-types) | |
350 ,(ppc-ff-call-type=>mactype-name (convert-foreign-type retty… | |
351 ,body) | |
352 (setf (gethash ',name *callbacks*) (symbol-value ',cb-name))))) | |
353 | |
354 (defun %callback (name) | |
355 (or (gethash name *callbacks*) | |
356 (error "Undefined callback: ~S" name))) | |
357 | |
358 ;;;# Loading Foreign Libraries | |
359 | |
360 (defun %load-foreign-library (name path) | |
361 "Load the foreign library NAME." | |
362 (declare (ignore path)) | |
363 (setf name (string name)) | |
364 ;; for mcl emulate this wrt frameworks | |
365 (unless (and (> (length name) 10) | |
366 (string-equal name ".framework" :start1 (- (length name) … | |
367 (setf name (concatenate 'string name ".framework"))) | |
368 ;; if the framework was not registered, add it | |
369 (unless (gethash name ccl::*framework-descriptors*) | |
370 (ccl::add-framework-bundle name :pathname "ccl:frameworks;" )) | |
371 (ccl::load-framework-bundle name)) | |
372 | |
373 (defun %close-foreign-library (name) | |
374 "Close the foreign library NAME." | |
375 ;; for mcl do nothing | |
376 (declare (ignore name)) | |
377 nil) | |
378 | |
379 (defun native-namestring (pathname) | |
380 (ccl::posix-namestring (ccl:full-pathname pathname))) | |
381 | |
382 | |
383 ;;;# Foreign Globals | |
384 | |
385 (deftrap-inline "_findsymbol" | |
386 ((map :pointer) | |
387 (name :pointer)) | |
388 :pointer | |
389 ()) | |
390 | |
391 | |
392 (defun %foreign-symbol-pointer (name library) | |
393 "Returns a pointer to a foreign symbol NAME." | |
394 (declare (ignore library)) | |
395 (ccl::macho-address | |
396 (ccl::get-macho-entry-point (convert-external-name name)))) |