dataset management work. getting numerical data into lisp-matrix.
[CommonLispStat.git] / external / cffi.darcs / src / cffi-openmcl.lisp
blob081573fd69083b6d3570407a785de98d927714f6
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 ;;;
28 ;;;# Administrivia
30 (defpackage #:cffi-sys
31 (:use #:common-lisp #:ccl #:cffi-utils #:alexandria)
32 (:export
33 #:canonicalize-symbol-name-case
34 #:foreign-pointer
35 #:pointerp ; ccl:pointerp
36 #:pointer-eq
37 #:%foreign-alloc
38 #:foreign-free
39 #:with-foreign-pointer
40 #:null-pointer
41 #:null-pointer-p
42 #:inc-pointer
43 #:make-pointer
44 #:pointer-address
45 #:%mem-ref
46 #:%mem-set
47 #:%foreign-funcall
48 #:%foreign-funcall-pointer
49 #:%foreign-type-alignment
50 #:%foreign-type-size
51 #:%load-foreign-library
52 #:%close-foreign-library
53 #:native-namestring
54 #:make-shareable-byte-vector
55 #:with-pointer-to-vector-data
56 #:%foreign-symbol-pointer
57 #:%defcallback
58 #:%callback))
60 (in-package #:cffi-sys)
62 ;;;# Mis-features
64 (eval-when (:compile-toplevel :load-toplevel :execute)
65 (mapc (lambda (feature) (pushnew feature *features*))
66 '(cffi-features:flat-namespace)))
68 ;;;# Symbol Case
70 (defun canonicalize-symbol-name-case (name)
71 (declare (string name))
72 (string-upcase name))
74 ;;;# Allocation
75 ;;;
76 ;;; Functions and macros for allocating foreign memory on the stack
77 ;;; and on the heap. The main CFFI package defines macros that wrap
78 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
79 ;;; usage when the memory has dynamic extent.
81 (defun %foreign-alloc (size)
82 "Allocate SIZE bytes on the heap and return a pointer."
83 (ccl::malloc size))
85 (defun foreign-free (ptr)
86 "Free a PTR allocated by FOREIGN-ALLOC."
87 ;; TODO: Should we make this a dead macptr?
88 (ccl::free ptr))
90 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
91 "Bind VAR to SIZE bytes of foreign memory during BODY. The
92 pointer in VAR is invalid beyond the dynamic extent of BODY, and
93 may be stack-allocated if supported by the implementation. If
94 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
95 (unless size-var
96 (setf size-var (gensym "SIZE")))
97 `(let ((,size-var ,size))
98 (%stack-block ((,var ,size-var))
99 ,@body)))
101 ;;;# Misc. Pointer Operations
103 (deftype foreign-pointer ()
104 'ccl:macptr)
106 (defun null-pointer ()
107 "Construct and return a null pointer."
108 (ccl:%null-ptr))
110 (defun null-pointer-p (ptr)
111 "Return true if PTR is a null pointer."
112 (ccl:%null-ptr-p ptr))
114 (defun inc-pointer (ptr offset)
115 "Return a pointer OFFSET bytes past PTR."
116 (ccl:%inc-ptr ptr offset))
118 (defun pointer-eq (ptr1 ptr2)
119 "Return true if PTR1 and PTR2 point to the same address."
120 (ccl:%ptr-eql ptr1 ptr2))
122 (defun make-pointer (address)
123 "Return a pointer pointing to ADDRESS."
124 (ccl:%int-to-ptr address))
126 (defun pointer-address (ptr)
127 "Return the address pointed to by PTR."
128 (ccl:%ptr-to-int ptr))
130 ;;;# Shareable Vectors
132 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
133 ;;; should be defined to perform a copy-in/copy-out if the Lisp
134 ;;; implementation can't do this.
136 (defun make-shareable-byte-vector (size)
137 "Create a Lisp vector of SIZE bytes that can passed to
138 WITH-POINTER-TO-VECTOR-DATA."
139 (make-array size :element-type '(unsigned-byte 8)))
141 (defmacro with-pointer-to-vector-data ((ptr-var vector) &body body)
142 "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
143 `(ccl:with-pointer-to-ivector (,ptr-var ,vector)
144 ,@body))
146 ;;;# Dereferencing
148 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
149 ;;; macros that optimize the case where the type keyword is constant
150 ;;; at compile-time.
151 (defmacro define-mem-accessors (&body pairs)
152 `(progn
153 (defun %mem-ref (ptr type &optional (offset 0))
154 (ecase type
155 ,@(loop for (keyword fn) in pairs
156 collect `(,keyword (,fn ptr offset)))))
157 (defun %mem-set (value ptr type &optional (offset 0))
158 (ecase type
159 ,@(loop for (keyword fn) in pairs
160 collect `(,keyword (setf (,fn ptr offset) value)))))
161 (define-compiler-macro %mem-ref
162 (&whole form ptr type &optional (offset 0))
163 (if (constantp type)
164 (ecase (eval type)
165 ,@(loop for (keyword fn) in pairs
166 collect `(,keyword `(,',fn ,ptr ,offset))))
167 form))
168 (define-compiler-macro %mem-set
169 (&whole form value ptr type &optional (offset 0))
170 (if (constantp type)
171 (once-only (value)
172 (ecase (eval type)
173 ,@(loop for (keyword fn) in pairs
174 collect `(,keyword `(setf (,',fn ,ptr ,offset)
175 ,value)))))
176 form))))
178 (define-mem-accessors
179 (:char %get-signed-byte)
180 (:unsigned-char %get-unsigned-byte)
181 (:short %get-signed-word)
182 (:unsigned-short %get-unsigned-word)
183 (:int %get-signed-long)
184 (:unsigned-int %get-unsigned-long)
185 #+32-bit-target (:long %get-signed-long)
186 #+64-bit-target (:long ccl::%%get-signed-longlong)
187 #+32-bit-target (:unsigned-long %get-unsigned-long)
188 #+64-bit-target (:unsigned-long ccl::%%get-unsigned-longlong)
189 (:long-long ccl::%get-signed-long-long)
190 (:unsigned-long-long ccl::%get-unsigned-long-long)
191 (:float %get-single-float)
192 (:double %get-double-float)
193 (:pointer %get-ptr))
195 ;;;# Calling Foreign Functions
197 (defun convert-foreign-type (type-keyword)
198 "Convert a CFFI type keyword to an OpenMCL type."
199 (ecase type-keyword
200 (:char :signed-byte)
201 (:unsigned-char :unsigned-byte)
202 (:short :signed-short)
203 (:unsigned-short :unsigned-short)
204 (:int :signed-int)
205 (:unsigned-int :unsigned-int)
206 (:long :signed-long)
207 (:unsigned-long :unsigned-long)
208 (:long-long :signed-doubleword)
209 (:unsigned-long-long :unsigned-doubleword)
210 (:float :single-float)
211 (:double :double-float)
212 (:pointer :address)
213 (:void :void)))
215 (defun %foreign-type-size (type-keyword)
216 "Return the size in bytes of a foreign type."
217 (/ (ccl::foreign-type-bits
218 (ccl::parse-foreign-type
219 (convert-foreign-type type-keyword))) 8))
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))
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))
235 (defun convert-external-name (name)
236 "Add an underscore to NAME if necessary for the ABI."
237 #+darwinppc-target (concatenate 'string "_" name)
238 #-darwinppc-target name)
240 (defmacro %foreign-funcall (function-name args &key library calling-convention)
241 "Perform a foreign function call, document it more later."
242 (declare (ignore library calling-convention))
243 `(external-call
244 ,(convert-external-name function-name)
245 ,@(convert-foreign-funcall-types args)))
247 (defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
248 (declare (ignore calling-convention))
249 `(ff-call ,ptr ,@(convert-foreign-funcall-types args)))
251 ;;;# Callbacks
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))
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))
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" (package-name (symbol-package name))
269 (symbol-name name))
270 '#:cffi-callbacks))
272 (defmacro %defcallback (name rettype arg-names arg-types body
273 &key calling-convention)
274 (declare (ignore calling-convention))
275 (let ((cb-name (intern-callback name)))
276 `(progn
277 (defcallback ,cb-name
278 (,@(mapcan (lambda (sym type)
279 (list (convert-foreign-type type) sym))
280 arg-names arg-types)
281 ,(convert-foreign-type rettype))
282 ,body)
283 (setf (gethash ',name *callbacks*) (symbol-value ',cb-name)))))
285 (defun %callback (name)
286 (or (gethash name *callbacks*)
287 (error "Undefined callback: ~S" name)))
289 ;;;# Loading Foreign Libraries
291 (defun %load-foreign-library (name path)
292 "Load the foreign library NAME."
293 (declare (ignore name))
294 (open-shared-library path))
296 (defun %close-foreign-library (name)
297 "Close the foreign library NAME."
298 (close-shared-library name)) ; :completely t ?
300 (defun native-namestring (pathname)
301 (ccl::native-translated-namestring pathname))
303 ;;;# Foreign Globals
305 (defun %foreign-symbol-pointer (name library)
306 "Returns a pointer to a foreign symbol NAME."
307 (declare (ignore library))
308 (foreign-symbol-address (convert-external-name name)))