functions.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 | |
--- | |
functions.lisp (19030B) | |
--- | |
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- | |
2 ;;; | |
3 ;;; functions.lisp --- High-level interface to foreign functions. | |
4 ;;; | |
5 ;;; Copyright (C) 2005-2006, James Bielman <[email protected]> | |
6 ;;; Copyright (C) 2005-2007, Luis Oliveira <[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 (in-package #:cffi) | |
30 | |
31 ;;;# Calling Foreign Functions | |
32 ;;; | |
33 ;;; FOREIGN-FUNCALL is the main primitive for calling foreign | |
34 ;;; functions. It converts each argument based on the installed | |
35 ;;; translators for its type, then passes the resulting list to | |
36 ;;; CFFI-SYS:%FOREIGN-FUNCALL. | |
37 ;;; | |
38 ;;; For implementation-specific reasons, DEFCFUN doesn't use | |
39 ;;; FOREIGN-FUNCALL directly and might use something else (passed to | |
40 ;;; TRANSLATE-OBJECTS as the CALL-FORM argument) instead of | |
41 ;;; CFFI-SYS:%FOREIGN-FUNCALL to call the foreign-function. | |
42 | |
43 (defun translate-objects (syms args types rettype call-form &optional in… | |
44 "Helper function for FOREIGN-FUNCALL and DEFCFUN. If 'indirect is T, … | |
45 (if (null args) | |
46 (expand-from-foreign call-form (parse-type rettype)) | |
47 (funcall | |
48 (if indirect | |
49 #'expand-to-foreign-dyn-indirect | |
50 #'expand-to-foreign-dyn) | |
51 (car args) (car syms) | |
52 (list (translate-objects (cdr syms) (cdr args) | |
53 (cdr types) rettype call-form indirect)) | |
54 (parse-type (car types))))) | |
55 | |
56 (defun parse-args-and-types (args) | |
57 "Returns 4 values: types, canonicalized types, args and return type." | |
58 (let* ((len (length args)) | |
59 (return-type (if (oddp len) (lastcar args) :void))) | |
60 (loop repeat (floor len 2) | |
61 for (type arg) on args by #'cddr | |
62 collect type into types | |
63 collect (canonicalize-foreign-type type) into ctypes | |
64 collect arg into fargs | |
65 finally (return (values types ctypes fargs return-type))))) | |
66 | |
67 ;;; While the options passed directly to DEFCFUN/FOREIGN-FUNCALL have | |
68 ;;; precedence, we also grab its library's options, if possible. | |
69 (defun parse-function-options (options &key pointer) | |
70 (destructuring-bind (&key (library :default libraryp) | |
71 (cconv nil cconv-p) | |
72 (calling-convention cconv calling-convention… | |
73 (convention calling-convention)) | |
74 options | |
75 (when cconv-p | |
76 (warn-obsolete-argument :cconv :convention)) | |
77 (when calling-convention-p | |
78 (warn-obsolete-argument :calling-convention :convention)) | |
79 (list* :convention | |
80 (or convention | |
81 (when libraryp | |
82 (let ((lib-options (foreign-library-options | |
83 (get-foreign-library library)))) | |
84 (getf lib-options :convention))) | |
85 :cdecl) | |
86 ;; Don't pass the library option if we're dealing with | |
87 ;; FOREIGN-FUNCALL-POINTER. | |
88 (unless pointer | |
89 (list :library library))))) | |
90 | |
91 (defun structure-by-value-p (ctype) | |
92 "A structure or union is to be called or returned by value." | |
93 (let ((actual-type (ensure-parsed-base-type ctype))) | |
94 (or (and (typep actual-type 'foreign-struct-type) | |
95 (not (bare-struct-type-p actual-type))) | |
96 #+cffi::no-long-long (typep actual-type 'emulated-llong-type)))) | |
97 | |
98 (defun fn-call-by-value-p (argument-types return-type) | |
99 "One or more structures in the arguments or return from the function a… | |
100 (or (some 'structure-by-value-p argument-types) | |
101 (structure-by-value-p return-type))) | |
102 | |
103 (defvar *foreign-structures-by-value* | |
104 (lambda (&rest args) | |
105 (declare (ignore args)) | |
106 (restart-case | |
107 (error "Unable to call structures by value without cffi-libffi l… | |
108 (load-cffi-libffi () :report "Load cffi-libffi." | |
109 (asdf:operate 'asdf:load-op 'cffi-libffi)))) | |
110 "A function that produces a form suitable for calling structures by va… | |
111 | |
112 (defun foreign-funcall-form (thing options args pointerp) | |
113 (multiple-value-bind (types ctypes fargs rettype) | |
114 (parse-args-and-types args) | |
115 (let ((syms (make-gensym-list (length fargs))) | |
116 (fsbvp (fn-call-by-value-p ctypes rettype))) | |
117 (if fsbvp | |
118 ;; Structures by value call through *foreign-structures-by-val… | |
119 (funcall *foreign-structures-by-value* | |
120 thing | |
121 fargs | |
122 syms | |
123 types | |
124 rettype | |
125 ctypes | |
126 pointerp) | |
127 (translate-objects | |
128 syms fargs types rettype | |
129 `(,(if pointerp '%foreign-funcall-pointer '%foreign-funcall) | |
130 ;; No structures by value, direct call | |
131 ,thing | |
132 (,@(mapcan #'list ctypes syms) | |
133 ,(canonicalize-foreign-type rettype)) | |
134 ,@(parse-function-options options :pointer pointerp))))))) | |
135 | |
136 (defmacro foreign-funcall (name-and-options &rest args) | |
137 "Wrapper around %FOREIGN-FUNCALL that translates its arguments." | |
138 (let ((name (car (ensure-list name-and-options))) | |
139 (options (cdr (ensure-list name-and-options)))) | |
140 (foreign-funcall-form name options args nil))) | |
141 | |
142 (defmacro foreign-funcall-pointer (pointer options &rest args) | |
143 (foreign-funcall-form pointer options args t)) | |
144 | |
145 (defun promote-varargs-type (builtin-type) | |
146 "Default argument promotions." | |
147 (case builtin-type | |
148 (:float :double) | |
149 ((:char :short) :int) | |
150 ((:unsigned-char :unsigned-short) :unsigned-int) | |
151 (t builtin-type))) | |
152 | |
153 ;; If cffi-sys doesn't provide a %foreign-funcall-varargs macros we | |
154 ;; define one that use %foreign-funcall. | |
155 (eval-when (:compile-toplevel :load-toplevel :execute) | |
156 (unless (fboundp '%foreign-funcall-varargs) | |
157 (defmacro %foreign-funcall-varargs (name fixed-args varargs | |
158 &rest args &key convention libra… | |
159 (declare (ignore convention library)) | |
160 `(%foreign-funcall ,name ,(append fixed-args varargs) ,@args))) | |
161 (unless (fboundp '%foreign-funcall-pointer-varargs) | |
162 (defmacro %foreign-funcall-pointer-varargs (pointer fixed-args varar… | |
163 &rest args &key conventi… | |
164 (declare (ignore convention)) | |
165 `(%foreign-funcall-pointer ,pointer ,(append fixed-args varargs) ,… | |
166 | |
167 (defun foreign-funcall-varargs-form (thing options fixed-args varargs po… | |
168 (multiple-value-bind (fixed-types fixed-ctypes fixed-fargs) | |
169 (parse-args-and-types fixed-args) | |
170 (multiple-value-bind (varargs-types varargs-ctypes varargs-fargs ret… | |
171 (parse-args-and-types varargs) | |
172 (let ((fixed-syms (make-gensym-list (length fixed-fargs))) | |
173 (varargs-syms (make-gensym-list (length varargs-fargs)))) | |
174 (translate-objects | |
175 (append fixed-syms varargs-syms) | |
176 (append fixed-fargs varargs-fargs) | |
177 (append fixed-types varargs-types) | |
178 rettype | |
179 `(,(if pointerp '%foreign-funcall-pointer-varargs '%foreign-fun… | |
180 ,thing | |
181 ,(mapcan #'list fixed-ctypes fixed-syms) | |
182 ,(append | |
183 (mapcan #'list | |
184 (mapcar #'promote-varargs-type varargs-ctypes) | |
185 (loop for sym in varargs-syms | |
186 and type in varargs-ctypes | |
187 if (eq type :float) | |
188 collect `(float ,sym 1.0d0) | |
189 else collect sym)) | |
190 (list (canonicalize-foreign-type rettype))) | |
191 ,@options)))))) | |
192 | |
193 (defmacro foreign-funcall-varargs (name-and-options fixed-args | |
194 &rest varargs) | |
195 "Wrapper around %FOREIGN-FUNCALL that translates its arguments | |
196 and does type promotion for the variadic arguments." | |
197 (let ((name (car (ensure-list name-and-options))) | |
198 (options (cdr (ensure-list name-and-options)))) | |
199 (foreign-funcall-varargs-form name options fixed-args varargs nil))) | |
200 | |
201 (defmacro foreign-funcall-pointer-varargs (pointer options fixed-args | |
202 &rest varargs) | |
203 "Wrapper around %FOREIGN-FUNCALL-POINTER that translates its | |
204 arguments and does type promotion for the variadic arguments." | |
205 (foreign-funcall-varargs-form pointer options fixed-args varargs t)) | |
206 | |
207 ;;;# Defining Foreign Functions | |
208 ;;; | |
209 ;;; The DEFCFUN macro provides a declarative interface for defining | |
210 ;;; Lisp functions that call foreign functions. | |
211 | |
212 ;; If cffi-sys doesn't provide a defcfun-helper-forms, | |
213 ;; we define one that uses %foreign-funcall. | |
214 (eval-when (:compile-toplevel :load-toplevel :execute) | |
215 (unless (fboundp 'defcfun-helper-forms) | |
216 (defun defcfun-helper-forms (name lisp-name rettype args types optio… | |
217 (declare (ignore lisp-name)) | |
218 (values | |
219 '() | |
220 `(%foreign-funcall ,name ,(append (mapcan #'list types args) | |
221 (list rettype)) | |
222 ,@options))))) | |
223 | |
224 (defun %defcfun (lisp-name foreign-name return-type args options docstri… | |
225 (let* ((arg-names (mapcar #'first args)) | |
226 (arg-types (mapcar #'second args)) | |
227 (syms (make-gensym-list (length args))) | |
228 (call-by-value (fn-call-by-value-p arg-types return-type))) | |
229 (multiple-value-bind (prelude caller) | |
230 (if call-by-value | |
231 (values nil nil) | |
232 (defcfun-helper-forms | |
233 foreign-name lisp-name (canonicalize-foreign-type return-ty… | |
234 syms (mapcar #'canonicalize-foreign-type arg-types) options… | |
235 `(progn | |
236 ,prelude | |
237 (defun ,lisp-name ,arg-names | |
238 ,@(ensure-list docstring) | |
239 ,(if call-by-value | |
240 `(foreign-funcall | |
241 ,(cons foreign-name options) | |
242 ,@(append (mapcan #'list arg-types arg-names) | |
243 (list return-type))) | |
244 (translate-objects | |
245 syms arg-names arg-types return-type caller))))))) | |
246 | |
247 (defun %defcfun-varargs (lisp-name foreign-name return-type args options… | |
248 (with-unique-names (varargs) | |
249 (let ((arg-names (mapcar #'car args))) | |
250 `(defmacro ,lisp-name (,@arg-names &rest ,varargs) | |
251 ,@(ensure-list doc) | |
252 `(foreign-funcall-varargs | |
253 ,'(,foreign-name ,@options) | |
254 ,,`(list ,@(loop for (name type) in args | |
255 collect `',type collect name)) | |
256 ,@,varargs | |
257 ,',return-type))))) | |
258 | |
259 (defgeneric translate-underscore-separated-name (name) | |
260 (:method ((name string)) | |
261 (values (intern (canonicalize-symbol-name-case (substitute #\- #\_ n… | |
262 (:method ((name symbol)) | |
263 (substitute #\_ #\- (string-downcase (symbol-name name))))) | |
264 | |
265 (defun collapse-prefix (l special-words) | |
266 (unless (null l) | |
267 (multiple-value-bind (newpre skip) (check-prefix l special-words) | |
268 (cons newpre (collapse-prefix (nthcdr skip l) special-words))))) | |
269 | |
270 (defun check-prefix (l special-words) | |
271 (let ((pl (loop for i from (1- (length l)) downto 0 | |
272 collect (apply #'concatenate 'simple-string (butlast l… | |
273 (loop for w in special-words | |
274 for p = (position-if #'(lambda (s) (string= s w)) pl) | |
275 when p do (return-from check-prefix (values (nth p pl) (1+ p))… | |
276 (values (first l) 1))) | |
277 | |
278 (defgeneric translate-camelcase-name (name &key upper-initial-p special-… | |
279 (:method ((name string) &key upper-initial-p special-words) | |
280 (declare (ignore upper-initial-p)) | |
281 (values (intern (reduce #'(lambda (s1 s2) | |
282 (concatenate 'simple-string s1 "-" s2)) | |
283 (mapcar #'string-upcase | |
284 (collapse-prefix | |
285 (split-if #'(lambda (ch) | |
286 (or (upper-case-p ch) | |
287 (digit-char-p ch)… | |
288 name) | |
289 special-words)))))) | |
290 (:method ((name symbol) &key upper-initial-p special-words) | |
291 (apply #'concatenate | |
292 'string | |
293 (loop for str in (split-if #'(lambda (ch) (eq ch #\-)) | |
294 (string name) | |
295 :elide) | |
296 for first-word-p = t then nil | |
297 for e = (member str special-words | |
298 :test #'equal :key #'string-upcase) | |
299 collect (cond | |
300 ((and first-word-p (not upper-initial-p)) | |
301 (string-downcase str)) | |
302 (e (first e)) | |
303 (t (string-capitalize str))))))) | |
304 | |
305 (defgeneric translate-name-from-foreign (foreign-name package &optional … | |
306 (:method (foreign-name package &optional varp) | |
307 (declare (ignore package)) | |
308 (let ((sym (translate-underscore-separated-name foreign-name))) | |
309 (if varp | |
310 (values (intern (format nil "*~A*" | |
311 (canonicalize-symbol-name-case | |
312 (symbol-name sym))))) | |
313 sym)))) | |
314 | |
315 (defgeneric translate-name-to-foreign (lisp-name package &optional varp) | |
316 (:method (lisp-name package &optional varp) | |
317 (declare (ignore package)) | |
318 (let ((name (translate-underscore-separated-name lisp-name))) | |
319 (if varp | |
320 (string-trim '(#\*) name) | |
321 name)))) | |
322 | |
323 (defun lisp-name (spec varp) | |
324 (check-type spec string) | |
325 (translate-name-from-foreign spec *package* varp)) | |
326 | |
327 (defun foreign-name (spec varp) | |
328 (check-type spec (and symbol (not null))) | |
329 (translate-name-to-foreign spec *package* varp)) | |
330 | |
331 (defun foreign-options (opts varp) | |
332 (if varp | |
333 (funcall 'parse-defcvar-options opts) | |
334 (parse-function-options opts))) | |
335 | |
336 (defun lisp-name-p (name) | |
337 (and name (symbolp name) (not (keywordp name)))) | |
338 | |
339 (defun %parse-name-and-options (spec varp) | |
340 (cond | |
341 ((stringp spec) | |
342 (values (lisp-name spec varp) spec nil)) | |
343 ((symbolp spec) | |
344 (assert (not (null spec))) | |
345 (values spec (foreign-name spec varp) nil)) | |
346 ((and (consp spec) (stringp (first spec))) | |
347 (destructuring-bind (foreign-name &rest options) | |
348 spec | |
349 (cond | |
350 ((or (null options) | |
351 (keywordp (first options))) | |
352 (values (lisp-name foreign-name varp) foreign-name options)) | |
353 (t | |
354 (assert (lisp-name-p (first options))) | |
355 (values (first options) foreign-name (rest options)))))) | |
356 ((and (consp spec) (lisp-name-p (first spec))) | |
357 (destructuring-bind (lisp-name &rest options) | |
358 spec | |
359 (cond | |
360 ((or (null options) | |
361 (keywordp (first options))) | |
362 (values lisp-name (foreign-name spec varp) options)) | |
363 (t | |
364 (assert (stringp (first options))) | |
365 (values lisp-name (first options) (rest options)))))) | |
366 (t | |
367 (error "Not a valid foreign function specifier: ~A" spec)))) | |
368 | |
369 ;;; DEFCFUN's first argument has can have the following syntax: | |
370 ;;; | |
371 ;;; 1. string | |
372 ;;; 2. symbol | |
373 ;;; 3. \( string [symbol] options* ) | |
374 ;;; 4. \( symbol [string] options* ) | |
375 ;;; | |
376 ;;; The string argument denotes the foreign function's name. The | |
377 ;;; symbol argument is used to name the Lisp function. If one isn't | |
378 ;;; present, its name is derived from the other. See the user | |
379 ;;; documentation for an explanation of the derivation rules. | |
380 (defun parse-name-and-options (spec &optional varp) | |
381 (multiple-value-bind (lisp-name foreign-name options) | |
382 (%parse-name-and-options spec varp) | |
383 (values lisp-name foreign-name (foreign-options options varp)))) | |
384 | |
385 ;;; If we find a &REST token at the end of ARGS, it means this is a | |
386 ;;; varargs foreign function therefore we define a lisp macro using | |
387 ;;; %DEFCFUN-VARARGS. Otherwise, a lisp function is defined with | |
388 ;;; %DEFCFUN. | |
389 (defmacro defcfun (name-and-options return-type &body args) | |
390 "Defines a Lisp function that calls a foreign function." | |
391 (let ((docstring (when (stringp (car args)) (pop args)))) | |
392 (multiple-value-bind (lisp-name foreign-name options) | |
393 (parse-name-and-options name-and-options) | |
394 (if (eq (lastcar args) '&rest) | |
395 (%defcfun-varargs lisp-name foreign-name return-type | |
396 (butlast args) options docstring) | |
397 (%defcfun lisp-name foreign-name return-type args options | |
398 docstring))))) | |
399 | |
400 ;;;# Defining Callbacks | |
401 | |
402 (defun inverse-translate-objects (args types declarations rettype call) | |
403 `(let (,@(loop for arg in args and type in types | |
404 collect (list arg (expand-from-foreign | |
405 arg (parse-type type))))) | |
406 ,@declarations | |
407 ,(expand-to-foreign call (parse-type rettype)))) | |
408 | |
409 (defun parse-defcallback-options (options) | |
410 (destructuring-bind (&key (cconv :cdecl cconv-p) | |
411 (calling-convention cconv calling-convention… | |
412 (convention calling-convention)) | |
413 options | |
414 (when cconv-p | |
415 (warn-obsolete-argument :cconv :convention)) | |
416 (when calling-convention-p | |
417 (warn-obsolete-argument :calling-convention :convention)) | |
418 (list :convention convention))) | |
419 | |
420 (defmacro defcallback (name-and-options return-type args &body body) | |
421 (multiple-value-bind (body declarations) | |
422 (parse-body body :documentation t) | |
423 (let ((arg-names (mapcar #'car args)) | |
424 (arg-types (mapcar #'cadr args)) | |
425 (name (car (ensure-list name-and-options))) | |
426 (options (cdr (ensure-list name-and-options)))) | |
427 `(progn | |
428 (%defcallback ,name ,(canonicalize-foreign-type return-type) | |
429 ,arg-names ,(mapcar #'canonicalize-foreign-type arg-types) | |
430 ,(inverse-translate-objects | |
431 arg-names arg-types declarations return-type | |
432 `(block ,name ,@body)) | |
433 ,@(parse-defcallback-options options)) | |
434 ',name)))) | |
435 | |
436 (declaim (inline get-callback)) | |
437 (defun get-callback (symbol) | |
438 (%callback symbol)) | |
439 | |
440 (defmacro callback (name) | |
441 `(%callback ',name)) |