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