cffi-mcl.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-mcl.lisp (13656B)
---
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; cffi-mcl.lisp --- CFFI-SYS implementation for Digitool MCL.
4 ;;;
5 ;;; Copyright 2010 james.anderson@setf.de
6 ;;; Copyright 2005-2006, James Bielman <jamesjb@jamesjb.com>
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 ;;; this is a stop-gap emulation. (at least) three things are not right
30 ;;; - integer vector arguments are copied
31 ;;; - return values are not typed
32 ;;; - a shared library must be packaged as a framework and statically loaded
33 ;;;
34 ;;; on the topic of shared libraries, see
35 ;;; http://developer.apple.com/library/mac/#documentation/DeveloperTools/Conceptual/MachOTopics/1-Articles/loading_code.html
36 ;;; which describes how to package a shared library as a framework.
37 ;;; once a framework exists, load it as, eg.
38 ;;; (ccl::add-framework-bundle "fftw.framework" :pathname "ccl:frameworks;" )
39
40 ;;;# Administrivia
41
42 (defpackage #:cffi-sys
43 (:use #:common-lisp #:ccl)
44 (:import-from #:alexandria #:once-only #:if-let)
45 (:export
46 #:canonicalize-symbol-name-case
47 #:foreign-pointer
48 #:pointerp ; ccl:pointerp
49 #:pointer-eq
50 #:%foreign-alloc
51 #:foreign-free
52 #:with-foreign-pointer
53 #:null-pointer
54 #:null-pointer-p
55 #:inc-pointer
56 #:make-pointer
57 #:pointer-address
58 #:%mem-ref
59 #:%mem-set
60 #:%foreign-funcall
61 #:%foreign-funcall-pointer
62 #:%foreign-type-alignment
63 #:%foreign-type-size
64 #:%load-foreign-library
65 #:%close-foreign-library
66 #:native-namestring
67 #:make-shareable-byte-vector
68 #:with-pointer-to-vector-data
69 #:%foreign-symbol-pointer
70 #:%defcallback
71 #:%callback))
72
73 (in-package #:cffi-sys)
74
75 ;;;# Misfeatures
76
77 (pushnew 'flat-namespace *features*)
78
79 ;;;# Symbol Case
80
81 (defun canonicalize-symbol-name-case (name)
82 (declare (string name))
83 (string-upcase name))
84
85 ;;;# Allocation
86 ;;;
87 ;;; Functions and macros for allocating foreign memory on the stack
88 ;;; and on the heap. The main CFFI package defines macros that wrap
89 ;;; FOREIGN-ALLOC and FOREIGN-FREE in UNWIND-PROTECT for the common
90 ;;; usage when the memory has dynamic extent.
91
92 (defun %foreign-alloc (size)
93 "Allocate SIZE bytes on the heap and return a pointer."
94 (#_newPtr size))
95
96 (defun foreign-free (ptr)
97 "Free a PTR allocated by FOREIGN-ALLOC."
98 ;; TODO: Should we make this a dead macptr?
99 (#_disposePtr ptr))
100
101 (defmacro with-foreign-pointer ((var size &optional size-var) &body body)
102 "Bind VAR to SIZE bytes of foreign memory during BODY. The
103 pointer in VAR is invalid beyond the dynamic extent of BODY, and
104 may be stack-allocated if supported by the implementation. If
105 SIZE-VAR is supplied, it will be bound to SIZE during BODY."
106 (unless size-var
107 (setf size-var (gensym "SIZE")))
108 `(let ((,size-var ,size))
109 (ccl:%stack-block ((,var ,size-var))
110 ,@body)))
111
112 ;;;# Misc. Pointer Operations
113
114 (deftype foreign-pointer ()
115 'ccl:macptr)
116
117 (defun null-pointer ()
118 "Construct and return a null pointer."
119 (ccl:%null-ptr))
120
121 (defun null-pointer-p (ptr)
122 "Return true if PTR is a null pointer."
123 (ccl:%null-ptr-p ptr))
124
125 (defun inc-pointer (ptr offset)
126 "Return a pointer OFFSET bytes past PTR."
127 (ccl:%inc-ptr ptr offset))
128
129 (defun pointer-eq (ptr1 ptr2)
130 "Return true if PTR1 and PTR2 point to the same address."
131 (ccl:%ptr-eql ptr1 ptr2))
132
133 (defun make-pointer (address)
134 "Return a pointer pointing to ADDRESS."
135 (ccl:%int-to-ptr address))
136
137 (defun pointer-address (ptr)
138 "Return the address pointed to by PTR."
139 (ccl:%ptr-to-int ptr))
140
141 ;;;# Shareable Vectors
142 ;;;
143 ;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
144 ;;; should be defined to perform a copy-in/copy-out if the Lisp
145 ;;; implementation can't do this.
146
147 (defun make-shareable-byte-vector (size)
148 "Create a Lisp vector of SIZE bytes that can passed to
149 WITH-POINTER-TO-VECTOR-DATA."
150 (make-array size :element-type '(unsigned-byte 8)))
151
152 ;;; from openmcl::macros.lisp
153
154 (defmacro with-pointer-to-vector-data ((ptr ivector) &body body)
155 "Bind PTR-VAR to a foreign pointer to the data in VECTOR."
156 (let* ((v (gensym))
157 (l (gensym)))
158 `(let* ((,v ,ivector)
159 (,l (length ,v)))
160 (unless (typep ,v 'ccl::ivector) (ccl::report-bad-arg ,v 'ccl::ivector))
161 ;;;!!! this, unless it's possible to suppress gc
162 (let ((,ptr (#_newPtr ,l)))
163 (unwind-protect (progn (ccl::%copy-ivector-to-ptr ,v 0 ,ptr 0 ,l)
164 (mutliple-value-prog1
165 (locally ,@body)
166 (ccl::%copy-ptr-to-ivector ,ptr 0 ,v 0 ,l)))
167 (#_disposePtr ,ptr))))))
168
169 ;;;# Dereferencing
170
171 ;;; Define the %MEM-REF and %MEM-SET functions, as well as compiler
172 ;;; macros that optimize the case where the type keyword is constant
173 ;;; at compile-time.
174 (defmacro define-mem-accessors (&body pairs)
175 `(progn
176 (defun %mem-ref (ptr type &optional (offset 0))
177 (ecase type
178 ,@(loop for (keyword fn) in pairs
179 collect `(,keyword (,fn ptr offset)))))
180 (defun %mem-set (value ptr type &optional (offset 0))
181 (ecase type
182 ,@(loop for (keyword fn) in pairs
183 collect `(,keyword (setf (,fn ptr offset) value)))))
184 (define-compiler-macro %mem-ref
185 (&whole form ptr type &optional (offset 0))
186 (if (constantp type)
187 (ecase (eval type)
188 ,@(loop for (keyword fn) in pairs
189 collect `(,keyword `(,',fn ,ptr ,offset))))
190 form))
191 (define-compiler-macro %mem-set
192 (&whole form value ptr type &optional (offset 0))
193 (if (constantp type)
194 (once-only (value)
195 (ecase (eval type)
196 ,@(loop for (keyword fn) in pairs
197 collect `(,keyword `(setf (,',fn ,ptr ,offset)
198 ,value)))))
199 form))))
200
201 (define-mem-accessors
202 (:char %get-signed-byte)
203 (:unsigned-char %get-unsigned-byte)
204 (:short %get-signed-word)
205 (:unsigned-short %get-unsigned-word)
206 (:int %get-signed-long)
207 (:unsigned-int %get-unsigned-long)
208 (:long %get-signed-long)
209 (:unsigned-long %get-unsigned-long)
210 (:long-long ccl::%get-signed-long-long)
211 (:unsigned-long-long ccl::%get-unsigned-long-long)
212 (:float %get-single-float)
213 (:double %get-double-float)
214 (:pointer %get-ptr))
215
216
217 (defun ccl::%get-unsigned-long-long (ptr offset)
218 (let ((value 0) (bit 0))
219 (dotimes (i 8)
220 (setf (ldb (byte 8 (shiftf bit (+ bit 8))) value)
221 (ccl:%get-unsigned-byte ptr (+ offset i))))
222 value))
223
224 (setf (fdefinition 'ccl::%get-signed-long-long)
225 (fdefinition 'ccl::%get-unsigned-long-long))
226
227 (defun (setf ccl::%get-unsigned-long-long) (value ptr offset)
228 (let ((bit 0))
229 (dotimes (i 8)
230 (setf (ccl:%get-unsigned-byte ptr (+ offset i))
231 (ldb (byte 8 (shiftf bit (+ bit 8))) value))))
232 ptr)
233
234 (setf (fdefinition '(setf ccl::%get-signed-long-long))
235 (fdefinition '(setf ccl::%get-unsigned-long-long)))
236
237
238 ;;;# Calling Foreign Functions
239
240 (defun convert-foreign-type (type-keyword)
241 "Convert a CFFI type keyword to a ppc-ff-call type."
242 (ecase type-keyword
243 (:char :signed-byte)
244 (:unsigned-char :unsigned-byte)
245 (:short :signed-short)
246 (:unsigned-short :unsigned-short)
247 (:int :signed-fullword)
248 (:unsigned-int :unsigned-fullword)
249 (:long :signed-fullword)
250 (:unsigned-long :unsigned-fullword)
251 (:long-long :signed-doubleword)
252 (:unsigned-long-long :unsigned-doubleword)
253 (:float :single-float)
254 (:double :double-float)
255 (:pointer :address)
256 (:void :void)))
257
258 (defun ppc-ff-call-type=>mactype-name (type-keyword)
259 (ecase type-keyword
260 (:signed-byte :sint8)
261 (:unsigned-byte :uint8)
262 (:signed-short :sint16)
263 (:unsigned-short :uint16)
264 (:signed-halfword :sint16)
265 (:unsigned-halfword :uint16)
266 (:signed-fullword :sint32)
267 (:unsigned-fullword :uint32)
268 ;(:signed-doubleword :long-long)
269 ;(:unsigned-doubleword :unsigned-long-long)
270 (:single-float :single-float)
271 (:double-float :double-float)
272 (:address :pointer)
273 (:void :void)))
274
275
276
277 (defun %foreign-type-size (type-keyword)
278 "Return the size in bytes of a foreign type."
279 (case type-keyword
280 ((:long-long :unsigned-long-long) 8)
281 (t (ccl::mactype-record-size
282 (ccl::find-mactype
283 (ppc-ff-call-type=>mactype-name (convert-foreign-type type-keyword)))))))
284
285 ;; There be dragons here. See the following thread for details:
286 ;; http://clozure.com/pipermail/openmcl-devel/2005-June/002777.html
287 (defun %foreign-type-alignment (type-keyword)
288 "Return the alignment in bytes of a foreign type."
289 (case type-keyword
290 ((:long-long :unsigned-long-long) 4)
291 (t (ccl::mactype-record-size
292 (ccl::find-mactype
293 (ppc-ff-call-type=>mactype-name (convert-foreign-type type-keyword)))))))
294
295 (defun convert-foreign-funcall-types (args)
296 "Convert foreign types for a call to FOREIGN-FUNCALL."
297 (loop for (type arg) on args by #'cddr
298 collect (convert-foreign-type type)
299 if arg collect arg))
300
301 (defun convert-external-name (name)
302 "no '_' is necessary here, the internal lookup operators handle it"
303 name)
304
305 (defmacro %foreign-funcall (function-name args &key library convention)
306 "Perform a foreign function call, document it more later."
307 (declare (ignore library convention))
308 `(ccl::ppc-ff-call
309 (ccl::macho-address ,(ccl::get-macho-entry-point (convert-external-name function-name)))
310 ,@(convert-foreign-funcall-types args)))
311
312 (defmacro %foreign-funcall-pointer (ptr args &key convention)
313 (declare (ignore convention))
314 `(ccl::ppc-ff-call ,ptr ,@(convert-foreign-funcall-types args)))
315
316 ;;;# Callbacks
317
318 ;;; The *CALLBACKS* hash table maps CFFI callback names to OpenMCL "macptr"
319 ;;; entry points. It is safe to store the pointers directly because
320 ;;; OpenMCL will update the address of these pointers when a saved image
321 ;;; is loaded (see CCL::RESTORE-PASCAL-FUNCTIONS).
322 (defvar *callbacks* (make-hash-table))
323
324 ;;; Create a package to contain the symbols for callback functions. We
325 ;;; want to redefine callbacks with the same symbol so the internal data
326 ;;; structures are reused.
327 (defpackage #:cffi-callbacks
328 (:use))
329
330 ;;; Intern a symbol in the CFFI-CALLBACKS package used to name the internal
331 ;;; callback for NAME.
332 (defun intern-callback (name)
333 (intern (format nil "~A::~A"
334 (if-let (package (symbol-package name))
335 (package-name package)
336 "#")
337 (symbol-name name))
338 '#:cffi-callbacks))
339
340 (defmacro %defcallback (name rettype arg-names arg-types body
341 &key convention)
342 (declare (ignore convention))
343 (let ((cb-name (intern-callback name)))
344 `(progn
345 (ccl::ppc-defpascal ,cb-name
346 (;; ? ,@(when (eq convention :stdcall) '(:discard-stack-args))
347 ,@(mapcan (lambda (sym type)
348 (list (ppc-ff-call-type=>mactype-name (convert-foreign-type type)) sym))
349 arg-names arg-types)
350 ,(ppc-ff-call-type=>mactype-name (convert-foreign-type rettype)))
351 ,body)
352 (setf (gethash ',name *callbacks*) (symbol-value ',cb-name)))))
353
354 (defun %callback (name)
355 (or (gethash name *callbacks*)
356 (error "Undefined callback: ~S" name)))
357
358 ;;;# Loading Foreign Libraries
359
360 (defun %load-foreign-library (name path)
361 "Load the foreign library NAME."
362 (declare (ignore path))
363 (setf name (string name))
364 ;; for mcl emulate this wrt frameworks
365 (unless (and (> (length name) 10)
366 (string-equal name ".framework" :start1 (- (length name) 10)))
367 (setf name (concatenate 'string name ".framework")))
368 ;; if the framework was not registered, add it
369 (unless (gethash name ccl::*framework-descriptors*)
370 (ccl::add-framework-bundle name :pathname "ccl:frameworks;" ))
371 (ccl::load-framework-bundle name))
372
373 (defun %close-foreign-library (name)
374 "Close the foreign library NAME."
375 ;; for mcl do nothing
376 (declare (ignore name))
377 nil)
378
379 (defun native-namestring (pathname)
380 (ccl::posix-namestring (ccl:full-pathname pathname)))
381
382
383 ;;;# Foreign Globals
384
385 (deftrap-inline "_findsymbol"
386 ((map :pointer)
387 (name :pointer))
388 :pointer
389 ())
390
391
392 (defun %foreign-symbol-pointer (name library)
393 "Returns a pointer to a foreign symbol NAME."
394 (declare (ignore library))
395 (ccl::macho-address
396 (ccl::get-macho-entry-point (convert-external-name name))))