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   if (mask == NULL)
 120     {
 121       name`'rtype_qual`_'atype_code (ret, xlen, array, len);
 122       return;
 123     }
 124
 125   rank = GFC_DESCRIPTOR_RANK (array);
 126   if (rank <= 0)
 127     runtime_error ("Rank of array needs to be > 0");
 128
 129   assert (xlen == len);
 130
 131 /* Initialize return value.  */
 132   memset (ret, INITVAL, sizeof(*ret) * len);
 133
 134   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 135
 136   mbase = mask->base_addr;
 137
 138   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 139 #ifdef HAVE_GFC_LOGICAL_16
 140       || mask_kind == 16
 141 #endif
 142       )
 143     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 144   else
 145     runtime_error ("Funny sized logical array");
 146
 147   for (n = 0; n < rank; n++)
 148     {
 149       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
 150       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 151       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 152       count[n] = 0;
 153       if (extent[n] <= 0)
 154         return;
 155     }
 156
 157   base = array->base_addr;
 158   {
 159 ')dnl
 160 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
 161 define(FINISH_MASKED_FOREACH_FUNCTION,
 162 `         /* Implementation end.  */
 163           /* Advance to the next element.  */
 164           base += sstride[0];
 165           mbase += mstride[0];
 166         }
 167       while (++count[0] != extent[0]);
 168       n = 0;
 169       do
 170         {
 171           /* When we get to the end of a dimension, reset it and increment
 172              the next dimension.  */
 173           count[n] = 0;
 174           /* We could precalculate these products, but this is a less
 175              frequently used path so probably not worth it.  */
 176           base -= sstride[n] * extent[n];
 177           mbase -= mstride[n] * extent[n];
 178           n++;
 179           if (n >= rank)
 180             {
 181               /* Break out of the loop.  */
 182               base = NULL;
 183               break;
 184             }
 185           else
 186             {
 187               count[n]++;
 188               base += sstride[n];
 189               mbase += mstride[n];
 190             }
 191         }
 192       while (count[n] == extent[n]);
 193     }
 194     memcpy (ret, retval, len * sizeof (*ret));
 195   }
 196 }')dnl
 197 define(FOREACH_FUNCTION,
 198 `START_FOREACH_FUNCTION
 199 $1
 200 START_FOREACH_BLOCK
 201 $2
 202 FINISH_FOREACH_FUNCTION')dnl
 203 define(MASKED_FOREACH_FUNCTION,
 204 `START_MASKED_FOREACH_FUNCTION
 205 $1
 206 START_MASKED_FOREACH_BLOCK
 207 $2
 208 FINISH_MASKED_FOREACH_FUNCTION')dnl
 209 define(SCALAR_FOREACH_FUNCTION,
 210 `
 211 extern void `s'name`'rtype_qual`_'atype_code (atype_name * restrict,
 212         gfc_charlen_type,
 213         atype * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
 214 export_proto(`s'name`'rtype_qual`_'atype_code);
 215
 216 void
 217 `s'name`'rtype_qual`_'atype_code (atype_name * restrict ret,
 218         gfc_charlen_type xlen, atype * const restrict array,
 219         GFC_LOGICAL_4 *mask, gfc_charlen_type len)
 220
 221 {
 222   if (mask == NULL || *mask)
 223     {
 224       name`'rtype_qual`_'atype_code (ret, xlen, array, len);
 225       return;
 226     }
 227   memset (ret, INITVAL, sizeof (*ret) * len);
 228 }')dnl