1  #include <ISO_Fortran_binding.h>
       2  
       3  intptr_t assumed_rank_alloc_f (CFI_cdesc_t *);
       4  intptr_t assumed_rank_pointer_f (CFI_cdesc_t *);
       5  intptr_t assumed_rank_f (CFI_cdesc_t *);
       6  intptr_t assumed_rank_cont_f (CFI_cdesc_t *);
       7  intptr_t assumed_shape_f (CFI_cdesc_t *);
       8  intptr_t assumed_shape_cont_f (CFI_cdesc_t *);
       9  intptr_t deferred_shape_alloc_f (CFI_cdesc_t *);
      10  intptr_t deferred_shape_pointer_f (CFI_cdesc_t *);
      11  
      12  
      13  static void
      14  basic_check(CFI_cdesc_t *x)
      15  {
      16    if (!x->base_addr)
      17      __builtin_abort ();
      18    if (x->elem_len != sizeof(int32_t))
      19      __builtin_abort ();
      20    if (x->version != CFI_VERSION)
      21      __builtin_abort ();
      22    if (x->rank != 4)
      23      __builtin_abort ();
      24    if (x->type != CFI_type_int32_t)
      25      __builtin_abort ();
      26    if (x->attribute == CFI_attribute_other)
      27      {
      28        if (x->dim[0].lower_bound != 0)
      29  	__builtin_abort ();
      30        if (x->dim[1].lower_bound != 0)
      31  	__builtin_abort ();
      32        if (x->dim[2].lower_bound != 0)
      33  	__builtin_abort ();
      34        if (x->dim[3].lower_bound != 0)
      35  	__builtin_abort ();
      36      }
      37  }
      38  
      39  intptr_t
      40  assumed_rank_alloc_c (CFI_cdesc_t *x)
      41  {
      42    basic_check (x);
      43    if (!CFI_is_contiguous (x))
      44      __builtin_abort ();
      45    if (x->attribute != CFI_attribute_allocatable)
      46      __builtin_abort ();
      47    intptr_t addr = (intptr_t) x->base_addr;
      48    intptr_t addr2 = assumed_rank_alloc_f (x);
      49    if (addr != addr2 || addr != (intptr_t) x->base_addr)
      50      __builtin_abort ();
      51    return addr;
      52  }
      53  
      54  intptr_t
      55  assumed_rank_pointer_c (CFI_cdesc_t *x)
      56  {
      57    basic_check (x);
      58    if (x->attribute != CFI_attribute_pointer)
      59      __builtin_abort ();
      60    intptr_t addr = (intptr_t) x->base_addr;
      61    intptr_t addr2 = assumed_rank_pointer_f (x);
      62    if (addr != addr2 || addr != (intptr_t) x->base_addr)
      63      __builtin_abort ();
      64    return addr;
      65  }
      66  
      67  
      68  intptr_t
      69  assumed_rank_c (CFI_cdesc_t *x)
      70  {
      71    basic_check (x);
      72    if (x->attribute != CFI_attribute_other)
      73      __builtin_abort ();
      74    intptr_t addr = (intptr_t) x->base_addr;
      75    intptr_t addr2 = assumed_rank_f (x);
      76    if (addr != addr2 || addr != (intptr_t) x->base_addr)
      77      __builtin_abort ();
      78    return addr;
      79  }
      80  
      81  intptr_t
      82  assumed_rank_cont_c (CFI_cdesc_t *x)
      83  {
      84    basic_check (x);
      85    if (!CFI_is_contiguous (x))
      86      __builtin_abort ();
      87    if (x->attribute != CFI_attribute_other)
      88      __builtin_abort ();
      89    intptr_t addr = (intptr_t) x->base_addr;
      90    intptr_t addr2 = assumed_rank_cont_f (x);
      91    if (addr != addr2 || addr != (intptr_t) x->base_addr)
      92      __builtin_abort ();
      93    return addr;
      94  }
      95  
      96  intptr_t
      97  assumed_shape_c (CFI_cdesc_t *x, int num)
      98  {
      99    basic_check (x);
     100    if (x->attribute != CFI_attribute_other)
     101      __builtin_abort ();
     102    intptr_t addr = (intptr_t) x->base_addr;
     103    intptr_t addr2;
     104    if (num == 1 || num == 2 || num == 3)
     105      {
     106        if (!CFI_is_contiguous (x))
     107  	__builtin_abort ();
     108      }
     109    else
     110      {
     111        if (CFI_is_contiguous (x))
     112  	__builtin_abort ();
     113      }
     114  
     115    if (num == 1 || num == 4)
     116      addr2 = assumed_shape_f (x);
     117    else if (num == 2 || num == 5)
     118      addr2 = assumed_shape_cont_f (x);
     119    else if (num == 3 || num == 6)
     120      addr2 = assumed_rank_cont_f (x);
     121    else
     122      __builtin_abort ();
     123  
     124    if (num == 1 || num == 2 || num == 3)
     125      {
     126        if (addr != addr2)
     127  	__builtin_abort ();
     128      }
     129    else
     130      {
     131        if (CFI_is_contiguous (x))
     132  	__builtin_abort ();
     133      }
     134    if (addr != (intptr_t) x->base_addr)
     135      __builtin_abort ();
     136    return addr2;
     137  }
     138  
     139  intptr_t
     140  assumed_shape_cont_c (CFI_cdesc_t *x)
     141  {
     142    basic_check (x);
     143    if (!CFI_is_contiguous (x))
     144      __builtin_abort ();
     145    if (x->attribute != CFI_attribute_other)
     146      __builtin_abort ();
     147    intptr_t addr = (intptr_t) x->base_addr;
     148    intptr_t addr2 = assumed_shape_cont_f (x);
     149    if (addr != addr2 || addr != (intptr_t) x->base_addr)
     150      __builtin_abort ();
     151    return addr;
     152  }
     153  
     154  intptr_t
     155  deferred_shape_alloc_c (CFI_cdesc_t *x)
     156  {
     157    basic_check (x);
     158    if (!CFI_is_contiguous (x))
     159      __builtin_abort ();
     160    if (x->attribute != CFI_attribute_allocatable)
     161      __builtin_abort ();
     162    intptr_t addr = (intptr_t) x->base_addr;
     163    intptr_t addr2 = deferred_shape_alloc_f (x);
     164    if (addr != addr2 || addr != (intptr_t) x->base_addr)
     165      __builtin_abort ();
     166    return addr;
     167  }
     168  
     169  intptr_t
     170  deferred_shape_pointer_c (CFI_cdesc_t *x)
     171  {
     172    basic_check (x);
     173    if (x->attribute != CFI_attribute_pointer)
     174      __builtin_abort ();
     175    intptr_t addr = (intptr_t) x->base_addr;
     176    intptr_t addr2 = deferred_shape_pointer_f (x);
     177    if (addr != addr2 || addr != (intptr_t) x->base_addr)
     178      __builtin_abort ();
     179    return addr;
     180  }