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