libgfortran/m4/iforeach.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 define(START_FOREACH_FUNCTION,
   6 `void
   7 `__'name`'rtype_qual`_'atype_code (rtype * retarray, atype *array)
   8 {
   9   index_type count[GFC_MAX_DIMENSIONS];
  10   index_type extent[GFC_MAX_DIMENSIONS];
  11   index_type sstride[GFC_MAX_DIMENSIONS];
  12   index_type dstride;
  13   atype_name *base;
  14   rtype_name *dest;
  15   index_type rank;
  16   index_type n;
  17
  18   rank = GFC_DESCRIPTOR_RANK (array);
  19   assert (rank > 0);
  20   assert (GFC_DESCRIPTOR_RANK (retarray) == 1);
  21   assert (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound == rank);
  22   if (array->dim[0].stride == 0)
  23     array->dim[0].stride = 1;
  24   if (retarray->dim[0].stride == 0)
  25     retarray->dim[0].stride = 1;
  26
  27   dstride = retarray->dim[0].stride;
  28   dest = retarray->data;
  29   for (n = 0; n < rank; n++)
  30     {
  31       sstride[n] = array->dim[n].stride;
  32       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
  33       count[n] = 0;
  34       if (extent[n] <= 0)
  35         {
  36           /* Set the return value.  */
  37           for (n = 0; n < rank; n++)
  38             dest[n * dstride] = 0;
  39           return;
  40         }
  41     }
  42
  43   base = array->data;
  44
  45   /* Initialize the return value.  */
  46   for (n = 0; n < rank; n++)
  47     dest[n * dstride] = 1;
  48   {
  49 ')dnl
  50 define(START_FOREACH_BLOCK,
  51 `  while (base)
  52     {
  53       {
  54         /* Implementation start.  */
  55 ')dnl
  56 define(FINISH_FOREACH_FUNCTION,
  57 `        /* Implementation end.  */
  58       }
  59       /* Advance to the next element.  */
  60       count[0]++;
  61       base += sstride[0];
  62       n = 0;
  63       while (count[n] == extent[n])
  64         {
  65           /* When we get to the end of a dimension, reset it and increment
  66              the next dimension.  */
  67           count[n] = 0;
  68           /* We could precalculate these products, but this is a less
  69              frequently used path so proabably not worth it.  */
  70           base -= sstride[n] * extent[n];
  71           n++;
  72           if (n == rank)
  73             {
  74               /* Break out of the loop.  */
  75               base = NULL;
  76               break;
  77             }
  78           else
  79             {
  80               count[n]++;
  81               base += sstride[n];
  82             }
  83         }
  84     }
  85   }
  86 }')dnl
  87 define(START_MASKED_FOREACH_FUNCTION,
  88 `void
  89 `__m'name`'rtype_qual`_'atype_code (rtype * retarray, atype *array, gfc_array_l4 * mask)
  90 {
  91   index_type count[GFC_MAX_DIMENSIONS];
  92   index_type extent[GFC_MAX_DIMENSIONS];
  93   index_type sstride[GFC_MAX_DIMENSIONS];
  94   index_type mstride[GFC_MAX_DIMENSIONS];
  95   index_type dstride;
  96   rtype_name *dest;
  97   atype_name *base;
  98   GFC_LOGICAL_4 *mbase;
  99   int rank;
 100   index_type n;
 101
 102   rank = GFC_DESCRIPTOR_RANK (array);
 103   assert (rank > 0);
 104   assert (GFC_DESCRIPTOR_RANK (retarray) == 1);
 105   assert (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound == rank);
 106   assert (GFC_DESCRIPTOR_RANK (mask) == rank);
 107
 108   if (array->dim[0].stride == 0)
 109     array->dim[0].stride = 1;
 110   if (retarray->dim[0].stride == 0)
 111     retarray->dim[0].stride = 1;
 112   if (retarray->dim[0].stride == 0)
 113     retarray->dim[0].stride = 1;
 114
 115   dstride = retarray->dim[0].stride;
 116   dest = retarray->data;
 117   for (n = 0; n < rank; n++)
 118     {
 119       sstride[n] = array->dim[n].stride;
 120       mstride[n] = mask->dim[n].stride;
 121       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 122       count[n] = 0;
 123       if (extent[n] <= 0)
 124         {
 125           /* Set the return value.  */
 126           for (n = 0; n < rank; n++)
 127             dest[n * dstride] = 0;
 128           return;
 129         }
 130     }
 131
 132   base = array->data;
 133   mbase = mask->data;
 134
 135   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
 136     {
 137       /* This allows the same loop to be used for all logical types.  */
 138       assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
 139       for (n = 0; n < rank; n++)
 140         mstride[n] <<= 1;
 141       mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
 142     }
 143
 144
 145   /* Initialize the return value.  */
 146   for (n = 0; n < rank; n++)
 147     dest[n * dstride] = 1;
 148   {
 149 ')dnl
 150 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
 151 define(FINISH_MASKED_FOREACH_FUNCTION,
 152 `        /* Implementation end.  */
 153       }
 154       /* Advance to the next element.  */
 155       count[0]++;
 156       base += sstride[0];
 157       mbase += mstride[0];
 158       n = 0;
 159       while (count[n] == extent[n])
 160         {
 161           /* When we get to the end of a dimension, reset it and increment
 162              the next dimension.  */
 163           count[n] = 0;
 164           /* We could precalculate these products, but this is a less
 165              frequently used path so proabably not worth it.  */
 166           base -= sstride[n] * extent[n];
 167           mbase -= mstride[n] * extent[n];
 168           n++;
 169           if (n == rank)
 170             {
 171               /* Break out of the loop.  */
 172               base = NULL;
 173               break;
 174             }
 175           else
 176             {
 177               count[n]++;
 178               base += sstride[n];
 179               mbase += mstride[n];
 180             }
 181         }
 182     }
 183   }
 184 }')dnl
 185 define(FOREACH_FUNCTION,
 186 `START_FOREACH_FUNCTION
 187 $1
 188 START_FOREACH_BLOCK
 189 $2
 190 FINISH_FOREACH_FUNCTION')dnl
 191 define(MASKED_FOREACH_FUNCTION,
 192 `START_MASKED_FOREACH_FUNCTION
 193 $1
 194 START_MASKED_FOREACH_BLOCK
 195 $2
 196 FINISH_MASKED_FOREACH_FUNCTION')dnl