1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
3 ;;; misc-types.lisp --- Various tests on the type system.
5 ;;; Copyright (C) 2005-2006, Luis Oliveira <loliveira(@)common-lisp.net>
7 ;;; Permission is hereby granted, free of charge, to any person
8 ;;; obtaining a copy of this software and associated documentation
9 ;;; files (the "Software"), to deal in the Software without
10 ;;; restriction, including without limitation the rights to use, copy,
11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
12 ;;; of the Software, and to permit persons to whom the Software is
13 ;;; furnished to do so, subject to the following conditions:
15 ;;; The above copyright notice and this permission notice shall be
16 ;;; included in all copies or substantial portions of the Software.
18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
21 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
25 ;;; DEALINGS IN THE SOFTWARE.
28 (in-package #:cffi-tests
)
30 (defcfun ("my_strdup" strdup
) :string
+ptr
(str :string
))
32 (deftest misc-types.string
+ptr
33 (destructuring-bind (string pointer
)
35 (foreign-free pointer
)
39 (deftest misc-types.string
+ptr.ub8
40 (destructuring-bind (string pointer
)
41 (strdup (make-array 3 :element-type
'(unsigned-byte 8)
42 :initial-contents
(map 'list
#'char-code
"foo")))
43 (foreign-free pointer
)
47 (deftest misc-types.string.ub8.1
48 (let ((array (make-array 7 :element-type
'(unsigned-byte 8)
49 :initial-contents
'(84 117 114 97 110 103 97))))
50 (with-foreign-string (foreign-string array
)
51 (foreign-string-to-lisp foreign-string
)))
54 (deftest misc-types.string.ub8.2
55 (let ((str (foreign-string-alloc
56 (make-array 7 :element-type
'(unsigned-byte 8)
57 :initial-contents
'(84 117 114 97 110 103 97)))))
58 (prog1 (foreign-string-to-lisp str
)
59 (foreign-string-free str
)))
62 (defcfun "equalequal" :boolean
64 (b (:boolean
:unsigned-int
)))
66 (defcfun "bool_and" (:boolean
:char
)
67 (a (:boolean
:unsigned-char
))
70 (defcfun "bool_xor" (:boolean
:unsigned-long
)
72 (b (:boolean
:unsigned-long
)))
74 (deftest misc-types.boolean
.1
75 (list (equalequal nil nil
)
85 ;;; Regression test: boolean type only worked with canonicalized
86 ;;; built-in integer types. Should work for any type that canonicalizes
87 ;;; to a built-in integer type.
88 (defctype int-for-bool
:int
)
89 (defcfun ("equalequal" equalequal2
) :boolean
90 (a (:boolean int-for-bool
))
93 (deftest misc-types.boolean
.2
97 (defctype my-string
:string
+ptr
)
100 (concatenate 'string
"MORE " (string-upcase str
)))
102 (defun 3rd-person (value)
103 (list (concatenate 'string
"Strdup says: " (first value
))
106 ;; (defctype funky-string
107 ;; (:wrapper my-string
109 ;; :from-c (lambda (value)
111 ;; (concatenate 'string "Strdup says: "
116 (defctype funky-string
(:wrapper my-string
:to-c funkify
:from-c
3rd-person
))
118 (defcfun ("my_strdup" funky-strdup
) funky-string
121 (deftest misc-types.wrapper
122 (destructuring-bind (string ptr
)
123 (funky-strdup "code")
126 "Strdup says: MORE CODE")
128 (deftest misc-types.sized-ints
129 (mapcar #'foreign-type-size
'(:int8
:uint8
:int16
:uint16
:int32
:uint32
130 #-cffi-features
:no-long-long
:int64
131 #-cffi-features
:no-long-long
:uint64
))
133 #-cffi-features
:no-long-long
8
134 #-cffi-features
:no-long-long
8))
136 (define-foreign-type error-error
()
139 (:simple-parser error-error
))
141 (defmethod translate-to-foreign (value (type error-error
))
142 (declare (ignore value
))
143 (error "translate-to-foreign invoked."))
145 (defmethod translate-from-foreign (value (type error-error
))
146 (declare (ignore value
))
147 (error "translate-from-foreign invoked."))
149 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
150 (defmethod expand-to-foreign (value (type error-error
))
153 (defmethod expand-from-foreign (value (type error-error
))
156 (defcfun ("abs" expand-abs
) error-error
159 (defcvar ("var_int" *expand-var-int
*) error-error
)
161 (defcfun ("expect_int_sum" expand-expect-int-sum
) :boolean
164 (defcallback expand-int-sum error-error
((x error-error
) (y error-error
))
167 ;;; Ensure that macroexpansion-time translators are called where this
168 ;;; is guaranteed (defcfun, defcvar, foreign-funcall and defcallback)
169 (deftest misc-types.expand
.1
173 #-cffi-features
:no-foreign-funcall
174 (deftest misc-types.expand
.2
175 (foreign-funcall "abs" error-error -
1 error-error
)
178 (deftest misc-types.expand
.3
179 (let ((old (mem-ref (get-var-pointer '*expand-var-int
*) :int
)))
182 (setf *expand-var-int
* 42)
184 (setf (mem-ref (get-var-pointer '*expand-var-int
*) :int
) old
)))
187 (deftest misc-types.expand
.4
188 (expand-expect-int-sum (callback expand-int-sum
))
191 (define-foreign-type translate-tracker
()
194 (:simple-parser translate-tracker
))
196 (declaim (special .fto-called.
))
198 (defmethod free-translated-object (value (type translate-tracker
) param
)
199 (declare (ignore value param
))
200 (setf .fto-called. t
))
202 (define-foreign-type expand-tracker
()
205 (:simple-parser expand-tracker
))
207 (defmethod free-translated-object (value (type expand-tracker
) param
)
208 (declare (ignore value param
))
209 (setf .fto-called. t
))
211 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
212 (defmethod expand-to-foreign (value (type expand-tracker
))
213 (declare (ignore value
))
216 (defcfun ("abs" ttracker-abs
) :int
217 (n translate-tracker
))
219 (defcfun ("abs" etracker-abs
) :int
222 ;; free-translated-object must be called when there is no etf
223 (deftest misc-types.expand
.5
224 (let ((.fto-called. nil
))
229 ;; free-translated-object must be called when there is an etf, but
230 ;; they answer *runtime-translator-form*
231 (deftest misc-types.expand
.6
232 (let ((.fto-called. nil
))