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       if (extent[n] < 0)
  56         extent[n] = 0;
  57     }
  58   for (n = dim; n < rank; n++)
  59     {
  60       sstride[n] = array->dim[n + 1].stride;
  61       extent[n] =
  62         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
  63
  64       if (extent[n] < 0)
  65         extent[n] = 0;
  66     }
  67
  68   if (retarray->data == NULL)
  69     {
  70       size_t alloc_size;
  71
  72       for (n = 0; n < rank; n++)
  73         {
  74           retarray->dim[n].lbound = 0;
  75           retarray->dim[n].ubound = extent[n]-1;
  76           if (n == 0)
  77             retarray->dim[n].stride = 1;
  78           else
  79             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
  80         }
  81
  82       retarray->offset = 0;
  83       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
  84
  85       alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride
  86                    * extent[rank-1];
  87
  88       if (alloc_size == 0)
  89         {
  90           /* Make sure we have a zero-sized array.  */
  91           retarray->dim[0].lbound = 0;
  92           retarray->dim[0].ubound = -1;
  93           return;
  94         }
  95       else
  96         retarray->data = internal_malloc_size (alloc_size);
  97     }
  98   else
  99     {
 100       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 101         runtime_error ("rank of return array incorrect");
 102     }
 103
 104   for (n = 0; n < rank; n++)
 105     {
 106       count[n] = 0;
 107       dstride[n] = retarray->dim[n].stride;
 108       if (extent[n] <= 0)
 109         len = 0;
 110     }
 111
 112   base = array->data;
 113   dest = retarray->data;
 114
 115   while (base)
 116     {
 117       const atype_name * restrict src;
 118       rtype_name result;
 119       src = base;
 120       {
 121 ')dnl
 122 define(START_ARRAY_BLOCK,
 123 `        if (len <= 0)
 124           *dest = '$1`;
 125         else
 126           {
 127             for (n = 0; n < len; n++, src += delta)
 128               {
 129 ')dnl
 130 define(FINISH_ARRAY_FUNCTION,
 131     `          }
 132             *dest = result;
 133           }
 134       }
 135       /* Advance to the next element.  */
 136       count[0]++;
 137       base += sstride[0];
 138       dest += dstride[0];
 139       n = 0;
 140       while (count[n] == extent[n])
 141         {
 142           /* When we get to the end of a dimension, reset it and increment
 143              the next dimension.  */
 144           count[n] = 0;
 145           /* We could precalculate these products, but this is a less
 146              frequently used path so probably not worth it.  */
 147           base -= sstride[n] * extent[n];
 148           dest -= dstride[n] * extent[n];
 149           n++;
 150           if (n == rank)
 151             {
 152               /* Break out of the look.  */
 153               base = NULL;
 154               break;
 155             }
 156           else
 157             {
 158               count[n]++;
 159               base += sstride[n];
 160               dest += dstride[n];
 161             }
 162         }
 163     }
 164 }')dnl
 165 define(START_MASKED_ARRAY_FUNCTION,
 166 `
 167 extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
 168         atype * const restrict, const index_type * const restrict,
 169         gfc_array_l4 * const restrict);
 170 export_proto(`m'name`'rtype_qual`_'atype_code);
 171
 172 void
 173 `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
 174         atype * const restrict array,
 175         const index_type * const restrict pdim,
 176         gfc_array_l4 * const restrict mask)
 177 {
 178   index_type count[GFC_MAX_DIMENSIONS];
 179   index_type extent[GFC_MAX_DIMENSIONS];
 180   index_type sstride[GFC_MAX_DIMENSIONS];
 181   index_type dstride[GFC_MAX_DIMENSIONS];
 182   index_type mstride[GFC_MAX_DIMENSIONS];
 183   rtype_name * restrict dest;
 184   const atype_name * restrict base;
 185   const GFC_LOGICAL_4 * restrict mbase;
 186   int rank;
 187   int dim;
 188   index_type n;
 189   index_type len;
 190   index_type delta;
 191   index_type mdelta;
 192
 193   dim = (*pdim) - 1;
 194   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 195
 196   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 197   if (len <= 0)
 198     return;
 199   delta = array->dim[dim].stride;
 200   mdelta = mask->dim[dim].stride;
 201
 202   for (n = 0; n < dim; n++)
 203     {
 204       sstride[n] = array->dim[n].stride;
 205       mstride[n] = mask->dim[n].stride;
 206       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 207
 208       if (extent[n] < 0)
 209         extent[n] = 0;
 210
 211     }
 212   for (n = dim; n < rank; n++)
 213     {
 214       sstride[n] = array->dim[n + 1].stride;
 215       mstride[n] = mask->dim[n + 1].stride;
 216       extent[n] =
 217         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 218
 219       if (extent[n] < 0)
 220         extent[n] = 0;
 221     }
 222
 223   if (retarray->data == NULL)
 224     {
 225       size_t alloc_size;
 226
 227       for (n = 0; n < rank; n++)
 228         {
 229           retarray->dim[n].lbound = 0;
 230           retarray->dim[n].ubound = extent[n]-1;
 231           if (n == 0)
 232             retarray->dim[n].stride = 1;
 233           else
 234             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 235         }
 236
 237       alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride
 238                    * extent[rank-1];
 239
 240       retarray->offset = 0;
 241       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 242
 243       if (alloc_size == 0)
 244         {
 245           /* Make sure we have a zero-sized array.  */
 246           retarray->dim[0].lbound = 0;
 247           retarray->dim[0].ubound = -1;
 248           return;
 249         }
 250       else
 251         retarray->data = internal_malloc_size (alloc_size);
 252
 253     }
 254   else
 255     {
 256       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 257         runtime_error ("rank of return array incorrect");
 258     }
 259
 260   for (n = 0; n < rank; n++)
 261     {
 262       count[n] = 0;
 263       dstride[n] = retarray->dim[n].stride;
 264       if (extent[n] <= 0)
 265         return;
 266     }
 267
 268   dest = retarray->data;
 269   base = array->data;
 270   mbase = mask->data;
 271
 272   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
 273     {
 274       /* This allows the same loop to be used for all logical types.  */
 275       assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
 276       for (n = 0; n < rank; n++)
 277         mstride[n] <<= 1;
 278       mdelta <<= 1;
 279       mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
 280     }
 281
 282   while (base)
 283     {
 284       const atype_name * restrict src;
 285       const GFC_LOGICAL_4 * restrict msrc;
 286       rtype_name result;
 287       src = base;
 288       msrc = mbase;
 289       {
 290 ')dnl
 291 define(START_MASKED_ARRAY_BLOCK,
 292 `        if (len <= 0)
 293           *dest = '$1`;
 294         else
 295           {
 296             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 297               {
 298 ')dnl
 299 define(FINISH_MASKED_ARRAY_FUNCTION,
 300 `              }
 301             *dest = result;
 302           }
 303       }
 304       /* Advance to the next element.  */
 305       count[0]++;
 306       base += sstride[0];
 307       mbase += mstride[0];
 308       dest += dstride[0];
 309       n = 0;
 310       while (count[n] == extent[n])
 311         {
 312           /* When we get to the end of a dimension, reset it and increment
 313              the next dimension.  */
 314           count[n] = 0;
 315           /* We could precalculate these products, but this is a less
 316              frequently used path so probably not worth it.  */
 317           base -= sstride[n] * extent[n];
 318           mbase -= mstride[n] * extent[n];
 319           dest -= dstride[n] * extent[n];
 320           n++;
 321           if (n == rank)
 322             {
 323               /* Break out of the look.  */
 324               base = NULL;
 325               break;
 326             }
 327           else
 328             {
 329               count[n]++;
 330               base += sstride[n];
 331               mbase += mstride[n];
 332               dest += dstride[n];
 333             }
 334         }
 335     }
 336 }')dnl
 337 define(SCALAR_ARRAY_FUNCTION,
 338 `
 339 extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
 340         atype * const restrict, const index_type * const restrict,
 341         GFC_LOGICAL_4 *);
 342 export_proto(`s'name`'rtype_qual`_'atype_code);
 343
 344 void
 345 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
 346         atype * const restrict array,
 347         const index_type * const restrict pdim,
 348         GFC_LOGICAL_4 * mask)
 349 {
 350   index_type rank;
 351   index_type n;
 352   index_type dstride;
 353   rtype_name *dest;
 354
 355   if (*mask)
 356     {
 357       name`'rtype_qual`_'atype_code (retarray, array, pdim);
 358       return;
 359     }
 360     rank = GFC_DESCRIPTOR_RANK (array);
 361   if (rank <= 0)
 362     runtime_error ("Rank of array needs to be > 0");
 363
 364   if (retarray->data == NULL)
 365     {
 366       retarray->dim[0].lbound = 0;
 367       retarray->dim[0].ubound = rank-1;
 368       retarray->dim[0].stride = 1;
 369       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 370       retarray->offset = 0;
 371       retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
 372     }
 373   else
 374     {
 375       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 376         runtime_error ("rank of return array does not equal 1");
 377
 378       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 379         runtime_error ("dimension of return array incorrect");
 380     }
 381
 382     dstride = retarray->dim[0].stride;
 383     dest = retarray->data;
 384
 385     for (n = 0; n < rank; n++)
 386       dest[n * dstride] = $1 ;
 387 }')dnl
 388 define(ARRAY_FUNCTION,
 389 `START_ARRAY_FUNCTION
 390 $2
 391 START_ARRAY_BLOCK($1)
 392 $3
 393 FINISH_ARRAY_FUNCTION')dnl
 394 define(MASKED_ARRAY_FUNCTION,
 395 `START_MASKED_ARRAY_FUNCTION
 396 $2
 397 START_MASKED_ARRAY_BLOCK($1)
 398 $3
 399 FINISH_MASKED_ARRAY_FUNCTION')dnl