libgfortran/m4/ifunction.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 dnl
   6 dnl Pass the implementation for a single section as the parameter to
   7 dnl {MASK_}ARRAY_FUNCTION.
   8 dnl The variables base, delta, and len describe the input section.
   9 dnl For masked section the mask is described by mbase and mdelta.
  10 dnl These should not be modified. The result should be stored in *dest.
  11 dnl The names count, extent, sstride, dstride, base, dest, rank, dim
  12 dnl retarray, array, pdim and mstride should not be used.
  13 dnl The variable n is declared as index_type and may be used.
  14 dnl Other variable declarations may be placed at the start of the code,
  15 dnl The types of the array parameter and the return value are
  16 dnl atype_name and rtype_name respectively.
  17 dnl Execution should be allowed to continue to the end of the block.
  18 dnl You should not return or break from the inner loop of the implementation.
  19 dnl Care should also be taken to avoid using the names defined in iparm.m4
  20 define(START_ARRAY_FUNCTION,
  21 `
  22 extern void name`'rtype_qual`_'atype_code (rtype * const restrict,
  23         atype * const restrict, const index_type * const restrict);
  24 export_proto(name`'rtype_qual`_'atype_code);
  25
  26 void
  27 name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
  28         atype * const restrict array,
  29         const index_type * const restrict pdim)
  30 {
  31   index_type count[GFC_MAX_DIMENSIONS];
  32   index_type extent[GFC_MAX_DIMENSIONS];
  33   index_type sstride[GFC_MAX_DIMENSIONS];
  34   index_type dstride[GFC_MAX_DIMENSIONS];
  35   const atype_name * restrict base;
  36   rtype_name * restrict dest;
  37   index_type rank;
  38   index_type n;
  39   index_type len;
  40   index_type delta;
  41   index_type dim;
  42
  43   /* Make dim zero based to avoid confusion.  */
  44   dim = (*pdim) - 1;
  45   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  46
  47   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  48   delta = array->dim[dim].stride;
  49
  50   for (n = 0; n < dim; n++)
  51     {
  52       sstride[n] = array->dim[n].stride;
  53       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
  54     }
  55   for (n = dim; n < rank; n++)
  56     {
  57       sstride[n] = array->dim[n + 1].stride;
  58       extent[n] =
  59         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
  60     }
  61
  62   if (retarray->data == NULL)
  63     {
  64       for (n = 0; n < rank; n++)
  65         {
  66           retarray->dim[n].lbound = 0;
  67           retarray->dim[n].ubound = extent[n]-1;
  68           if (n == 0)
  69             retarray->dim[n].stride = 1;
  70           else
  71             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
  72         }
  73
  74       retarray->data
  75          = internal_malloc_size (sizeof (rtype_name)
  76                                  * retarray->dim[rank-1].stride
  77                                  * extent[rank-1]);
  78       retarray->offset = 0;
  79       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
  80     }
  81   else
  82     {
  83       if (rank != GFC_DESCRIPTOR_RANK (retarray))
  84         runtime_error ("rank of return array incorrect");
  85     }
  86
  87   for (n = 0; n < rank; n++)
  88     {
  89       count[n] = 0;
  90       dstride[n] = retarray->dim[n].stride;
  91       if (extent[n] <= 0)
  92         len = 0;
  93     }
  94
  95   base = array->data;
  96   dest = retarray->data;
  97
  98   while (base)
  99     {
 100       const atype_name * restrict src;
 101       rtype_name result;
 102       src = base;
 103       {
 104 ')dnl
 105 define(START_ARRAY_BLOCK,
 106 `        if (len <= 0)
 107           *dest = '$1`;
 108         else
 109           {
 110             for (n = 0; n < len; n++, src += delta)
 111               {
 112 ')dnl
 113 define(FINISH_ARRAY_FUNCTION,
 114     `          }
 115             *dest = result;
 116           }
 117       }
 118       /* Advance to the next element.  */
 119       count[0]++;
 120       base += sstride[0];
 121       dest += dstride[0];
 122       n = 0;
 123       while (count[n] == extent[n])
 124         {
 125           /* When we get to the end of a dimension, reset it and increment
 126              the next dimension.  */
 127           count[n] = 0;
 128           /* We could precalculate these products, but this is a less
 129              frequently used path so proabably not worth it.  */
 130           base -= sstride[n] * extent[n];
 131           dest -= dstride[n] * extent[n];
 132           n++;
 133           if (n == rank)
 134             {
 135               /* Break out of the look.  */
 136               base = NULL;
 137               break;
 138             }
 139           else
 140             {
 141               count[n]++;
 142               base += sstride[n];
 143               dest += dstride[n];
 144             }
 145         }
 146     }
 147 }')dnl
 148 define(START_MASKED_ARRAY_FUNCTION,
 149 `
 150 extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
 151         atype * const restrict, const index_type * const restrict,
 152         gfc_array_l4 * const restrict);
 153 export_proto(`m'name`'rtype_qual`_'atype_code);
 154
 155 void
 156 `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
 157         atype * const restrict array,
 158         const index_type * const restrict pdim,
 159         gfc_array_l4 * const restrict mask)
 160 {
 161   index_type count[GFC_MAX_DIMENSIONS];
 162   index_type extent[GFC_MAX_DIMENSIONS];
 163   index_type sstride[GFC_MAX_DIMENSIONS];
 164   index_type dstride[GFC_MAX_DIMENSIONS];
 165   index_type mstride[GFC_MAX_DIMENSIONS];
 166   rtype_name * restrict dest;
 167   const atype_name * restrict base;
 168   const GFC_LOGICAL_4 * restrict mbase;
 169   int rank;
 170   int dim;
 171   index_type n;
 172   index_type len;
 173   index_type delta;
 174   index_type mdelta;
 175
 176   dim = (*pdim) - 1;
 177   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 178
 179   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 180   if (len <= 0)
 181     return;
 182   delta = array->dim[dim].stride;
 183   mdelta = mask->dim[dim].stride;
 184
 185   for (n = 0; n < dim; n++)
 186     {
 187       sstride[n] = array->dim[n].stride;
 188       mstride[n] = mask->dim[n].stride;
 189       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 190     }
 191   for (n = dim; n < rank; n++)
 192     {
 193       sstride[n] = array->dim[n + 1].stride;
 194       mstride[n] = mask->dim[n + 1].stride;
 195       extent[n] =
 196         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 197     }
 198
 199   if (retarray->data == NULL)
 200     {
 201       for (n = 0; n < rank; n++)
 202         {
 203           retarray->dim[n].lbound = 0;
 204           retarray->dim[n].ubound = extent[n]-1;
 205           if (n == 0)
 206             retarray->dim[n].stride = 1;
 207           else
 208             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 209         }
 210
 211       retarray->data
 212          = internal_malloc_size (sizeof (rtype_name)
 213                                  * retarray->dim[rank-1].stride
 214                                  * extent[rank-1]);
 215       retarray->offset = 0;
 216       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 217     }
 218   else
 219     {
 220       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 221         runtime_error ("rank of return array incorrect");
 222     }
 223
 224   for (n = 0; n < rank; n++)
 225     {
 226       count[n] = 0;
 227       dstride[n] = retarray->dim[n].stride;
 228       if (extent[n] <= 0)
 229         return;
 230     }
 231
 232   dest = retarray->data;
 233   base = array->data;
 234   mbase = mask->data;
 235
 236   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
 237     {
 238       /* This allows the same loop to be used for all logical types.  */
 239       assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
 240       for (n = 0; n < rank; n++)
 241         mstride[n] <<= 1;
 242       mdelta <<= 1;
 243       mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
 244     }
 245
 246   while (base)
 247     {
 248       const atype_name * restrict src;
 249       const GFC_LOGICAL_4 * restrict msrc;
 250       rtype_name result;
 251       src = base;
 252       msrc = mbase;
 253       {
 254 ')dnl
 255 define(START_MASKED_ARRAY_BLOCK,
 256 `        if (len <= 0)
 257           *dest = '$1`;
 258         else
 259           {
 260             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 261               {
 262 ')dnl
 263 define(FINISH_MASKED_ARRAY_FUNCTION,
 264 `              }
 265             *dest = result;
 266           }
 267       }
 268       /* Advance to the next element.  */
 269       count[0]++;
 270       base += sstride[0];
 271       mbase += mstride[0];
 272       dest += dstride[0];
 273       n = 0;
 274       while (count[n] == extent[n])
 275         {
 276           /* When we get to the end of a dimension, reset it and increment
 277              the next dimension.  */
 278           count[n] = 0;
 279           /* We could precalculate these products, but this is a less
 280              frequently used path so proabably not worth it.  */
 281           base -= sstride[n] * extent[n];
 282           mbase -= mstride[n] * extent[n];
 283           dest -= dstride[n] * extent[n];
 284           n++;
 285           if (n == rank)
 286             {
 287               /* Break out of the look.  */
 288               base = NULL;
 289               break;
 290             }
 291           else
 292             {
 293               count[n]++;
 294               base += sstride[n];
 295               mbase += mstride[n];
 296               dest += dstride[n];
 297             }
 298         }
 299     }
 300 }')dnl
 301 define(SCALAR_ARRAY_FUNCTION,
 302 `
 303 extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
 304         atype * const restrict, const index_type * const restrict,
 305         GFC_LOGICAL_4 *);
 306 export_proto(`s'name`'rtype_qual`_'atype_code);
 307
 308 void
 309 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
 310         atype * const restrict array,
 311         const index_type * const restrict pdim,
 312         GFC_LOGICAL_4 * mask)
 313 {
 314   index_type rank;
 315   index_type n;
 316   index_type dstride;
 317   rtype_name *dest;
 318
 319   if (*mask)
 320     {
 321       name`'rtype_qual`_'atype_code (retarray, array, pdim);
 322       return;
 323     }
 324     rank = GFC_DESCRIPTOR_RANK (array);
 325   if (rank <= 0)
 326     runtime_error ("Rank of array needs to be > 0");
 327
 328   if (retarray->data == NULL)
 329     {
 330       retarray->dim[0].lbound = 0;
 331       retarray->dim[0].ubound = rank-1;
 332       retarray->dim[0].stride = 1;
 333       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 334       retarray->offset = 0;
 335       retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
 336     }
 337   else
 338     {
 339       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 340         runtime_error ("rank of return array does not equal 1");
 341
 342       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 343         runtime_error ("dimension of return array incorrect");
 344     }
 345
 346     dstride = retarray->dim[0].stride;
 347     dest = retarray->data;
 348
 349     for (n = 0; n < rank; n++)
 350       dest[n * dstride] = $1 ;
 351 }')dnl
 352 define(ARRAY_FUNCTION,
 353 `START_ARRAY_FUNCTION
 354 $2
 355 START_ARRAY_BLOCK($1)
 356 $3
 357 FINISH_ARRAY_FUNCTION')dnl
 358 define(MASKED_ARRAY_FUNCTION,
 359 `START_MASKED_ARRAY_FUNCTION
 360 $2
 361 START_MASKED_ARRAY_BLOCK($1)
 362 $3
 363 FINISH_MASKED_ARRAY_FUNCTION')dnl