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 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, GFC_LOGICAL_4);
   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, GFC_LOGICAL_4 back)
  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 * restrict 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->base_addr == NULL)
  29     {
  30       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
  31       retarray->dtype.rank = 1;
  32       retarray->offset = 0;
  33       retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
  34     }
  35   else
  36     {
  37       if (unlikely (compile_options.bounds_check))
  38         bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
  39                                 "u_name");
  40     }
  41
  42   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  43   dest = retarray->base_addr;
  44   for (n = 0; n < rank; n++)
  45     {
  46       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
  47       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  48       count[n] = 0;
  49       if (extent[n] <= 0)
  50         {
  51           /* Set the return value.  */
  52           for (n = 0; n < rank; n++)
  53             dest[n * dstride] = 0;
  54           return;
  55         }
  56     }
  57
  58   base = array->base_addr;
  59
  60   /* Initialize the return value.  */
  61   for (n = 0; n < rank; n++)
  62     dest[n * dstride] = 1;
  63   {
  64 ')dnl
  65 define(START_FOREACH_BLOCK,
  66 `  while (base)
  67     {
  68           /* Implementation start.  */
  69 ')dnl
  70 define(FINISH_FOREACH_FUNCTION,
  71 `         /* Implementation end.  */
  72           /* Advance to the next element.  */
  73           base += sstride[0];
  74         }
  75       while (++count[0] != extent[0]);
  76       n = 0;
  77       do
  78         {
  79           /* When we get to the end of a dimension, reset it and increment
  80              the next dimension.  */
  81           count[n] = 0;
  82           /* We could precalculate these products, but this is a less
  83              frequently used path so probably not worth it.  */
  84           base -= sstride[n] * extent[n];
  85           n++;
  86           if (n >= rank)
  87             {
  88               /* Break out of the loop.  */
  89               base = NULL;
  90               break;
  91             }
  92           else
  93             {
  94               count[n]++;
  95               base += sstride[n];
  96             }
  97         }
  98       while (count[n] == extent[n]);
  99     }
 100   }
 101 }')dnl
 102 define(START_MASKED_FOREACH_FUNCTION,
 103 `
 104 extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
 105         atype * const restrict, gfc_array_l1 * const restrict,
 106         GFC_LOGICAL_4);
 107 export_proto(`m'name`'rtype_qual`_'atype_code);
 108
 109 void
 110 `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
 111         atype * const restrict array,
 112         gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back)
 113 {
 114   index_type count[GFC_MAX_DIMENSIONS];
 115   index_type extent[GFC_MAX_DIMENSIONS];
 116   index_type sstride[GFC_MAX_DIMENSIONS];
 117   index_type mstride[GFC_MAX_DIMENSIONS];
 118   index_type dstride;
 119   rtype_name *dest;
 120   const atype_name *base;
 121   GFC_LOGICAL_1 *mbase;
 122   int rank;
 123   index_type n;
 124   int mask_kind;
 125
 126
 127   if (mask == NULL)
 128     {
 129       name`'rtype_qual`_'atype_code (retarray, array, back);
 130       return;
 131     }
 132
 133   rank = GFC_DESCRIPTOR_RANK (array);
 134   if (rank <= 0)
 135     runtime_error ("Rank of array needs to be > 0");
 136
 137   if (retarray->base_addr == NULL)
 138     {
 139       GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
 140       retarray->dtype.rank = 1;
 141       retarray->offset = 0;
 142       retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
 143     }
 144   else
 145     {
 146       if (unlikely (compile_options.bounds_check))
 147         {
 148
 149           bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 150                                   "u_name");
 151           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 152                                   "MASK argument", "u_name");
 153         }
 154     }
 155
 156   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 157
 158   mbase = mask->base_addr;
 159
 160   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 161 #ifdef HAVE_GFC_LOGICAL_16
 162       || mask_kind == 16
 163 #endif
 164       )
 165     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 166   else
 167     runtime_error ("Funny sized logical array");
 168
 169   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 170   dest = retarray->base_addr;
 171   for (n = 0; n < rank; n++)
 172     {
 173       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 174       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 175       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 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->base_addr;
 187
 188   /* Initialize the return value.  */
 189   for (n = 0; n < rank; n++)
 190     dest[n * dstride] = 0;
 191   {
 192 ')dnl
 193 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
 194 define(FINISH_MASKED_FOREACH_FUNCTION,
 195 `         /* Implementation end.  */
 196           /* Advance to the next element.  */
 197           base += sstride[0];
 198           mbase += mstride[0];
 199         }
 200       while (++count[0] != extent[0]);
 201       n = 0;
 202       do
 203         {
 204           /* When we get to the end of a dimension, reset it and increment
 205              the next dimension.  */
 206           count[n] = 0;
 207           /* We could precalculate these products, but this is a less
 208              frequently used path so probably not worth it.  */
 209           base -= sstride[n] * extent[n];
 210           mbase -= mstride[n] * extent[n];
 211           n++;
 212           if (n >= rank)
 213             {
 214               /* Break out of the loop.  */
 215               base = NULL;
 216               break;
 217             }
 218           else
 219             {
 220               count[n]++;
 221               base += sstride[n];
 222               mbase += mstride[n];
 223             }
 224         }
 225       while (count[n] == extent[n]);
 226     }
 227   }
 228 }')dnl
 229 define(FOREACH_FUNCTION,
 230 `START_FOREACH_FUNCTION
 231 $1
 232 START_FOREACH_BLOCK
 233 $2
 234 FINISH_FOREACH_FUNCTION')dnl
 235 define(MASKED_FOREACH_FUNCTION,
 236 `START_MASKED_FOREACH_FUNCTION
 237 $1
 238 START_MASKED_FOREACH_BLOCK
 239 $2
 240 FINISH_MASKED_FOREACH_FUNCTION')dnl
 241 define(SCALAR_FOREACH_FUNCTION,
 242 `
 243 extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
 244         atype * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4);
 245 export_proto(`s'name`'rtype_qual`_'atype_code);
 246
 247 void
 248 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
 249         atype * const restrict array,
 250         GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
 251 {
 252   index_type rank;
 253   index_type dstride;
 254   index_type n;
 255   rtype_name *dest;
 256
 257   if (mask == NULL || *mask)
 258     {
 259       name`'rtype_qual`_'atype_code (retarray, array, back);
 260       return;
 261     }
 262
 263   rank = GFC_DESCRIPTOR_RANK (array);
 264
 265   if (rank <= 0)
 266     runtime_error ("Rank of array needs to be > 0");
 267
 268   if (retarray->base_addr == NULL)
 269     {
 270       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
 271       retarray->dtype.rank = 1;
 272       retarray->offset = 0;
 273       retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
 274     }
 275   else if (unlikely (compile_options.bounds_check))
 276     {
 277        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 278                                "u_name");
 279     }
 280
 281   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 282   dest = retarray->base_addr;
 283   for (n = 0; n<rank; n++)
 284     dest[n * dstride] = $1 ;
 285 }')dnl