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