types.lisp - clic - Clic is an command line interactive client for gopher writt… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
types.lisp (44771B) | |
--- | |
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- | |
2 ;;; | |
3 ;;; types.lisp --- User-defined CFFI types. | |
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 ;;;# Built-In Types | |
32 | |
33 ;; NOTE: In the C standard there's a "signed-char": | |
34 ;; https://stackoverflow.com/questions/436513/char-signed-char-char-unsi… | |
35 ;; and "char" may be either signed or unsigned, i.e. treating it as a sm… | |
36 ;; is not wise. At the level of CFFI we can safely ignore this and assum… | |
37 ;; :char is mapped to "signed-char" by the CL implementation under us. | |
38 (define-built-in-foreign-type :char) | |
39 (define-built-in-foreign-type :unsigned-char) | |
40 (define-built-in-foreign-type :short) | |
41 (define-built-in-foreign-type :unsigned-short) | |
42 (define-built-in-foreign-type :int) | |
43 (define-built-in-foreign-type :unsigned-int) | |
44 (define-built-in-foreign-type :long) | |
45 (define-built-in-foreign-type :unsigned-long) | |
46 (define-built-in-foreign-type :float) | |
47 (define-built-in-foreign-type :double) | |
48 (define-built-in-foreign-type :void) | |
49 | |
50 #-cffi-sys::no-long-long | |
51 (progn | |
52 (define-built-in-foreign-type :long-long) | |
53 (define-built-in-foreign-type :unsigned-long-long)) | |
54 | |
55 ;;; Define emulated LONG-LONG types. Needs checking whether we're | |
56 ;;; using the right sizes on various platforms. | |
57 ;;; | |
58 ;;; A possibly better, certainly faster though more intrusive, | |
59 ;;; alternative is available here: | |
60 ;;; <http://article.gmane.org/gmane.lisp.cffi.devel/1091> | |
61 #+cffi-sys::no-long-long | |
62 (eval-when (:compile-toplevel :load-toplevel :execute) | |
63 (defclass emulated-llong-type (foreign-type) ()) | |
64 (defmethod foreign-type-size ((tp emulated-llong-type)) 8) | |
65 (defmethod foreign-type-alignment ((tp emulated-llong-type)) | |
66 ;; better than assuming that the alignment is 8 | |
67 (foreign-type-alignment :long)) | |
68 (defmethod aggregatep ((tp emulated-llong-type)) nil) | |
69 | |
70 (define-foreign-type emulated-llong (emulated-llong-type) | |
71 () | |
72 (:simple-parser :long-long)) | |
73 | |
74 (define-foreign-type emulated-ullong (emulated-llong-type) | |
75 () | |
76 (:simple-parser :unsigned-long-long)) | |
77 | |
78 (defmethod canonicalize ((tp emulated-llong)) :long-long) | |
79 (defmethod unparse-type ((tp emulated-llong)) :long-long) | |
80 (defmethod canonicalize ((tp emulated-ullong)) :unsigned-long-long) | |
81 (defmethod unparse-type ((tp emulated-ullong)) :unsigned-long-long) | |
82 | |
83 (defun %emulated-mem-ref-64 (ptr type offset) | |
84 (let ((value #+big-endian | |
85 (+ (ash (mem-ref ptr :unsigned-long offset) 32) | |
86 (mem-ref ptr :unsigned-long (+ offset 4))) | |
87 #+little-endian | |
88 (+ (mem-ref ptr :unsigned-long offset) | |
89 (ash (mem-ref ptr :unsigned-long (+ offset 4)) 32)))) | |
90 (if (and (eq type :long-long) (logbitp 63 value)) | |
91 (lognot (logxor value #xFFFFFFFFFFFFFFFF)) | |
92 value))) | |
93 | |
94 (defun %emulated-mem-set-64 (value ptr type offset) | |
95 (when (and (eq type :long-long) (minusp value)) | |
96 (setq value (lognot (logxor value #xFFFFFFFFFFFFFFFF)))) | |
97 (%mem-set (ldb (byte 32 0) value) ptr :unsigned-long | |
98 #+big-endian (+ offset 4) #+little-endian offset) | |
99 (%mem-set (ldb (byte 32 32) value) ptr :unsigned-long | |
100 #+big-endian offset #+little-endian (+ offset 4)) | |
101 value)) | |
102 | |
103 ;;; When some lisp other than SCL supports :long-double we should | |
104 ;;; use #-cffi-sys::no-long-double here instead. | |
105 #+(and scl long-float) (define-built-in-foreign-type :long-double) | |
106 | |
107 (defparameter *possible-float-types* '(:float :double :long-double)) | |
108 | |
109 (defparameter *other-builtin-types* '(:pointer :void) | |
110 "List of types other than integer or float built in to CFFI.") | |
111 | |
112 (defparameter *built-in-integer-types* | |
113 (set-difference | |
114 cffi:*built-in-foreign-types* | |
115 (append *possible-float-types* *other-builtin-types*)) | |
116 "List of integer types supported by CFFI.") | |
117 | |
118 (defparameter *built-in-float-types* | |
119 (set-difference | |
120 cffi:*built-in-foreign-types* | |
121 (append *built-in-integer-types* *other-builtin-types*)) | |
122 "List of real float types supported by CFFI.") | |
123 | |
124 ;;;# Foreign Pointers | |
125 | |
126 (define-compiler-macro inc-pointer (&whole form pointer offset) | |
127 (if (and (constantp offset) | |
128 (eql 0 (eval offset))) | |
129 pointer | |
130 form)) | |
131 | |
132 (define-modify-macro incf-pointer (&optional (offset 1)) inc-pointer) | |
133 | |
134 (defun mem-ref (ptr type &optional (offset 0)) | |
135 "Return the value of TYPE at OFFSET bytes from PTR. If TYPE is aggrega… | |
136 we don't return its 'value' but a pointer to it, which is PTR itself." | |
137 (let* ((parsed-type (parse-type type)) | |
138 (ctype (canonicalize parsed-type))) | |
139 #+cffi-sys::no-long-long | |
140 (when (member ctype '(:long-long :unsigned-long-long)) | |
141 (return-from mem-ref | |
142 (translate-from-foreign (%emulated-mem-ref-64 ptr ctype of… | |
143 parsed-type))) | |
144 ;; normal branch | |
145 (if (aggregatep parsed-type) | |
146 (if (bare-struct-type-p parsed-type) | |
147 (inc-pointer ptr offset) | |
148 (translate-from-foreign (inc-pointer ptr offset) parsed-type… | |
149 (translate-from-foreign (%mem-ref ptr ctype offset) parsed-type)… | |
150 | |
151 (define-compiler-macro mem-ref (&whole form ptr type &optional (offset 0… | |
152 "Compiler macro to open-code MEM-REF when TYPE is constant." | |
153 (if (constantp type) | |
154 (let* ((parsed-type (parse-type (eval type))) | |
155 (ctype (canonicalize parsed-type))) | |
156 ;; Bail out when using emulated long long types. | |
157 #+cffi-sys::no-long-long | |
158 (when (member ctype '(:long-long :unsigned-long-long)) | |
159 (return-from mem-ref form)) | |
160 (if (aggregatep parsed-type) | |
161 (if (bare-struct-type-p parsed-type) | |
162 `(inc-pointer ,ptr ,offset) | |
163 (expand-from-foreign `(inc-pointer ,ptr ,offset) parsed-… | |
164 (expand-from-foreign `(%mem-ref ,ptr ,ctype ,offset) parsed-… | |
165 form)) | |
166 | |
167 (defun mem-set (value ptr type &optional (offset 0)) | |
168 "Set the value of TYPE at OFFSET bytes from PTR to VALUE." | |
169 (let* ((ptype (parse-type type)) | |
170 (ctype (canonicalize ptype))) | |
171 #+cffi-sys::no-long-long | |
172 (when (or (eq ctype :long-long) (eq ctype :unsigned-long-long)) | |
173 (return-from mem-set | |
174 (%emulated-mem-set-64 (translate-to-foreign value ptype) | |
175 ptr ctype offset))) | |
176 (if (aggregatep ptype) ; XXX: backwards incompatible? | |
177 (translate-into-foreign-memory value ptype (inc-pointer ptr offs… | |
178 (%mem-set (translate-to-foreign value ptype) ptr ctype offset)))) | |
179 | |
180 (define-setf-expander mem-ref (ptr type &optional (offset 0) &environmen… | |
181 "SETF expander for MEM-REF that doesn't rebind TYPE. | |
182 This is necessary for the compiler macro on MEM-SET to be able | |
183 to open-code (SETF MEM-REF) forms." | |
184 (multiple-value-bind (dummies vals newval setter getter) | |
185 (get-setf-expansion ptr env) | |
186 (declare (ignore setter newval)) | |
187 ;; if either TYPE or OFFSET are constant, we avoid rebinding them | |
188 ;; so that the compiler macros on MEM-SET and %MEM-SET work. | |
189 (with-unique-names (store type-tmp offset-tmp) | |
190 (values | |
191 (append (unless (constantp type) (list type-tmp)) | |
192 (unless (constantp offset) (list offset-tmp)) | |
193 dummies) | |
194 (append (unless (constantp type) (list type)) | |
195 (unless (constantp offset) (list offset)) | |
196 vals) | |
197 (list store) | |
198 `(progn | |
199 (mem-set ,store ,getter | |
200 ,@(if (constantp type) (list type) (list type-tmp… | |
201 ,@(if (constantp offset) (list offset) (list offset-t… | |
202 ,store) | |
203 `(mem-ref ,getter | |
204 ,@(if (constantp type) (list type) (list type-tmp)) | |
205 ,@(if (constantp offset) (list offset) (list offset-tmp… | |
206 | |
207 (define-compiler-macro mem-set | |
208 (&whole form value ptr type &optional (offset 0)) | |
209 "Compiler macro to open-code (SETF MEM-REF) when type is constant." | |
210 (if (constantp type) | |
211 (let* ((parsed-type (parse-type (eval type))) | |
212 (ctype (canonicalize parsed-type))) | |
213 ;; Bail out when using emulated long long types. | |
214 #+cffi-sys::no-long-long | |
215 (when (member ctype '(:long-long :unsigned-long-long)) | |
216 (return-from mem-set form)) | |
217 (if (aggregatep parsed-type) | |
218 (expand-into-foreign-memory | |
219 value parsed-type `(inc-pointer ,ptr ,offset)) | |
220 `(%mem-set ,(expand-to-foreign value parsed-type) | |
221 ,ptr ,ctype ,offset))) | |
222 form)) | |
223 | |
224 ;;;# Dereferencing Foreign Arrays | |
225 | |
226 ;;; Maybe this should be named MEM-SVREF? [2007-02-28 LO] | |
227 (defun mem-aref (ptr type &optional (index 0)) | |
228 "Like MEM-REF except for accessing 1d arrays." | |
229 (mem-ref ptr type (* index (foreign-type-size type)))) | |
230 | |
231 (define-compiler-macro mem-aref (&whole form ptr type &optional (index 0… | |
232 "Compiler macro to open-code MEM-AREF when TYPE (and eventually INDEX)… | |
233 (if (constantp type) | |
234 (if (constantp index) | |
235 `(mem-ref ,ptr ,type | |
236 ,(* (eval index) (foreign-type-size (eval type)))) | |
237 `(mem-ref ,ptr ,type (* ,index ,(foreign-type-size (eval type)… | |
238 form)) | |
239 | |
240 (define-setf-expander mem-aref (ptr type &optional (index 0) &environmen… | |
241 "SETF expander for MEM-AREF." | |
242 (multiple-value-bind (dummies vals newval setter getter) | |
243 (get-setf-expansion ptr env) | |
244 (declare (ignore setter newval)) | |
245 ;; we avoid rebinding type and index, if possible (and if type is not | |
246 ;; constant, we don't bother about the index), so that the compiler … | |
247 ;; on MEM-SET or %MEM-SET can work. | |
248 (with-unique-names (store type-tmp index-tmp) | |
249 (values | |
250 (append (unless (constantp type) | |
251 (list type-tmp)) | |
252 (unless (and (constantp type) (constantp index)) | |
253 (list index-tmp)) | |
254 dummies) | |
255 (append (unless (constantp type) | |
256 (list type)) | |
257 (unless (and (constantp type) (constantp index)) | |
258 (list index)) | |
259 vals) | |
260 (list store) | |
261 ;; Here we'll try to calculate the offset from the type and index, | |
262 ;; or if not possible at least get the type size early. | |
263 `(progn | |
264 ,(if (constantp type) | |
265 (if (constantp index) | |
266 `(mem-set ,store ,getter ,type | |
267 ,(* (eval index) (foreign-type-size (eval t… | |
268 `(mem-set ,store ,getter ,type | |
269 (* ,index-tmp ,(foreign-type-size (eval typ… | |
270 `(mem-set ,store ,getter ,type-tmp | |
271 (* ,index-tmp (foreign-type-size ,type-tmp)))) | |
272 ,store) | |
273 `(mem-aref ,getter | |
274 ,@(if (constantp type) | |
275 (list type) | |
276 (list type-tmp)) | |
277 ,@(if (and (constantp type) (constantp index)) | |
278 (list index) | |
279 (list index-tmp))))))) | |
280 | |
281 (defmethod translate-into-foreign-memory | |
282 (value (type foreign-pointer-type) pointer) | |
283 (setf (mem-aref pointer :pointer) value)) | |
284 | |
285 (defmethod translate-into-foreign-memory | |
286 (value (type foreign-built-in-type) pointer) | |
287 (setf (mem-aref pointer (unparse-type type)) value)) | |
288 | |
289 (defun mem-aptr (ptr type &optional (index 0)) | |
290 "The pointer to the element." | |
291 (inc-pointer ptr (* index (foreign-type-size type)))) | |
292 | |
293 (define-compiler-macro mem-aptr (&whole form ptr type &optional (index 0… | |
294 "The pointer to the element." | |
295 (cond ((not (constantp type)) | |
296 form) | |
297 ((not (constantp index)) | |
298 `(inc-pointer ,ptr (* ,index ,(foreign-type-size (eval type))))) | |
299 ((zerop (eval index)) | |
300 ptr) | |
301 (t | |
302 `(inc-pointer ,ptr ,(* (eval index) | |
303 (foreign-type-size (eval type))))))) | |
304 | |
305 (define-foreign-type foreign-array-type () | |
306 ((dimensions :reader dimensions :initarg :dimensions) | |
307 (element-type :reader element-type :initarg :element-type)) | |
308 (:actual-type :pointer)) | |
309 | |
310 (defmethod aggregatep ((type foreign-array-type)) | |
311 t) | |
312 | |
313 (defmethod print-object ((type foreign-array-type) stream) | |
314 "Print a FOREIGN-ARRAY-TYPE instance to STREAM unreadably." | |
315 (print-unreadable-object (type stream :type t :identity nil) | |
316 (format stream "~S ~S" (element-type type) (dimensions type)))) | |
317 | |
318 (defun array-element-size (array-type) | |
319 (foreign-type-size (element-type array-type))) | |
320 | |
321 (defmethod foreign-type-size ((type foreign-array-type)) | |
322 (* (array-element-size type) (reduce #'* (dimensions type)))) | |
323 | |
324 (defmethod foreign-type-alignment ((type foreign-array-type)) | |
325 (foreign-type-alignment (element-type type))) | |
326 | |
327 (define-parse-method :array (element-type &rest dimensions) | |
328 (assert (plusp (length dimensions))) | |
329 (make-instance 'foreign-array-type | |
330 :element-type element-type | |
331 :dimensions dimensions)) | |
332 | |
333 (defun indexes-to-row-major-index (dimensions &rest subscripts) | |
334 (apply #'+ (maplist (lambda (x y) | |
335 (* (car x) (apply #'* (cdr y)))) | |
336 subscripts | |
337 dimensions))) | |
338 | |
339 (defun row-major-index-to-indexes (index dimensions) | |
340 (loop with idx = index | |
341 with rank = (length dimensions) | |
342 with indexes = (make-list rank) | |
343 for dim-index from (- rank 1) downto 0 do | |
344 (setf (values idx (nth dim-index indexes)) | |
345 (floor idx (nth dim-index dimensions))) | |
346 finally (return indexes))) | |
347 | |
348 (defun foreign-alloc (type &key (initial-element nil initial-element-p) | |
349 (initial-contents nil initial-contents-p) | |
350 (count 1 count-p) null-terminated-p) | |
351 "Allocate enough memory to hold COUNT objects of type TYPE. If | |
352 INITIAL-ELEMENT is supplied, each element of the newly allocated | |
353 memory is initialized with its value. If INITIAL-CONTENTS is supplied, | |
354 each of its elements will be used to initialize the contents of the | |
355 newly allocated memory." | |
356 (let (contents-length) | |
357 ;; Some error checking, etc... | |
358 (when (and null-terminated-p | |
359 (not (eq (canonicalize-foreign-type type) :pointer))) | |
360 (error "Cannot use :NULL-TERMINATED-P with non-pointer types.")) | |
361 (when (and initial-element-p initial-contents-p) | |
362 (error "Cannot specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS… | |
363 (when initial-contents-p | |
364 (setq contents-length (length initial-contents)) | |
365 (if count-p | |
366 (assert (>= count contents-length)) | |
367 (setq count contents-length))) | |
368 ;; Everything looks good. | |
369 (let ((ptr (%foreign-alloc (* (foreign-type-size type) | |
370 (if null-terminated-p (1+ count) count… | |
371 (when initial-element-p | |
372 (dotimes (i count) | |
373 (setf (mem-aref ptr type i) initial-element))) | |
374 (when initial-contents-p | |
375 (dotimes (i contents-length) | |
376 (setf (mem-aref ptr type i) (elt initial-contents i)))) | |
377 (when null-terminated-p | |
378 (setf (mem-aref ptr :pointer count) (null-pointer))) | |
379 ptr))) | |
380 | |
381 ;;; Simple compiler macro that kicks in when TYPE is constant and only | |
382 ;;; the COUNT argument is passed. (Note: hard-coding the type's size | |
383 ;;; into the fasl will likely break CLISP fasl cross-platform | |
384 ;;; compatibilty.) | |
385 (define-compiler-macro foreign-alloc (&whole form type &rest args | |
386 &key (count 1 count-p) &allow-othe… | |
387 (if (or (and count-p (<= (length args) 2)) (null args)) | |
388 (cond | |
389 ((and (constantp type) (constantp count)) | |
390 `(%foreign-alloc ,(* (eval count) (foreign-type-size (eval type… | |
391 ((constantp type) | |
392 `(%foreign-alloc (* ,count ,(foreign-type-size (eval type))))) | |
393 (t form)) | |
394 form)) | |
395 | |
396 (defun lisp-array-to-foreign (array pointer array-type) | |
397 "Copy elements from a Lisp array to POINTER. ARRAY-TYPE must be a CFFI… | |
398 type." | |
399 (let* ((type (ensure-parsed-base-type array-type)) | |
400 (el-type (element-type type)) | |
401 (dimensions (dimensions type))) | |
402 (loop with foreign-type-size = (array-element-size type) | |
403 with size = (reduce #'* dimensions) | |
404 for i from 0 below size | |
405 for offset = (* i foreign-type-size) | |
406 for element = (apply #'aref array | |
407 (row-major-index-to-indexes i dimensions)) | |
408 do (setf (mem-ref pointer el-type offset) element)))) | |
409 | |
410 (defun foreign-array-to-lisp (pointer array-type &rest make-array-args) | |
411 "Copy elements from pointer into a Lisp array. ARRAY-TYPE must be a CF… | |
412 type; the type of the resulting Lisp array can be defined in MAKE-ARRAY-… | |
413 that are then passed to MAKE-ARRAY. If POINTER is a null pointer, return… | |
414 (unless (null-pointer-p pointer) | |
415 (let* ((type (ensure-parsed-base-type array-type)) | |
416 (el-type (element-type type)) | |
417 (dimensions (dimensions type)) | |
418 (array (apply #'make-array dimensions make-array-args))) | |
419 (loop with foreign-type-size = (array-element-size type) | |
420 with size = (reduce #'* dimensions) | |
421 for i from 0 below size | |
422 for offset = (* i foreign-type-size) | |
423 for element = (mem-ref pointer el-type offset) | |
424 do (setf (apply #'aref array | |
425 (row-major-index-to-indexes i dimensions)) | |
426 element)) | |
427 array))) | |
428 | |
429 (defun foreign-array-alloc (array array-type) | |
430 "Allocate a foreign array containing the elements of lisp array. | |
431 The foreign array must be freed with foreign-array-free." | |
432 (check-type array array) | |
433 (let* ((type (ensure-parsed-base-type array-type)) | |
434 (ptr (foreign-alloc (element-type type) | |
435 :count (reduce #'* (dimensions type))))) | |
436 (lisp-array-to-foreign array ptr array-type) | |
437 ptr)) | |
438 | |
439 (defun foreign-array-free (ptr) | |
440 "Free a foreign array allocated by foreign-array-alloc." | |
441 (foreign-free ptr)) | |
442 | |
443 (defmacro with-foreign-array ((var lisp-array array-type) &body body) | |
444 "Bind var to a foreign array containing lisp-array elements in body." | |
445 (with-unique-names (type) | |
446 `(let ((,type (ensure-parsed-base-type ,array-type))) | |
447 (with-foreign-pointer (,var (* (reduce #'* (dimensions ,type)) | |
448 (array-element-size ,type))) | |
449 (lisp-array-to-foreign ,lisp-array ,var ,array-type) | |
450 ,@body)))) | |
451 | |
452 (defun foreign-aref (ptr array-type &rest indexes) | |
453 (let* ((type (ensure-parsed-base-type array-type)) | |
454 (offset (* (array-element-size type) | |
455 (apply #'indexes-to-row-major-index | |
456 (dimensions type) indexes)))) | |
457 (mem-ref ptr (element-type type) offset))) | |
458 | |
459 (defun (setf foreign-aref) (value ptr array-type &rest indexes) | |
460 (let* ((type (ensure-parsed-base-type array-type)) | |
461 (offset (* (array-element-size type) | |
462 (apply #'indexes-to-row-major-index | |
463 (dimensions type) indexes)))) | |
464 (setf (mem-ref ptr (element-type type) offset) value))) | |
465 | |
466 ;;; Automatic translations for the :ARRAY type. Notice that these | |
467 ;;; translators will also invoke the appropriate translators for for | |
468 ;;; each of the array's elements since that's the normal behaviour of | |
469 ;;; the FOREIGN-ARRAY-* operators, but there's a FIXME: **it doesn't | |
470 ;;; free them yet** | |
471 | |
472 ;;; This used to be in a separate type but let's experiment with just | |
473 ;;; one type for a while. [2008-12-30 LO] | |
474 | |
475 ;;; FIXME: those ugly invocations of UNPARSE-TYPE suggest that these | |
476 ;;; foreign array operators should take the type and dimention | |
477 ;;; arguments "unboxed". [2008-12-31 LO] | |
478 | |
479 (defmethod translate-to-foreign (array (type foreign-array-type)) | |
480 (foreign-array-alloc array (unparse-type type))) | |
481 | |
482 (defmethod translate-aggregate-to-foreign (ptr value (type foreign-array… | |
483 (lisp-array-to-foreign value ptr (unparse-type type))) | |
484 | |
485 (defmethod translate-from-foreign (pointer (type foreign-array-type)) | |
486 (foreign-array-to-lisp pointer (unparse-type type))) | |
487 | |
488 (defmethod free-translated-object (pointer (type foreign-array-type) par… | |
489 (declare (ignore param)) | |
490 (foreign-array-free pointer)) | |
491 | |
492 ;;;# Foreign Structures | |
493 | |
494 ;;;## Foreign Structure Slots | |
495 | |
496 (defgeneric foreign-struct-slot-pointer (ptr slot) | |
497 (:documentation | |
498 "Get the address of SLOT relative to PTR.")) | |
499 | |
500 (defgeneric foreign-struct-slot-pointer-form (ptr slot) | |
501 (:documentation | |
502 "Return a form to get the address of SLOT in PTR.")) | |
503 | |
504 (defgeneric foreign-struct-slot-value (ptr slot) | |
505 (:documentation | |
506 "Return the value of SLOT in structure PTR.")) | |
507 | |
508 (defgeneric (setf foreign-struct-slot-value) (value ptr slot) | |
509 (:documentation | |
510 "Set the value of a SLOT in structure PTR.")) | |
511 | |
512 (defgeneric foreign-struct-slot-value-form (ptr slot) | |
513 (:documentation | |
514 "Return a form to get the value of SLOT in struct PTR.")) | |
515 | |
516 (defgeneric foreign-struct-slot-set-form (value ptr slot) | |
517 (:documentation | |
518 "Return a form to set the value of SLOT in struct PTR.")) | |
519 | |
520 (defclass foreign-struct-slot () | |
521 ((name :initarg :name :reader slot-name) | |
522 (offset :initarg :offset :accessor slot-offset) | |
523 ;; FIXME: the type should probably be parsed? | |
524 (type :initarg :type :accessor slot-type)) | |
525 (:documentation "Base class for simple and aggregate slots.")) | |
526 | |
527 (defmethod foreign-struct-slot-pointer (ptr (slot foreign-struct-slot)) | |
528 "Return the address of SLOT relative to PTR." | |
529 (inc-pointer ptr (slot-offset slot))) | |
530 | |
531 (defmethod foreign-struct-slot-pointer-form (ptr (slot foreign-struct-sl… | |
532 "Return a form to get the address of SLOT relative to PTR." | |
533 (let ((offset (slot-offset slot))) | |
534 (if (zerop offset) | |
535 ptr | |
536 `(inc-pointer ,ptr ,offset)))) | |
537 | |
538 (defun foreign-slot-names (type) | |
539 "Returns a list of TYPE's slot names in no particular order." | |
540 (loop for value being the hash-values | |
541 in (slots (ensure-parsed-base-type type)) | |
542 collect (slot-name value))) | |
543 | |
544 ;;;### Simple Slots | |
545 | |
546 (defclass simple-struct-slot (foreign-struct-slot) | |
547 () | |
548 (:documentation "Non-aggregate structure slots.")) | |
549 | |
550 (defmethod foreign-struct-slot-value (ptr (slot simple-struct-slot)) | |
551 "Return the value of a simple SLOT from a struct at PTR." | |
552 (mem-ref ptr (slot-type slot) (slot-offset slot))) | |
553 | |
554 (defmethod foreign-struct-slot-value-form (ptr (slot simple-struct-slot)) | |
555 "Return a form to get the value of a slot from PTR." | |
556 `(mem-ref ,ptr ',(slot-type slot) ,(slot-offset slot))) | |
557 | |
558 (defmethod (setf foreign-struct-slot-value) (value ptr (slot simple-stru… | |
559 "Set the value of a simple SLOT to VALUE in PTR." | |
560 (setf (mem-ref ptr (slot-type slot) (slot-offset slot)) value)) | |
561 | |
562 (defmethod foreign-struct-slot-set-form (value ptr (slot simple-struct-s… | |
563 "Return a form to set the value of a simple structure slot." | |
564 `(setf (mem-ref ,ptr ',(slot-type slot) ,(slot-offset slot)) ,value)) | |
565 | |
566 ;;;### Aggregate Slots | |
567 | |
568 (defclass aggregate-struct-slot (foreign-struct-slot) | |
569 ((count :initarg :count :accessor slot-count)) | |
570 (:documentation "Aggregate structure slots.")) | |
571 | |
572 ;;; Since MEM-REF returns a pointer for struct types we are able to | |
573 ;;; chain together slot names when accessing slot values in nested | |
574 ;;; structures. | |
575 (defmethod foreign-struct-slot-value (ptr (slot aggregate-struct-slot)) | |
576 "Return a pointer to SLOT relative to PTR." | |
577 (convert-from-foreign (inc-pointer ptr (slot-offset slot)) | |
578 (slot-type slot))) | |
579 | |
580 (defmethod foreign-struct-slot-value-form (ptr (slot aggregate-struct-sl… | |
581 "Return a form to get the value of SLOT relative to PTR." | |
582 `(convert-from-foreign (inc-pointer ,ptr ,(slot-offset slot)) | |
583 ',(slot-type slot))) | |
584 | |
585 (defmethod translate-aggregate-to-foreign (ptr value (type foreign-struc… | |
586 ;;; FIXME: use the block memory interface instead. | |
587 (loop for i below (foreign-type-size type) | |
588 do (%mem-set (%mem-ref value :char i) ptr :char i))) | |
589 | |
590 (defmethod (setf foreign-struct-slot-value) | |
591 (value ptr (slot aggregate-struct-slot)) | |
592 "Set the value of an aggregate SLOT to VALUE in PTR." | |
593 (translate-aggregate-to-foreign (inc-pointer ptr (slot-offset slot)) | |
594 value | |
595 (parse-type (slot-type slot)))) | |
596 | |
597 (defmethod foreign-struct-slot-set-form (value ptr (slot aggregate-struc… | |
598 "Return a form to get the value of an aggregate SLOT relative to PTR." | |
599 `(translate-aggregate-to-foreign (inc-pointer ,ptr ,(slot-offset slot)) | |
600 ,value | |
601 ,(parse-type (slot-type slot)))) | |
602 | |
603 ;;;## Defining Foreign Structures | |
604 | |
605 (defun make-struct-slot (name offset type count) | |
606 "Make the appropriate type of structure slot." | |
607 ;; If TYPE is an aggregate type or COUNT is >1, create an | |
608 ;; AGGREGATE-STRUCT-SLOT, otherwise a SIMPLE-STRUCT-SLOT. | |
609 (if (or (> count 1) (aggregatep (parse-type type))) | |
610 (make-instance 'aggregate-struct-slot :offset offset :type type | |
611 :name name :count count) | |
612 (make-instance 'simple-struct-slot :offset offset :type type | |
613 :name name))) | |
614 | |
615 (defun parse-deprecated-struct-type (name struct-or-union) | |
616 (check-type struct-or-union (member :struct :union)) | |
617 (let* ((struct-type-name `(,struct-or-union ,name)) | |
618 (struct-type (parse-type struct-type-name))) | |
619 (simple-style-warning | |
620 "bare references to struct types are deprecated. ~ | |
621 Please use ~S or ~S instead." | |
622 `(:pointer ,struct-type-name) struct-type-name) | |
623 (make-instance (class-of struct-type) | |
624 :alignment (alignment struct-type) | |
625 :size (size struct-type) | |
626 :slots (slots struct-type) | |
627 :name (name struct-type) | |
628 :bare t))) | |
629 | |
630 ;;; Regarding structure alignment, the following ABIs were checked: | |
631 ;;; - System-V ABI: x86, x86-64, ppc, arm, mips and itanium. (more?) | |
632 ;;; - Mac OS X ABI Function Call Guide: ppc32, ppc64 and x86. | |
633 ;;; | |
634 ;;; Rules used here: | |
635 ;;; | |
636 ;;; 1. "An entire structure or union object is aligned on the same | |
637 ;;; boundary as its most strictly aligned member." | |
638 ;;; | |
639 ;;; 2. "Each member is assigned to the lowest available offset with | |
640 ;;; the appropriate alignment. This may require internal | |
641 ;;; padding, depending on the previous member." | |
642 ;;; | |
643 ;;; 3. "A structure's size is increased, if necessary, to make it a | |
644 ;;; multiple of the alignment. This may require tail padding, | |
645 ;;; depending on the last member." | |
646 ;;; | |
647 ;;; Special cases from darwin/ppc32's ABI: | |
648 ;;; http://developer.apple.com/documentation/DeveloperTools/Conceptual/L… | |
649 ;;; | |
650 ;;; 4. "The embedding alignment of the first element in a data | |
651 ;;; structure is equal to the element's natural alignment." | |
652 ;;; | |
653 ;;; 5. "For subsequent elements that have a natural alignment | |
654 ;;; greater than 4 bytes, the embedding alignment is 4, unless | |
655 ;;; the element is a vector." (note: this applies for | |
656 ;;; structures too) | |
657 | |
658 ;; FIXME: get a better name for this. --luis | |
659 (defun get-alignment (type alignment-type firstp) | |
660 "Return alignment for TYPE according to ALIGNMENT-TYPE." | |
661 (declare (ignorable firstp)) | |
662 (ecase alignment-type | |
663 (:normal #-(and darwin ppc) | |
664 (foreign-type-alignment type) | |
665 #+(and darwin ppc) | |
666 (if firstp | |
667 (foreign-type-alignment type) | |
668 (min 4 (foreign-type-alignment type)))))) | |
669 | |
670 (defun adjust-for-alignment (type offset alignment-type firstp) | |
671 "Return OFFSET aligned properly for TYPE according to ALIGNMENT-TYPE." | |
672 (let* ((align (get-alignment type alignment-type firstp)) | |
673 (rem (mod offset align))) | |
674 (if (zerop rem) | |
675 offset | |
676 (+ offset (- align rem))))) | |
677 | |
678 (defmacro with-tentative-type-definition ((name value namespace) &body b… | |
679 (once-only (name namespace) | |
680 `(unwind-protect-case () | |
681 (progn | |
682 (notice-foreign-type ,name ,value ,namespace) | |
683 ,@body) | |
684 (:abort (undefine-foreign-type ,name ,namespace))))) | |
685 | |
686 (defun notice-foreign-struct-definition (name options slots) | |
687 "Parse and install a foreign structure definition." | |
688 (destructuring-bind (&key size (class 'foreign-struct-type)) | |
689 options | |
690 (let ((struct (make-instance class :name name)) | |
691 (current-offset 0) | |
692 (max-align 1) | |
693 (firstp t)) | |
694 (with-tentative-type-definition (name struct :struct) | |
695 ;; determine offsets | |
696 (dolist (slotdef slots) | |
697 (destructuring-bind (slotname type &key (count 1) offset) slot… | |
698 (when (eq (canonicalize-foreign-type type) :void) | |
699 (simple-foreign-type-error type :struct | |
700 "In struct ~S: void type not al… | |
701 name slotdef)) | |
702 (setq current-offset | |
703 (or offset | |
704 (adjust-for-alignment type current-offset :normal … | |
705 (let* ((slot (make-struct-slot slotname current-offset type … | |
706 (align (get-alignment (slot-type slot) :normal firstp… | |
707 (setf (gethash slotname (slots struct)) slot) | |
708 (when (> align max-align) | |
709 (setq max-align align))) | |
710 (incf current-offset (* count (foreign-type-size type)))) | |
711 (setq firstp nil)) | |
712 ;; calculate padding and alignment | |
713 (setf (alignment struct) max-align) ; See point 1 above. | |
714 (let ((tail-padding (- max-align (rem current-offset max-align))… | |
715 (unless (= tail-padding max-align) ; See point 3 above. | |
716 (incf current-offset tail-padding))) | |
717 (setf (size struct) (or size current-offset)))))) | |
718 | |
719 (defun generate-struct-accessors (name conc-name slot-names) | |
720 (loop with pointer-arg = (symbolicate '#:pointer-to- name) | |
721 for slot in slot-names | |
722 for accessor = (symbolicate conc-name slot) | |
723 collect `(defun ,accessor (,pointer-arg) | |
724 (foreign-slot-value ,pointer-arg '(:struct ,name) ',s… | |
725 collect `(defun (setf ,accessor) (value ,pointer-arg) | |
726 (foreign-slot-set value ,pointer-arg '(:struct ,name)… | |
727 | |
728 (define-parse-method :struct (name) | |
729 (funcall (find-type-parser name :struct))) | |
730 | |
731 (defvar *defcstruct-hook* nil) | |
732 | |
733 (defmacro defcstruct (name-and-options &body fields) | |
734 "Define the layout of a foreign structure." | |
735 (discard-docstring fields) | |
736 (destructuring-bind (name . options) | |
737 (ensure-list name-and-options) | |
738 (let ((conc-name (getf options :conc-name))) | |
739 (remf options :conc-name) | |
740 (unless (getf options :class) (setf (getf options :class) (symboli… | |
741 `(eval-when (:compile-toplevel :load-toplevel :execute) | |
742 ;; m-f-s-t could do with this with mop:ensure-class. | |
743 ,(when-let (class (getf options :class)) | |
744 `(defclass ,class (foreign-struct-type | |
745 translatable-foreign-type) | |
746 ())) | |
747 (notice-foreign-struct-definition ',name ',options ',fields) | |
748 ,@(when conc-name | |
749 (generate-struct-accessors name conc-name | |
750 (mapcar #'car fields))) | |
751 ,@(when *defcstruct-hook* | |
752 ;; If non-nil, *defcstruct-hook* should be a function | |
753 ;; of the arguments that returns NIL or a list of | |
754 ;; forms to include in the expansion. | |
755 (apply *defcstruct-hook* name-and-options fields)) | |
756 (define-parse-method ,name () | |
757 (parse-deprecated-struct-type ',name :struct)) | |
758 '(:struct ,name))))) | |
759 | |
760 ;;;## Accessing Foreign Structure Slots | |
761 | |
762 (defun get-slot-info (type slot-name) | |
763 "Return the slot info for SLOT-NAME or raise an error." | |
764 (let* ((struct (ensure-parsed-base-type type)) | |
765 (info (gethash slot-name (slots struct)))) | |
766 (unless info | |
767 (simple-foreign-type-error type :struct | |
768 "Undefined slot ~A in foreign type ~A." | |
769 slot-name type)) | |
770 info)) | |
771 | |
772 (defun foreign-slot-pointer (ptr type slot-name) | |
773 "Return the address of SLOT-NAME in the structure at PTR." | |
774 (foreign-struct-slot-pointer ptr (get-slot-info type slot-name))) | |
775 | |
776 (define-compiler-macro foreign-slot-pointer (&whole whole ptr type slot-… | |
777 (if (and (constantp type) (constantp slot-name)) | |
778 (foreign-struct-slot-pointer-form | |
779 ptr (get-slot-info (eval type) (eval slot-name))) | |
780 whole)) | |
781 | |
782 (defun foreign-slot-type (type slot-name) | |
783 "Return the type of SLOT in a struct TYPE." | |
784 (slot-type (get-slot-info type slot-name))) | |
785 | |
786 (defun foreign-slot-offset (type slot-name) | |
787 "Return the offset of SLOT in a struct TYPE." | |
788 (slot-offset (get-slot-info type slot-name))) | |
789 | |
790 (defun foreign-slot-count (type slot-name) | |
791 "Return the number of items in SLOT in a struct TYPE." | |
792 (slot-count (get-slot-info type slot-name))) | |
793 | |
794 (defun foreign-slot-value (ptr type slot-name) | |
795 "Return the value of SLOT-NAME in the foreign structure at PTR." | |
796 (foreign-struct-slot-value ptr (get-slot-info type slot-name))) | |
797 | |
798 (define-compiler-macro foreign-slot-value (&whole form ptr type slot-nam… | |
799 "Optimizer for FOREIGN-SLOT-VALUE when TYPE is constant." | |
800 (if (and (constantp type) (constantp slot-name)) | |
801 (foreign-struct-slot-value-form | |
802 ptr (get-slot-info (eval type) (eval slot-name))) | |
803 form)) | |
804 | |
805 (define-setf-expander foreign-slot-value (ptr type slot-name &environmen… | |
806 "SETF expander for FOREIGN-SLOT-VALUE." | |
807 (multiple-value-bind (dummies vals newval setter getter) | |
808 (get-setf-expansion ptr env) | |
809 (declare (ignore setter newval)) | |
810 (if (and (constantp type) (constantp slot-name)) | |
811 ;; if TYPE and SLOT-NAME are constant we avoid rebinding them | |
812 ;; so that the compiler macro on FOREIGN-SLOT-SET works. | |
813 (with-unique-names (store) | |
814 (values | |
815 dummies | |
816 vals | |
817 (list store) | |
818 `(progn | |
819 (foreign-slot-set ,store ,getter ,type ,slot-name) | |
820 ,store) | |
821 `(foreign-slot-value ,getter ,type ,slot-name))) | |
822 ;; if not... | |
823 (with-unique-names (store slot-name-tmp type-tmp) | |
824 (values | |
825 (list* type-tmp slot-name-tmp dummies) | |
826 (list* type slot-name vals) | |
827 (list store) | |
828 `(progn | |
829 (foreign-slot-set ,store ,getter ,type-tmp ,slot-name-tmp) | |
830 ,store) | |
831 `(foreign-slot-value ,getter ,type-tmp ,slot-name-tmp)))))) | |
832 | |
833 (defun foreign-slot-set (value ptr type slot-name) | |
834 "Set the value of SLOT-NAME in a foreign structure." | |
835 (setf (foreign-struct-slot-value ptr (get-slot-info type slot-name)) v… | |
836 | |
837 (define-compiler-macro foreign-slot-set | |
838 (&whole form value ptr type slot-name) | |
839 "Optimizer when TYPE and SLOT-NAME are constant." | |
840 (if (and (constantp type) (constantp slot-name)) | |
841 (foreign-struct-slot-set-form | |
842 value ptr (get-slot-info (eval type) (eval slot-name))) | |
843 form)) | |
844 | |
845 (defmacro with-foreign-slots ((vars ptr type) &body body) | |
846 "Create local symbol macros for each var in VARS to reference | |
847 foreign slots in PTR of TYPE. Similar to WITH-SLOTS. | |
848 Each var can be of the form: slot-name - in which case slot-name will | |
849 be bound to the value of the slot or: (:pointer slot-name) - in which | |
850 case slot-name will be bound to the pointer to that slot." | |
851 (let ((ptr-var (gensym "PTR"))) | |
852 `(let ((,ptr-var ,ptr)) | |
853 (symbol-macrolet | |
854 ,(loop :for var :in vars | |
855 :collect | |
856 (if (listp var) | |
857 (if (eq (first var) :pointer) | |
858 `(,(second var) (foreign-slot-pointer | |
859 ,ptr-var ',type ',(second var))) | |
860 (error | |
861 "Malformed slot specification ~a; must be:`name' … | |
862 var)) | |
863 `(,var (foreign-slot-value ,ptr-var ',type ',var)))) | |
864 ,@body)))) | |
865 | |
866 ;;; We could add an option to define a struct instead of a class, in | |
867 ;;; the unlikely event someone needs something like that. | |
868 (defmacro define-c-struct-wrapper (class-and-type supers &optional slots) | |
869 "Define a new class with CLOS slots matching those of a foreign | |
870 struct type. An INITIALIZE-INSTANCE method is defined which | |
871 takes a :POINTER initarg that is used to store the slots of a | |
872 foreign object. This pointer is only used for initialization and | |
873 it is not retained. | |
874 | |
875 CLASS-AND-TYPE is either a list of the form (class-name | |
876 struct-type) or a single symbol naming both. The class will | |
877 inherit SUPERS. If a list of SLOTS is specified, only those | |
878 slots will be defined and stored." | |
879 (destructuring-bind (class-name &optional (struct-type (list :struct c… | |
880 (ensure-list class-and-type) | |
881 (let ((slots (or slots (foreign-slot-names struct-type)))) | |
882 `(progn | |
883 (defclass ,class-name ,supers | |
884 ,(loop for slot in slots collect | |
885 `(,slot :reader ,(format-symbol t "~A-~A" class-name s… | |
886 ;; This could be done in a parent class by using | |
887 ;; FOREIGN-SLOT-NAMES when instantiating but then the compiler | |
888 ;; macros wouldn't kick in. | |
889 (defmethod initialize-instance :after ((inst ,class-name) &key … | |
890 (with-foreign-slots (,slots pointer ,struct-type) | |
891 ,@(loop for slot in slots collect | |
892 `(setf (slot-value inst ',slot) ,slot)))) | |
893 ',class-name)))) | |
894 | |
895 ;;;# Foreign Unions | |
896 ;;; | |
897 ;;; A union is a subclass of FOREIGN-STRUCT-TYPE in which all slots | |
898 ;;; have an offset of zero. | |
899 | |
900 ;;; See also the notes regarding ABI requirements in | |
901 ;;; NOTICE-FOREIGN-STRUCT-DEFINITION | |
902 (defun notice-foreign-union-definition (name-and-options slots) | |
903 "Parse and install a foreign union definition." | |
904 (destructuring-bind (name &key size) | |
905 (ensure-list name-and-options) | |
906 (let ((union (make-instance 'foreign-union-type :name name)) | |
907 (max-size 0) | |
908 (max-align 0)) | |
909 (with-tentative-type-definition (name union :union) | |
910 (dolist (slotdef slots) | |
911 (destructuring-bind (slotname type &key (count 1)) slotdef | |
912 (when (eq (canonicalize-foreign-type type) :void) | |
913 (simple-foreign-type-error name :struct | |
914 "In union ~S: void type not all… | |
915 name slotdef)) | |
916 (let* ((slot (make-struct-slot slotname 0 type count)) | |
917 (size (* count (foreign-type-size type))) | |
918 (align (foreign-type-alignment (slot-type slot)))) | |
919 (setf (gethash slotname (slots union)) slot) | |
920 (when (> size max-size) | |
921 (setf max-size size)) | |
922 (when (> align max-align) | |
923 (setf max-align align))))) | |
924 (setf (size union) (or size max-size)) | |
925 (setf (alignment union) max-align))))) | |
926 | |
927 (define-parse-method :union (name) | |
928 (funcall (find-type-parser name :union))) | |
929 | |
930 (defmacro defcunion (name-and-options &body fields) | |
931 "Define the layout of a foreign union." | |
932 (discard-docstring fields) | |
933 (destructuring-bind (name &key size) | |
934 (ensure-list name-and-options) | |
935 (declare (ignore size)) | |
936 `(eval-when (:compile-toplevel :load-toplevel :execute) | |
937 (notice-foreign-union-definition ',name-and-options ',fields) | |
938 (define-parse-method ,name () | |
939 (parse-deprecated-struct-type ',name :union)) | |
940 '(:union ,name)))) | |
941 | |
942 ;;;# Operations on Types | |
943 | |
944 (defmethod foreign-type-alignment (type) | |
945 "Return the alignment in bytes of a foreign type." | |
946 (foreign-type-alignment (parse-type type))) | |
947 | |
948 (defmacro with-foreign-object ((var type &optional (count 1)) &body body) | |
949 "Bind VAR to a pointer to COUNT objects of TYPE during BODY. | |
950 The buffer has dynamic extent and may be stack allocated." | |
951 `(with-foreign-pointer | |
952 (,var ,(if (constantp type) | |
953 ;; with-foreign-pointer may benefit from constant fold… | |
954 (if (constantp count) | |
955 (* (eval count) (foreign-type-size (eval type))) | |
956 `(* ,count ,(foreign-type-size (eval type)))) | |
957 `(* ,count (foreign-type-size ,type)))) | |
958 ,@body)) | |
959 | |
960 (defmacro with-foreign-objects (bindings &body body) | |
961 (if bindings | |
962 `(with-foreign-object ,(car bindings) | |
963 (with-foreign-objects ,(cdr bindings) | |
964 ,@body)) | |
965 `(progn ,@body))) | |
966 | |
967 ;;;## Anonymous Type Translators | |
968 ;;; | |
969 ;;; (:wrapper :to-c some-function :from-c another-function) | |
970 ;;; | |
971 ;;; TODO: We will need to add a FREE function to this as well I think. | |
972 ;;; --james | |
973 | |
974 (define-foreign-type foreign-type-wrapper () | |
975 ((to-c :initarg :to-c :reader wrapper-to-c) | |
976 (from-c :initarg :from-c :reader wrapper-from-c)) | |
977 (:documentation "Wrapper type.")) | |
978 | |
979 (define-parse-method :wrapper (base-type &key to-c from-c) | |
980 (make-instance 'foreign-type-wrapper | |
981 :actual-type (parse-type base-type) | |
982 :to-c (or to-c 'identity) | |
983 :from-c (or from-c 'identity))) | |
984 | |
985 (defmethod translate-to-foreign (value (type foreign-type-wrapper)) | |
986 (translate-to-foreign | |
987 (funcall (slot-value type 'to-c) value) (actual-type type))) | |
988 | |
989 (defmethod translate-from-foreign (value (type foreign-type-wrapper)) | |
990 (funcall (slot-value type 'from-c) | |
991 (translate-from-foreign value (actual-type type)))) | |
992 | |
993 ;;;# Other types | |
994 | |
995 ;;; Boolean type. Maps to an :int by default. Only accepts integer types. | |
996 (define-foreign-type foreign-boolean-type () | |
997 ()) | |
998 | |
999 (define-parse-method :boolean (&optional (base-type :int)) | |
1000 (make-instance | |
1001 'foreign-boolean-type :actual-type | |
1002 (ecase (canonicalize-foreign-type base-type) | |
1003 ((:char :unsigned-char :int :unsigned-int :long :unsigned-long | |
1004 #-cffi-sys::no-long-long :long-long | |
1005 #-cffi-sys::no-long-long :unsigned-long-long) base-type)))) | |
1006 | |
1007 (defmethod translate-to-foreign (value (type foreign-boolean-type)) | |
1008 (if value 1 0)) | |
1009 | |
1010 (defmethod translate-from-foreign (value (type foreign-boolean-type)) | |
1011 (not (zerop value))) | |
1012 | |
1013 (defmethod expand-to-foreign (value (type foreign-boolean-type)) | |
1014 "Optimization for the :boolean type." | |
1015 (if (constantp value) | |
1016 (if (eval value) 1 0) | |
1017 `(if ,value 1 0))) | |
1018 | |
1019 (defmethod expand-from-foreign (value (type foreign-boolean-type)) | |
1020 "Optimization for the :boolean type." | |
1021 (if (constantp value) ; very unlikely, heh | |
1022 (not (zerop (eval value))) | |
1023 `(not (zerop ,value)))) | |
1024 | |
1025 ;;; Boolean type that represents C99 _Bool | |
1026 (defctype :bool (:boolean :char)) | |
1027 | |
1028 ;;;# Typedefs for built-in types. | |
1029 | |
1030 (defctype :uchar :unsigned-char) | |
1031 (defctype :ushort :unsigned-short) | |
1032 (defctype :uint :unsigned-int) | |
1033 (defctype :ulong :unsigned-long) | |
1034 (defctype :llong :long-long) | |
1035 (defctype :ullong :unsigned-long-long) | |
1036 | |
1037 ;;; We try to define the :[u]int{8,16,32,64} types by looking at | |
1038 ;;; the sizes of the built-in integer types and defining typedefs. | |
1039 (eval-when (:compile-toplevel :load-toplevel :execute) | |
1040 (macrolet | |
1041 ((match-types (sized-types mtypes) | |
1042 `(progn | |
1043 ,@(loop for (type . size-or-type) in sized-types | |
1044 for m = (car (member (if (keywordp size-or-type) | |
1045 (foreign-type-size size-or-… | |
1046 size-or-type) | |
1047 mtypes :key #'foreign-type-size… | |
1048 when m collect `(defctype ,type ,m))))) | |
1049 ;; signed | |
1050 (match-types ((:int8 . 1) (:int16 . 2) (:int32 . 4) (:int64 . 8) | |
1051 (:intptr . :pointer)) | |
1052 (:char :short :int :long :long-long)) | |
1053 ;; unsigned | |
1054 (match-types ((:uint8 . 1) (:uint16 . 2) (:uint32 . 4) (:uint64 . 8) | |
1055 (:uintptr . :pointer)) | |
1056 (:unsigned-char :unsigned-short :unsigned-int :unsigned… | |
1057 :unsigned-long-long)))) |