funcall.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
---
funcall.lisp (6272B)
---
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; funcall.lisp -- FOREIGN-FUNCALL implementation using libffi
4 ;;;
5 ;;; Copyright (C) 2009, 2010, 2011 Liam M. Healy <lhealy@common-lisp.net>
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 (in-package #:cffi)
29
30 (define-condition libffi-error (cffi-error)
31 ((function-name
32 :initarg :function-name :reader function-name)))
33
34 (define-condition simple-libffi-error (simple-error libffi-error)
35 ())
36
37 (defun libffi-error (function-name format-control &rest format-arguments)
38 (error 'simple-libffi-error
39 :function-name function-name
40 :format-control format-control
41 :format-arguments format-arguments))
42
43 (defun make-libffi-cif (function-name return-type argument-types
44 &optional (abi :default-abi))
45 "Generate or retrieve the Call InterFace needed to call the function through libffi."
46 (let* ((argument-count (length argument-types))
47 (cif (foreign-alloc '(:struct ffi-cif)))
48 (ffi-argtypes (foreign-alloc :pointer :count argument-count)))
49 (loop
50 :for type :in argument-types
51 :for index :from 0
52 :do (setf (mem-aref ffi-argtypes :pointer index)
53 (make-libffi-type-descriptor (parse-type type))))
54 (unless (eql :ok (libffi/prep-cif cif abi argument-count
55 (make-libffi-type-descriptor (parse-type return-type))
56 ffi-argtypes))
57 (libffi-error function-name
58 "The 'ffi_prep_cif' libffi call failed for function ~S."
59 function-name))
60 cif))
61
62 (defun free-libffi-cif (ptr)
63 (foreign-free (foreign-slot-value ptr '(:struct ffi-cif) 'argument-types))
64 (foreign-free ptr))
65
66 (defun translate-objects-ret (symbols function-arguments types return-type call-form)
67 (translate-objects
68 symbols
69 function-arguments
70 types
71 return-type
72 (if (or (eql return-type :void)
73 (typep (parse-type return-type) 'translatable-foreign-type))
74 call-form
75 ;; built-in types won't be translated by
76 ;; expand-from-foreign, we have to do it here
77 `(mem-ref
78 ,call-form
79 ',(canonicalize-foreign-type return-type)))
80 t))
81
82 (defun foreign-funcall-form/fsbv-with-libffi (function function-arguments symbols types
83 return-type argument-types
84 &optional pointerp (abi :default-abi))
85 "A body of foreign-funcall calling the libffi function #'call (ffi_call)."
86 (let ((argument-count (length argument-types)))
87 `(with-foreign-objects ((argument-values :pointer ,argument-count)
88 ,@(unless (eql return-type :void)
89 `((result ',return-type))))
90 ,(translate-objects-ret
91 symbols function-arguments types return-type
92 ;; NOTE: We must delay the cif creation until the first call
93 ;; because it's FOREIGN-ALLOC'd, i.e. it gets corrupted by an
94 ;; image save/restore cycle. This way a lib will remain usable
95 ;; through a save/restore cycle if the save happens before any
96 ;; FFI calls will have been made, i.e. nothing is malloc'd yet.
97 `(progn
98 (loop
99 :for arg :in (list ,@symbols)
100 :for count :from 0
101 :do (setf (mem-aref argument-values :pointer count) arg))
102 (let* ((libffi-cif-cache (load-time-value (cons 'libffi-cif-cache nil)))
103 (libffi-cif (or (cdr libffi-cif-cache)
104 (setf (cdr libffi-cif-cache)
105 ;; FIXME ideally we should install a finalizer on the cons
106 ;; that calls FREE-LIBFFI-CIF on the cif (when the function
107 ;; gets redefined, and the cif becomes unreachable). but a
108 ;; finite world is full of compromises... - attila
109 (make-libffi-cif ,function ',return-type
110 ',argument-types ',abi)))))
111 (libffi/call libffi-cif
112 ,(if pointerp
113 function
114 `(foreign-symbol-pointer ,function))
115 ,(if (eql return-type :void) '(null-pointer) 'result)
116 argument-values)
117 ,(if (eql return-type :void)
118 '(values)
119 'result)))))))
120
121 (setf *foreign-structures-by-value* 'foreign-funcall-form/fsbv-with-libffi)
122
123 ;; DEPRECATED Its presence encourages the use of #+fsbv which may lead to the
124 ;; situation where a fasl was produced by an image that has fsbv feature
125 ;; and then ends up being loaded into an image later that has no fsbv support
126 ;; loaded. Use explicit ASDF dependencies instead and assume the presence
127 ;; of the feature accordingly.
128 (pushnew :fsbv *features*)
129
130 ;; DEPRECATED This is here only for backwards compatibility until its fate is
131 ;; decided. See the mailing list discussion for details.
132 (defctype :sizet size-t)