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