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