Coverage report: /home/luis/src/cffi/src/types.lisp
Kind | Covered | All | % |
expression | 415 | 466 | 89.1 |
branch | 85 | 104 | 81.7 |
Key
Not instrumented
Executed
Not executed
Both branches taken
One branch taken
Neither branch taken
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
;;; 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)
56
(define-modify-macro incf-pointer (&optional (offset 1)) inc-pointer)
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)))))
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."
70
(let ((parsed-type (parse-type (eval type))))
71
(if (aggregatep parsed-type)
72
`(inc-pointer ,ptr ,offset)
74
`(%mem-ref ,ptr ,(canonicalize parsed-type) ,offset)
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)))
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)
95
(append (unless (constantp type) (list type-tmp))
96
(unless (constantp offset) (list offset-tmp))
98
(append (unless (constantp type) (list type))
99
(unless (constantp offset) (list offset))
103
(mem-set ,store ,getter
104
,@(if (constantp type) (list type) (list type-tmp))
105
,@(if (constantp offset) (list offset) (list offset-tmp)))
108
,@(if (constantp type) (list type) (list type-tmp))
109
,@(if (constantp offset) (list offset) (list offset-tmp)))))))
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."
115
(let ((parsed-type (parse-type (eval type))))
116
`(%mem-set ,(expand-to-foreign value parsed-type) ,ptr
117
,(canonicalize parsed-type) ,offset))
120
;;;# Dereferencing Foreign Arrays
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))))
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)."
129
(if (constantp index)
131
,(* (eval index) (foreign-type-size (eval type))))
132
`(mem-ref ,ptr ,type (* ,index ,(foreign-type-size (eval type)))))
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)
145
(append (unless (constantp type)
147
(unless (and (constantp type) (constantp index))
150
(append (unless (constantp type)
152
(unless (and (constantp type) (constantp index))
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.
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))))
169
,@(if (constantp type)
172
,@(if (and (constantp type) (constantp index))
174
(list index-tmp)))))))
176
;;;# Foreign Structures
178
;;;## Foreign Structure Slots
180
(defgeneric foreign-struct-slot-pointer (ptr slot)
182
"Get the address of SLOT relative to PTR."))
184
(defgeneric foreign-struct-slot-pointer-form (ptr slot)
186
"Return a form to get the address of SLOT in PTR."))
188
(defgeneric foreign-struct-slot-value (ptr slot)
190
"Return the value of SLOT in structure PTR."))
192
(defgeneric (setf foreign-struct-slot-value) (value ptr slot)
194
"Set the value of a SLOT in structure PTR."))
196
(defgeneric foreign-struct-slot-value-form (ptr slot)
198
"Return a form to get the value of SLOT in struct PTR."))
200
(defgeneric foreign-struct-slot-set-form (value ptr slot)
202
"Return a form to set the value of SLOT in struct PTR."))
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."))
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)))
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)))
219
`(inc-pointer ,ptr ,offset))))
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)))
229
(defclass simple-struct-slot (foreign-struct-slot)
231
(:documentation "Non-aggregate structure slots."))
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)))
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)))
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))
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))
249
;;;### Aggregate Slots
251
(defclass aggregate-struct-slot (foreign-struct-slot)
252
((count :initarg :count :accessor slot-count))
253
(:documentation "Aggregate structure slots."))
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))
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))
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))
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))
280
;;;## Defining Foreign Structures
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
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.
298
;;; 1. "An entire structure or union object is aligned on the same
299
;;; boundary as its most strictly aligned member."
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."
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."
309
;;; Special case from darwin/ppc32's ABI:
310
;;; http://developer.apple.com/documentation/DeveloperTools/Conceptual/LowLevelABI/index.html
312
;;; 1. "The embedding alignment of the first element in a data
313
;;; structure is equal to the element's natural alignment."
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
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)
329
(foreign-type-alignment type)
330
(min 4 (foreign-type-alignment type))))))
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)))
338
(+ offset (- align rem)))))
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))
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))
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))))
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))))
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)))
377
;;;## Accessing Foreign Structure Slots
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))))
384
(error "Undefined slot ~A in foreign type ~A." slot-name type))
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)))
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)))
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)))
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)))
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)
420
(foreign-slot-set ,store ,getter ,type ,slot-name)
422
`(foreign-slot-value ,getter ,type ,slot-name)))
424
(with-unique-names (store slot-name-tmp type-tmp)
426
(list* type-tmp slot-name-tmp dummies)
427
(list* type slot-name vals)
430
(foreign-slot-set ,store ,getter ,type-tmp ,slot-name-tmp)
432
`(foreign-slot-value ,getter ,type-tmp ,slot-name-tmp))))))
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))
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)))
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))
452
,(loop for var in vars
453
collect `(,var (foreign-slot-value ,ptr-var ',type ',var)))
458
;;; A union is a FOREIGN-STRUCT-TYPE in which all slots have an offset
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))
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))))
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)))
492
;;;# Operations on Types
494
(defmethod foreign-type-alignment (type)
495
"Return the alignment in bytes of a foreign type."
496
(foreign-type-alignment (parse-type type)))
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))
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
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)))
531
;;; Stuff we could optimize here:
532
;;; 1. (and (constantp type) (constantp count)) => calculate size
533
;;; 2. (constantp type) => use the translators' expanders
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))
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))))
552
(defmacro with-foreign-objects (bindings &rest body)
554
`(with-foreign-object ,(car bindings)
555
(with-foreign-objects ,(cdr bindings)
559
;;;## Anonymous Type Translators
561
;;; (:wrapper :to-c some-function :from-c another-function)
563
;;; TODO: We will need to add a FREE function to this as well I think.
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."))
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)))
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)))
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))))
587
;;; Boolean type. Maps to an :int by default. Only accepts integer types.
588
(define-foreign-type foreign-boolean-type ()
591
(define-parse-method :boolean (&optional (base-type :int))
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))))
599
(defmethod translate-to-foreign (value (type foreign-boolean-type))
602
(defmethod translate-from-foreign (value (type foreign-boolean-type))
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)
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))))
617
;;;# Typedefs for built-in types.
619
(defctype :uchar :unsigned-char)
620
(defctype :ushort :unsigned-short)
621
(defctype :uint :unsigned-int)
622
(defctype :ulong :unsigned-long)
624
#-cffi-features:no-long-long
626
(defctype :llong :long-long)
627
(defctype :ullong :unsigned-long-long))
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)
633
((match-types (sized-types mtypes)
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)))))
639
(match-types ((:int8 . 1) (:int16 . 2) (:int32 . 4) (:int64 . 8))
640
(:char :short :int :long
641
#-cffi-features:no-long-long :long-long))
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))))