libgfortran/m4/ifunction.m4

   1 dnl Support macro file for intrinsic functions.
   2 dnl Contains the generic sections of the array functions.
   3 dnl This file is part of the GNU Fortran 95 Runtime Library (libgfortran)
   4 dnl Distributed under the GNU GPL with exception.  See COPYING for details.
   5 dnl
   6 dnl Pass the implementation for a single section as the parameter to
   7 dnl {MASK_}ARRAY_FUNCTION.
   8 dnl The variables base, delta, and len describe the input section.
   9 dnl For masked section the mask is described by mbase and mdelta.
  10 dnl These should not be modified. The result should be stored in *dest.
  11 dnl The names count, extent, sstride, dstride, base, dest, rank, dim
  12 dnl retarray, array, pdim and mstride should not be used.
  13 dnl The variable n is declared as index_type and may be used.
  14 dnl Other variable declarations may be placed at the start of the code,
  15 dnl The types of the array parameter and the return value are
  16 dnl atype_name and rtype_name respectively.
  17 dnl Execution should be allowed to continue to the end of the block.
  18 dnl You should not return or break from the inner loop of the implementation.
  19 dnl Care should also be taken to avoid using the names defined in iparm.m4
  20 define(START_ARRAY_FUNCTION,
  21 `
  22 extern void name`'rtype_qual`_'atype_code (rtype * const restrict,
  23         atype * const restrict, const index_type * const restrict);
  24 export_proto(name`'rtype_qual`_'atype_code);
  25
  26 void
  27 name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
  28         atype * const restrict array,
  29         const index_type * const restrict pdim)
  30 {
  31   index_type count[GFC_MAX_DIMENSIONS];
  32   index_type extent[GFC_MAX_DIMENSIONS];
  33   index_type sstride[GFC_MAX_DIMENSIONS];
  34   index_type dstride[GFC_MAX_DIMENSIONS];
  35   const atype_name * restrict base;
  36   rtype_name * restrict dest;
  37   index_type rank;
  38   index_type n;
  39   index_type len;
  40   index_type delta;
  41   index_type dim;
  42
  43   /* Make dim zero based to avoid confusion.  */
  44   dim = (*pdim) - 1;
  45   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  46
  47   /* TODO:  It should be a front end job to correctly set the strides.  */
  48
  49   if (array->dim[0].stride == 0)
  50     array->dim[0].stride = 1;
  51
  52   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  53   delta = array->dim[dim].stride;
  54
  55   for (n = 0; n < dim; n++)
  56     {
  57       sstride[n] = array->dim[n].stride;
  58       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
  59     }
  60   for (n = dim; n < rank; n++)
  61     {
  62       sstride[n] = array->dim[n + 1].stride;
  63       extent[n] =
  64         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
  65     }
  66
  67   if (retarray->data == NULL)
  68     {
  69       for (n = 0; n < rank; n++)
  70         {
  71           retarray->dim[n].lbound = 0;
  72           retarray->dim[n].ubound = extent[n]-1;
  73           if (n == 0)
  74             retarray->dim[n].stride = 1;
  75           else
  76             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
  77         }
  78
  79       retarray->data
  80          = internal_malloc_size (sizeof (rtype_name)
  81                                  * retarray->dim[rank-1].stride
  82                                  * extent[rank-1]);
  83       retarray->offset = 0;
  84       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
  85     }
  86   else
  87     {
  88       if (retarray->dim[0].stride == 0)
  89         retarray->dim[0].stride = 1;
  90
  91       if (rank != GFC_DESCRIPTOR_RANK (retarray))
  92         runtime_error ("rank of return array incorrect");
  93     }
  94
  95   for (n = 0; n < rank; n++)
  96     {
  97       count[n] = 0;
  98       dstride[n] = retarray->dim[n].stride;
  99       if (extent[n] <= 0)
 100         len = 0;
 101     }
 102
 103   base = array->data;
 104   dest = retarray->data;
 105
 106   while (base)
 107     {
 108       const atype_name * restrict src;
 109       rtype_name result;
 110       src = base;
 111       {
 112 ')dnl
 113 define(START_ARRAY_BLOCK,
 114 `        if (len <= 0)
 115           *dest = '$1`;
 116         else
 117           {
 118             for (n = 0; n < len; n++, src += delta)
 119               {
 120 ')dnl
 121 define(FINISH_ARRAY_FUNCTION,
 122     `          }
 123             *dest = result;
 124           }
 125       }
 126       /* Advance to the next element.  */
 127       count[0]++;
 128       base += sstride[0];
 129       dest += dstride[0];
 130       n = 0;
 131       while (count[n] == extent[n])
 132         {
 133           /* When we get to the end of a dimension, reset it and increment
 134              the next dimension.  */
 135           count[n] = 0;
 136           /* We could precalculate these products, but this is a less
 137              frequently used path so proabably not worth it.  */
 138           base -= sstride[n] * extent[n];
 139           dest -= dstride[n] * extent[n];
 140           n++;
 141           if (n == rank)
 142             {
 143               /* Break out of the look.  */
 144               base = NULL;
 145               break;
 146             }
 147           else
 148             {
 149               count[n]++;
 150               base += sstride[n];
 151               dest += dstride[n];
 152             }
 153         }
 154     }
 155 }')dnl
 156 define(START_MASKED_ARRAY_FUNCTION,
 157 `
 158 extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
 159         atype * const restrict, const index_type * const restrict,
 160         gfc_array_l4 * const restrict);
 161 export_proto(`m'name`'rtype_qual`_'atype_code);
 162
 163 void
 164 `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
 165         atype * const restrict array,
 166         const index_type * const restrict pdim,
 167         gfc_array_l4 * const restrict mask)
 168 {
 169   index_type count[GFC_MAX_DIMENSIONS];
 170   index_type extent[GFC_MAX_DIMENSIONS];
 171   index_type sstride[GFC_MAX_DIMENSIONS];
 172   index_type dstride[GFC_MAX_DIMENSIONS];
 173   index_type mstride[GFC_MAX_DIMENSIONS];
 174   rtype_name * restrict dest;
 175   const atype_name * restrict base;
 176   const GFC_LOGICAL_4 * restrict mbase;
 177   int rank;
 178   int dim;
 179   index_type n;
 180   index_type len;
 181   index_type delta;
 182   index_type mdelta;
 183
 184   dim = (*pdim) - 1;
 185   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 186
 187   /* TODO:  It should be a front end job to correctly set the strides.  */
 188
 189   if (array->dim[0].stride == 0)
 190     array->dim[0].stride = 1;
 191
 192   if (mask->dim[0].stride == 0)
 193     mask->dim[0].stride = 1;
 194
 195   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 196   if (len <= 0)
 197     return;
 198   delta = array->dim[dim].stride;
 199   mdelta = mask->dim[dim].stride;
 200
 201   for (n = 0; n < dim; n++)
 202     {
 203       sstride[n] = array->dim[n].stride;
 204       mstride[n] = mask->dim[n].stride;
 205       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 206     }
 207   for (n = dim; n < rank; n++)
 208     {
 209       sstride[n] = array->dim[n + 1].stride;
 210       mstride[n] = mask->dim[n + 1].stride;
 211       extent[n] =
 212         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 213     }
 214
 215   if (retarray->data == NULL)
 216     {
 217       for (n = 0; n < rank; n++)
 218         {
 219           retarray->dim[n].lbound = 0;
 220           retarray->dim[n].ubound = extent[n]-1;
 221           if (n == 0)
 222             retarray->dim[n].stride = 1;
 223           else
 224             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 225         }
 226
 227       retarray->data
 228          = internal_malloc_size (sizeof (rtype_name)
 229                                  * retarray->dim[rank-1].stride
 230                                  * extent[rank-1]);
 231       retarray->offset = 0;
 232       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 233     }
 234   else
 235     {
 236       if (retarray->dim[0].stride == 0)
 237         retarray->dim[0].stride = 1;
 238
 239       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 240         runtime_error ("rank of return array incorrect");
 241     }
 242
 243   for (n = 0; n < rank; n++)
 244     {
 245       count[n] = 0;
 246       dstride[n] = retarray->dim[n].stride;
 247       if (extent[n] <= 0)
 248         return;
 249     }
 250
 251   dest = retarray->data;
 252   base = array->data;
 253   mbase = mask->data;
 254
 255   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
 256     {
 257       /* This allows the same loop to be used for all logical types.  */
 258       assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
 259       for (n = 0; n < rank; n++)
 260         mstride[n] <<= 1;
 261       mdelta <<= 1;
 262       mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
 263     }
 264
 265   while (base)
 266     {
 267       const atype_name * restrict src;
 268       const GFC_LOGICAL_4 * restrict msrc;
 269       rtype_name result;
 270       src = base;
 271       msrc = mbase;
 272       {
 273 ')dnl
 274 define(START_MASKED_ARRAY_BLOCK,
 275 `        if (len <= 0)
 276           *dest = '$1`;
 277         else
 278           {
 279             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 280               {
 281 ')dnl
 282 define(FINISH_MASKED_ARRAY_FUNCTION,
 283 `              }
 284             *dest = result;
 285           }
 286       }
 287       /* Advance to the next element.  */
 288       count[0]++;
 289       base += sstride[0];
 290       mbase += mstride[0];
 291       dest += dstride[0];
 292       n = 0;
 293       while (count[n] == extent[n])
 294         {
 295           /* When we get to the end of a dimension, reset it and increment
 296              the next dimension.  */
 297           count[n] = 0;
 298           /* We could precalculate these products, but this is a less
 299              frequently used path so proabably not worth it.  */
 300           base -= sstride[n] * extent[n];
 301           mbase -= mstride[n] * extent[n];
 302           dest -= dstride[n] * extent[n];
 303           n++;
 304           if (n == rank)
 305             {
 306               /* Break out of the look.  */
 307               base = NULL;
 308               break;
 309             }
 310           else
 311             {
 312               count[n]++;
 313               base += sstride[n];
 314               mbase += mstride[n];
 315               dest += dstride[n];
 316             }
 317         }
 318     }
 319 }')dnl
 320 define(SCALAR_ARRAY_FUNCTION,
 321 `
 322 extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
 323         atype * const restrict, const index_type * const restrict,
 324         GFC_LOGICAL_4 *);
 325 export_proto(`s'name`'rtype_qual`_'atype_code);
 326
 327 void
 328 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
 329         atype * const restrict array,
 330         const index_type * const restrict pdim,
 331         GFC_LOGICAL_4 * mask)
 332 {
 333   index_type rank;
 334   index_type n;
 335   index_type dstride;
 336   rtype_name *dest;
 337
 338   if (*mask)
 339     {
 340       name`'rtype_qual`_'atype_code (retarray, array, pdim);
 341       return;
 342     }
 343     rank = GFC_DESCRIPTOR_RANK (array);
 344   if (rank <= 0)
 345     runtime_error ("Rank of array needs to be > 0");
 346
 347   if (retarray->data == NULL)
 348     {
 349       retarray->dim[0].lbound = 0;
 350       retarray->dim[0].ubound = rank-1;
 351       retarray->dim[0].stride = 1;
 352       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 353       retarray->offset = 0;
 354       retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
 355     }
 356   else
 357     {
 358       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 359         runtime_error ("rank of return array does not equal 1");
 360
 361       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 362         runtime_error ("dimension of return array incorrect");
 363
 364       if (retarray->dim[0].stride == 0)
 365         retarray->dim[0].stride = 1;
 366     }
 367
 368     dstride = retarray->dim[0].stride;
 369     dest = retarray->data;
 370
 371     for (n = 0; n < rank; n++)
 372       dest[n * dstride] = $1 ;
 373 }')dnl
 374 define(ARRAY_FUNCTION,
 375 `START_ARRAY_FUNCTION
 376 $2
 377 START_ARRAY_BLOCK($1)
 378 $3
 379 FINISH_ARRAY_FUNCTION')dnl
 380 define(MASKED_ARRAY_FUNCTION,
 381 `START_MASKED_ARRAY_FUNCTION
 382 $2
 383 START_MASKED_ARRAY_BLOCK($1)
 384 $3
 385 FINISH_MASKED_ARRAY_FUNCTION')dnl