libgfortran/m4/iforeach-s2.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 #define INITVAL 'initval`
  17
  18 extern void 'name`'rtype_qual`_'atype_code (atype_name * restrict,
  19         gfc_charlen_type,
  20         atype * const restrict array, gfc_charlen_type);
  21 export_proto(name`'rtype_qual`_'atype_code);
  22
  23 void
  24 name`'rtype_qual`_'atype_code` ('atype_name` * restrict ret,
  25         gfc_charlen_type xlen,
  26         'atype` * const restrict array, gfc_charlen_type len)
  27 {
  28   index_type count[GFC_MAX_DIMENSIONS];
  29   index_type extent[GFC_MAX_DIMENSIONS];
  30   index_type sstride[GFC_MAX_DIMENSIONS];
  31   const 'atype_name` *base;
  32   index_type rank;
  33   index_type n;
  34
  35   rank = GFC_DESCRIPTOR_RANK (array);
  36   if (rank <= 0)
  37     runtime_error ("Rank of array needs to be > 0");
  38
  39   assert (xlen == len);
  40
  41   /* Initialize return value.  */
  42   memset (ret, INITVAL, sizeof(*ret) * len);
  43
  44   for (n = 0; n < rank; n++)
  45     {
  46       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
  47       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  48       count[n] = 0;
  49       if (extent[n] <= 0)
  50         return;
  51     }
  52
  53   base = array->base_addr;
  54
  55   {
  56 ')dnl
  57 define(START_FOREACH_BLOCK,
  58 `  while (base)
  59     {
  60       do
  61         {
  62           /* Implementation start.  */
  63 ')dnl
  64 define(FINISH_FOREACH_FUNCTION,
  65 `         /* Implementation end.  */
  66           /* Advance to the next element.  */
  67           base += sstride[0];
  68         }
  69       while (++count[0] != extent[0]);
  70       n = 0;
  71       do
  72         {
  73           /* When we get to the end of a dimension, reset it and increment
  74              the next dimension.  */
  75           count[n] = 0;
  76           /* We could precalculate these products, but this is a less
  77              frequently used path so probably not worth it.  */
  78           base -= sstride[n] * extent[n];
  79           n++;
  80           if (n >= rank)
  81             {
  82               /* Break out of the loop.  */
  83               base = NULL;
  84               break;
  85             }
  86           else
  87             {
  88               count[n]++;
  89               base += sstride[n];
  90             }
  91         }
  92       while (count[n] == extent[n]);
  93     }
  94    memcpy (ret, retval, len * sizeof (*ret));
  95   }
  96 }')dnl
  97 define(START_MASKED_FOREACH_FUNCTION,
  98 `
  99 extern void `m'name`'rtype_qual`_'atype_code (atype_name * restrict,
 100        gfc_charlen_type, atype * const restrict array,
 101        gfc_array_l1 * const restrict mask, gfc_charlen_type len);
 102 export_proto(`m'name`'rtype_qual`_'atype_code);
 103
 104 void
 105 `m'name`'rtype_qual`_'atype_code (atype_name * const restrict ret,
 106         gfc_charlen_type xlen, atype * const restrict array,
 107         gfc_array_l1 * const restrict mask, gfc_charlen_type len)
 108 {
 109   index_type count[GFC_MAX_DIMENSIONS];
 110   index_type extent[GFC_MAX_DIMENSIONS];
 111   index_type sstride[GFC_MAX_DIMENSIONS];
 112   index_type mstride[GFC_MAX_DIMENSIONS];
 113   const atype_name *base;
 114   GFC_LOGICAL_1 *mbase;
 115   int rank;
 116   index_type n;
 117   int mask_kind;
 118
 119   rank = GFC_DESCRIPTOR_RANK (array);
 120   if (rank <= 0)
 121     runtime_error ("Rank of array needs to be > 0");
 122
 123   assert (xlen == len);
 124
 125 /* Initialize return value.  */
 126   memset (ret, INITVAL, sizeof(*ret) * len);
 127
 128   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 129
 130   mbase = mask->base_addr;
 131
 132   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 133 #ifdef HAVE_GFC_LOGICAL_16
 134       || mask_kind == 16
 135 #endif
 136       )
 137     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 138   else
 139     runtime_error ("Funny sized logical array");
 140
 141   for (n = 0; n < rank; n++)
 142     {
 143       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
 144       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 145       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 146       count[n] = 0;
 147       if (extent[n] <= 0)
 148         return;
 149     }
 150
 151   base = array->base_addr;
 152   {
 153 ')dnl
 154 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
 155 define(FINISH_MASKED_FOREACH_FUNCTION,
 156 `         /* Implementation end.  */
 157           /* Advance to the next element.  */
 158           base += sstride[0];
 159           mbase += mstride[0];
 160         }
 161       while (++count[0] != extent[0]);
 162       n = 0;
 163       do
 164         {
 165           /* When we get to the end of a dimension, reset it and increment
 166              the next dimension.  */
 167           count[n] = 0;
 168           /* We could precalculate these products, but this is a less
 169              frequently used path so probably not worth it.  */
 170           base -= sstride[n] * extent[n];
 171           mbase -= mstride[n] * extent[n];
 172           n++;
 173           if (n >= rank)
 174             {
 175               /* Break out of the loop.  */
 176               base = NULL;
 177               break;
 178             }
 179           else
 180             {
 181               count[n]++;
 182               base += sstride[n];
 183               mbase += mstride[n];
 184             }
 185         }
 186       while (count[n] == extent[n]);
 187     }
 188     memcpy (ret, retval, len * sizeof (*ret));
 189   }
 190 }')dnl
 191 define(FOREACH_FUNCTION,
 192 `START_FOREACH_FUNCTION
 193 $1
 194 START_FOREACH_BLOCK
 195 $2
 196 FINISH_FOREACH_FUNCTION')dnl
 197 define(MASKED_FOREACH_FUNCTION,
 198 `START_MASKED_FOREACH_FUNCTION
 199 $1
 200 START_MASKED_FOREACH_BLOCK
 201 $2
 202 FINISH_MASKED_FOREACH_FUNCTION')dnl
 203 define(SCALAR_FOREACH_FUNCTION,
 204 `
 205 extern void `s'name`'rtype_qual`_'atype_code (atype_name * restrict,
 206         gfc_charlen_type,
 207         atype * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
 208 export_proto(`s'name`'rtype_qual`_'atype_code);
 209
 210 void
 211 `s'name`'rtype_qual`_'atype_code (atype_name * restrict ret,
 212         gfc_charlen_type xlen, atype * const restrict array,
 213         GFC_LOGICAL_4 *mask, gfc_charlen_type len)
 214
 215 {
 216   if (*mask)
 217     {
 218       name`'rtype_qual`_'atype_code (ret, xlen, array, len);
 219       return;
 220     }
 221   memset (ret, INITVAL, sizeof (*ret) * len);
 222 }')dnl