Coverage report: /home/luis/src/cffi/src/types.lisp

KindCoveredAll%
expression415466 89.1
branch85104 81.7
Key
Not instrumented
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
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
 (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)
44
 
45
 #-cffi-features:no-long-long
46
 (progn
47
   (define-built-in-foreign-type :long-long)
48
   (define-built-in-foreign-type :unsigned-long-long))
49
 
50
 ;;; When some lisp other than SCL supports :long-double we should
51
 ;;; use #-cffi-features:no-long-double here instead.
52
 #+(and scl long-float) (define-built-in-foreign-type :long-double)
53
 
54
 ;;;# Foreign Pointers
55
 
56
 (define-modify-macro incf-pointer (&optional (offset 1)) inc-pointer)
57
 
58
 (defun mem-ref (ptr type &optional (offset 0))
59
   "Return the value of TYPE at OFFSET bytes from PTR. If TYPE is aggregate,
60
 we don't return its 'value' but a pointer to it, which is PTR itself."
61
   (let ((ptype (parse-type type)))
62
     (if (aggregatep ptype)
63
         (inc-pointer ptr offset)
64
         (let ((raw-value (%mem-ref ptr (canonicalize ptype) offset)))
65
           (translate-from-foreign raw-value ptype)))))
66
 
67
 (define-compiler-macro mem-ref (&whole form ptr type &optional (offset 0))
68
   "Compiler macro to open-code MEM-REF when TYPE is constant."
69
   (if (constantp type)
70
       (let ((parsed-type (parse-type (eval type))))
71
         (if (aggregatep parsed-type)
72
             `(inc-pointer ,ptr ,offset)
73
             (expand-from-foreign
74
              `(%mem-ref ,ptr ,(canonicalize parsed-type) ,offset)
75
              parsed-type)))
76
       form))
77
 
78
 (defun mem-set (value ptr type &optional (offset 0))
79
   "Set the value of TYPE at OFFSET bytes from PTR to VALUE."
80
   (let ((ptype (parse-type type)))
81
     (%mem-set (translate-to-foreign value ptype)
82
               ptr (canonicalize ptype) offset)))
83
 
84
 (define-setf-expander mem-ref (ptr type &optional (offset 0) &environment env)
85
   "SETF expander for MEM-REF that doesn't rebind TYPE.
86
 This is necessary for the compiler macro on MEM-SET to be able
87
 to open-code (SETF MEM-REF) forms."
88
   (multiple-value-bind (dummies vals newval setter getter)
89
       (get-setf-expansion ptr env)
90
     (declare (ignore setter newval))
91
     ;; if either TYPE or OFFSET are constant, we avoid rebinding them
92
     ;; so that the compiler macros on MEM-SET and %MEM-SET work.
93
     (with-unique-names (store type-tmp offset-tmp)
94
       (values
95
        (append (unless (constantp type)   (list type-tmp))
96
                (unless (constantp offset) (list offset-tmp))
97
                dummies)
98
        (append (unless (constantp type)   (list type))
99
                (unless (constantp offset) (list offset))
100
                vals)
101
        (list store)
102
        `(progn
103
           (mem-set ,store ,getter
104
                    ,@(if (constantp type)   (list type)   (list type-tmp))
105
                    ,@(if (constantp offset) (list offset) (list offset-tmp)))
106
           ,store)
107
        `(mem-ref ,getter
108
                  ,@(if (constantp type)   (list type)   (list type-tmp))
109
                  ,@(if (constantp offset) (list offset) (list offset-tmp)))))))
110
 
