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   rank = GFC_DESCRIPTOR_RANK (array);
 127   if (rank <= 0)
 128     runtime_error ("Rank of array needs to be > 0");
 129
 130   if (retarray->base_addr == NULL)
 131     {
 132       GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
 133       retarray->dtype.rank = 1;
 134       retarray->offset = 0;
 135       retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
 136     }
 137   else
 138     {
 139       if (unlikely (compile_options.bounds_check))
 140         {
 141
 142           bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 143                                   "u_name");
 144           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 145                                   "MASK argument", "u_name");
 146         }
 147     }
 148
 149   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 150
 151   mbase = mask->base_addr;
 152
 153   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 154 #ifdef HAVE_GFC_LOGICAL_16
 155       || mask_kind == 16
 156 #endif
 157       )
 158     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 159   else
 160     runtime_error ("Funny sized logical array");
 161
 162   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 163   dest = retarray->base_addr;
 164   for (n = 0; n < rank; n++)
 165     {
 166       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 167       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 168       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 169       count[n] = 0;
 170       if (extent[n] <= 0)
 171         {
 172           /* Set the return value.  */
 173           for (n = 0; n < rank; n++)
 174             dest[n * dstride] = 0;
 175           return;
 176         }
 177     }
 178
 179   base = array->base_addr;
 180
 181   /* Initialize the return value.  */
 182   for (n = 0; n < rank; n++)
 183     dest[n * dstride] = 0;
 184   {
 185 ')dnl
 186 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
 187 define(FINISH_MASKED_FOREACH_FUNCTION,
 188 `         /* Implementation end.  */
 189           /* Advance to the next element.  */
 190           base += sstride[0];
 191           mbase += mstride[0];
 192         }
 193       while (++count[0] != extent[0]);
 194       n = 0;
 195       do
 196         {
 197           /* When we get to the end of a dimension, reset it and increment
 198              the next dimension.  */
 199           count[n] = 0;
 200           /* We could precalculate these products, but this is a less
 201              frequently used path so probably not worth it.  */
 202           base -= sstride[n] * extent[n];
 203           mbase -= mstride[n] * extent[n];
 204           n++;
 205           if (n >= rank)
 206             {
 207               /* Break out of the loop.  */
 208               base = NULL;
 209               break;
 210             }
 211           else
 212             {
 213               count[n]++;
 214               base += sstride[n];
 215               mbase += mstride[n];
 216             }
 217         }
 218       while (count[n] == extent[n]);
 219     }
 220   }
 221 }')dnl
 222 define(FOREACH_FUNCTION,
 223 `START_FOREACH_FUNCTION
 224 $1
 225 START_FOREACH_BLOCK
 226 $2
 227 FINISH_FOREACH_FUNCTION')dnl
 228 define(MASKED_FOREACH_FUNCTION,
 229 `START_MASKED_FOREACH_FUNCTION
 230 $1
 231 START_MASKED_FOREACH_BLOCK
 232 $2
 233 FINISH_MASKED_FOREACH_FUNCTION')dnl
 234 define(SCALAR_FOREACH_FUNCTION,
 235 `
 236 extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
 237         atype * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4);
 238 export_proto(`s'name`'rtype_qual`_'atype_code);
 239
 240 void
 241 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
 242         atype * const restrict array,
 243         GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
 244 {
 245   index_type rank;
 246   index_type dstride;
 247   index_type n;
 248   rtype_name *dest;
 249
 250   if (*mask)
 251     {
 252       name`'rtype_qual`_'atype_code (retarray, array, back);
 253       return;
 254     }
 255
 256   rank = GFC_DESCRIPTOR_RANK (array);
 257
 258   if (rank <= 0)
 259     runtime_error ("Rank of array needs to be > 0");
 260
 261   if (retarray->base_addr == NULL)
 262     {
 263       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
 264       retarray->dtype.rank = 1;
 265       retarray->offset = 0;
 266       retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
 267     }
 268   else if (unlikely (compile_options.bounds_check))
 269     {
 270        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 271                                "u_name");
 272     }
 273
 274   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 275   dest = retarray->base_addr;
 276   for (n = 0; n<rank; n++)
 277     dest[n * dstride] = $1 ;
 278 }')dnl