types.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
---
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 <jamesjb@jamesjb.com>
6 ;;; Copyright (C) 2005-2007, Luis Oliveira <loliveira@common-lisp.net>
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-unsigned-char
35 ;; and "char" may be either signed or unsigned, i.e. treating it as a small int
36 ;; is not wise. At the level of CFFI we can safely ignore this and assume that
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 aggregate,
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 offset)
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-type))
164 (expand-from-foreign `(%mem-ref ,ptr ,ctype ,offset) parsed-type)))
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 offset))
178 (%mem-set (translate-to-foreign value ptype) ptr ctype offset))))
179
180 (define-setf-expander mem-ref (ptr type &optional (offset 0) &environment env)
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-tmp)))
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) &environment env)
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 macros
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 type))))
268 `(mem-set ,store ,getter ,type
269 (* ,index-tmp ,(foreign-type-size (eval type)))))
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-other-keys)
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 array
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 CFFI array
412 type; the type of the resulting Lisp array can be defined in MAKE-ARRAY-ARGS
413 that are then passed to MAKE-ARRAY. If POINTER is a null pointer, returns NIL."
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-type))
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) param)
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-slot))
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-struct-slot))
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-slot))
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-slot))
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-struct-type))
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-struct-slot))
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/LowLevelABI/index.html
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 body)
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) slotdef
698 (when (eq (canonicalize-foreign-type type) :void)
699 (simple-foreign-type-error type :struct
700 "In struct ~S: void type not allowed in field ~S"
701 name slotdef))
702 (setq current-offset
703 (or offset
704 (adjust-for-alignment type current-offset :normal firstp)))
705 (let* ((slot (make-struct-slot slotname current-offset type count))
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) ',slot))
725 collect `(defun (setf ,accessor) (value ,pointer-arg)
726 (foreign-slot-set value ,pointer-arg '(:struct ,name) ',slot))))
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) (symbolicate name '-tclass)))
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-name)
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-name)
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 &environment env)
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)) value))
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' or `(:pointer 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 class-name)))
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 slot))))
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 pointer)
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 allowed in field ~S"
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 folding:
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-type)
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-long
1057 :unsigned-long-long))))