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