gcc/testsuite/gfortran.dg/PR100914.c

   1 /* Test the fix for PR100914 */
   2
   3 #include <assert.h>
   4 #include <complex.h>
   5 #include <stdbool.h>
   6 #include <stdio.h>
   7 #include <math.h>
   8
   9 #include <ISO_Fortran_binding.h>
  10
  11 #define _CFI_type_mask 0xFF
  12 #define _CFI_type_kind_shift 8
  13
  14 #define _CFI_decode_type(NAME) (signed char)((NAME) & CFI_type_mask)
  15 #define _CFI_decode_kind(NAME) (signed char)(((NAME) >> CFI_type_kind_shift) & CFI_type_mask)
  16
  17 #define _CFI_encode_type(TYPE, KIND) (int16_t)\
  18 ((((KIND) & CFI_type_mask) << CFI_type_kind_shift)\
  19  | ((TYPE) & CFI_type_mask))
  20
  21 #undef CMPLXF
  22 #define CMPLXF(x, y) ((float complex)((float)(x) + I * (float)(y)))
  23
  24 #undef CMPLX
  25 #define CMPLX(x, y) ((double complex)((double)(x) + (double complex)I * (double)(y)))
  26
  27 #undef CMPLXL
  28 #define CMPLXL(x, y) ((long double complex)((long double)(x) + (long double complex)I * (long double)(y)))
  29
  30 #undef CMPLX
  31 #define CMPLX(x, y) ((_Float128 _Complex )((double)(x) + (double complex)I * (double)(y)))
  32
  33 #define N 11
  34 #define M 7
  35
  36 typedef float _Complex c_float_complex;
  37 typedef double _Complex c_double_complex;
  38 typedef long double _Complex c_long_double_complex;
  39 typedef _Float128 _Complex c_float128_complex;
  40
  41 bool c_vrfy_c_float_complex (const CFI_cdesc_t *restrict);
  42
  43 bool c_vrfy_c_double_complex (const CFI_cdesc_t *restrict);
  44
  45 bool c_vrfy_c_long_double_complex (const CFI_cdesc_t *restrict);
  46
  47 bool c_vrfy_c_float128_complex (const CFI_cdesc_t *restrict);
  48
  49 bool c_vrfy_complex (const CFI_cdesc_t *restrict);
  50
  51 bool c_vrfy_desc (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t);
  52
  53 void check_tk (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t);
  54
  55
  56
  57 bool
  58 c_vrfy_c_float_complex (const CFI_cdesc_t *restrict auxp)
  59 {
  60   CFI_index_t i, lb, ub, ex;
  61   size_t sz;
  62   c_float_complex *ip = NULL;
  63
  64   assert (auxp);
  65   assert (auxp->base_addr);
  66   assert (auxp->elem_len>0);
  67   lb = auxp->dim[0].lower_bound;
  68   ex = auxp->dim[0].extent;
  69   assert (ex==11);
  70   sz = (size_t)auxp->elem_len / sizeof (c_float_complex);
  71   assert (sz==1);
  72   ub = ex + lb - 1;
  73   ip = (c_float_complex*)auxp->base_addr;
  74   for (i=0; i<ex; i++, ip+=sz)
  75     if ((cabsf (*ip-(c_float_complex)(CMPLXF((i+1), (2*(i+1)))))>(float)0.0))
  76       return false;
  77   for (i=lb; i<ub+1; i++)
  78     {
  79       ip = (c_float_complex*)CFI_address(auxp, &i);
  80       if ((cabsf (*ip-(c_float_complex)(CMPLXF((i-lb+1), (2*(i-lb+1)))))>(float)0.0))
  81         return false;
  82     }
  83   return true;
  84 }
  85
  86 bool
  87 c_vrfy_c_double_complex (const CFI_cdesc_t *restrict auxp)
  88 {
  89   CFI_index_t i, lb, ub, ex;
  90   size_t sz;
  91   c_double_complex *ip = NULL;
  92
  93   assert (auxp);
  94   assert (auxp->base_addr);
  95   assert (auxp->elem_len>0);
  96   lb = auxp->dim[0].lower_bound;
  97   ex = auxp->dim[0].extent;
  98   assert (ex==11);
  99   sz = (size_t)auxp->elem_len / sizeof (c_double_complex);
 100   assert (sz==1);
 101   ub = ex + lb - 1;
 102   ip = (c_double_complex*)auxp->base_addr;
 103   for (i=0; i<ex; i++, ip+=sz)
 104     if ((cabs (*ip-(c_double_complex)(CMPLX((i+1), (2*(i+1)))))>(double)0.0))
 105       return false;
 106   for (i=lb; i<ub+1; i++)
 107     {
 108       ip = (c_double_complex*)CFI_address(auxp, &i);
 109       if ((cabs (*ip-(c_double_complex)(CMPLX((i-lb+1), (2*(i-lb+1)))))>(double)0.0))
 110         return false;
 111     }
 112   return true;
 113 }
 114
 115 bool
 116 c_vrfy_c_long_double_complex (const CFI_cdesc_t *restrict auxp)
 117 {
 118   CFI_index_t i, lb, ub, ex;
 119   size_t sz;
 120   c_long_double_complex *ip = NULL;
 121
 122   assert (auxp);
 123   assert (auxp->base_addr);
 124   assert (auxp->elem_len>0);
 125   lb = auxp->dim[0].lower_bound;
 126   ex = auxp->dim[0].extent;
 127   assert (ex==11);
 128   sz = (size_t)auxp->elem_len / sizeof (c_long_double_complex);
 129   assert (sz==1);
 130   ub = ex + lb - 1;
 131   ip = (c_long_double_complex*)auxp->base_addr;
 132   for (i=0; i<ex; i++, ip+=sz)
 133     if ((cabsl (*ip-(c_long_double_complex)(CMPLXL((i+1), (2*(i+1)))))>(long double)0.0))
 134       return false;
 135   for (i=lb; i<ub+1; i++)
 136     {
 137       ip = (c_long_double_complex*)CFI_address(auxp, &i);
 138       if ((cabsl (*ip-(c_long_double_complex)(CMPLXL((i-lb+1), (2*(i-lb+1)))))>(long double)0.0))
 139         return false;
 140     }
 141   return true;
 142 }
 143
 144 bool
 145 c_vrfy_c_float128_complex (const CFI_cdesc_t *restrict auxp)
 146 {
 147   CFI_index_t i, lb, ub, ex;
 148   size_t sz;
 149   c_float128_complex *ip = NULL;
 150
 151   assert (auxp);
 152   assert (auxp->base_addr);
 153   assert (auxp->elem_len>0);
 154   lb = auxp->dim[0].lower_bound;
 155   ex = auxp->dim[0].extent;
 156   assert (ex==11);
 157   sz = (size_t)auxp->elem_len / sizeof (c_float128_complex);
 158   assert (sz==1);
 159   ub = ex + lb - 1;
 160   ip = (c_float128_complex*)auxp->base_addr;
 161   for (i=0; i<ex; i++, ip+=sz)
 162     if ((cabs ((double complex)(*ip-(c_float128_complex)(CMPLX((i+1), (2*(i+1))))))>(double)0.0))
 163       return false;
 164   for (i=lb; i<ub+1; i++)
 165     {
 166       ip = (c_float128_complex*)CFI_address(auxp, &i);
 167       if ((cabs ((double complex)(*ip-(c_float128_complex)(CMPLX((i-lb+1), (2*(i-lb+1))))))>(double)0.0))
 168         return false;
 169     }
 170   return true;
 171 }
 172
 173 bool
 174 c_vrfy_complex (const CFI_cdesc_t *restrict auxp)
 175 {
 176   signed char type, kind;
 177
 178   assert (auxp);
 179   type = _CFI_decode_type(auxp->type);
 180   kind = _CFI_decode_kind(auxp->type);
 181   assert (type == CFI_type_Complex);
 182   switch (kind)
 183     {
 184     case 4:
 185       return c_vrfy_c_float_complex (auxp);
 186       break;
 187     case 8:
 188       return c_vrfy_c_double_complex (auxp);
 189       break;
 190     case 10:
 191       return c_vrfy_c_long_double_complex (auxp);
 192       break;
 193     case 16:
 194       return c_vrfy_c_float128_complex (auxp);
 195       break;
 196     default:
 197       assert (false);
 198     }
 199   return true;
 200 }
 201
 202 void
 203 check_tk (const CFI_cdesc_t *restrict auxp, const CFI_type_t type, const signed char kind, const size_t elem_len, const size_t nelem)
 204 {
 205   signed char ityp, iknd;
 206
 207   assert (auxp);
 208   assert (auxp->elem_len==elem_len*nelem);
 209   assert (auxp->rank==1);
 210   assert (auxp->dim[0].sm>0);
 211   assert ((size_t)auxp->dim[0].sm==elem_len*nelem);
 212   /*  */
 213   assert (auxp->type==type);
 214   ityp = _CFI_decode_type(auxp->type);
 215   assert (ityp == CFI_type_Complex);
 216   iknd = _CFI_decode_kind(auxp->type);
 217   assert (_CFI_decode_type(type)==ityp);
 218   assert (kind==iknd);
 219   assert (c_vrfy_complex (auxp));
 220   return;
 221 }
 222
 223 // Local Variables:
 224 // mode: C
 225 // End: