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 LGPL.  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 `void
  22 `__'name`'rtype_qual`_'atype_code (rtype * retarray, atype *array, index_type *pdim)
  23 {
  24   index_type count[GFC_MAX_DIMENSIONS - 1];
  25   index_type extent[GFC_MAX_DIMENSIONS - 1];
  26   index_type sstride[GFC_MAX_DIMENSIONS - 1];
  27   index_type dstride[GFC_MAX_DIMENSIONS - 1];
  28   atype_name *base;
  29   rtype_name *dest;
  30   index_type rank;
  31   index_type n;
  32   index_type len;
  33   index_type delta;
  34   index_type dim;
  35
  36   /* Make dim zero based to avoid confusion.  */
  37   dim = (*pdim) - 1;
  38   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  39   assert (rank == GFC_DESCRIPTOR_RANK (retarray));
  40   if (array->dim[0].stride == 0)
  41     array->dim[0].stride = 1;
  42   if (retarray->dim[0].stride == 0)
  43     retarray->dim[0].stride = 1;
  44
  45   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  46   delta = array->dim[dim].stride;
  47
  48   for (n = 0; n < dim; n++)
  49     {
  50       sstride[n] = array->dim[n].stride;
  51       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
  52     }
  53   for (n = dim; n < rank; n++)
  54     {
  55       sstride[n] = array->dim[n + 1].stride;
  56       extent[n] =
  57         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
  58     }
  59
  60   if (retarray->data == NULL)
  61     {
  62       for (n = 0; n < rank; n++)
  63         {
  64           retarray->dim[n].lbound = 0;
  65           retarray->dim[n].ubound = extent[n]-1;
  66           if (n == 0)
  67             retarray->dim[n].stride = 1;
  68           else
  69             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
  70         }
  71
  72       retarray->data
  73          = internal_malloc_size (sizeof (rtype_name)
  74                                  * retarray->dim[rank-1].stride
  75                                  * extent[rank-1]);
  76       retarray->base = 0;
  77     }
  78
  79   for (n = 0; n < rank; n++)
  80     {
  81       count[n] = 0;
  82       dstride[n] = retarray->dim[n].stride;
  83       if (extent[n] <= 0)
  84         len = 0;
  85     }
  86
  87   base = array->data;
  88   dest = retarray->data;
  89
  90   while (base)
  91     {
  92       atype_name *src;
  93       rtype_name result;
  94       src = base;
  95       {
  96 ')dnl
  97 define(START_ARRAY_BLOCK,
  98 `        if (len <= 0)
  99           *dest = '$1`;
 100         else
 101           {
 102             for (n = 0; n < len; n++, src += delta)
 103               {
 104 ')dnl
 105 define(FINISH_ARRAY_FUNCTION,
 106     `          }
 107             *dest = result;
 108           }
 109       }
 110       /* Advance to the next element.  */
 111       count[0]++;
 112       base += sstride[0];
 113       dest += dstride[0];
 114       n = 0;
 115       while (count[n] == extent[n])
 116         {
 117           /* When we get to the end of a dimension, reset it and increment
 118              the next dimension.  */
 119           count[n] = 0;
 120           /* We could precalculate these products, but this is a less
 121              frequently used path so proabably not worth it.  */
 122           base -= sstride[n] * extent[n];
 123           dest -= dstride[n] * extent[n];
 124           n++;
 125           if (n == rank)
 126             {
 127               /* Break out of the look.  */
 128               base = NULL;
 129               break;
 130             }
 131           else
 132             {
 133               count[n]++;
 134               base += sstride[n];
 135               dest += dstride[n];
 136             }
 137         }
 138     }
 139 }')dnl
 140 define(START_MASKED_ARRAY_FUNCTION,
 141 `void
 142 `__m'name`'rtype_qual`_'atype_code (rtype * retarray, atype * array, index_type *pdim, gfc_array_l4 * mask)
 143 {
 144   index_type count[GFC_MAX_DIMENSIONS - 1];
 145   index_type extent[GFC_MAX_DIMENSIONS - 1];
 146   index_type sstride[GFC_MAX_DIMENSIONS - 1];
 147   index_type dstride[GFC_MAX_DIMENSIONS - 1];
 148   index_type mstride[GFC_MAX_DIMENSIONS - 1];
 149   rtype_name *dest;
 150   atype_name *base;
 151   GFC_LOGICAL_4 *mbase;
 152   int rank;
 153   int dim;
 154   index_type n;
 155   index_type len;
 156   index_type delta;
 157   index_type mdelta;
 158
 159   dim = (*pdim) - 1;
 160   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 161   assert (rank == GFC_DESCRIPTOR_RANK (retarray));
 162   if (array->dim[0].stride == 0)
 163     array->dim[0].stride = 1;
 164   if (retarray->dim[0].stride == 0)
 165     retarray->dim[0].stride = 1;
 166
 167   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 168   if (len <= 0)
 169     return;
 170   delta = array->dim[dim].stride;
 171   mdelta = mask->dim[dim].stride;
 172
 173   for (n = 0; n < dim; n++)
 174     {
 175       sstride[n] = array->dim[n].stride;
 176       mstride[n] = mask->dim[n].stride;
 177       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 178     }
 179   for (n = dim; n < rank; n++)
 180     {
 181       sstride[n] = array->dim[n + 1].stride;
 182       mstride[n] = mask->dim[n + 1].stride;
 183       extent[n] =
 184         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 185     }
 186
 187   for (n = 0; n < rank; n++)
 188     {
 189       count[n] = 0;
 190       dstride[n] = retarray->dim[n].stride;
 191       if (extent[n] <= 0)
 192         return;
 193     }
 194
 195   dest = retarray->data;
 196   base = array->data;
 197   mbase = mask->data;
 198
 199   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
 200     {
 201       /* This allows the same loop to be used for all logical types.  */
 202       assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
 203       for (n = 0; n < rank; n++)
 204         mstride[n] <<= 1;
 205       mdelta <<= 1;
 206       mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
 207     }
 208
 209   while (base)
 210     {
 211       atype_name *src;
 212       GFC_LOGICAL_4 *msrc;
 213       rtype_name result;
 214       src = base;
 215       msrc = mbase;
 216       {
 217 ')dnl
 218 define(START_MASKED_ARRAY_BLOCK,
 219 `        if (len <= 0)
 220           *dest = '$1`;
 221         else
 222           {
 223             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 224               {
 225 ')dnl
 226 define(FINISH_MASKED_ARRAY_FUNCTION,
 227 `              }
 228             *dest = result;
 229           }
 230       }
 231       /* Advance to the next element.  */
 232       count[0]++;
 233       base += sstride[0];
 234       mbase += mstride[0];
 235       dest += dstride[0];
 236       n = 0;
 237       while (count[n] == extent[n])
 238         {
 239           /* When we get to the end of a dimension, reset it and increment
 240              the next dimension.  */
 241           count[n] = 0;
 242           /* We could precalculate these products, but this is a less
 243              frequently used path so proabably not worth it.  */
 244           base -= sstride[n] * extent[n];
 245           mbase -= mstride[n] * extent[n];
 246           dest -= dstride[n] * extent[n];
 247           n++;
 248           if (n == rank)
 249             {
 250               /* Break out of the look.  */
 251               base = NULL;
 252               break;
 253             }
 254           else
 255             {
 256               count[n]++;
 257               base += sstride[n];
 258               mbase += mstride[n];
 259               dest += dstride[n];
 260             }
 261         }
 262     }
 263 }')dnl
 264 define(ARRAY_FUNCTION,
 265 `START_ARRAY_FUNCTION
 266 $2
 267 START_ARRAY_BLOCK($1)
 268 $3
 269 FINISH_ARRAY_FUNCTION')dnl
 270 define(MASKED_ARRAY_FUNCTION,
 271 `START_MASKED_ARRAY_FUNCTION
 272 $2
 273 START_MASKED_ARRAY_BLOCK($1)
 274 $3
 275 FINISH_MASKED_ARRAY_FUNCTION')dnl