cffi-lispworks.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-lispworks.lisp (15916B)
---
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; cffi-lispworks.lisp --- Lispworks CFFI-SYS implementation.
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 #:cl #:alexandria)
32 (:export
33 #:canonicalize-symbol-name-case
34 #:foreign-pointer
35 #:pointerp
36 #:pointer-eq
37 #:null-pointer
38 #:null-pointer-p
39 #:inc-pointer
40 #:make-pointer
41 #:pointer-address
42 #:%foreign-alloc
43 #:foreign-free
44 #:with-foreign-pointer
45 #:%foreign-funcall
46 #:%foreign-funcall-pointer
47 #:%foreign-type-alignment
48 #:%foreign-type-size
49 #:%load-foreign-library
50 #:%close-foreign-library
51 #:native-namestring
52 #:%mem-ref
53 #:%mem-set
54 #:make-shareable-byte-vector
55 #:with-pointer-to-vector-data
56 #:%foreign-symbol-pointer
57 #:defcfun-helper-forms
58 #:%defcallback
59 #:%callback))
60
61 (in-package #:cffi-sys)
62
63 ;;;# Misfeatures
64
65 #-lispworks-64bit (pushnew 'no-long-long *features*)
66
67 ;;;# Symbol Case
68
69 (defun canonicalize-symbol-name-case (name)
70 (declare (string name))
71 (string-upcase name))
72
73 ;;;# Basic Pointer Operations
74
75 (deftype foreign-pointer ()
76 'fli::pointer)
77
78 (defun pointerp (ptr)
79 "Return true if PTR is a foreign pointer."
80 (fli:pointerp ptr))
81
82 (defun pointer-eq (ptr1 ptr2)
83 "Return true if PTR1 and PTR2 point to the same address."
84 (fli:pointer-eq ptr1 ptr2))
85
86 ;; We use FLI:MAKE-POINTER here instead of FLI:*NULL-POINTER* since old
87 ;; versions of Lispworks don't seem to have it.
88 (defun null-pointer ()
89 "Return a null foreign pointer."
90 (fli:make-pointer :address 0 :type :void))
91
92 (defun null-pointer-p (ptr)
93 "Return true if PTR is a null pointer."
94 (check-type ptr fli::pointer)
95 (fli:null-pointer-p ptr))
96
97 ;; FLI:INCF-POINTER won't work on FLI pointers to :void so we
98 ;; increment "manually."
99 (defun inc-pointer (ptr offset)
100 "Return a pointer OFFSET bytes past PTR."
101 (fli:make-pointer :type :void :address (+ (fli:pointer-address ptr) offset)))
102
103 (defun make-pointer (address)
104 "Return a pointer pointing to ADDRESS."
105 (fli:make-pointer :type :void :address address))
106
107 (defun pointer-address (ptr)
108 "Return the address pointed to by PTR."
109 (fli:pointer-address ptr))
110
111 ;;;# Allocation
112
113 (defun %foreign-alloc (size)
114 "Allocate SIZE bytes of memory and return a pointer."
115 (fli:allocate-foreign-object :type :byte :nelems size))
116
117 (defun foreign-free (ptr)
118 "Free a pointer PTR allocated by FOREIGN-ALLOC."
119 (fli:free-foreign-object ptr))
120
121 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
122 "Bind VAR to SIZE bytes of foreign memory during BODY. Both the
123 pointer in VAR and the memory it points to have dynamic extent and may
124 be stack allocated if supported by the implementation."
125 (unless size-var
126 (setf size-var (gensym "SIZE")))
127 `(fli:with-dynamic-foreign-objects ()
128 (let* ((,size-var ,size)
129 (,var (fli:alloca :type :byte :nelems ,size-var)))
130 ,@body)))
131
132 ;;;# Shareable Vectors
133
134 (defun make-shareable-byte-vector (size)
135 "Create a shareable byte vector."
136 #+(or lispworks3 lispworks4 lispworks5.0)
137 (sys:in-static-area
138 (make-array size :element-type '(unsigned-byte 8)))
139 #-(or lispworks3 lispworks4 lispworks5.0)
140 (make-array size :element-type '(unsigned-byte 8) :allocation :static))
141
142 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
143 "Bind PTR-VAR to a pointer at the data in VECTOR."
144 `(fli:with-dynamic-lisp-array-pointer (,ptr-var ,vector)
145 ,@body))
146
147 ;;;# Dereferencing
148
149 (defun convert-foreign-type (cffi-type)
150 "Convert a CFFI type keyword to an FLI type."
151 (ecase cffi-type
152 (:char :byte)
153 (:unsigned-char '(:unsigned :byte))
154 (:short :short)
155 (:unsigned-short '(:unsigned :short))
156 (:int :int)
157 (:unsigned-int '(:unsigned :int))
158 (:long :long)
159 (:unsigned-long '(:unsigned :long))
160 ;; On 32-bit platforms, Lispworks 5.0+ supports long-long for
161 ;; DEFCFUN and FOREIGN-FUNCALL.
162 (:long-long '(:long :long))
163 (:unsigned-long-long '(:unsigned :long :long))
164 (:float :float)
165 (:double :double)
166 (:pointer :pointer)
167 (:void :void)))
168
169 ;;; Convert a CFFI type keyword to a symbol suitable for passing to
170 ;;; FLI:FOREIGN-TYPED-AREF.
171 #+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
172 (defun convert-foreign-typed-aref-type (cffi-type)
173 (ecase cffi-type
174 ((:char :short :int :long #+lispworks-64bit :long-long)
175 `(signed-byte ,(* 8 (%foreign-type-size cffi-type))))
176 ((:unsigned-char :unsigned-short :unsigned-int :unsigned-long
177 #+lispworks-64bit :unsigned-long-long)
178 `(unsigned-byte ,(* 8 (%foreign-type-size cffi-type))))
179 (:float 'single-float)
180 (:double 'double-float)))
181
182 (defun %mem-ref (ptr type &optional (offset 0))
183 "Dereference an object of type TYPE OFFSET bytes from PTR."
184 (unless (zerop offset)
185 (setf ptr (inc-pointer ptr offset)))
186 (fli:dereference ptr :type (convert-foreign-type type)))
187
188 ;; Lispworks 5.0 on 64-bit platforms doesn't have [u]int64 support in
189 ;; FOREIGN-TYPED-AREF. That was implemented in 5.1.
190 #+(and lispworks-64bit lispworks5.0)
191 (defun 64-bit-type-p (type)
192 (member type '(:long :unsigned-long :long-long :unsigned-long-long)))
193
194 ;;; In LispWorks versions where FLI:FOREIGN-TYPED-AREF is fbound, use
195 ;;; it instead of FLI:DEREFERENCE in the optimizer for %MEM-REF.
196 #+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
197 (define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0))
198 (if (constantp type)
199 (let ((type (eval type)))
200 (if (or #+(and lispworks-64bit lispworks5.0) (64-bit-type-p type)
201 (eql type :pointer))
202 (let ((fli-type (convert-foreign-type type))
203 (ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off))))
204 `(fli:dereference ,ptr-form :type ',fli-type))
205 (let ((lisp-type (convert-foreign-typed-aref-type type)))
206 `(locally
207 (declare (optimize (speed 3) (safety 0)))
208 (fli:foreign-typed-aref ',lisp-type ,ptr (the fixnum ,off))))))
209 form))
210
211 ;;; Open-code the call to FLI:DEREFERENCE when TYPE is constant at
212 ;;; macroexpansion time, when FLI:FOREIGN-TYPED-AREF is not available.
213 #-#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
214 (define-compiler-macro %mem-ref (&whole form ptr type &optional (off 0))
215 (if (constantp type)
216 (let ((ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off)))
217 (type (convert-foreign-type (eval type))))
218 `(fli:dereference ,ptr-form :type ',type))
219 form))
220
221 (defun %mem-set (value ptr type &optional (offset 0))
222 "Set the object of TYPE at OFFSET bytes from PTR."
223 (unless (zerop offset)
224 (setf ptr (inc-pointer ptr offset)))
225 (setf (fli:dereference ptr :type (convert-foreign-type type)) value))
226
227 ;;; In LispWorks versions where FLI:FOREIGN-TYPED-AREF is fbound, use
228 ;;; it instead of FLI:DEREFERENCE in the optimizer for %MEM-SET.
229 #+#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
230 (define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0))
231 (if (constantp type)
232 (once-only (val)
233 (let ((type (eval type)))
234 (if (or #+(and lispworks-64bit lispworks5.0) (64-bit-type-p type)
235 (eql type :pointer))
236 (let ((fli-type (convert-foreign-type type))
237 (ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off))))
238 `(setf (fli:dereference ,ptr-form :type ',fli-type) ,val))
239 (let ((lisp-type (convert-foreign-typed-aref-type type)))
240 `(locally
241 (declare (optimize (speed 3) (safety 0)))
242 (setf (fli:foreign-typed-aref ',lisp-type ,ptr
243 (the fixnum ,off))
244 ,val))))))
245 form))
246
247 ;;; Open-code the call to (SETF FLI:DEREFERENCE) when TYPE is constant
248 ;;; at macroexpansion time.
249 #-#.(cl:if (cl:find-symbol "FOREIGN-TYPED-AREF" "FLI") '(and) '(or))
250 (define-compiler-macro %mem-set (&whole form val ptr type &optional (off 0))
251 (if (constantp type)
252 (once-only (val)
253 (let ((ptr-form (if (eql off 0) ptr `(inc-pointer ,ptr ,off)))
254 (type (convert-foreign-type (eval type))))
255 `(setf (fli:dereference ,ptr-form :type ',type) ,val)))
256 form))
257
258 ;;;# Foreign Type Operations
259
260 (defun %foreign-type-size (type)
261 "Return the size in bytes of a foreign type."
262 (fli:size-of (convert-foreign-type type)))
263
264 (defun %foreign-type-alignment (type)
265 "Return the structure alignment in bytes of foreign type."
266 #+(and darwin harp::powerpc)
267 (when (eq type :double)
268 (return-from %foreign-type-alignment 8))
269 ;; Override not necessary for the remaining types...
270 (fli:align-of (convert-foreign-type type)))
271
272 ;;;# Calling Foreign Functions
273
274 (defvar *foreign-funcallable-cache* (make-hash-table :test 'equal)
275 "Caches foreign funcallables created by %FOREIGN-FUNCALL or
276 %FOREIGN-FUNCALL-POINTER. We only need to have one per each
277 signature.")
278
279 (defun foreign-funcall-type-and-args (args)
280 "Returns a list of types, list of args and return type."
281 (let ((return-type :void))
282 (loop for (type arg) on args by #'cddr
283 if arg collect (convert-foreign-type type) into types
284 and collect arg into fargs
285 else do (setf return-type (convert-foreign-type type))
286 finally (return (values types fargs return-type)))))
287
288 (defun create-foreign-funcallable (types rettype convention)
289 "Creates a foreign funcallable for the signature TYPES -> RETTYPE."
290 #+mac (declare (ignore convention))
291 (format t "~&Creating foreign funcallable for signature ~S -> ~S~%"
292 types rettype)
293 ;; yes, ugly, this most likely wants to be a top-level form...
294 (let ((internal-name (gensym)))
295 (funcall
296 (compile nil
297 `(lambda ()
298 (fli:define-foreign-funcallable ,internal-name
299 ,(loop for type in types
300 collect (list (gensym) type))
301 :result-type ,rettype
302 :language :ansi-c
303 ;; avoid warning about cdecl not being supported on mac
304 #-mac ,@(list :calling-convention convention)))))
305 internal-name))
306
307 (defun get-foreign-funcallable (types rettype convention)
308 "Returns a foreign funcallable for the signature TYPES -> RETTYPE -
309 either from the cache or newly created."
310 (let ((signature (cons rettype types)))
311 (or (gethash signature *foreign-funcallable-cache*)
312 ;; (SETF GETHASH) is supposed to be thread-safe
313 (setf (gethash signature *foreign-funcallable-cache*)
314 (create-foreign-funcallable types rettype convention)))))
315
316 (defmacro %%foreign-funcall (foreign-function args convention)
317 "Does the actual work for %FOREIGN-FUNCALL-POINTER and %FOREIGN-FUNCALL.
318 Checks if a foreign funcallable which fits ARGS already exists and creates
319 and caches it if necessary. Finally calls it."
320 (multiple-value-bind (types fargs rettype)
321 (foreign-funcall-type-and-args args)
322 `(funcall (load-time-value
323 (get-foreign-funcallable ',types ',rettype ',convention))
324 ,foreign-function ,@fargs)))
325
326 (defmacro %foreign-funcall (name args &key library convention)
327 "Calls a foreign function named NAME passing arguments ARGS."
328 `(%%foreign-funcall
329 (fli:make-pointer :symbol-name ,name
330 :module ',(if (eq library :default) nil library))
331 ,args ,convention))
332
333 (defmacro %foreign-funcall-pointer (ptr args &key convention)
334 "Calls a foreign function pointed at by PTR passing arguments ARGS."
335 `(%%foreign-funcall ,ptr ,args ,convention))
336
337 (defun defcfun-helper-forms (name lisp-name rettype args types options)
338 "Return 2 values for DEFCFUN. A prelude form and a caller form."
339 (let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name))))
340 (values
341 `(fli:define-foreign-function (,ff-name ,name :source)
342 ,(mapcar (lambda (ty) (list (gensym) (convert-foreign-type ty)))
343 types)
344 :result-type ,(convert-foreign-type rettype)
345 :language :ansi-c
346 :module ',(let ((lib (getf options :library)))
347 (if (eq lib :default) nil lib))
348 ;; avoid warning about cdecl not being supported on mac platforms
349 #-mac ,@(list :calling-convention (getf options :convention)))
350 `(,ff-name ,@args))))
351
352 ;;;# Callbacks
353
354 (defvar *callbacks* (make-hash-table))
355
356 ;;; Create a package to contain the symbols for callback functions. We
357 ;;; want to redefine callbacks with the same symbol so the internal data
358 ;;; structures are reused.
359 (defpackage #:cffi-callbacks
360 (:use))
361
362 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
363 ;;; callback for NAME.
364 (eval-when (:compile-toplevel :load-toplevel :execute)
365 (defun intern-callback (name)
366 (intern (format nil "~A::~A"
367 (if-let (package (symbol-package name))
368 (package-name package)
369 "#")
370 (symbol-name name))
371 '#:cffi-callbacks)))
372
373 (defmacro %defcallback (name rettype arg-names arg-types body
374 &key convention)
375 (let ((cb-name (intern-callback name)))
376 `(progn
377 (fli:define-foreign-callable
378 (,cb-name :encode :lisp
379 :result-type ,(convert-foreign-type rettype)
380 :calling-convention ,convention
381 :language :ansi-c
382 :no-check nil)
383 ,(mapcar (lambda (sym type)
384 (list sym (convert-foreign-type type)))
385 arg-names arg-types)
386 ,body)
387 (setf (gethash ',name *callbacks*) ',cb-name))))
388
389 (defun %callback (name)
390 (multiple-value-bind (symbol winp)
391 (gethash name *callbacks*)
392 (unless winp
393 (error "Undefined callback: ~S" name))
394 (fli:make-pointer :symbol-name symbol :module :callbacks)))
395
396 ;;;# Loading Foreign Libraries
397
398 (defun %load-foreign-library (name path)
399 "Load the foreign library NAME."
400 (fli:register-module (or name path) :connection-style :immediate
401 :real-name path))
402
403 (defun %close-foreign-library (name)
404 "Close the foreign library NAME."
405 (fli:disconnect-module name :remove t))
406
407 (defun native-namestring (pathname)
408 (namestring pathname))
409
410 ;;;# Foreign Globals
411
412 (defun %foreign-symbol-pointer (name library)
413 "Returns a pointer to a foreign symbol NAME."
414 (values
415 (ignore-errors
416 (fli:make-pointer :symbol-name name :type :void
417 :module (if (eq library :default) nil library)))))