111
 (define-compiler-macro mem-set
112
     (&whole form value ptr type &optional (offset 0))
113
   "Compiler macro to open-code (SETF MEM-REF) when type is constant."
114
   (if (constantp type)
115
       (let ((parsed-type (parse-type (eval type))))
116
         `(%mem-set ,(expand-to-foreign value parsed-type) ,ptr
117
                    ,(canonicalize parsed-type) ,offset))
118
       form))
119
 
120
 ;;;# Dereferencing Foreign Arrays
121
 
122
 (defun mem-aref (ptr type &optional (index 0))
123
   "Like MEM-REF except for accessing 1d arrays."
124
   (mem-ref ptr type (* index (foreign-type-size type))))
125
 
126
 (define-compiler-macro mem-aref (&whole form ptr type &optional (index 0))
127
   "Compiler macro to open-code MEM-AREF when TYPE (and eventually INDEX)."
128
   (if (constantp type)
129
       (if (constantp index)
130
           `(mem-ref ,ptr ,type
131
                     ,(* (eval index) (foreign-type-size (eval type))))
132
           `(mem-ref ,ptr ,type (* ,index ,(foreign-type-size (eval type)))))
133
       form))
134
 
135
 (define-setf-expander mem-aref (ptr type &optional (index 0) &environment env)
136
   "SETF expander for MEM-AREF."
137
   (multiple-value-bind (dummies vals newval setter getter)
138
       (get-setf-expansion ptr env)
139
     (declare (ignore setter newval))
140
     ;; we avoid rebinding type and index, if possible (and if type is not
141
     ;; constant, we don't bother about the index), so that the compiler macros
142
     ;; on MEM-SET or %MEM-SET can work.
143
     (with-unique-names (store type-tmp index-tmp)
144
       (values
145
        (append (unless (constantp type)
146
                  (list type-tmp))
147
                (unless (and (constantp type) (constantp index))
148
                  (list index-tmp))
149
                dummies)
150
        (append (unless (constantp type)
151
                  (list type))
152
                (unless (and (constantp type) (constantp index))
153
                  (list index))
154
                vals)
155
        (list store)
156
        ;; Here we'll try to calculate the offset from the type and index,
157
        ;; or if not possible at least get the type size early.
158
        `(progn
159
           ,(if (constantp type)
160
                (if (constantp index)
161
                    `(mem-set ,store ,getter ,type
162
                              ,(* (eval index) (foreign-type-size (eval type))))
163
                    `(mem-set ,store ,getter ,type
164
                              (* ,index-tmp ,(foreign-type-size (eval type)))))
165
                `(mem-set ,store ,getter ,type-tmp
166
                          (* ,index-tmp (foreign-type-size ,type-tmp))))
167
           ,store)
168
        `(mem-aref ,getter
169
                   ,@(if (constantp type)
170
                         (list type)
171
                         (list type-tmp))
172
                   ,@(if (and (constantp type) (constantp index))
173
                         (list index)
174
                         (list index-tmp)))))))
175
 
176
 ;;;# Foreign Structures
177
 
178
 ;;;## Foreign Structure Slots
179
 
180
 (defgeneric foreign-struct-slot-pointer (ptr slot)
181
   (:documentation
182
    "Get the address of SLOT relative to PTR."))
183
 
184
 (defgeneric foreign-struct-slot-pointer-form (ptr slot)
185
   (:documentation
186
    "Return a form to get the address of SLOT in PTR."))
187
 
188
 (defgeneric foreign-struct-slot-value (ptr slot)
189
   (:documentation
190
    "Return the value of SLOT in structure PTR."))
191
 
192
 (defgeneric (setf foreign-struct-slot-value) (value ptr slot)
193
   (:documentation
194
    "Set the value of a SLOT in structure PTR."))
195
 
196
 (defgeneric foreign-struct-slot-value-form (ptr slot)
197
   (:documentation
198
    "Return a form to get the value of SLOT in struct PTR."))
199
 
200
 (defgeneric foreign-struct-slot-set-form (value ptr slot)
201
   (:documentation
202
    "Return a form to set the value of SLOT in struct PTR."))
203
 
204
 (defclass foreign-struct-slot ()
205
   ((name   :initarg :name   :reader   slot-name)
206
    (offset :initarg :offset :accessor slot-offset)
207
    (type   :initarg :type   :accessor slot-type))
208
   (:documentation "Base class for simple and aggregate slots."))
209
 
210
 (defmethod foreign-struct-slot-pointer (ptr (slot foreign-struct-slot))
211
   "Return the address of SLOT relative to PTR."
212
   (inc-pointer ptr (slot-offset slot)))
213
 
214
 (defmethod foreign-struct-slot-pointer-form (ptr (slot foreign-struct-slot))
215
   "Return a form to get the address of SLOT relative to PTR."
216
   (let ((offset (slot-offset slot)))
217
     (if (zerop offset)
218
         ptr
219
         `(inc-pointer ,ptr ,offset))))
220
 
221
 (defun foreign-slot-names (type)
222
   "Returns a list of TYPE's slot names in no particular order."
223
   (loop for value being the hash-values
224
         in (slots (follow-typedefs (parse-type type)))
225
         collect (slot-name value)))
226
 
227
 ;;;### Simple Slots
228
 
229
 (defclass simple-struct-slot (foreign-struct-slot)
230
   ()
231
   (:documentation "Non-aggregate structure slots."))
232
 
233
 (defmethod foreign-struct-slot-value (ptr (slot simple-struct-slot))
234
   "Return the value of a simple SLOT from a struct at PTR."
235
   (mem-ref ptr (slot-type slot) (slot-offset slot)))
236
 
237
 (defmethod foreign-struct-slot-value-form (ptr (slot simple-struct-slot))
238
   "Return a form to get the value of a slot from PTR."
239
   `(mem-ref ,ptr ',(slot-type slot) ,(slot-offset slot)))
240
 
241
 (defmethod (setf foreign-struct-slot-value) (value ptr (slot simple-struct-slot))
242
   "Set the value of a simple SLOT to VALUE in PTR."
243
   (setf (mem-ref ptr (slot-type slot) (slot-offset slot)) value))
244
 
245
 (defmethod foreign-struct-slot-set-form (value ptr (slot simple-struct-slot))
246
   "Return a form to set the value of a simple structure slot."
247
   `(setf (mem-ref ,ptr ',(slot-type slot) ,(slot-offset slot)) ,value))
248
 
249
 ;;;### Aggregate Slots
250
 
251
 (defclass aggregate-struct-slot (foreign-struct-slot)
252
   ((count :initarg :count :accessor slot-count))
253
   (:documentation "Aggregate structure slots."))
254
 
255
 ;;; A case could be made for just returning an error here instead of
256
 ;;; this rather DWIM-ish behavior to return the address.  It would
257
 ;;; complicate being able to chain together slot names when accessing
258
 ;;; slot values in nested structures though.
259
 (defmethod foreign-struct-slot-value (ptr (slot aggregate-struct-slot))
260
   "Return a pointer to SLOT relative to PTR."
261
   (foreign-struct-slot-pointer ptr slot))
262
 
263
 (defmethod foreign-struct-slot-value-form (ptr (slot aggregate-struct-slot))
264
   "Return a form to get the value of SLOT relative to PTR."
265
   (foreign-struct-slot-pointer-form ptr slot))
266
 
267
 ;;; This is definitely an error though.  Eventually, we could define a
268
 ;;; new type of type translator that can convert certain aggregate
269
 ;;; types, notably C strings or arrays of integers.  For now, just error.
270
 (defmethod (setf foreign-struct-slot-value) (value ptr (slot aggregate-struct-slot))
271
   "Signal an error; setting aggregate slot values is forbidden."
272
   (declare (ignore value ptr))
273
   (error "Cannot set value of aggregate slot ~A." slot))
274
 
275
 (defmethod foreign-struct-slot-set-form (value ptr (slot aggregate-struct-slot))
276
   "Signal an error; setting aggregate slot values is forbidden."
277
   (declare (ignore value ptr))
278
   (error "Cannot set value of aggregate slot ~A." slot))
279
 
280
 ;;;## Defining Foreign Structures
281
 
282
 (defun make-struct-slot (name offset type count)
283
   "Make the appropriate type of structure slot."
284
   ;; If TYPE is an aggregate type or COUNT is >1, create an
285
   ;; AGGREGATE-STRUCT-SLOT, otherwise a SIMPLE-STRUCT-SLOT.
286
   (if (or (> count 1) (aggregatep (parse-type type)))
287
       (make-instance 'aggregate-struct-slot :offset offset :type type
288
                      :name name :count count)
289
       (make-instance 'simple-struct-slot :offset offset :type type
290
                      :name name)))
291
 
292
 ;;; Regarding structure alignment, the following ABIs were checked:
293
 ;;;   - System-V ABI: x86, x86-64, ppc, arm, mips and itanium. (more?)
294
 ;;;   - Mac OS X ABI Function Call Guide: ppc32, ppc64 and x86.
295
 ;;;
296
 ;;; Rules used here:
297
 ;;;
298
 ;;;   1. "An entire structure or union object is aligned on the same
299
 ;;;       boundary as its most strictly aligned member."
300
 ;;;
301
 ;;;   2. "Each member is assigned to the lowest available offset with
302
 ;;;       the appropriate alignment. This may require internal
303
 ;;;       padding, depending on the previous member."
304
 ;;;
305
 ;;;   3. "A structure's size is increased, if necessary, to make it a
306
 ;;;       multiple of the alignment. This may require tail padding,
307
 ;;;       depending on the last member."
308
 ;;;
309
 ;;; Special case from darwin/ppc32's ABI:
310
 ;;; http://developer.apple.com/documentation/DeveloperTools/Conceptual/LowLevelABI/index.html
311
 ;;;
312
 ;;;   1. "The embedding alignment of the first element in a data
313
 ;;;       structure is equal to the element's natural alignment."
314
 ;;;
315
 ;;;   2. "For subsequent elements that have a natural alignment
316
 ;;;       greater than 4 bytes, the embedding alignment is 4, unless
317
 ;;;       the element is a vector."  (note: this applies for
318
 ;;;       structures too)
319
 
320
 ;; FIXME: get a better name for this. --luis
321
 (defun get-alignment (type alignment-type firstp)
322
   "Return alignment for TYPE according to ALIGNMENT-TYPE."
323
   (declare (ignorable firstp))
324
   (ecase alignment-type
325
     (:normal #-(and cffi-features:darwin cffi-features:ppc32)
326
              (foreign-type-alignment type)
327
              #+(and cffi-features:darwin cffi-features:ppc32)
328
              (if firstp
329
                  (foreign-type-alignment type)
330
                  (min 4 (foreign-type-alignment type))))))
331
 
332
 (defun adjust-for-alignment (type offset alignment-type firstp)
333
   "Return OFFSET aligned properly for TYPE according to ALIGNMENT-TYPE."
334
   (let* ((align (get-alignment type alignment-type firstp))
335
          (rem (mod offset align)))
336
     (if (zerop rem)
337
         offset
338
         (+ offset (- align rem)))))
339
 
340
 (defun notice-foreign-struct-definition (name-and-options slots)
341
   "Parse and install a foreign structure definition."
342
   (destructuring-bind (name &key size #+nil alignment)
343
       (ensure-list name-and-options)
344
     (let ((struct (make-instance 'foreign-struct-type :name name))
345
           (current-offset 0)
346
           (max-align 1)
347
           (firstp t))
348
       ;; determine offsets
349
       (dolist (slotdef slots)
350
         (destructuring-bind (slotname type &key (count 1) offset) slotdef
351
           (when (eq (canonicalize-foreign-type type) :void)
352
             (error "void type not allowed in structure definition: ~S" slotdef))
353
           (setq current-offset
354
                 (or offset
355
                     (adjust-for-alignment type current-offset :normal firstp)))
356
           (let* ((slot (make-struct-slot slotname current-offset type count))
357
                  (align (get-alignment (slot-type slot) :normal firstp)))
358
             (setf (gethash slotname (slots struct)) slot)
359
             (when (> align max-align)
360
               (setq max-align align)))
361
           (incf current-offset (* count (foreign-type-size type))))
362
         (setq firstp nil))
363
       ;; calculate padding and alignment
364
       (setf (alignment struct) max-align) ; See point 1 above.
365
       (let ((tail-padding (- max-align (rem current-offset max-align))))
366
         (unless (= tail-padding max-align) ; See point 3 above.
367
           (incf current-offset tail-padding)))
368
       (setf (size struct) (or size current-offset))
369
       (notice-foreign-type name struct))))
370
 
371
 (defmacro defcstruct (name &body fields)
372
   "Define the layout of a foreign structure."
373
   (discard-docstring fields)
374
   `(eval-when (:compile-toplevel :load-toplevel :execute)
375
      (notice-foreign-struct-definition ',name ',fields)))
376
 
377
 ;;;## Accessing Foreign Structure Slots
378
 
379
 (defun get-slot-info (type slot-name)
380
   "Return the slot info for SLOT-NAME or raise an error."
381
   (let* ((struct (follow-typedefs (parse-type type)))
382
          (info (gethash slot-name (slots struct))))
383
     (unless info
384
       (error "Undefined slot ~A in foreign type ~A." slot-name type))
385
     info))
386
 
387
 (defun foreign-slot-pointer (ptr type slot-name)
388
   "Return the address of SLOT-NAME in the structure at PTR."
389
   (foreign-struct-slot-pointer ptr (get-slot-info type slot-name)))
390
 
391
 (defun foreign-slot-offset (type slot-name)
392
   "Return the offset of SLOT in a struct TYPE."
393
   (slot-offset (get-slot-info type slot-name)))
394
 
395
 (defun foreign-slot-value (ptr type slot-name)
396
   "Return the value of SLOT-NAME in the foreign structure at PTR."
397
   (foreign-struct-slot-value ptr (get-slot-info type slot-name)))
398
 
399
 (define-compiler-macro foreign-slot-value (&whole form ptr type slot-name)
400
   "Optimizer for FOREIGN-SLOT-VALUE when TYPE is constant."
401
   (if (and (constantp type) (constantp slot-name))
402
       (foreign-struct-slot-value-form
403
        ptr (get-slot-info (eval type) (eval slot-name)))
404
       form))
405
 
406
 (define-setf-expander foreign-slot-value (ptr type slot-name &environment env)
407
   "SETF expander for FOREIGN-SLOT-VALUE."
408
   (multiple-value-bind (dummies vals newval setter getter)
409
       (get-setf-expansion ptr env)
410
     (declare (ignore setter newval))
411
     (if (and (constantp type) (constantp slot-name))
412
         ;; if TYPE and SLOT-NAME are constant we avoid rebinding them
413
         ;; so that the compiler macro on FOREIGN-SLOT-SET works.
414
         (with-unique-names (store)
415
           (values
416
            dummies
417
            vals
418
            (list store)
419
            `(progn
420
               (foreign-slot-set ,store ,getter ,type ,slot-name)
421
               ,store)
422
            `(foreign-slot-value ,getter ,type ,slot-name)))
423
         ;; if not...
424
         (with-unique-names (store slot-name-tmp type-tmp)
425
           (values
426
            (list* type-tmp slot-name-tmp dummies)
427
            (list* type slot-name vals)
428
            (list store)
429
            `(progn
430
               (foreign-slot-set ,store ,getter ,type-tmp ,slot-name-tmp)
431
               ,store)
432
            `(foreign-slot-value ,getter ,type-tmp ,slot-name-tmp))))))
433
 
434
 (defun foreign-slot-set (value ptr type slot-name)
435
   "Set the value of SLOT-NAME in a foreign structure."
436
   (setf (foreign-struct-slot-value ptr (get-slot-info type slot-name)) value))
437
 
438
 (define-compiler-macro foreign-slot-set
439
     (&whole form value ptr type slot-name)
440
   "Optimizer when TYPE and SLOT-NAME are constant."
441
   (if (and (constantp type) (constantp slot-name))
442
       (foreign-struct-slot-set-form
443
        value ptr (get-slot-info (eval type) (eval slot-name)))
444
       form))
445
 
446
 (defmacro with-foreign-slots ((vars ptr type) &body body)
447
   "Create local symbol macros for each var in VARS to reference
448
 foreign slots in PTR of TYPE.  Similar to WITH-SLOTS."
449
   (let ((ptr-var (gensym "PTR")))
450
     `(let ((,ptr-var ,ptr))
451
        (symbol-macrolet
452
            ,(loop for var in vars
453
                   collect `(,var (foreign-slot-value ,ptr-var ',type ',var)))
454
          ,@body))))
455
 
456
 ;;;# Foreign Unions
457
 ;;;
458
 ;;; A union is a FOREIGN-STRUCT-TYPE in which all slots have an offset
459
 ;;; of zero.
460
 
461
 ;;; See also the notes regarding ABI requirements in
462
 ;;; NOTICE-FOREIGN-STRUCT-DEFINITION
463
 (defun notice-foreign-union-definition (name-and-options slots)
464
   "Parse and install a foreign union definition."
465
   (destructuring-bind (name &key size)
466
       (ensure-list name-and-options)
467
     (let ((struct (make-instance 'foreign-struct-type :name name))
468
           (max-size 0)
469
           (max-align 0))
470
       (dolist (slotdef slots)
471
         (destructuring-bind (slotname type &key (count 1)) slotdef
472
           (when (eq (canonicalize-foreign-type type) :void)
473
             (error "void type not allowed in union definition: ~S" slotdef))
474
           (let* ((slot (make-struct-slot slotname 0 type count))
475
                  (size (* count (foreign-type-size type)))
476
                  (align (foreign-type-alignment (slot-type slot))))
477
             (setf (gethash slotname (slots struct)) slot)
478
             (when (> size max-size)
479
               (setf max-size size))
480
             (when (> align max-align)
481
               (setf max-align align)))))
482
       (setf (size struct) (or size max-size))
483
       (setf (alignment struct) max-align)
484
       (notice-foreign-type name struct))))
485
 
486
 (defmacro defcunion (name &body fields)
487
   "Define the layout of a foreign union."
488
   (discard-docstring fields)
489
   `(eval-when (:compile-toplevel :load-toplevel :execute)
490
      (notice-foreign-union-definition ',name ',fields)))
491
 
492
 ;;;# Operations on Types
493
 
494
 (defmethod foreign-type-alignment (type)
495
   "Return the alignment in bytes of a foreign type."
496
   (foreign-type-alignment (parse-type type)))
497
 
498
 (defun foreign-alloc (type &key (initial-element nil initial-element-p)
499
                       (initial-contents nil initial-contents-p)
500
                       (count 1 count-p) null-terminated-p)
501
   "Allocate enough memory to hold COUNT objects of type TYPE. If
502
 INITIAL-ELEMENT is supplied, each element of the newly allocated
503
 memory is initialized with its value. If INITIAL-CONTENTS is supplied,
504
 each of its elements will be used to initialize the contents of the
505
 newly allocated memory."
506
   (let (contents-length)
507
     ;; Some error checking, etc...
508
     (when (and null-terminated-p
509
                (not (eq (canonicalize-foreign-type type) :pointer)))
510
       (error "Cannot use :NULL-TERMINATED-P with non-pointer types."))
511
     (when (and initial-element-p initial-contents-p)
512
       (error "Cannot specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS"))
513
     (when initial-contents-p
514
       (setq contents-length (length initial-contents))
515
       (if count-p
516
           (assert (>= count contents-length))
517
           (setq count contents-length)))
518
     ;; Everything looks good.
519
     (let ((ptr (%foreign-alloc (* (foreign-type-size type)
520
                                   (if null-terminated-p (1+ count) count)))))
521
       (when initial-element-p
522
         (dotimes (i count)
523
           (setf (mem-aref ptr type i) initial-element)))
524
       (when initial-contents-p
525
         (dotimes (i contents-length)
526
           (setf (mem-aref ptr type i) (elt initial-contents i))))
527
       (when null-terminated-p
528
         (setf (mem-aref ptr :pointer count) (null-pointer)))
529
       ptr)))
530
 
531
 ;;; Stuff we could optimize here:
532
 ;;;   1. (and (constantp type) (constantp count)) => calculate size
533
 ;;;   2. (constantp type) => use the translators' expanders
534
 #-(and)
535
 (define-compiler-macro foreign-alloc
536
     (&whole form type &key (initial-element nil initial-element-p)
537
      (initial-contents nil initial-contents-p) (count 1 count-p))
538
   )
539
 
540
 (defmacro with-foreign-object ((var type &optional (count 1)) &body body)
541
   "Bind VAR to a pointer to COUNT objects of TYPE during BODY.
542
 The buffer has dynamic extent and may be stack allocated."
543
   `(with-foreign-pointer
544
        (,var ,(if (constantp type)
545
                   ;; with-foreign-pointer may benefit from constant folding:
546
                   (if (constantp count)
547
                       (* (eval count) (foreign-type-size (eval type)))
548
                       `(* ,count ,(foreign-type-size (eval type))))
549
                   `(* ,count (foreign-type-size ,type))))
550
      ,@body))
551
 
552
 (defmacro with-foreign-objects (bindings &rest body)
553
   (if bindings
554
       `(with-foreign-object ,(car bindings)
555
          (with-foreign-objects ,(cdr bindings)
556
            ,@body))
557
       `(progn ,@body)))
558
 
559
 ;;;## Anonymous Type Translators
560
 ;;;
561
 ;;; (:wrapper :to-c some-function :from-c another-function)
562
 ;;;
563
 ;;; TODO: We will need to add a FREE function to this as well I think.
564
 ;;; --james
565
 
566
 (define-foreign-type foreign-type-wrapper ()
567
   ((to-c   :initarg :to-c   :reader wrapper-to-c)
568
    (from-c :initarg :from-c :reader wrapper-from-c))
569
   (:documentation "Wrapper type."))
570
 
571
 (define-parse-method :wrapper (base-type &key to-c from-c)
572
   (make-instance 'foreign-type-wrapper
573
                  :actual-type (parse-type base-type)
574
                  :to-c (or to-c 'identity)
575
                  :from-c (or from-c 'identity)))
576
 
577
 (defmethod translate-to-foreign (value (type foreign-type-wrapper))
578
   (translate-to-foreign
579
    (funcall (slot-value type 'to-c) value) (actual-type type)))
580
 
581
 (defmethod translate-from-foreign (value (type foreign-type-wrapper))
582
   (funcall (slot-value type 'from-c)
583
            (translate-from-foreign value (actual-type type))))
584
 
585
 ;;;# Other types
586
 
587
 ;;; Boolean type. Maps to an :int by default. Only accepts integer types.
588
 (define-foreign-type foreign-boolean-type ()
589
   ())
590
 
591
 (define-parse-method :boolean (&optional (base-type :int))
592
   (make-instance
593
    'foreign-boolean-type :actual-type
594
    (ecase (canonicalize-foreign-type base-type)
595
      ((:char :unsigned-char :int :unsigned-int :long :unsigned-long
596
        #-cffi-features:no-long-long :long-long
597
        #-cffi-features:no-long-long :unsigned-long-long) base-type))))
598
 
599
 (defmethod translate-to-foreign (value (type foreign-boolean-type))
600
   (if value 1 0))
601
 
602
 (defmethod translate-from-foreign (value (type foreign-boolean-type))
603
   (not (zerop value)))
604
 
605
 (defmethod expand-to-foreign (value (type foreign-boolean-type))
606
   "Optimization for the :boolean type."
607
   (if (constantp value)
608
       (if (eval value) 1 0)
609
       `(if ,value 1 0)))
610
 
611
 (defmethod expand-from-foreign (value (type foreign-boolean-type))
612
   "Optimization for the :boolean type."
613
   (if (constantp value) ; very unlikely, heh
614
       (not (zerop (eval value)))
615
       `(not (zerop ,value))))
616
 
617
 ;;;# Typedefs for built-in types.
618
 
619
 (defctype :uchar  :unsigned-char)
620
 (defctype :ushort :unsigned-short)
621
 (defctype :uint   :unsigned-int)
622
 (defctype :ulong  :unsigned-long)
623
 
624
 #-cffi-features:no-long-long
625
 (progn
626
   (defctype :llong  :long-long)
627
   (defctype :ullong :unsigned-long-long))
628
 
629
 ;;; We try to define the :[u]int{8,16,32,64} types by looking at
630
 ;;; the sizes of the built-in integer types and defining typedefs.
631
 (eval-when (:compile-toplevel :load-toplevel :execute)
632
   (macrolet
633
       ((match-types (sized-types mtypes)
634
          `(progn
635
             ,@(loop for (type . size) in sized-types
636
                     for m = (car (member size mtypes :key #'foreign-type-size))
637
                     when m collect `(defctype ,type ,m)))))
638
     ;; signed
639
     (match-types ((:int8 . 1) (:int16 . 2) (:int32 . 4) (:int64 . 8))
640
                  (:char :short :int :long
641
                   #-cffi-features:no-long-long :long-long))
642
     ;; unsigned
643
     (match-types ((:uint8 . 1) (:uint16 . 2) (:uint32 . 4) (:uint64 . 8))
644
                  (:unsigned-char :unsigned-short :unsigned-int :unsigned-long
645
                   #-cffi-features:no-long-long :unsigned-long-long))))
646