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