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