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