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 *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       retarray->dim[0].lbound = 0;
  31       retarray->dim[0].ubound = rank-1;
  32       retarray->dim[0].stride = 1;
  33       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
  34       retarray->offset = 0;
  35       retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
  36     }
  37   else
  38     {
  39       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
  40         runtime_error ("rank of return array does not equal 1");
  41
  42       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
  43         runtime_error ("dimension of return array incorrect");
  44     }
  45
  46   dstride = retarray->dim[0].stride;
  47   dest = retarray->data;
  48   for (n = 0; n < rank; n++)
  49     {
  50       sstride[n] = array->dim[n].stride;
  51       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
  52       count[n] = 0;
  53       if (extent[n] <= 0)
  54         {
  55           /* Set the return value.  */
  56           for (n = 0; n < rank; n++)
  57             dest[n * dstride] = 0;
  58           return;
  59         }
  60     }
  61
  62   base = array->data;
  63
  64   /* Initialize the return value.  */
  65   for (n = 0; n < rank; n++)
  66     dest[n * dstride] = 0;
  67   {
  68 ')dnl
  69 define(START_FOREACH_BLOCK,
  70 `  while (base)
  71     {
  72       {
  73         /* Implementation start.  */
  74 ')dnl
  75 define(FINISH_FOREACH_FUNCTION,
  76 `        /* Implementation end.  */
  77       }
  78       /* Advance to the next element.  */
  79       count[0]++;
  80       base += sstride[0];
  81       n = 0;
  82       while (count[n] == extent[n])
  83         {
  84           /* When we get to the end of a dimension, reset it and increment
  85              the next dimension.  */
  86           count[n] = 0;
  87           /* We could precalculate these products, but this is a less
  88              frequently used path so probably not worth it.  */
  89           base -= sstride[n] * extent[n];
  90           n++;
  91           if (n == rank)
  92             {
  93               /* Break out of the loop.  */
  94               base = NULL;
  95               break;
  96             }
  97           else
  98             {
  99               count[n]++;
 100               base += sstride[n];
 101             }
 102         }
 103     }
 104   }
 105 }')dnl
 106 define(START_MASKED_FOREACH_FUNCTION,
 107 `
 108 extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
 109         atype * const restrict, gfc_array_l1 * const restrict);
 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)
 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   rank = GFC_DESCRIPTOR_RANK (array);
 130   if (rank <= 0)
 131     runtime_error ("Rank of array needs to be > 0");
 132
 133   if (retarray->data == NULL)
 134     {
 135       retarray->dim[0].lbound = 0;
 136       retarray->dim[0].ubound = rank-1;
 137       retarray->dim[0].stride = 1;
 138       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 139       retarray->offset = 0;
 140       retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
 141     }
 142   else
 143     {
 144       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 145         runtime_error ("rank of return array does not equal 1");
 146
 147       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 148         runtime_error ("dimension of return array incorrect");
 149     }
 150
 151   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 152
 153   mbase = mask->data;
 154
 155   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 156 #ifdef HAVE_GFC_LOGICAL_16
 157       || mask_kind == 16
 158 #endif
 159       )
 160     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 161   else
 162     runtime_error ("Funny sized logical array");
 163
 164   dstride = retarray->dim[0].stride;
 165   dest = retarray->data;
 166   for (n = 0; n < rank; n++)
 167     {
 168       sstride[n] = array->dim[n].stride;
 169       mstride[n] = mask->dim[n].stride * mask_kind;
 170       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 171       count[n] = 0;
 172       if (extent[n] <= 0)
 173         {
 174           /* Set the return value.  */
 175           for (n = 0; n < rank; n++)
 176             dest[n * dstride] = 0;
 177           return;
 178         }
 179     }
 180
 181   base = array->data;
 182
 183   /* Initialize the return value.  */
 184   for (n = 0; n < rank; n++)
 185     dest[n * dstride] = 0;
 186   {
 187 ')dnl
 188 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
 189 define(FINISH_MASKED_FOREACH_FUNCTION,
 190 `        /* Implementation end.  */
 191       }
 192       /* Advance to the next element.  */
 193       count[0]++;
 194       base += sstride[0];
 195       mbase += mstride[0];
 196       n = 0;
 197       while (count[n] == extent[n])
 198         {
 199           /* When we get to the end of a dimension, reset it and increment
 200              the next dimension.  */
 201           count[n] = 0;
 202           /* We could precalculate these products, but this is a less
 203              frequently used path so probably not worth it.  */
 204           base -= sstride[n] * extent[n];
 205           mbase -= mstride[n] * extent[n];
 206           n++;
 207           if (n == rank)
 208             {
 209               /* Break out of the loop.  */
 210               base = NULL;
 211               break;
 212             }
 213           else
 214             {
 215               count[n]++;
 216               base += sstride[n];
 217               mbase += mstride[n];
 218             }
 219         }
 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       retarray->dim[0].lbound = 0;
 265       retarray->dim[0].ubound = rank-1;
 266       retarray->dim[0].stride = 1;
 267       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 268       retarray->offset = 0;
 269       retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
 270     }
 271   else
 272     {
 273       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 274         runtime_error ("rank of return array does not equal 1");
 275
 276       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 277         runtime_error ("dimension of return array incorrect");
 278     }
 279
 280   dstride = retarray->dim[0].stride;
 281   dest = retarray->data;
 282   for (n = 0; n<rank; n++)
 283     dest[n * dstride] = $1 ;
 284 }')dnl