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