gcc/testsuite/gfortran.dg/bind-c-contiguous-4.c

   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 }