1 #include <ISO_Fortran_binding.h>
2 #include <stdbool.h>
3 #include <string.h>
4
5 struct loc_t {
6 intptr_t x, y, z;
7 };
8
9 typedef struct loc_t (*ftn_fn) (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
10 struct loc_t char_assumed_size_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
11 struct loc_t char_assumed_size_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
12 struct loc_t char_expl_size_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int);
13 struct loc_t char_expl_size_in_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int);
14 struct loc_t char_assumed_rank_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
15 struct loc_t char_assumed_rank_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
16 struct loc_t char_assumed_rank_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
17 struct loc_t char_assumed_rank_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
18 struct loc_t char_assumed_shape_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
19 struct loc_t char_assumed_shape_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
20 struct loc_t char_assumed_shape_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
21 struct loc_t char_assumed_shape_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
22
23 static void
24 basic_check(CFI_cdesc_t *x, bool is_cont)
25 {
26 if (!x->base_addr)
27 __builtin_abort ();
28 if (x->elem_len != 3*sizeof(char))
29 __builtin_abort ();
30 if (x->version != CFI_VERSION)
31 __builtin_abort ();
32 if (x->rank != 1)
33 __builtin_abort ();
34 if (x->attribute != CFI_attribute_other)
35 __builtin_abort ();
36 if (x->type != CFI_type_char)
37 __builtin_abort ();
38 if (x->dim[0].lower_bound != 0)
39 __builtin_abort ();
40 if (x->dim[0].extent != 3)
41 __builtin_abort ();
42 if (CFI_is_contiguous (x) != (x->elem_len == x->dim[0].sm))
43 __builtin_abort ();
44 if (is_cont != CFI_is_contiguous (x))
45 __builtin_abort ();
46 }
47
48 static void
49 print_str (void *p, size_t len)
50 {
51 __builtin_printf ("DEBUG: >");
52 for (size_t i = 0; i < len; ++i)
53 __builtin_printf ("%c", ((const char*) p)[i]);
54 __builtin_printf ("<\n");
55 }
56
57 static void
58 check_str (CFI_cdesc_t *x, const char *str, const CFI_index_t subscripts[])
59 {
60 /* Avoid checking for '\0'. */
61 if (strncmp ((const char*) CFI_address (x, subscripts), str, strlen(str)) != 0)
62 __builtin_abort ();
63 }
64
65 static void
66 set_str (CFI_cdesc_t *x, const char *str, const CFI_index_t subscripts[])
67 {
68 char *p = CFI_address (x, subscripts);
69 size_t len = strlen (str);
70 if (x->elem_len != len)
71 __builtin_abort ();
72 for (size_t i = 0; i < len; ++i)
73 p[i] = str[i];
74 }
75
76 static struct loc_t
77 do_call (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
78 int k, int num, bool intent_in, ftn_fn fn, bool is_cont, bool fort_cont)
79 {
80 const CFI_index_t zero[1] = { 0 };
81 const CFI_index_t one[1] = { 1 };
82 const CFI_index_t two[1] = { 2 };
83 struct loc_t addr1, addr2;
84 if (k != 3)
85 __builtin_abort ();
86 basic_check (x, is_cont || num == 2);
87 basic_check (y, is_cont || num == 2);
88 basic_check (z, is_cont || num == 2);
89 if (!is_cont && num == 1)
90 {
91 check_str (x, "abc", zero);
92 check_str (x, "ghi", one);
93 check_str (x, "nop", two);
94 check_str (y, "abc", zero);
95 check_str (y, "ghi", one);
96 check_str (y, "nop", two);
97 check_str (z, "abc", zero);
98 check_str (z, "ghi", one);
99 check_str (z, "nop", two);
100 }
101 else if (num == 1)
102 {
103 if (strncmp ((const char*) x->base_addr, "abcghinop", 9) != 0)
104 __builtin_abort ();
105 if (strncmp ((const char*) y->base_addr, "abcghinop", 9) != 0)
106 __builtin_abort ();
107 if (strncmp ((const char*) z->base_addr, "abcghinop", 9) != 0)
108 __builtin_abort ();
109 }
110 else if (num == 2)
111 {
112 if (strncmp ((const char*) x->base_addr, "defghijlm", 9) != 0)
113 __builtin_abort ();
114 if (strncmp ((const char*) y->base_addr, "defghijlm", 9) != 0)
115 __builtin_abort ();
116 if (strncmp ((const char*) z->base_addr, "defghijlm", 9) != 0)
117 __builtin_abort ();
118 }
119 else
120 __builtin_abort ();
121 addr1.x = (intptr_t) x->base_addr;
122 addr1.y = (intptr_t) y->base_addr;
123 addr1.z = (intptr_t) z->base_addr;
124 addr2 = fn (x, y, z, 3, num);
125 if (!CFI_is_contiguous (x) && fort_cont)
126 {
127 /* Check for callee copy in/copy out. */
128 if (addr1.x == addr2.x || addr1.x != (intptr_t) x->base_addr)
129 __builtin_abort ();
130 if (addr1.y == addr2.y || addr1.y != (intptr_t) y->base_addr)
131 __builtin_abort ();
132 if (addr1.z == addr2.z || addr1.z != (intptr_t) z->base_addr)
133 __builtin_abort ();
134 }
135 else
136 {
137 if (addr1.x != addr2.x || addr1.x != (intptr_t) x->base_addr)
138 __builtin_abort ();
139 if (addr1.y != addr2.y || addr1.y != (intptr_t) y->base_addr)
140 __builtin_abort ();
141 if (addr1.z != addr2.z || addr1.z != (intptr_t) z->base_addr)
142 __builtin_abort ();
143 }
144 // intent_in
145 if (intent_in && !is_cont && num == 1)
146 {
147 check_str (x, "abc", zero);
148 check_str (x, "ghi", one);
149 check_str (x, "nop", two);
150 check_str (y, "abc", zero);
151 check_str (y, "ghi", one);
152 check_str (y, "nop", two);
153 check_str (z, "abc", zero);
154 check_str (z, "ghi", one);
155 check_str (z, "nop", two);
156 }
157 else if (intent_in && num == 1)
158 {
159 if (strncmp ((const char*) x->base_addr, "abcghinop", 9) != 0)
160 __builtin_abort ();
161 if (strncmp ((const char*) y->base_addr, "abcghinop", 9) != 0)
162 __builtin_abort ();
163 if (strncmp ((const char*) z->base_addr, "abcghinop", 9) != 0)
164 __builtin_abort ();
165 }
166 else if (intent_in && num == 2)
167 {
168 if (strncmp ((const char*) x->base_addr, "defghijlm", 9) != 0)
169 __builtin_abort ();
170 if (strncmp ((const char*) y->base_addr, "defghijlm", 9) != 0)
171 __builtin_abort ();
172 if (strncmp ((const char*) z->base_addr, "defghijlm", 9) != 0)
173 __builtin_abort ();
174 }
175 else if (intent_in)
176 __builtin_abort ();
177 if (intent_in)
178 {
179 if (is_cont && num == 1)
180 {
181 /* Copy in - set the value to check that no copy out is done. */
182 memcpy ((char*) x->base_addr, "123456789", 9);
183 memcpy ((char*) y->base_addr, "123456789", 9);
184 memcpy ((char*) z->base_addr, "123456789", 9);
185 }
186 return addr1;
187 }
188 // !intent_in
189 if (!is_cont && num == 1)
190 {
191 check_str (x, "ABC", zero);
192 check_str (x, "DEF", one);
193 check_str (x, "GHI", two);
194 check_str (y, "ABC", zero);
195 check_str (y, "DEF", one);
196 check_str (y, "GHI", two);
197 check_str (z, "ABC", zero);
198 check_str (z, "DEF", one);
199 check_str (z, "GHI", two);
200 }
201 else
202 {
203 if (strncmp ((const char*) x->base_addr, "ABCDEFGHI", 9) != 0)
204 __builtin_abort ();
205 if (strncmp ((const char*) y->base_addr, "ABCDEFGHI", 9) != 0)
206 __builtin_abort ();
207 if (strncmp ((const char*) z->base_addr, "ABCDEFGHI", 9) != 0)
208 __builtin_abort ();
209 }
210 return addr1;
211 }
212
213 struct loc_t
214 char_assumed_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
215 int k, int num)
216 {
217 return do_call (x, y, z, k, num, false, char_assumed_size_f, true, false);
218 }
219
220 struct loc_t
221 char_assumed_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
222 int k, int num)
223 {
224 return do_call (x, y, z, k, num, true, char_assumed_size_in_f, true, false);
225 }
226
227 struct loc_t
228 char_expl_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
229 int k, int num)
230 {
231 return do_call (x, y, z, k, num, false, char_expl_size_f, true, false);
232 }
233
234 struct loc_t
235 char_expl_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
236 int k, int num)
237 {
238 return do_call (x, y, z, k, num, true, char_expl_size_in_f, true, false);
239 }
240
241 struct loc_t
242 char_assumed_rank_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
243 int k, int num)
244 {
245 return do_call (x, y, z, k, num, false, char_assumed_rank_f, false, false);
246 }
247
248 struct loc_t
249 char_assumed_rank_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
250 int k, int num)
251 {
252 return do_call (x, y, z, k, num, true, char_assumed_rank_in_f, false, false);
253 }
254
255 struct loc_t
256 char_assumed_rank_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
257 int k, int num)
258 {
259 return do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, true, false);
260 }
261
262 struct loc_t
263 char_assumed_rank_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
264 int k, int num)
265 {
266 return do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, true, false);
267 }
268
269 static void
270 reset_var (CFI_cdesc_t *x, int num)
271 {
272 const CFI_index_t zero[1] = { 0 };
273 const CFI_index_t one[1] = { 1 };
274 const CFI_index_t two[1] = { 2 };
275
276 if (num == 1)
277 {
278 set_str (x, "abc", zero);
279 set_str (x, "ghi", one);
280 set_str (x, "nop", two);
281 }
282 else if (num == 2)
283 {
284 set_str (x, "def", zero);
285 set_str (x, "ghi", one);
286 set_str (x, "jlm", two);
287 }
288 else
289 __builtin_abort ();
290 }
291
292 static void
293 reset_vars (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, int num)
294 {
295 reset_var (x, num);
296 reset_var (y, num);
297 reset_var (z, num);
298 }
299
300 struct loc_t
301 char_assumed_shape_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
302 int k, int num)
303 {
304 /* Make use of having a noncontiguous argument to check that the callee
305 handles noncontiguous variables. */
306 do_call (x, y, z, k, num, false, char_assumed_size_f, false, true);
307 reset_vars (x, y, z, num);
308 do_call (x, y, z, k, num, true, char_assumed_size_in_f, false, true);
309 reset_vars (x, y, z, num);
310 do_call (x, y, z, k, num, false, char_expl_size_f, false, true);
311 reset_vars (x, y, z, num);
312 do_call (x, y, z, k, num, true, char_expl_size_in_f, false, true);
313 reset_vars (x, y, z, num);
314 do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, false, true);
315 reset_vars (x, y, z, num);
316 do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, false, true);
317 reset_vars (x, y, z, num);
318 do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, false, true);
319 reset_vars (x, y, z, num);
320 do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, false, true);
321 /* Actual func call. */
322 reset_vars (x, y, z, num);
323 return do_call (x, y, z, k, num, false, char_assumed_shape_f, false, false);
324 }
325
326 struct loc_t
327 char_assumed_shape_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
328 int k, int num)
329 {
330 return do_call (x, y, z, k, num, true, char_assumed_shape_in_f, false, false);
331 }
332
333 struct loc_t
334 char_assumed_shape_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
335 int k, int num)
336 {
337 return do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, true, false);
338 }
339
340 struct loc_t
341 char_assumed_shape_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
342 int k, int num)
343 {
344 return do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, true, false);
345 }