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
87 if (num == 3)
88 {
89 if (x != NULL)
90 __builtin_abort ();
91 if (y != NULL)
92 __builtin_abort ();
93 if (z != NULL)
94 __builtin_abort ();
95 addr2 = fn (x, y, z, 3, num);
96 if (addr2.x != -1 || addr2.y != -1 || addr2.z != -1)
97 __builtin_abort ();
98 return addr2;
99 }
100 if (x == NULL)
101 __builtin_abort ();
102 if (y == NULL)
103 __builtin_abort ();
104 if (z == NULL)
105 __builtin_abort ();
106 basic_check (x, is_cont || num == 2);
107 basic_check (y, is_cont || num == 2);
108 basic_check (z, is_cont || num == 2);
109 if (!is_cont && num == 1)
110 {
111 check_str (x, "abc", zero);
112 check_str (x, "ghi", one);
113 check_str (x, "nop", two);
114 check_str (y, "abc", zero);
115 check_str (y, "ghi", one);
116 check_str (y, "nop", two);
117 check_str (z, "abc", zero);
118 check_str (z, "ghi", one);
119 check_str (z, "nop", two);
120 }
121 else if (num == 1)
122 {
123 if (strncmp ((const char*) x->base_addr, "abcghinop", 9) != 0)
124 __builtin_abort ();
125 if (strncmp ((const char*) y->base_addr, "abcghinop", 9) != 0)
126 __builtin_abort ();
127 if (strncmp ((const char*) z->base_addr, "abcghinop", 9) != 0)
128 __builtin_abort ();
129 }
130 else if (num == 2)
131 {
132 if (strncmp ((const char*) x->base_addr, "defghijlm", 9) != 0)
133 __builtin_abort ();
134 if (strncmp ((const char*) y->base_addr, "defghijlm", 9) != 0)
135 __builtin_abort ();
136 if (strncmp ((const char*) z->base_addr, "defghijlm", 9) != 0)
137 __builtin_abort ();
138 }
139 else
140 __builtin_abort ();
141 addr1.x = (intptr_t) x->base_addr;
142 addr1.y = (intptr_t) y->base_addr;
143 addr1.z = (intptr_t) z->base_addr;
144 addr2 = fn (x, y, z, 3, num);
145 if (!CFI_is_contiguous (x) && fort_cont)
146 {
147 /* Check for callee copy in/copy out. */
148 if (addr1.x == addr2.x || addr1.x != (intptr_t) x->base_addr)
149 __builtin_abort ();
150 if (addr1.y == addr2.y || addr1.y != (intptr_t) y->base_addr)
151 __builtin_abort ();
152 if (addr1.z == addr2.z || addr1.z != (intptr_t) z->base_addr)
153 __builtin_abort ();
154 }
155 else
156 {
157 if (addr1.x != addr2.x || addr1.x != (intptr_t) x->base_addr)
158 __builtin_abort ();
159 if (addr1.y != addr2.y || addr1.y != (intptr_t) y->base_addr)
160 __builtin_abort ();
161 if (addr1.z != addr2.z || addr1.z != (intptr_t) z->base_addr)
162 __builtin_abort ();
163 }
164 // intent_in
165 if (intent_in && !is_cont && num == 1)
166 {
167 check_str (x, "abc", zero);
168 check_str (x, "ghi", one);
169 check_str (x, "nop", two);
170 check_str (y, "abc", zero);
171 check_str (y, "ghi", one);
172 check_str (y, "nop", two);
173 check_str (z, "abc", zero);
174 check_str (z, "ghi", one);
175 check_str (z, "nop", two);
176 }
177 else if (intent_in && num == 1)
178 {
179 if (strncmp ((const char*) x->base_addr, "abcghinop", 9) != 0)
180 __builtin_abort ();
181 if (strncmp ((const char*) y->base_addr, "abcghinop", 9) != 0)
182 __builtin_abort ();
183 if (strncmp ((const char*) z->base_addr, "abcghinop", 9) != 0)
184 __builtin_abort ();
185 }
186 else if (intent_in && num == 2)
187 {
188 if (strncmp ((const char*) x->base_addr, "defghijlm", 9) != 0)
189 __builtin_abort ();
190 if (strncmp ((const char*) y->base_addr, "defghijlm", 9) != 0)
191 __builtin_abort ();
192 if (strncmp ((const char*) z->base_addr, "defghijlm", 9) != 0)
193 __builtin_abort ();
194 }
195 else if (intent_in)
196 __builtin_abort ();
197 if (intent_in)
198 {
199 if (is_cont && num == 1)
200 {
201 /* Copy in - set the value to check that no copy out is done. */
202 memcpy ((char*) x->base_addr, "123456789", 9);
203 memcpy ((char*) y->base_addr, "123456789", 9);
204 memcpy ((char*) z->base_addr, "123456789", 9);
205 }
206 return addr1;
207 }
208 // !intent_in
209 if (!is_cont && num == 1)
210 {
211 check_str (x, "ABC", zero);
212 check_str (x, "DEF", one);
213 check_str (x, "GHI", two);
214 check_str (y, "ABC", zero);
215 check_str (y, "DEF", one);
216 check_str (y, "GHI", two);
217 check_str (z, "ABC", zero);
218 check_str (z, "DEF", one);
219 check_str (z, "GHI", two);
220 }
221 else
222 {
223 if (strncmp ((const char*) x->base_addr, "ABCDEFGHI", 9) != 0)
224 __builtin_abort ();
225 if (strncmp ((const char*) y->base_addr, "ABCDEFGHI", 9) != 0)
226 __builtin_abort ();
227 if (strncmp ((const char*) z->base_addr, "ABCDEFGHI", 9) != 0)
228 __builtin_abort ();
229 }
230 return addr1;
231 }
232
233 struct loc_t
234 char_assumed_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
235 int k, int num)
236 {
237 return do_call (x, y, z, k, num, false, char_assumed_size_f, true, false);
238 }
239
240 struct loc_t
241 char_assumed_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
242 int k, int num)
243 {
244 return do_call (x, y, z, k, num, true, char_assumed_size_in_f, true, false);
245 }
246
247 struct loc_t
248 char_expl_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
249 int k, int num)
250 {
251 return do_call (x, y, z, k, num, false, char_expl_size_f, true, false);
252 }
253
254 struct loc_t
255 char_expl_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
256 int k, int num)
257 {
258 return do_call (x, y, z, k, num, true, char_expl_size_in_f, true, false);
259 }
260
261 struct loc_t
262 char_assumed_rank_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
263 int k, int num)
264 {
265 return do_call (x, y, z, k, num, false, char_assumed_rank_f, false, false);
266 }
267
268 struct loc_t
269 char_assumed_rank_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
270 int k, int num)
271 {
272 return do_call (x, y, z, k, num, true, char_assumed_rank_in_f, false, false);
273 }
274
275 struct loc_t
276 char_assumed_rank_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
277 int k, int num)
278 {
279 return do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, true, false);
280 }
281
282 struct loc_t
283 char_assumed_rank_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
284 int k, int num)
285 {
286 return do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, true, false);
287 }
288
289 static void
290 reset_var (CFI_cdesc_t *x, int num)
291 {
292 const CFI_index_t zero[1] = { 0 };
293 const CFI_index_t one[1] = { 1 };
294 const CFI_index_t two[1] = { 2 };
295
296 if (num == 1)
297 {
298 set_str (x, "abc", zero);
299 set_str (x, "ghi", one);
300 set_str (x, "nop", two);
301 }
302 else if (num == 2)
303 {
304 set_str (x, "def", zero);
305 set_str (x, "ghi", one);
306 set_str (x, "jlm", two);
307 }
308 else if (num == 3)
309 {
310 if (x != NULL)
311 __builtin_abort ();
312 }
313 else
314 __builtin_abort ();
315 }
316
317 static void
318 reset_vars (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, int num)
319 {
320 reset_var (x, num);
321 reset_var (y, num);
322 reset_var (z, num);
323 }
324
325 struct loc_t
326 char_assumed_shape_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
327 int k, int num)
328 {
329 /* Make use of having a noncontiguous argument to check that the callee
330 handles noncontiguous variables. */
331 do_call (x, y, z, k, num, false, char_assumed_size_f, false, true);
332 reset_vars (x, y, z, num);
333 do_call (x, y, z, k, num, true, char_assumed_size_in_f, false, true);
334 reset_vars (x, y, z, num);
335 do_call (x, y, z, k, num, false, char_expl_size_f, false, true);
336 reset_vars (x, y, z, num);
337 do_call (x, y, z, k, num, true, char_expl_size_in_f, false, true);
338 reset_vars (x, y, z, num);
339 do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, false, true);
340 reset_vars (x, y, z, num);
341 do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, false, true);
342 reset_vars (x, y, z, num);
343 do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, false, true);
344 reset_vars (x, y, z, num);
345 do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, false, true);
346 /* Actual func call. */
347 reset_vars (x, y, z, num);
348 return do_call (x, y, z, k, num, false, char_assumed_shape_f, false, false);
349 }
350
351 struct loc_t
352 char_assumed_shape_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
353 int k, int num)
354 {
355 return do_call (x, y, z, k, num, true, char_assumed_shape_in_f, false, false);
356 }
357
358 struct loc_t
359 char_assumed_shape_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
360 int k, int num)
361 {
362 return do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, true, false);
363 }
364
365 struct loc_t
366 char_assumed_shape_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
367 int k, int num)
368 {
369 return do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, true, false);
370 }