1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; types.lisp --- User-defined CFFI types.
5 ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
6 ;;; Copyright (C) 2005-2007, Luis Oliveira <loliveira@common-lisp.net>
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:
16 ;;; The above copyright notice and this permission notice shall be
17 ;;; included in all copies or substantial portions of the Software.
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.
33 (define-built-in-foreign-type :char
)
34 (define-built-in-foreign-type :unsigned-char
)
35 (define-built-in-foreign-type :short
)
36 (define-built-in-foreign-type :unsigned-short
)
37 (define-built-in-foreign-type :int
)
38 (define-built-in-foreign-type :unsigned-int
)
39 (define-built-in-foreign-type :long
)
40 (define-built-in-foreign-type :unsigned-long
)
41 (define-built-in-foreign-type :float
)
42 (define-built-in-foreign-type :double
)
43 (define-built-in-foreign-type :void
)
45 #-cffi-features
:no-long-long
47 (define-built-in-foreign-type :long-long
)
48 (define-built-in-foreign-type :unsigned-long-long
))
50 ;;; Define emulated LONG-LONG types. Needs checking whether we're
51 ;;; using the right sizes on various platforms.
53 ;;; A possibly better, certainly faster though more intrusive,
54 ;;; alternative is available here:
55 ;;; <http://article.gmane.org/gmane.lisp.cffi.devel/1091>
56 #+cffi-features
:no-long-long
57 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
58 (defclass emulated-llong-type
(foreign-type) ())
59 (defmethod foreign-type-size ((tp emulated-llong-type
)) 8)
60 (defmethod foreign-type-alignment ((tp emulated-llong-type
)) 8)
61 (defmethod aggregatep ((tp emulated-llong-type
)) nil
)
63 (define-foreign-type emulated-llong
(emulated-llong-type)
65 (:simple-parser
:long-long
))
67 (define-foreign-type emulated-ullong
(emulated-llong-type)
69 (:simple-parser
:unsigned-long-long
))
71 (defmethod canonicalize ((tp emulated-llong
)) :long-long
)
72 (defmethod unparse-type ((tp emulated-llong
)) :long-long
)
73 (defmethod canonicalize ((tp emulated-ullong
)) :unsigned-long-long
)
74 (defmethod unparse-type ((tp emulated-ullong
)) :unsigned-long-long
)
76 (defun %emulated-mem-ref-64
(ptr type offset
)
77 (let ((value #+big-endian
78 (+ (ash (mem-ref ptr
:unsigned-long offset
) 32)
79 (mem-ref ptr
:unsigned-long
(+ offset
4)))
81 (+ (mem-ref ptr
:unsigned-long offset
)
82 (ash (mem-ref ptr
:unsigned-long
(+ offset
4)) -
32))))
83 (if (and (eq type
:long-long
) (logbitp 63 value
))
84 (lognot (logxor value
#xFFFFFFFFFFFFFFFF
))
87 (defun %emulated-mem-set-64
(value ptr type offset
)
88 (when (and (eq type
:long-long
) (minusp value
))
89 (setq value
(lognot (logxor value
#xFFFFFFFFFFFFFFFF
))))
90 (%mem-set
(ldb (byte 32 0) value
) ptr
:unsigned-long
91 #+big-endian
(+ offset
4) #+little-endian offset
)
92 (%mem-set
(ldb (byte 32 32) value
) ptr
:unsigned-long
93 #+big-endian offset
#+little-endian
(+ offset
4))
96 ;;; When some lisp other than SCL supports :long-double we should
97 ;;; use #-cffi-features:no-long-double here instead.
98 #+(and scl long-float
) (define-built-in-foreign-type :long-double
)
100 ;;;# Foreign Pointers
102 (define-modify-macro incf-pointer
(&optional
(offset 1)) inc-pointer
)
104 (defun mem-ref (ptr type
&optional
(offset 0))
105 "Return the value of TYPE at OFFSET bytes from PTR. If TYPE is aggregate,
106 we don't return its 'value' but a pointer to it, which is PTR itself."
107 (let ((ptype (parse-type type
)))
108 (if (aggregatep ptype
)
109 (inc-pointer ptr offset
)
110 (let ((ctype (canonicalize ptype
)))
111 #+cffi-features
:no-long-long
112 (when (or (eq ctype
:long-long
) (eq ctype
:unsigned-long-long
))
114 (translate-from-foreign (%emulated-mem-ref-64 ptr ctype offset
)
117 (translate-from-foreign (%mem-ref ptr ctype offset
) ptype
)))))
119 (define-compiler-macro mem-ref
(&whole form ptr type
&optional
(offset 0))
120 "Compiler macro to open-code MEM-REF when TYPE is constant."
122 (let* ((parsed-type (parse-type (eval type
)))
123 (ctype (canonicalize parsed-type
)))
124 ;; Bail out when using emulated long long types.
125 #+cffi-features
:no-long-long
126 (when (member ctype
'(:long-long
:unsigned-long-long
))
127 (return-from mem-ref form
))
128 (if (aggregatep parsed-type
)
129 `(inc-pointer ,ptr
,offset
)
130 (expand-from-foreign `(%mem-ref
,ptr
,ctype
,offset
) parsed-type
)))
133 (defun mem-set (value ptr type
&optional
(offset 0))
134 "Set the value of TYPE at OFFSET bytes from PTR to VALUE."
135 (let* ((ptype (parse-type type
))
136 (ctype (canonicalize ptype
)))
137 #+cffi-features
:no-long-long
138 (when (or (eq ctype
:long-long
) (eq ctype
:unsigned-long-long
))
140 (%emulated-mem-set-64
(translate-to-foreign value ptype
)
142 (%mem-set
(translate-to-foreign value ptype
) ptr ctype offset
)))
144 (define-setf-expander mem-ref
(ptr type
&optional
(offset 0) &environment env
)
145 "SETF expander for MEM-REF that doesn't rebind TYPE.
146 This is necessary for the compiler macro on MEM-SET to be able
147 to open-code (SETF MEM-REF) forms."
148 (multiple-value-bind (dummies vals newval setter getter
)
149 (get-setf-expansion ptr env
)
150 (declare (ignore setter newval
))
151 ;; if either TYPE or OFFSET are constant, we avoid rebinding them
152 ;; so that the compiler macros on MEM-SET and %MEM-SET work.
153 (with-unique-names (store type-tmp offset-tmp
)
155 (append (unless (constantp type
) (list type-tmp
))
156 (unless (constantp offset
) (list offset-tmp
))
158 (append (unless (constantp type
) (list type
))
159 (unless (constantp offset
) (list offset
))
163 (mem-set ,store
,getter
164 ,@(if (constantp type
) (list type
) (list type-tmp
))
165 ,@(if (constantp offset
) (list offset
) (list offset-tmp
)))
168 ,@(if (constantp type
) (list type
) (list type-tmp
))
169 ,@(if (constantp offset
) (list offset
) (list offset-tmp
)))))))
171 (define-compiler-macro mem-set
172 (&whole form value ptr type
&optional
(offset 0))
173 "Compiler macro to open-code (SETF MEM-REF) when type is constant."
175 (let* ((parsed-type (parse-type (eval type
)))
176 (ctype (canonicalize parsed-type
)))
177 ;; Bail out when using emulated long long types.
178 #+cffi-features
:no-long-long
179 (when (member ctype
'(:long-long
:unsigned-long-long
))
180 (return-from mem-set form
))
181 `(%mem-set
,(expand-to-foreign value parsed-type
) ,ptr
,ctype
,offset
))
184 ;;;# Dereferencing Foreign Arrays
186 ;;; Maybe this should be named MEM-SVREF? [2007-02-28 LO]
187 (defun mem-aref (ptr type
&optional
(index 0))
188 "Like MEM-REF except for accessing 1d arrays."
189 (mem-ref ptr type
(* index
(foreign-type-size type
))))
191 (define-compiler-macro mem-aref
(&whole form ptr type
&optional
(index 0))
192 "Compiler macro to open-code MEM-AREF when TYPE (and eventually INDEX)."
194 (if (constantp index
)
196 ,(* (eval index
) (foreign-type-size (eval type
))))
197 `(mem-ref ,ptr
,type
(* ,index
,(foreign-type-size (eval type
)))))
200 (define-setf-expander mem-aref
(ptr type
&optional
(index 0) &environment env
)
201 "SETF expander for MEM-AREF."
202 (multiple-value-bind (dummies vals newval setter getter
)
203 (get-setf-expansion ptr env
)
204 (declare (ignore setter newval
))
205 ;; we avoid rebinding type and index, if possible (and if type is not
206 ;; constant, we don't bother about the index), so that the compiler macros
207 ;; on MEM-SET or %MEM-SET can work.
208 (with-unique-names (store type-tmp index-tmp
)
210 (append (unless (constantp type
)
212 (unless (and (constantp type
) (constantp index
))
215 (append (unless (constantp type
)
217 (unless (and (constantp type
) (constantp index
))
221 ;; Here we'll try to calculate the offset from the type and index,
222 ;; or if not possible at least get the type size early.
224 ,(if (constantp type
)
225 (if (constantp index
)
226 `(mem-set ,store
,getter
,type
227 ,(* (eval index
) (foreign-type-size (eval type
))))
228 `(mem-set ,store
,getter
,type
229 (* ,index-tmp
,(foreign-type-size (eval type
)))))
230 `(mem-set ,store
,getter
,type-tmp
231 (* ,index-tmp
(foreign-type-size ,type-tmp
))))
234 ,@(if (constantp type
)
237 ,@(if (and (constantp type
) (constantp index
))
239 (list index-tmp
)))))))
241 (define-foreign-type foreign-array-type
()
242 ((dimensions :reader dimensions
:initarg
:dimensions
)
243 (element-type :reader element-type
:initarg
:element-type
))
244 (:actual-type
:pointer
))
246 (defmethod print-object ((type foreign-array-type
) stream
)
247 "Print a FOREIGN-ARRAY-TYPE instance to STREAM unreadably."
248 (print-unreadable-object (type stream
:type t
:identity nil
)
249 (format stream
"~S ~S" (element-type type
) (dimensions type
))))
251 (define-parse-method :array
(element-type &rest dimensions
)
252 (make-instance 'foreign-array-type
253 :element-type element-type
254 :dimensions dimensions
))
256 (defun array-element-size (array-type)
257 (foreign-type-size (element-type array-type
)))
259 (defun indexes-to-row-major-index (dimensions &rest subscripts
)
260 (apply #'+ (maplist (lambda (x y
)
261 (* (car x
) (apply #'* (cdr y
))))
265 (defun row-major-index-to-indexes (index dimensions
)
266 (loop with idx
= index
267 with rank
= (length dimensions
)
268 with indexes
= (make-list rank
)
269 for dim-index from
(- rank
1) downto
0 do
270 (setf (values idx
(nth dim-index indexes
))
271 (floor idx
(nth dim-index dimensions
)))
272 finally
(return indexes
)))
274 (defun lisp-array-to-foreign (array pointer array-type
)
275 "Copy elements from a Lisp array to POINTER."
276 (let* ((type (follow-typedefs (parse-type array-type
)))
277 (el-type (element-type type
))
278 (dimensions (dimensions type
)))
279 (loop with foreign-type-size
= (array-element-size type
)
280 with size
= (reduce #'* dimensions
)
281 for i from
0 below size
282 for offset
= (* i foreign-type-size
)
283 for element
= (apply #'aref array
284 (row-major-index-to-indexes i dimensions
))
285 do
(setf (mem-ref pointer el-type offset
) element
))))
287 (defun foreign-array-to-lisp (pointer array-type
)
288 "Copy elements from ptr into a Lisp array. If POINTER is a null
289 pointer, returns NIL."
290 (unless (null-pointer-p pointer
)
291 (let* ((type (follow-typedefs (parse-type array-type
)))
292 (el-type (element-type type
))
293 (dimensions (dimensions type
))
294 (array (make-array dimensions
)))
295 (loop with foreign-type-size
= (array-element-size type
)
296 with size
= (reduce #'* dimensions
)
297 for i from
0 below size
298 for offset
= (* i foreign-type-size
)
299 for element
= (mem-ref pointer el-type offset
)
300 do
(setf (apply #'aref array
301 (row-major-index-to-indexes i dimensions
))
305 (defun foreign-array-alloc (array array-type
)
306 "Allocate a foreign array containing the elements of lisp array.
307 The foreign array must be freed with foreign-array-free."
308 (check-type array array
)
309 (let* ((type (follow-typedefs (parse-type array-type
)))
310 (ptr (foreign-alloc (element-type type
)
311 :count
(reduce #'* (dimensions type
)))))
312 (lisp-array-to-foreign array ptr array-type
)
315 (defun foreign-array-free (ptr)
316 "Free a foreign array allocated by foreign-array-alloc."
319 (defmacro with-foreign-array
((var lisp-array array-type
) &body body
)
320 "Bind var to a foreign array containing lisp-array elements in body."
321 (with-unique-names (type)
322 `(let ((,type
(follow-typedefs (parse-type ,array-type
))))
323 (with-foreign-pointer (,var
(* (reduce #'* (dimensions ,type
))
324 (array-element-size ,type
)))
325 (lisp-array-to-foreign ,lisp-array
,var
,array-type
)
328 (defun foreign-aref (ptr array-type
&rest indexes
)
329 (let* ((type (follow-typedefs (parse-type array-type
)))
330 (offset (* (array-element-size type
)
331 (apply #'indexes-to-row-major-index
332 (dimensions type
) indexes
))))
333 (mem-ref ptr
(element-type type
) offset
)))
335 (defun (setf foreign-aref
) (value ptr array-type
&rest indexes
)
336 (let* ((type (follow-typedefs (parse-type array-type
)))
337 (offset (* (array-element-size type
)
338 (apply #'indexes-to-row-major-index
339 (dimensions type
) indexes
))))
340 (setf (mem-ref ptr
(element-type type
) offset
) value
)))
342 ;;; This type has defined type translators to allocate and free the
343 ;;; array. It will also invoke type translators for each of the
344 ;;; array's element. **But it doesn't free them yet**
345 (define-foreign-type auto-array-type
(foreign-array-type)
348 (define-parse-method :auto-array
(element-type &rest dimensions
)
349 (assert (>= (length dimensions
) 1))
350 (make-instance 'auto-array-type
351 :element-type element-type
352 :dimensions dimensions
))
354 (defmethod translate-to-foreign (array (type auto-array-type
))
355 (foreign-array-alloc array
(unparse-type type
)))
357 (defmethod translate-from-foreign (pointer (type auto-array-type
))
358 (foreign-array-to-lisp pointer
(unparse-type type
)))
360 (defmethod free-translated-object (pointer (type auto-array-type
) param
)
361 (declare (ignore param
))
362 (foreign-array-free pointer
))
364 ;;;# Foreign Structures
366 ;;;## Foreign Structure Slots
368 (defgeneric foreign-struct-slot-pointer
(ptr slot
)
370 "Get the address of SLOT relative to PTR."))
372 (defgeneric foreign-struct-slot-pointer-form
(ptr slot
)
374 "Return a form to get the address of SLOT in PTR."))
376 (defgeneric foreign-struct-slot-value
(ptr slot
)
378 "Return the value of SLOT in structure PTR."))
380 (defgeneric (setf foreign-struct-slot-value
) (value ptr slot
)
382 "Set the value of a SLOT in structure PTR."))
384 (defgeneric foreign-struct-slot-value-form
(ptr slot
)
386 "Return a form to get the value of SLOT in struct PTR."))
388 (defgeneric foreign-struct-slot-set-form
(value ptr slot
)
390 "Return a form to set the value of SLOT in struct PTR."))
392 (defclass foreign-struct-slot
()
393 ((name :initarg
:name
:reader slot-name
)
394 (offset :initarg
:offset
:accessor slot-offset
)
395 (type :initarg
:type
:accessor slot-type
))
396 (:documentation
"Base class for simple and aggregate slots."))
398 (defmethod foreign-struct-slot-pointer (ptr (slot foreign-struct-slot
))
399 "Return the address of SLOT relative to PTR."
400 (inc-pointer ptr
(slot-offset slot
)))
402 (defmethod foreign-struct-slot-pointer-form (ptr (slot foreign-struct-slot
))
403 "Return a form to get the address of SLOT relative to PTR."
404 (let ((offset (slot-offset slot
)))
407 `(inc-pointer ,ptr
,offset
))))
409 (defun foreign-slot-names (type)
410 "Returns a list of TYPE's slot names in no particular order."
411 (loop for value being the hash-values
412 in
(slots (follow-typedefs (parse-type type
)))
413 collect
(slot-name value
)))
417 (defclass simple-struct-slot
(foreign-struct-slot)
419 (:documentation
"Non-aggregate structure slots."))
421 (defmethod foreign-struct-slot-value (ptr (slot simple-struct-slot
))
422 "Return the value of a simple SLOT from a struct at PTR."
423 (mem-ref ptr
(slot-type slot
) (slot-offset slot
)))
425 (defmethod foreign-struct-slot-value-form (ptr (slot simple-struct-slot
))
426 "Return a form to get the value of a slot from PTR."
427 `(mem-ref ,ptr
',(slot-type slot
) ,(slot-offset slot
)))
429 (defmethod (setf foreign-struct-slot-value
) (value ptr
(slot simple-struct-slot
))
430 "Set the value of a simple SLOT to VALUE in PTR."
431 (setf (mem-ref ptr
(slot-type slot
) (slot-offset slot
)) value
))
433 (defmethod foreign-struct-slot-set-form (value ptr
(slot simple-struct-slot
))
434 "Return a form to set the value of a simple structure slot."
435 `(setf (mem-ref ,ptr
',(slot-type slot
) ,(slot-offset slot
)) ,value
))
437 ;;;### Aggregate Slots
439 (defclass aggregate-struct-slot
(foreign-struct-slot)
440 ((count :initarg
:count
:accessor slot-count
))
441 (:documentation
"Aggregate structure slots."))
443 ;;; A case could be made for just returning an error here instead of
444 ;;; this rather DWIM-ish behavior to return the address. It would
445 ;;; complicate being able to chain together slot names when accessing
446 ;;; slot values in nested structures though.
447 (defmethod foreign-struct-slot-value (ptr (slot aggregate-struct-slot
))
448 "Return a pointer to SLOT relative to PTR."
449 (foreign-struct-slot-pointer ptr slot
))
451 (defmethod foreign-struct-slot-value-form (ptr (slot aggregate-struct-slot
))
452 "Return a form to get the value of SLOT relative to PTR."
453 (foreign-struct-slot-pointer-form ptr slot
))
455 ;;; This is definitely an error though. Eventually, we could define a
456 ;;; new type of type translator that can convert certain aggregate
457 ;;; types, notably C strings or arrays of integers. For now, just error.
458 (defmethod (setf foreign-struct-slot-value
) (value ptr
(slot aggregate-struct-slot
))
459 "Signal an error; setting aggregate slot values is forbidden."
460 (declare (ignore value ptr
))
461 (error "Cannot set value of aggregate slot ~A." slot
))
463 (defmethod foreign-struct-slot-set-form (value ptr
(slot aggregate-struct-slot
))
464 "Signal an error; setting aggregate slot values is forbidden."
465 (declare (ignore value ptr
))
466 (error "Cannot set value of aggregate slot ~A." slot
))
468 ;;;## Defining Foreign Structures
470 (defun make-struct-slot (name offset type count
)
471 "Make the appropriate type of structure slot."
472 ;; If TYPE is an aggregate type or COUNT is >1, create an
473 ;; AGGREGATE-STRUCT-SLOT, otherwise a SIMPLE-STRUCT-SLOT.
474 (if (or (> count
1) (aggregatep (parse-type type
)))
475 (make-instance 'aggregate-struct-slot
:offset offset
:type type
476 :name name
:count count
)
477 (make-instance 'simple-struct-slot
:offset offset
:type type
480 ;;; Regarding structure alignment, the following ABIs were checked:
481 ;;; - System-V ABI: x86, x86-64, ppc, arm, mips and itanium. (more?)
482 ;;; - Mac OS X ABI Function Call Guide: ppc32, ppc64 and x86.
486 ;;; 1. "An entire structure or union object is aligned on the same
487 ;;; boundary as its most strictly aligned member."
489 ;;; 2. "Each member is assigned to the lowest available offset with
490 ;;; the appropriate alignment. This may require internal
491 ;;; padding, depending on the previous member."
493 ;;; 3. "A structure's size is increased, if necessary, to make it a
494 ;;; multiple of the alignment. This may require tail padding,
495 ;;; depending on the last member."
497 ;;; Special cases from darwin/ppc32's ABI:
498 ;;; http://developer.apple.com/documentation/DeveloperTools/Conceptual/LowLevelABI/index.html
500 ;;; 4. "The embedding alignment of the first element in a data
501 ;;; structure is equal to the element's natural alignment."
503 ;;; 5. "For subsequent elements that have a natural alignment
504 ;;; greater than 4 bytes, the embedding alignment is 4, unless
505 ;;; the element is a vector." (note: this applies for
508 ;; FIXME: get a better name for this. --luis
509 (defun get-alignment (type alignment-type firstp
)
510 "Return alignment for TYPE according to ALIGNMENT-TYPE."
511 (declare (ignorable firstp
))
512 (ecase alignment-type
513 (:normal
#-
(and darwin ppc
)
514 (foreign-type-alignment type
)
517 (foreign-type-alignment type
)
518 (min 4 (foreign-type-alignment type
))))))
520 (defun adjust-for-alignment (type offset alignment-type firstp
)
521 "Return OFFSET aligned properly for TYPE according to ALIGNMENT-TYPE."
522 (let* ((align (get-alignment type alignment-type firstp
))
523 (rem (mod offset align
)))
526 (+ offset
(- align rem
)))))
528 (defun notice-foreign-struct-definition (name-and-options slots
)
529 "Parse and install a foreign structure definition."
530 (destructuring-bind (name &key size
(class 'foreign-struct-type
))
531 (ensure-list name-and-options
)
532 (let ((struct (make-instance class
:name name
))
537 (dolist (slotdef slots
)
538 (destructuring-bind (slotname type
&key
(count 1) offset
) slotdef
539 (when (eq (canonicalize-foreign-type type
) :void
)
540 (error "void type not allowed in structure definition: ~S" slotdef
))
543 (adjust-for-alignment type current-offset
:normal firstp
)))
544 (let* ((slot (make-struct-slot slotname current-offset type count
))
545 (align (get-alignment (slot-type slot
) :normal firstp
)))
546 (setf (gethash slotname
(slots struct
)) slot
)
547 (when (> align max-align
)
548 (setq max-align align
)))
549 (incf current-offset
(* count
(foreign-type-size type
))))
551 ;; calculate padding and alignment
552 (setf (alignment struct
) max-align
) ; See point 1 above.
553 (let ((tail-padding (- max-align
(rem current-offset max-align
))))
554 (unless (= tail-padding max-align
) ; See point 3 above.
555 (incf current-offset tail-padding
)))
556 (setf (size struct
) (or size current-offset
))
557 (notice-foreign-type name struct
))))
559 (defmacro defcstruct
(name-and-options &body fields
)
560 "Define the layout of a foreign structure."
561 (discard-docstring fields
)
562 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
563 ;; n-f-s-d could do with this with mop:ensure-class.
564 ,(when-let (class (getf (cdr (ensure-list name-and-options
)) :class
))
565 `(defclass ,class
(foreign-struct-type) ()))
566 (notice-foreign-struct-definition ',name-and-options
',fields
)))
568 ;;;## Accessing Foreign Structure Slots
570 (defun get-slot-info (type slot-name
)
571 "Return the slot info for SLOT-NAME or raise an error."
572 (let* ((struct (follow-typedefs (parse-type type
)))
573 (info (gethash slot-name
(slots struct
))))
575 (error "Undefined slot ~A in foreign type ~A." slot-name type
))
578 (defun foreign-slot-pointer (ptr type slot-name
)
579 "Return the address of SLOT-NAME in the structure at PTR."
580 (foreign-struct-slot-pointer ptr
(get-slot-info type slot-name
)))
582 (defun foreign-slot-offset (type slot-name
)
583 "Return the offset of SLOT in a struct TYPE."
584 (slot-offset (get-slot-info type slot-name
)))
586 (defun foreign-slot-value (ptr type slot-name
)
587 "Return the value of SLOT-NAME in the foreign structure at PTR."
588 (foreign-struct-slot-value ptr
(get-slot-info type slot-name
)))
590 (define-compiler-macro foreign-slot-value
(&whole form ptr type slot-name
)
591 "Optimizer for FOREIGN-SLOT-VALUE when TYPE is constant."
592 (if (and (constantp type
) (constantp slot-name
))
593 (foreign-struct-slot-value-form
594 ptr
(get-slot-info (eval type
) (eval slot-name
)))
597 (define-setf-expander foreign-slot-value
(ptr type slot-name
&environment env
)
598 "SETF expander for FOREIGN-SLOT-VALUE."
599 (multiple-value-bind (dummies vals newval setter getter
)
600 (get-setf-expansion ptr env
)
601 (declare (ignore setter newval
))
602 (if (and (constantp type
) (constantp slot-name
))
603 ;; if TYPE and SLOT-NAME are constant we avoid rebinding them
604 ;; so that the compiler macro on FOREIGN-SLOT-SET works.
605 (with-unique-names (store)
611 (foreign-slot-set ,store
,getter
,type
,slot-name
)
613 `(foreign-slot-value ,getter
,type
,slot-name
)))
615 (with-unique-names (store slot-name-tmp type-tmp
)
617 (list* type-tmp slot-name-tmp dummies
)
618 (list* type slot-name vals
)
621 (foreign-slot-set ,store
,getter
,type-tmp
,slot-name-tmp
)
623 `(foreign-slot-value ,getter
,type-tmp
,slot-name-tmp
))))))
625 (defun foreign-slot-set (value ptr type slot-name
)
626 "Set the value of SLOT-NAME in a foreign structure."
627 (setf (foreign-struct-slot-value ptr
(get-slot-info type slot-name
)) value
))
629 (define-compiler-macro foreign-slot-set
630 (&whole form value ptr type slot-name
)
631 "Optimizer when TYPE and SLOT-NAME are constant."
632 (if (and (constantp type
) (constantp slot-name
))
633 (foreign-struct-slot-set-form
634 value ptr
(get-slot-info (eval type
) (eval slot-name
)))
637 (defmacro with-foreign-slots
((vars ptr type
) &body body
)
638 "Create local symbol macros for each var in VARS to reference
639 foreign slots in PTR of TYPE. Similar to WITH-SLOTS."
640 (let ((ptr-var (gensym "PTR")))
641 `(let ((,ptr-var
,ptr
))
643 ,(loop for var in vars
644 collect
`(,var
(foreign-slot-value ,ptr-var
',type
',var
)))
647 ;;; We could add an option to define a struct instead of a class, in
648 ;;; the unlikely event someone needs something like that.
649 (defmacro define-c-struct-wrapper
(class-and-type supers
&optional slots
)
650 "Define a new class with CLOS slots matching those of a foreign
651 struct type. An INITIALIZE-INSTANCE method is defined which
652 takes a :POINTER initarg that is used to store the slots of a
653 foreign object. This pointer is only used for initialization and
656 CLASS-AND-TYPE is either a list of the form (class-name
657 struct-type) or a single symbol naming both. The class will
658 inherit SUPERS. If a list of SLOTS is specified, only those
659 slots will be defined and stored."
660 (destructuring-bind (class-name &optional
(struct-type class-name
))
661 (ensure-list class-and-type
)
662 (let ((slots (or slots
(foreign-slot-names struct-type
))))
664 (defclass ,class-name
,supers
665 ,(loop for slot in slots collect
666 (list slot
:reader
(symbolicate class-name
"-" slot
))))
667 ;; This could be done in a parent class by using
668 ;; FOREIGN-SLOT-NAMES when instantiating but then the compiler
669 ;; macros wouldn't kick in.
670 (defmethod initialize-instance :after
((inst ,class-name
) &key pointer
)
671 (with-foreign-slots (,slots pointer
,struct-type
)
672 ,@(loop for slot in slots collect
673 `(setf (slot-value inst
',slot
) ,slot
))))
678 ;;; A union is a FOREIGN-STRUCT-TYPE in which all slots have an offset
681 ;;; See also the notes regarding ABI requirements in
682 ;;; NOTICE-FOREIGN-STRUCT-DEFINITION
683 (defun notice-foreign-union-definition (name-and-options slots
)
684 "Parse and install a foreign union definition."
685 (destructuring-bind (name &key size
)
686 (ensure-list name-and-options
)
687 (let ((struct (make-instance 'foreign-struct-type
:name name
))
690 (dolist (slotdef slots
)
691 (destructuring-bind (slotname type
&key
(count 1)) slotdef
692 (when (eq (canonicalize-foreign-type type
) :void
)
693 (error "void type not allowed in union definition: ~S" slotdef
))
694 (let* ((slot (make-struct-slot slotname
0 type count
))
695 (size (* count
(foreign-type-size type
)))
696 (align (foreign-type-alignment (slot-type slot
))))
697 (setf (gethash slotname
(slots struct
)) slot
)
698 (when (> size max-size
)
699 (setf max-size size
))
700 (when (> align max-align
)
701 (setf max-align align
)))))
702 (setf (size struct
) (or size max-size
))
703 (setf (alignment struct
) max-align
)
704 (notice-foreign-type name struct
))))
706 (defmacro defcunion
(name &body fields
)
707 "Define the layout of a foreign union."
708 (discard-docstring fields
)
709 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
710 (notice-foreign-union-definition ',name
',fields
)))
712 ;;;# Operations on Types
714 (defmethod foreign-type-alignment (type)
715 "Return the alignment in bytes of a foreign type."
716 (foreign-type-alignment (parse-type type
)))
718 (defun foreign-alloc (type &key
(initial-element nil initial-element-p
)
719 (initial-contents nil initial-contents-p
)
720 (count 1 count-p
) null-terminated-p
)
721 "Allocate enough memory to hold COUNT objects of type TYPE. If
722 INITIAL-ELEMENT is supplied, each element of the newly allocated
723 memory is initialized with its value. If INITIAL-CONTENTS is supplied,
724 each of its elements will be used to initialize the contents of the
725 newly allocated memory."
726 (let (contents-length)
727 ;; Some error checking, etc...
728 (when (and null-terminated-p
729 (not (eq (canonicalize-foreign-type type
) :pointer
)))
730 (error "Cannot use :NULL-TERMINATED-P with non-pointer types."))
731 (when (and initial-element-p initial-contents-p
)
732 (error "Cannot specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
733 (when initial-contents-p
734 (setq contents-length
(length initial-contents
))
736 (assert (>= count contents-length
))
737 (setq count contents-length
)))
738 ;; Everything looks good.
739 (let ((ptr (%foreign-alloc
(* (foreign-type-size type
)
740 (if null-terminated-p
(1+ count
) count
)))))
741 (when initial-element-p
743 (setf (mem-aref ptr type i
) initial-element
)))
744 (when initial-contents-p
745 (dotimes (i contents-length
)
746 (setf (mem-aref ptr type i
) (elt initial-contents i
))))
747 (when null-terminated-p
748 (setf (mem-aref ptr
:pointer count
) (null-pointer)))
751 ;;; Simple compiler macro that kicks in when TYPE is constant and only
752 ;;; the COUNT argument is passed. (Note: hard-coding the type's size
753 ;;; into the fasl will likely break CLISP fasl cross-platform
755 (define-compiler-macro foreign-alloc
(&whole form type
&rest args
756 &key
(count 1 count-p
) &allow-other-keys
)
757 (if (or (and count-p
(<= (length args
) 2)) (null args
))
759 ((and (constantp type
) (constantp count
))
760 `(%foreign-alloc
,(* (eval count
) (foreign-type-size (eval type
)))))
762 `(%foreign-alloc
(* ,count
,(foreign-type-size (eval type
)))))
766 (defmacro with-foreign-object
((var type
&optional
(count 1)) &body body
)
767 "Bind VAR to a pointer to COUNT objects of TYPE during BODY.
768 The buffer has dynamic extent and may be stack allocated."
769 `(with-foreign-pointer
770 (,var
,(if (constantp type
)
771 ;; with-foreign-pointer may benefit from constant folding:
772 (if (constantp count
)
773 (* (eval count
) (foreign-type-size (eval type
)))
774 `(* ,count
,(foreign-type-size (eval type
))))
775 `(* ,count
(foreign-type-size ,type
))))
778 (defmacro with-foreign-objects
(bindings &body body
)
780 `(with-foreign-object ,(car bindings
)
781 (with-foreign-objects ,(cdr bindings
)
785 ;;;## Anonymous Type Translators
787 ;;; (:wrapper :to-c some-function :from-c another-function)
789 ;;; TODO: We will need to add a FREE function to this as well I think.
792 (define-foreign-type foreign-type-wrapper
()
793 ((to-c :initarg
:to-c
:reader wrapper-to-c
)
794 (from-c :initarg
:from-c
:reader wrapper-from-c
))
795 (:documentation
"Wrapper type."))
797 (define-parse-method :wrapper
(base-type &key to-c from-c
)
798 (make-instance 'foreign-type-wrapper
799 :actual-type
(parse-type base-type
)
800 :to-c
(or to-c
'identity
)
801 :from-c
(or from-c
'identity
)))
803 (defmethod translate-to-foreign (value (type foreign-type-wrapper
))
804 (translate-to-foreign
805 (funcall (slot-value type
'to-c
) value
) (actual-type type
)))
807 (defmethod translate-from-foreign (value (type foreign-type-wrapper
))
808 (funcall (slot-value type
'from-c
)
809 (translate-from-foreign value
(actual-type type
))))
813 ;;; Boolean type. Maps to an :int by default. Only accepts integer types.
814 (define-foreign-type foreign-boolean-type
()
817 (define-parse-method :boolean
(&optional
(base-type :int
))
819 'foreign-boolean-type
:actual-type
820 (ecase (canonicalize-foreign-type base-type
)
821 ((:char
:unsigned-char
:int
:unsigned-int
:long
:unsigned-long
822 #-cffi-features
:no-long-long
:long-long
823 #-cffi-features
:no-long-long
:unsigned-long-long
) base-type
))))
825 (defmethod translate-to-foreign (value (type foreign-boolean-type
))
828 (defmethod translate-from-foreign (value (type foreign-boolean-type
))
831 (defmethod expand-to-foreign (value (type foreign-boolean-type
))
832 "Optimization for the :boolean type."
833 (if (constantp value
)
834 (if (eval value
) 1 0)
837 (defmethod expand-from-foreign (value (type foreign-boolean-type
))
838 "Optimization for the :boolean type."
839 (if (constantp value
) ; very unlikely, heh
840 (not (zerop (eval value
)))
841 `(not (zerop ,value
))))
843 ;;;# Typedefs for built-in types.
845 (defctype :uchar
:unsigned-char
)
846 (defctype :ushort
:unsigned-short
)
847 (defctype :uint
:unsigned-int
)
848 (defctype :ulong
:unsigned-long
)
849 (defctype :llong
:long-long
)
850 (defctype :ullong
:unsigned-long-long
)
852 ;;; We try to define the :[u]int{8,16,32,64} types by looking at
853 ;;; the sizes of the built-in integer types and defining typedefs.
854 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
856 ((match-types (sized-types mtypes
)
858 ,@(loop for
(type . size-or-type
) in sized-types
859 for m
= (car (member (if (keywordp size-or-type
)
860 (foreign-type-size size-or-type
)
862 mtypes
:key
#'foreign-type-size
))
863 when m collect
`(defctype ,type
,m
)))))
865 (match-types ((:int8 .
1) (:int16 .
2) (:int32 .
4) (:int64 .
8)
866 (:intptr .
:pointer
))
867 (:char
:short
:int
:long
:long-long
))
869 (match-types ((:uint8 .
1) (:uint16 .
2) (:uint32 .
4) (:uint64 .
8)
870 (:uintptr .
:pointer
))
871 (:unsigned-char
:unsigned-short
:unsigned-int
:unsigned-long
872 :unsigned-long-long
))))