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];
  29   index_type extent[GFC_MAX_DIMENSIONS];
  30   index_type sstride[GFC_MAX_DIMENSIONS];
  31   index_type dstride[GFC_MAX_DIMENSIONS];
  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
  44   /* TODO:  It should be a front end job to correctly set the strides.  */
  45
  46   if (array->dim[0].stride == 0)
  47     array->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->offset = 0;
  81       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
  82     }
  83   else
  84     {
  85       if (retarray->dim[0].stride == 0)
  86         retarray->dim[0].stride = 1;
  87
  88       if (rank != GFC_DESCRIPTOR_RANK (retarray))
  89         runtime_error ("rank of return array incorrect");
  90     }
  91
  92   for (n = 0; n < rank; n++)
  93     {
  94       count[n] = 0;
  95       dstride[n] = retarray->dim[n].stride;
  96       if (extent[n] <= 0)
  97         len = 0;
  98     }
  99
 100   base = array->data;
 101   dest = retarray->data;
 102
 103   while (base)
 104     {
 105       atype_name *src;
 106       rtype_name result;
 107       src = base;
 108       {
 109 ')dnl
 110 define(START_ARRAY_BLOCK,
 111 `        if (len <= 0)
 112           *dest = '$1`;
 113         else
 114           {
 115             for (n = 0; n < len; n++, src += delta)
 116               {
 117 ')dnl
 118 define(FINISH_ARRAY_FUNCTION,
 119     `          }
 120             *dest = result;
 121           }
 122       }
 123       /* Advance to the next element.  */
 124       count[0]++;
 125       base += sstride[0];
 126       dest += dstride[0];
 127       n = 0;
 128       while (count[n] == extent[n])
 129         {
 130           /* When we get to the end of a dimension, reset it and increment
 131              the next dimension.  */
 132           count[n] = 0;
 133           /* We could precalculate these products, but this is a less
 134              frequently used path so proabably not worth it.  */
 135           base -= sstride[n] * extent[n];
 136           dest -= dstride[n] * extent[n];
 137           n++;
 138           if (n == rank)
 139             {
 140               /* Break out of the look.  */
 141               base = NULL;
 142               break;
 143             }
 144           else
 145             {
 146               count[n]++;
 147               base += sstride[n];
 148               dest += dstride[n];
 149             }
 150         }
 151     }
 152 }')dnl
 153 define(START_MASKED_ARRAY_FUNCTION,
 154 `
 155 extern void `m'name`'rtype_qual`_'atype_code (rtype *, atype *, index_type *,
 156                                                gfc_array_l4 *);
 157 export_proto(`m'name`'rtype_qual`_'atype_code);
 158
 159 void
 160 `m'name`'rtype_qual`_'atype_code (rtype * retarray, atype * array,
 161                                   index_type *pdim, gfc_array_l4 * mask)
 162 {
 163   index_type count[GFC_MAX_DIMENSIONS];
 164   index_type extent[GFC_MAX_DIMENSIONS];
 165   index_type sstride[GFC_MAX_DIMENSIONS];
 166   index_type dstride[GFC_MAX_DIMENSIONS];
 167   index_type mstride[GFC_MAX_DIMENSIONS];
 168   rtype_name *dest;
 169   atype_name *base;
 170   GFC_LOGICAL_4 *mbase;
 171   int rank;
 172   int dim;
 173   index_type n;
 174   index_type len;
 175   index_type delta;
 176   index_type mdelta;
 177
 178   dim = (*pdim) - 1;
 179   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 180
 181   /* TODO:  It should be a front end job to correctly set the strides.  */
 182
 183   if (array->dim[0].stride == 0)
 184     array->dim[0].stride = 1;
 185
 186   if (mask->dim[0].stride == 0)
 187     mask->dim[0].stride = 1;
 188
 189   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 190   if (len <= 0)
 191     return;
 192   delta = array->dim[dim].stride;
 193   mdelta = mask->dim[dim].stride;
 194
 195   for (n = 0; n < dim; n++)
 196     {
 197       sstride[n] = array->dim[n].stride;
 198       mstride[n] = mask->dim[n].stride;
 199       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 200     }
 201   for (n = dim; n < rank; n++)
 202     {
 203       sstride[n] = array->dim[n + 1].stride;
 204       mstride[n] = mask->dim[n + 1].stride;
 205       extent[n] =
 206         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 207     }
 208
 209   if (retarray->data == NULL)
 210     {
 211       for (n = 0; n < rank; n++)
 212         {
 213           retarray->dim[n].lbound = 0;
 214           retarray->dim[n].ubound = extent[n]-1;
 215           if (n == 0)
 216             retarray->dim[n].stride = 1;
 217           else
 218             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 219         }
 220
 221       retarray->data
 222          = internal_malloc_size (sizeof (rtype_name)
 223                                  * retarray->dim[rank-1].stride
 224                                  * extent[rank-1]);
 225       retarray->offset = 0;
 226       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 227     }
 228   else
 229     {
 230       if (retarray->dim[0].stride == 0)
 231         retarray->dim[0].stride = 1;
 232
 233       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 234         runtime_error ("rank of return array incorrect");
 235     }
 236
 237   for (n = 0; n < rank; n++)
 238     {
 239       count[n] = 0;
 240       dstride[n] = retarray->dim[n].stride;
 241       if (extent[n] <= 0)
 242         return;
 243     }
 244
 245   dest = retarray->data;
 246   base = array->data;
 247   mbase = mask->data;
 248
 249   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
 250     {
 251       /* This allows the same loop to be used for all logical types.  */
 252       assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
 253       for (n = 0; n < rank; n++)
 254         mstride[n] <<= 1;
 255       mdelta <<= 1;
 256       mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
 257     }
 258
 259   while (base)
 260     {
 261       atype_name *src;
 262       GFC_LOGICAL_4 *msrc;
 263       rtype_name result;
 264       src = base;
 265       msrc = mbase;
 266       {
 267 ')dnl
 268 define(START_MASKED_ARRAY_BLOCK,
 269 `        if (len <= 0)
 270           *dest = '$1`;
 271         else
 272           {
 273             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 274               {
 275 ')dnl
 276 define(FINISH_MASKED_ARRAY_FUNCTION,
 277 `              }
 278             *dest = result;
 279           }
 280       }
 281       /* Advance to the next element.  */
 282       count[0]++;
 283       base += sstride[0];
 284       mbase += mstride[0];
 285       dest += dstride[0];
 286       n = 0;
 287       while (count[n] == extent[n])
 288         {
 289           /* When we get to the end of a dimension, reset it and increment
 290              the next dimension.  */
 291           count[n] = 0;
 292           /* We could precalculate these products, but this is a less
 293              frequently used path so proabably not worth it.  */
 294           base -= sstride[n] * extent[n];
 295           mbase -= mstride[n] * extent[n];
 296           dest -= dstride[n] * extent[n];
 297           n++;
 298           if (n == rank)
 299             {
 300               /* Break out of the look.  */
 301               base = NULL;
 302               break;
 303             }
 304           else
 305             {
 306               count[n]++;
 307               base += sstride[n];
 308               mbase += mstride[n];
 309               dest += dstride[n];
 310             }
 311         }
 312     }
 313 }')dnl
 314 define(ARRAY_FUNCTION,
 315 `START_ARRAY_FUNCTION
 316 $2
 317 START_ARRAY_BLOCK($1)
 318 $3
 319 FINISH_ARRAY_FUNCTION')dnl
 320 define(MASKED_ARRAY_FUNCTION,
 321 `START_MASKED_ARRAY_FUNCTION
 322 $2
 323 START_MASKED_ARRAY_BLOCK($1)
 324 $3
 325 FINISH_MASKED_ARRAY_FUNCTION')dnl