cffi-openmcl.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
cffi-openmcl.lisp (10662B)
---
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; cffi-openmcl.lisp --- CFFI-SYS implementation for OpenMCL.
4 ;;;
5 ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
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 ;;;# Administrivia
29
30 (defpackage #:cffi-sys
31 (:use #:common-lisp #:ccl)
32 (:import-from #:alexandria #:once-only #:if-let)
33 (:export
34 #:canonicalize-symbol-name-case
35 #:foreign-pointer
36 #:pointerp ; ccl:pointerp
37 #:pointer-eq
38 #:%foreign-alloc
39 #:foreign-free
40 #:with-foreign-pointer
41 #:null-pointer
42 #:null-pointer-p
43 #:inc-pointer
44 #:make-pointer
45 #:pointer-address
46 #:%mem-ref
47 #:%mem-set
48 #:%foreign-funcall
49 #:%foreign-funcall-pointer
50 #:%foreign-type-alignment
51 #:%foreign-type-size
52 #:%load-foreign-library
53 #:%close-foreign-library
54 #:native-namestring
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 ;;;# Misfeatures
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 ;;; Functions and macros for allocating foreign memory on the stack
76 ;;; and on the heap. The main CFFI package defines macros that wrap
77 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
78 ;;; usage when the memory has dynamic extent.
79
80 (defun %foreign-alloc (size)
81 "Allocate SIZE bytes on the heap and return a pointer."
82 (ccl::malloc size))
83
84 (defun foreign-free (ptr)
85 "Free a PTR allocated by FOREIGN-ALLOC."
86 ;; TODO: Should we make this a dead macptr?
87 (ccl::free ptr))
88
89 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
90 "Bind VAR to SIZE bytes of foreign memory during BODY. The
91 pointer in VAR is invalid beyond the dynamic extent of BODY, and
92 may be stack-allocated if supported by the implementation. If
93 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
94 (unless size-var
95 (setf size-var (gensym "SIZE")))
96 `(let ((,size-var ,size))
97 (%stack-block ((,var ,size-var))
98 ,@body)))
99
100 ;;;# Misc. Pointer Operations
101
102 (deftype foreign-pointer ()
103 'ccl:macptr)
104
105 (defun null-pointer ()
106 "Construct and return a null pointer."
107 (ccl:%null-ptr))
108
109 (defun null-pointer-p (ptr)
110 "Return true if PTR is a null pointer."
111 (ccl:%null-ptr-p ptr))
112
113 (defun inc-pointer (ptr offset)
114 "Return a pointer OFFSET bytes past PTR."
115 (ccl:%inc-ptr ptr offset))
116
117 (defun pointer-eq (ptr1 ptr2)
118 "Return true if PTR1 and PTR2 point to the same address."
119 (ccl:%ptr-eql ptr1 ptr2))
120
121 (defun make-pointer (address)
122 "Return a pointer pointing to ADDRESS."
123 (ccl:%int-to-ptr address))
124
125 (defun pointer-address (ptr)
126 "Return the address pointed to by PTR."
127 (ccl:%ptr-to-int ptr))
128
129 ;;;# Shareable Vectors
130 ;;;
131 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
132 ;;; should be defined to perform a copy-in/copy-out if the Lisp
133 ;;; implementation can't do this.
134
135 (defun make-shareable-byte-vector (size)
136 "Create a Lisp vector of SIZE bytes that can passed to
137 WITH-POINTER-TO-VECTOR-DATA."
138 (make-array size :element-type '(unsigned-byte 8)))
139
140 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
141 "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
142 `(ccl:with-pointer-to-ivector (,ptr-var ,vector)
143 ,@body))
144
145 ;;;# Dereferencing
146
147 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
148 ;;; macros that optimize the case where the type keyword is constant
149 ;;; at compile-time.
150 (defmacro define-mem-accessors (&body pairs)
151 `(progn
152 (defun %mem-ref (ptr type &optional (offset 0))
153 (ecase type
154 ,@(loop for (keyword fn) in pairs
155 collect `(,keyword (,fn ptr offset)))))
156 (defun %mem-set (value ptr type &optional (offset 0))
157 (ecase type
158 ,@(loop for (keyword fn) in pairs
159 collect `(,keyword (setf (,fn ptr offset) value)))))
160 (define-compiler-macro %mem-ref
161 (&whole form ptr type &optional (offset 0))
162 (if (constantp type)
163 (ecase (eval type)
164 ,@(loop for (keyword fn) in pairs
165 collect `(,keyword `(,',fn ,ptr ,offset))))
166 form))
167 (define-compiler-macro %mem-set
168 (&whole form value ptr type &optional (offset 0))
169 (if (constantp type)
170 (once-only (value)
171 (ecase (eval type)
172 ,@(loop for (keyword fn) in pairs
173 collect `(,keyword `(setf (,',fn ,ptr ,offset)
174 ,value)))))
175 form))))
176
177 (define-mem-accessors
178 (:char %get-signed-byte)
179 (:unsigned-char %get-unsigned-byte)
180 (:short %get-signed-word)
181 (:unsigned-short %get-unsigned-word)
182 (:int %get-signed-long)
183 (:unsigned-int %get-unsigned-long)
184 #+(or 32-bit-target windows-target) (:long %get-signed-long)
185 #+(and (not windows-target) 64-bit-target) (:long ccl::%%get-signed-longlong)
186 #+(or 32-bit-target windows-target) (:unsigned-long %get-unsigned-long)
187 #+(and 64-bit-target (not windows-target)) (:unsigned-long ccl::%%get-unsigned-longlong)
188 (:long-long ccl::%get-signed-long-long)
189 (:unsigned-long-long ccl::%get-unsigned-long-long)
190 (:float %get-single-float)
191 (:double %get-double-float)
192 (:pointer %get-ptr))
193
194 ;;;# Calling Foreign Functions
195
196 (defun convert-foreign-type (type-keyword)
197 "Convert a CFFI type keyword to an OpenMCL type."
198 (ecase type-keyword
199 (:char :signed-byte)
200 (:unsigned-char :unsigned-byte)
201 (:short :signed-short)
202 (:unsigned-short :unsigned-short)
203 (:int :signed-int)
204 (:unsigned-int :unsigned-int)
205 (:long :signed-long)
206 (:unsigned-long :unsigned-long)
207 (:long-long :signed-doubleword)
208 (:unsigned-long-long :unsigned-doubleword)
209 (:float :single-float)
210 (:double :double-float)
211 (:pointer :address)
212 (:void :void)))
213
214 (defun %foreign-type-size (type-keyword)
215 "Return the size in bytes of a foreign type."
216 (/ (ccl::foreign-type-bits
217 (ccl::parse-foreign-type
218 (convert-foreign-type type-keyword)))
219 8))
220
221 ;; There be dragons here. See the following thread for details:
222 ;; http://clozure.com/pipermail/openmcl-devel/2005-June/002777.html
223 (defun %foreign-type-alignment (type-keyword)
224 "Return the alignment in bytes of a foreign type."
225 (/ (ccl::foreign-type-alignment
226 (ccl::parse-foreign-type
227 (convert-foreign-type type-keyword))) 8))
228
229 (defun convert-foreign-funcall-types (args)
230 "Convert foreign types for a call to FOREIGN-FUNCALL."
231 (loop for (type arg) on args by #'cddr
232 collect (convert-foreign-type type)
233 if arg collect arg))
234
235 (defun convert-external-name (name)
236 "Add an underscore to NAME if necessary for the ABI."
237 #+darwin (concatenate 'string "_" name)
238 #-darwin name)
239
240 (defmacro %foreign-funcall (function-name args &key library convention)
241 "Perform a foreign function call, document it more later."
242 (declare (ignore library convention))
243 `(external-call
244 ,(convert-external-name function-name)
245 ,@(convert-foreign-funcall-types args)))
246
247 (defmacro %foreign-funcall-pointer (ptr args &key convention)
248 (declare (ignore convention))
249 `(ff-call ,ptr ,@(convert-foreign-funcall-types args)))
250
251 ;;;# Callbacks
252
253 ;;; The *CALLBACKS* hash table maps CFFI callback names to OpenMCL "macptr"
254 ;;; entry points. It is safe to store the pointers directly because
255 ;;; OpenMCL will update the address of these pointers when a saved image
256 ;;; is loaded (see CCL::RESTORE-PASCAL-FUNCTIONS).
257 (defvar *callbacks* (make-hash-table))
258
259 ;;; Create a package to contain the symbols for callback functions. We
260 ;;; want to redefine callbacks with the same symbol so the internal data
261 ;;; structures are reused.
262 (defpackage #:cffi-callbacks
263 (:use))
264
265 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
266 ;;; callback for NAME.
267 (defun intern-callback (name)
268 (intern (format nil "~A::~A"
269 (if-let (package (symbol-package name))
270 (package-name package)
271 "#")
272 (symbol-name name))
273 '#:cffi-callbacks))
274
275 (defmacro %defcallback (name rettype arg-names arg-types body
276 &key convention)
277 (let ((cb-name (intern-callback name)))
278 `(progn
279 (defcallback ,cb-name
280 (,@(when (eq convention :stdcall)
281 '(:discard-stack-args))
282 ,@(mapcan (lambda (sym type)
283 (list (convert-foreign-type type) sym))
284 arg-names arg-types)
285 ,(convert-foreign-type rettype))
286 ,body)
287 (setf (gethash ',name *callbacks*) (symbol-value ',cb-name)))))
288
289 (defun %callback (name)
290 (or (gethash name *callbacks*)
291 (error "Undefined callback: ~S" name)))
292
293 ;;;# Loading Foreign Libraries
294
295 (defun %load-foreign-library (name path)
296 "Load the foreign library NAME."
297 (declare (ignore name))
298 (open-shared-library path))
299
300 (defun %close-foreign-library (name)
301 "Close the foreign library NAME."
302 ;; C-S-L sometimes ends in an endless loop
303 ;; with :COMPLETELY T
304 (close-shared-library name :completely nil))
305
306 (defun native-namestring (pathname)
307 (ccl::native-translated-namestring pathname))
308
309 ;;;# Foreign Globals
310
311 (defun %foreign-symbol-pointer (name library)
312 "Returns a pointer to a foreign symbol NAME."
313 (declare (ignore library))
314 (foreign-symbol-address (convert-external-name name)))