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       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 (unlikely (compile_options.bounds_check))
  40         {
  41           int ret_rank;
  42           index_type ret_extent;
  43
  44           ret_rank = GFC_DESCRIPTOR_RANK (retarray);
  45           if (ret_rank != 1)
  46             runtime_error ("rank of return array in u_name intrinsic"
  47                            " should be 1, is %ld", (long int) ret_rank);
  48
  49           ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound;
  50           if (ret_extent != rank)
  51             runtime_error ("Incorrect extent in return value of"
  52                            " u_name intrnisic: is %ld, should be %ld",
  53                            (long int) ret_extent, (long int) rank);
  54         }
  55     }
  56
  57   dstride = retarray->dim[0].stride;
  58   dest = retarray->data;
  59   for (n = 0; n < rank; n++)
  60     {
  61       sstride[n] = array->dim[n].stride;
  62       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
  63       count[n] = 0;
  64       if (extent[n] <= 0)
  65         {
  66           /* Set the return value.  */
  67           for (n = 0; n < rank; n++)
  68             dest[n * dstride] = 0;
  69           return;
  70         }
  71     }
  72
  73   base = array->data;
  74
  75   /* Initialize the return value.  */
  76   for (n = 0; n < rank; n++)
  77     dest[n * dstride] = 0;
  78   {
  79 ')dnl
  80 define(START_FOREACH_BLOCK,
  81 `  while (base)
  82     {
  83       {
  84         /* Implementation start.  */
  85 ')dnl
  86 define(FINISH_FOREACH_FUNCTION,
  87 `        /* Implementation end.  */
  88       }
  89       /* Advance to the next element.  */
  90       count[0]++;
  91       base += sstride[0];
  92       n = 0;
  93       while (count[n] == extent[n])
  94         {
  95           /* When we get to the end of a dimension, reset it and increment
  96              the next dimension.  */
  97           count[n] = 0;
  98           /* We could precalculate these products, but this is a less
  99              frequently used path so probably not worth it.  */
 100           base -= sstride[n] * extent[n];
 101           n++;
 102           if (n == rank)
 103             {
 104               /* Break out of the loop.  */
 105               base = NULL;
 106               break;
 107             }
 108           else
 109             {
 110               count[n]++;
 111               base += sstride[n];
 112             }
 113         }
 114     }
 115   }
 116 }')dnl
 117 define(START_MASKED_FOREACH_FUNCTION,
 118 `
 119 extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
 120         atype * const restrict, gfc_array_l1 * const restrict);
 121 export_proto(`m'name`'rtype_qual`_'atype_code);
 122
 123 void
 124 `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
 125         atype * const restrict array,
 126         gfc_array_l1 * const restrict mask)
 127 {
 128   index_type count[GFC_MAX_DIMENSIONS];
 129   index_type extent[GFC_MAX_DIMENSIONS];
 130   index_type sstride[GFC_MAX_DIMENSIONS];
 131   index_type mstride[GFC_MAX_DIMENSIONS];
 132   index_type dstride;
 133   rtype_name *dest;
 134   const atype_name *base;
 135   GFC_LOGICAL_1 *mbase;
 136   int rank;
 137   index_type n;
 138   int mask_kind;
 139
 140   rank = GFC_DESCRIPTOR_RANK (array);
 141   if (rank <= 0)
 142     runtime_error ("Rank of array needs to be > 0");
 143
 144   if (retarray->data == NULL)
 145     {
 146       retarray->dim[0].lbound = 0;
 147       retarray->dim[0].ubound = rank-1;
 148       retarray->dim[0].stride = 1;
 149       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 150       retarray->offset = 0;
 151       retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
 152     }
 153   else
 154     {
 155       if (unlikely (compile_options.bounds_check))
 156         {
 157           int ret_rank, mask_rank;
 158           index_type ret_extent;
 159           int n;
 160           index_type array_extent, mask_extent;
 161
 162           ret_rank = GFC_DESCRIPTOR_RANK (retarray);
 163           if (ret_rank != 1)
 164             runtime_error ("rank of return array in u_name intrinsic"
 165                            " should be 1, is %ld", (long int) ret_rank);
 166
 167           ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound;
 168           if (ret_extent != rank)
 169             runtime_error ("Incorrect extent in return value of"
 170                            " u_name intrnisic: is %ld, should be %ld",
 171                            (long int) ret_extent, (long int) rank);
 172
 173           mask_rank = GFC_DESCRIPTOR_RANK (mask);
 174           if (rank != mask_rank)
 175             runtime_error ("rank of MASK argument in u_name intrnisic"
 176                            "should be %ld, is %ld", (long int) rank,
 177                            (long int) mask_rank);
 178
 179           for (n=0; n<rank; n++)
 180             {
 181               array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound;
 182               mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound;
 183               if (array_extent != mask_extent)
 184                 runtime_error ("Incorrect extent in MASK argument of"
 185                                " u_name intrinsic in dimension %ld:"
 186                                " is %ld, should be %ld", (long int) n + 1,
 187                                (long int) mask_extent, (long int) array_extent);
 188             }
 189         }
 190     }
 191
 192   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 193
 194   mbase = mask->data;
 195
 196   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 197 #ifdef HAVE_GFC_LOGICAL_16
 198       || mask_kind == 16
 199 #endif
 200       )
 201     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 202   else
 203     runtime_error ("Funny sized logical array");
 204
 205   dstride = retarray->dim[0].stride;
 206   dest = retarray->data;
 207   for (n = 0; n < rank; n++)
 208     {
 209       sstride[n] = array->dim[n].stride;
 210       mstride[n] = mask->dim[n].stride * mask_kind;
 211       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 212       count[n] = 0;
 213       if (extent[n] <= 0)
 214         {
 215           /* Set the return value.  */
 216           for (n = 0; n < rank; n++)
 217             dest[n * dstride] = 0;
 218           return;
 219         }
 220     }
 221
 222   base = array->data;
 223
 224   /* Initialize the return value.  */
 225   for (n = 0; n < rank; n++)
 226     dest[n * dstride] = 0;
 227   {
 228 ')dnl
 229 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
 230 define(FINISH_MASKED_FOREACH_FUNCTION,
 231 `        /* Implementation end.  */
 232       }
 233       /* Advance to the next element.  */
 234       count[0]++;
 235       base += sstride[0];
 236       mbase += mstride[0];
 237       n = 0;
 238       while (count[n] == extent[n])
 239         {
 240           /* When we get to the end of a dimension, reset it and increment
 241              the next dimension.  */
 242           count[n] = 0;
 243           /* We could precalculate these products, but this is a less
 244              frequently used path so probably not worth it.  */
 245           base -= sstride[n] * extent[n];
 246           mbase -= mstride[n] * extent[n];
 247           n++;
 248           if (n == rank)
 249             {
 250               /* Break out of the loop.  */
 251               base = NULL;
 252               break;
 253             }
 254           else
 255             {
 256               count[n]++;
 257               base += sstride[n];
 258               mbase += mstride[n];
 259             }
 260         }
 261     }
 262   }
 263 }')dnl
 264 define(FOREACH_FUNCTION,
 265 `START_FOREACH_FUNCTION
 266 $1
 267 START_FOREACH_BLOCK
 268 $2
 269 FINISH_FOREACH_FUNCTION')dnl
 270 define(MASKED_FOREACH_FUNCTION,
 271 `START_MASKED_FOREACH_FUNCTION
 272 $1
 273 START_MASKED_FOREACH_BLOCK
 274 $2
 275 FINISH_MASKED_FOREACH_FUNCTION')dnl
 276 define(SCALAR_FOREACH_FUNCTION,
 277 `
 278 extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
 279         atype * const restrict, GFC_LOGICAL_4 *);
 280 export_proto(`s'name`'rtype_qual`_'atype_code);
 281
 282 void
 283 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
 284         atype * const restrict array,
 285         GFC_LOGICAL_4 * mask)
 286 {
 287   index_type rank;
 288   index_type dstride;
 289   index_type n;
 290   rtype_name *dest;
 291
 292   if (*mask)
 293     {
 294       name`'rtype_qual`_'atype_code (retarray, array);
 295       return;
 296     }
 297
 298   rank = GFC_DESCRIPTOR_RANK (array);
 299
 300   if (rank <= 0)
 301     runtime_error ("Rank of array needs to be > 0");
 302
 303   if (retarray->data == NULL)
 304     {
 305       retarray->dim[0].lbound = 0;
 306       retarray->dim[0].ubound = rank-1;
 307       retarray->dim[0].stride = 1;
 308       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 309       retarray->offset = 0;
 310       retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
 311     }
 312   else
 313     {
 314       if (unlikely (compile_options.bounds_check))
 315         {
 316           int ret_rank;
 317           index_type ret_extent;
 318
 319           ret_rank = GFC_DESCRIPTOR_RANK (retarray);
 320           if (ret_rank != 1)
 321             runtime_error ("rank of return array in u_name intrinsic"
 322                            " should be 1, is %ld", (long int) ret_rank);
 323
 324           ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound;
 325             if (ret_extent != rank)
 326               runtime_error ("dimension of return array incorrect");
 327         }
 328     }
 329
 330   dstride = retarray->dim[0].stride;
 331   dest = retarray->data;
 332   for (n = 0; n<rank; n++)
 333     dest[n * dstride] = $1 ;
 334 }')dnl