fsbv.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
---
fsbv.lisp (5358B)
---
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; fsbv.lisp --- Tests of foreign structure by value calls.
4 ;;;
5 ;;; Copyright (C) 2011, Liam M. Healy
6 ;;;
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:
14 ;;;
15 ;;; The above copyright notice and this permission notice shall be
16 ;;; included in all copies or substantial portions of the Software.
17 ;;;
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.
26 ;;;
27
28 (in-package #:cffi-tests)
29
30 ;; Requires struct.lisp
31
32 (defcfun "sumpair" :int
33 (p (:struct struct-pair)))
34
35 (defcfun "makepair" (:struct struct-pair)
36 (condition :bool))
37
38 (defcfun "doublepair" (:struct struct-pair)
39 (p (:struct struct-pair)))
40
41 (defcfun "prodsumpair" :double
42 (p (:struct struct-pair+double)))
43
44 (defcfun "doublepairdouble" (:struct struct-pair+double)
45 (p (:struct struct-pair+double)))
46
47 ;;; Call struct by value
48 (deftest fsbv.1
49 (sumpair '(1 . 2))
50 3)
51
52 ;;; See lp#1528719
53 (deftest (fsbv.wfo :expected-to-fail t)
54 (with-foreign-object (arg '(:struct struct-pair))
55 (convert-into-foreign-memory '(40 . 2) '(:struct struct-pair) arg)
56 (sumpair arg))
57 42)
58
59 ;;; Call and return struct by value
60 (deftest fsbv.2
61 (doublepair '(1 . 2))
62 (2 . 4))
63
64 ;;; return struct by value
65 (deftest (fsbv.makepair.1 :expected-to-fail t)
66 (makepair nil)
67 (-127 . 43))
68
69 (deftest (fsbv.makepair.2 :expected-to-fail t)
70 (makepair t)
71 (-127 . 42))
72
73 ;;; Call recursive structure by value
74 (deftest fsbv.3
75 (prodsumpair '(pr (a 4 b 5) dbl 2.5d0))
76 22.5d0)
77
78 ;;; Call and return recursive structure by value
79 (deftest fsbv.4
80 (let ((ans (doublepairdouble '(pr (a 4 b 5) dbl 2.5d0))))
81 (values (getf (getf ans 'pr) 'a)
82 (getf (getf ans 'pr) 'b)
83 (getf ans 'dbl)))
84 8
85 10
86 5.0d0)
87
88 (defcstruct (struct-with-array :size 6)
89 (s1 (:array :char 6)))
90
91 (defcfun "zork" :void
92 (p (:struct struct-with-array)))
93
94 ;;; Typedef fsbv test
95
96 (defcfun ("sumpair" sumpair2) :int
97 (p struct-pair-typedef1))
98
99 (deftest fsbv.5
100 (sumpair2 '(1 . 2))
101 3)
102
103 (defcfun "returnpairpointer" (:pointer (:struct struct-pair))
104 (ignored (:struct struct-pair)))
105
106 (deftest fsbv.return-a-pointer
107 (let ((ptr (returnpairpointer '(1 . 2))))
108 (+ (foreign-slot-value ptr '(:struct struct-pair) 'a)
109 (foreign-slot-value ptr '(:struct struct-pair) 'b)))
110 42)
111
112 ;;; Test ulonglong on no-long-long implementations.
113
114 (defcfun "ullsum" :unsigned-long-long
115 (a :unsigned-long-long) (b :unsigned-long-long))
116
117 (deftest fsbv.6
118 (ullsum #x10DEADBEEF #x2300000000)
119 #x33DEADBEEF)
120
121 ;;; Combine structures by value with a string argument
122 (defcfun "stringlenpair" (:struct struct-pair)
123 (s :string)
124 (p (:struct struct-pair)))
125
126 (deftest fsbv.7
127 (stringlenpair "abc" '(1 . 2))
128 (3 . 6))
129
130 ;;; Combine structures by value with an enum argument
131 (defcfun "enumpair" (:int)
132 (e numeros)
133 (p (:struct struct-pair)))
134
135 (deftest fsbv.8
136 (enumpair :two '(1 . 2))
137 5)
138
139 ;;; returning struct with bitfield member (bug #1474631)
140 (defbitfield (struct-bitfield :unsigned-int)
141 (:a 1)
142 (:b 2))
143
144 (defcstruct bitfield-struct
145 (b struct-bitfield))
146
147 (defcfun "structbitfield" (:struct bitfield-struct)
148 (x :unsigned-int))
149
150 (defctype struct-bitfield-typedef struct-bitfield)
151
152 (defcstruct bitfield-struct.2
153 (b struct-bitfield-typedef))
154
155 (defcfun ("structbitfield" structbitfield.2) (:struct bitfield-struct.2)
156 (x :unsigned-int))
157
158 ;; these would get stuck in an infinite loop previously
159 (deftest fsbv.struct-bitfield.0
160 (structbitfield 0)
161 (b nil))
162
163 (deftest fsbv.struct-bitfield.1
164 (structbitfield 1)
165 (b (:a)))
166
167 (deftest fsbv.struct-bitfield.2
168 (structbitfield 2)
169 (b (:b)))
170
171 (deftest fsbv.struct-bitfield.3
172 (structbitfield.2 2)
173 (b (:b)))
174
175 ;;; Test for a discrepancy between normal and fsbv return values
176 (cffi:define-foreign-type int-return-code (cffi::foreign-type-alias)
177 ()
178 (:default-initargs :actual-type (cffi::parse-type :int))
179 (:simple-parser int-return-code))
180
181 (defmethod cffi:expand-from-foreign (value (type int-return-code))
182 ;; NOTE: strictly speaking it should be
183 ;; (cffi:convert-from-foreign ,value :int), but it's irrelevant in this case
184 `(let ((return-code ,value))
185 (check-type return-code integer)
186 return-code))
187
188 (defcfun (noargs-with-typedef "noargs") int-return-code)
189
190 (deftest fsbv.noargs-with-typedef ; for reference, not an FSBV call
191 (noargs-with-typedef)
192 42)
193
194 (defcfun (sumpair-with-typedef "sumpair") int-return-code
195 (p (:struct struct-pair)))
196
197 (deftest (fsbv.return-value-typedef)
198 (sumpair-with-typedef '(40 . 2))
199 42)