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 GPL with exception.  See COPYING for details.
   5 define(START_FOREACH_FUNCTION,
   6 `
   7 extern void name`'rtype_qual`_'atype_code (rtype * retarray, atype *array);
   8 export_proto(name`'rtype_qual`_'atype_code);
   9
  10 void
  11 name`'rtype_qual`_'atype_code (rtype * retarray, atype *array)
  12 {
  13   index_type count[GFC_MAX_DIMENSIONS];
  14   index_type extent[GFC_MAX_DIMENSIONS];
  15   index_type sstride[GFC_MAX_DIMENSIONS];
  16   index_type dstride;
  17   atype_name *base;
  18   rtype_name *dest;
  19   index_type rank;
  20   index_type n;
  21
  22   rank = GFC_DESCRIPTOR_RANK (array);
  23   if (rank <= 0)
  24     runtime_error ("Rank of array needs to be > 0");
  25
  26   if (retarray->data == NULL)
  27     {
  28       retarray->dim[0].lbound = 0;
  29       retarray->dim[0].ubound = rank-1;
  30       retarray->dim[0].stride = 1;
  31       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
  32       retarray->base = 0;
  33       retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
  34     }
  35   else
  36     {
  37       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
  38         runtime_error ("rank of return array does not equal 1");
  39
  40       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
  41         runtime_error ("dimension of return array incorrect");
  42
  43       if (retarray->dim[0].stride == 0)
  44         retarray->dim[0].stride = 1;
  45     }
  46
  47   /* TODO:  It should be a front end job to correctly set the strides.  */
  48
  49   if (array->dim[0].stride == 0)
  50     array->dim[0].stride = 1;
  51
  52   dstride = retarray->dim[0].stride;
  53   dest = retarray->data;
  54   for (n = 0; n < rank; n++)
  55     {
  56       sstride[n] = array->dim[n].stride;
  57       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
  58       count[n] = 0;
  59       if (extent[n] <= 0)
  60         {
  61           /* Set the return value.  */
  62           for (n = 0; n < rank; n++)
  63             dest[n * dstride] = 0;
  64           return;
  65         }
  66     }
  67
  68   base = array->data;
  69
  70   /* Initialize the return value.  */
  71   for (n = 0; n < rank; n++)
  72     dest[n * dstride] = 1;
  73   {
  74 ')dnl
  75 define(START_FOREACH_BLOCK,
  76 `  while (base)
  77     {
  78       {
  79         /* Implementation start.  */
  80 ')dnl
  81 define(FINISH_FOREACH_FUNCTION,
  82 `        /* Implementation end.  */
  83       }
  84       /* Advance to the next element.  */
  85       count[0]++;
  86       base += sstride[0];
  87       n = 0;
  88       while (count[n] == extent[n])
  89         {
  90           /* When we get to the end of a dimension, reset it and increment
  91              the next dimension.  */
  92           count[n] = 0;
  93           /* We could precalculate these products, but this is a less
  94              frequently used path so proabably not worth it.  */
  95           base -= sstride[n] * extent[n];
  96           n++;
  97           if (n == rank)
  98             {
  99               /* Break out of the loop.  */
 100               base = NULL;
 101               break;
 102             }
 103           else
 104             {
 105               count[n]++;
 106               base += sstride[n];
 107             }
 108         }
 109     }
 110   }
 111 }')dnl
 112 define(START_MASKED_FOREACH_FUNCTION,
 113 `
 114 extern void `m'name`'rtype_qual`_'atype_code (rtype *, atype *, gfc_array_l4 *);
 115 export_proto(`m'name`'rtype_qual`_'atype_code);
 116
 117 void
 118 `m'name`'rtype_qual`_'atype_code (rtype * retarray, atype *array,
 119                                   gfc_array_l4 * mask)
 120 {
 121   index_type count[GFC_MAX_DIMENSIONS];
 122   index_type extent[GFC_MAX_DIMENSIONS];
 123   index_type sstride[GFC_MAX_DIMENSIONS];
 124   index_type mstride[GFC_MAX_DIMENSIONS];
 125   index_type dstride;
 126   rtype_name *dest;
 127   atype_name *base;
 128   GFC_LOGICAL_4 *mbase;
 129   int rank;
 130   index_type n;
 131
 132   rank = GFC_DESCRIPTOR_RANK (array);
 133   if (rank <= 0)
 134     runtime_error ("Rank of array needs to be > 0");
 135
 136   if (retarray->data == NULL)
 137     {
 138       retarray->dim[0].lbound = 0;
 139       retarray->dim[0].ubound = rank-1;
 140       retarray->dim[0].stride = 1;
 141       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 142       retarray->base = 0;
 143       retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
 144     }
 145   else
 146     {
 147       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 148         runtime_error ("rank of return array does not equal 1");
 149
 150       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 151         runtime_error ("dimension of return array incorrect");
 152
 153       if (retarray->dim[0].stride == 0)
 154         retarray->dim[0].stride = 1;
 155     }
 156
 157   /* TODO:  It should be a front end job to correctly set the strides.  */
 158
 159   if (array->dim[0].stride == 0)
 160     array->dim[0].stride = 1;
 161
 162   if (mask->dim[0].stride == 0)
 163     mask->dim[0].stride = 1;
 164
 165   dstride = retarray->dim[0].stride;
 166   dest = retarray->data;
 167   for (n = 0; n < rank; n++)
 168     {
 169       sstride[n] = array->dim[n].stride;
 170       mstride[n] = mask->dim[n].stride;
 171       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 172       count[n] = 0;
 173       if (extent[n] <= 0)
 174         {
 175           /* Set the return value.  */
 176           for (n = 0; n < rank; n++)
 177             dest[n * dstride] = 0;
 178           return;
 179         }
 180     }
 181
 182   base = array->data;
 183   mbase = mask->data;
 184
 185   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
 186     {
 187       /* This allows the same loop to be used for all logical types.  */
 188       assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
 189       for (n = 0; n < rank; n++)
 190         mstride[n] <<= 1;
 191       mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
 192     }
 193
 194
 195   /* Initialize the return value.  */
 196   for (n = 0; n < rank; n++)
 197     dest[n * dstride] = 1;
 198   {
 199 ')dnl
 200 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
 201 define(FINISH_MASKED_FOREACH_FUNCTION,
 202 `        /* Implementation end.  */
 203       }
 204       /* Advance to the next element.  */
 205       count[0]++;
 206       base += sstride[0];
 207       mbase += mstride[0];
 208       n = 0;
 209       while (count[n] == extent[n])
 210         {
 211           /* When we get to the end of a dimension, reset it and increment
 212              the next dimension.  */
 213           count[n] = 0;
 214           /* We could precalculate these products, but this is a less
 215              frequently used path so proabably not worth it.  */
 216           base -= sstride[n] * extent[n];
 217           mbase -= mstride[n] * extent[n];
 218           n++;
 219           if (n == rank)
 220             {
 221               /* Break out of the loop.  */
 222               base = NULL;
 223               break;
 224             }
 225           else
 226             {
 227               count[n]++;
 228               base += sstride[n];
 229               mbase += mstride[n];
 230             }
 231         }
 232     }
 233   }
 234 }')dnl
 235 define(FOREACH_FUNCTION,
 236 `START_FOREACH_FUNCTION
 237 $1
 238 START_FOREACH_BLOCK
 239 $2
 240 FINISH_FOREACH_FUNCTION')dnl
 241 define(MASKED_FOREACH_FUNCTION,
 242 `START_MASKED_FOREACH_FUNCTION
 243 $1
 244 START_MASKED_FOREACH_BLOCK
 245 $2
 246 FINISH_MASKED_FOREACH_FUNCTION')dnl