fsbv.lisp - clic - Clic is an command line interactive client for gopher writte… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
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 thi… | |
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) |