functions.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
---
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 <jamesjb@jamesjb.com>
6 ;;; Copyright (C) 2005-2007, Luis Oliveira <loliveira@common-lisp.net>
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 indirect)
44 "Helper function for FOREIGN-FUNCALL and DEFCFUN. If 'indirect is T, all arguments are represented by foreign pointers, even those that can be represented by CL objects."
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-p)
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 are called by value."
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 loaded.")
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 value.")
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-value*
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 library)
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 varargs
163 &rest args &key convention)
164 (declare (ignore convention))
165 `(%foreign-funcall-pointer ,pointer ,(append fixed-args varargs) ,@args))))
166
167 (defun foreign-funcall-varargs-form (thing options fixed-args varargs pointerp)
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 rettype)
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-funcall-varargs)
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 options)
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 docstring)
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-type)
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 doc)
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 #\- #\_ name)))))
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 i)))))
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-words)
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 varp)
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-p)
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))