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 in"
 102                        " u_name intrinsic: is %ld, should be %ld",
 103                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 104                        (long int) rank);
 105
 106       if (compile_options.bounds_check)
 107         {
 108           for (n=0; n < rank; n++)
 109             {
 110               index_type ret_extent;
 111
 112               ret_extent = retarray->dim[n].ubound + 1
 113                 - retarray->dim[n].lbound;
 114               if (extent[n] != ret_extent)
 115                 runtime_error ("Incorrect extent in return value of"
 116                                " u_name intrinsic in dimension %ld:"
 117                                " is %ld, should be %ld", (long int) n + 1,
 118                                (long int) ret_extent, (long int) extent[n]);
 119             }
 120         }
 121     }
 122
 123   for (n = 0; n < rank; n++)
 124     {
 125       count[n] = 0;
 126       dstride[n] = retarray->dim[n].stride;
 127       if (extent[n] <= 0)
 128         len = 0;
 129     }
 130
 131   base = array->data;
 132   dest = retarray->data;
 133
 134   while (base)
 135     {
 136       const atype_name * restrict src;
 137       rtype_name result;
 138       src = base;
 139       {
 140 ')dnl
 141 define(START_ARRAY_BLOCK,
 142 `        if (len <= 0)
 143           *dest = '$1`;
 144         else
 145           {
 146             for (n = 0; n < len; n++, src += delta)
 147               {
 148 ')dnl
 149 define(FINISH_ARRAY_FUNCTION,
 150     `          }
 151             *dest = result;
 152           }
 153       }
 154       /* Advance to the next element.  */
 155       count[0]++;
 156       base += sstride[0];
 157       dest += dstride[0];
 158       n = 0;
 159       while (count[n] == extent[n])
 160         {
 161           /* When we get to the end of a dimension, reset it and increment
 162              the next dimension.  */
 163           count[n] = 0;
 164           /* We could precalculate these products, but this is a less
 165              frequently used path so probably not worth it.  */
 166           base -= sstride[n] * extent[n];
 167           dest -= dstride[n] * extent[n];
 168           n++;
 169           if (n == rank)
 170             {
 171               /* Break out of the look.  */
 172               base = NULL;
 173               break;
 174             }
 175           else
 176             {
 177               count[n]++;
 178               base += sstride[n];
 179               dest += dstride[n];
 180             }
 181         }
 182     }
 183 }')dnl
 184 define(START_MASKED_ARRAY_FUNCTION,
 185 `
 186 extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
 187         atype * const restrict, const index_type * const restrict,
 188         gfc_array_l1 * const restrict);
 189 export_proto(`m'name`'rtype_qual`_'atype_code);
 190
 191 void
 192 `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
 193         atype * const restrict array,
 194         const index_type * const restrict pdim,
 195         gfc_array_l1 * const restrict mask)
 196 {
 197   index_type count[GFC_MAX_DIMENSIONS];
 198   index_type extent[GFC_MAX_DIMENSIONS];
 199   index_type sstride[GFC_MAX_DIMENSIONS];
 200   index_type dstride[GFC_MAX_DIMENSIONS];
 201   index_type mstride[GFC_MAX_DIMENSIONS];
 202   rtype_name * restrict dest;
 203   const atype_name * restrict base;
 204   const GFC_LOGICAL_1 * restrict mbase;
 205   int rank;
 206   int dim;
 207   index_type n;
 208   index_type len;
 209   index_type delta;
 210   index_type mdelta;
 211   int mask_kind;
 212
 213   dim = (*pdim) - 1;
 214   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 215
 216   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 217   if (len <= 0)
 218     return;
 219
 220   mbase = mask->data;
 221
 222   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 223
 224   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 225 #ifdef HAVE_GFC_LOGICAL_16
 226       || mask_kind == 16
 227 #endif
 228       )
 229     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 230   else
 231     runtime_error ("Funny sized logical array");
 232
 233   delta = array->dim[dim].stride;
 234   mdelta = mask->dim[dim].stride * mask_kind;
 235
 236   for (n = 0; n < dim; n++)
 237     {
 238       sstride[n] = array->dim[n].stride;
 239       mstride[n] = mask->dim[n].stride * mask_kind;
 240       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 241
 242       if (extent[n] < 0)
 243         extent[n] = 0;
 244
 245     }
 246   for (n = dim; n < rank; n++)
 247     {
 248       sstride[n] = array->dim[n + 1].stride;
 249       mstride[n] = mask->dim[n + 1].stride * mask_kind;
 250       extent[n] =
 251         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 252
 253       if (extent[n] < 0)
 254         extent[n] = 0;
 255     }
 256
 257   if (retarray->data == NULL)
 258     {
 259       size_t alloc_size;
 260
 261       for (n = 0; n < rank; n++)
 262         {
 263           retarray->dim[n].lbound = 0;
 264           retarray->dim[n].ubound = extent[n]-1;
 265           if (n == 0)
 266             retarray->dim[n].stride = 1;
 267           else
 268             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 269         }
 270
 271       alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride
 272                    * extent[rank-1];
 273
 274       retarray->offset = 0;
 275       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 276
 277       if (alloc_size == 0)
 278         {
 279           /* Make sure we have a zero-sized array.  */
 280           retarray->dim[0].lbound = 0;
 281           retarray->dim[0].ubound = -1;
 282           return;
 283         }
 284       else
 285         retarray->data = internal_malloc_size (alloc_size);
 286
 287     }
 288   else
 289     {
 290       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 291         runtime_error ("rank of return array incorrect in u_name intrinsic");
 292
 293       if (compile_options.bounds_check)
 294         {
 295           for (n=0; n < rank; n++)
 296             {
 297               index_type ret_extent;
 298
 299               ret_extent = retarray->dim[n].ubound + 1
 300                 - retarray->dim[n].lbound;
 301               if (extent[n] != ret_extent)
 302                 runtime_error ("Incorrect extent in return value of"
 303                                " u_name intrinsic in dimension %ld:"
 304                                " is %ld, should be %ld", (long int) n + 1,
 305                                (long int) ret_extent, (long int) extent[n]);
 306             }
 307           for (n=0; n<= rank; n++)
 308             {
 309               index_type mask_extent, array_extent;
 310
 311               array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound;
 312               mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound;
 313               if (array_extent != mask_extent)
 314                 runtime_error ("Incorrect extent in MASK argument of"
 315                                " u_name intrinsic in dimension %ld:"
 316                                " is %ld, should be %ld", (long int) n + 1,
 317                                (long int) mask_extent, (long int) array_extent);
 318             }
 319         }
 320     }
 321
 322   for (n = 0; n < rank; n++)
 323     {
 324       count[n] = 0;
 325       dstride[n] = retarray->dim[n].stride;
 326       if (extent[n] <= 0)
 327         return;
 328     }
 329
 330   dest = retarray->data;
 331   base = array->data;
 332
 333   while (base)
 334     {
 335       const atype_name * restrict src;
 336       const GFC_LOGICAL_1 * restrict msrc;
 337       rtype_name result;
 338       src = base;
 339       msrc = mbase;
 340       {
 341 ')dnl
 342 define(START_MASKED_ARRAY_BLOCK,
 343 `        if (len <= 0)
 344           *dest = '$1`;
 345         else
 346           {
 347             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 348               {
 349 ')dnl
 350 define(FINISH_MASKED_ARRAY_FUNCTION,
 351 `              }
 352             *dest = result;
 353           }
 354       }
 355       /* Advance to the next element.  */
 356       count[0]++;
 357       base += sstride[0];
 358       mbase += mstride[0];
 359       dest += dstride[0];
 360       n = 0;
 361       while (count[n] == extent[n])
 362         {
 363           /* When we get to the end of a dimension, reset it and increment
 364              the next dimension.  */
 365           count[n] = 0;
 366           /* We could precalculate these products, but this is a less
 367              frequently used path so probably not worth it.  */
 368           base -= sstride[n] * extent[n];
 369           mbase -= mstride[n] * extent[n];
 370           dest -= dstride[n] * extent[n];
 371           n++;
 372           if (n == rank)
 373             {
 374               /* Break out of the look.  */
 375               base = NULL;
 376               break;
 377             }
 378           else
 379             {
 380               count[n]++;
 381               base += sstride[n];
 382               mbase += mstride[n];
 383               dest += dstride[n];
 384             }
 385         }
 386     }
 387 }')dnl
 388 define(SCALAR_ARRAY_FUNCTION,
 389 `
 390 extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
 391         atype * const restrict, const index_type * const restrict,
 392         GFC_LOGICAL_4 *);
 393 export_proto(`s'name`'rtype_qual`_'atype_code);
 394
 395 void
 396 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
 397         atype * const restrict array,
 398         const index_type * const restrict pdim,
 399         GFC_LOGICAL_4 * mask)
 400 {
 401   index_type rank;
 402   index_type n;
 403   index_type dstride;
 404   rtype_name *dest;
 405
 406   if (*mask)
 407     {
 408       name`'rtype_qual`_'atype_code (retarray, array, pdim);
 409       return;
 410     }
 411     rank = GFC_DESCRIPTOR_RANK (array);
 412   if (rank <= 0)
 413     runtime_error ("Rank of array needs to be > 0");
 414
 415   if (retarray->data == NULL)
 416     {
 417       retarray->dim[0].lbound = 0;
 418       retarray->dim[0].ubound = rank-1;
 419       retarray->dim[0].stride = 1;
 420       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 421       retarray->offset = 0;
 422       retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);
 423     }
 424   else
 425     {
 426       if (compile_options.bounds_check)
 427         {
 428           int ret_rank;
 429           index_type ret_extent;
 430
 431           ret_rank = GFC_DESCRIPTOR_RANK (retarray);
 432           if (ret_rank != 1)
 433             runtime_error ("rank of return array in u_name intrinsic"
 434                            " should be 1, is %ld", (long int) ret_rank);
 435
 436           ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound;
 437             if (ret_extent != rank)
 438               runtime_error ("dimension of return array incorrect");
 439         }
 440     }
 441     dstride = retarray->dim[0].stride;
 442     dest = retarray->data;
 443
 444     for (n = 0; n < rank; n++)
 445       dest[n * dstride] = $1 ;
 446 }')dnl
 447 define(ARRAY_FUNCTION,
 448 `START_ARRAY_FUNCTION
 449 $2
 450 START_ARRAY_BLOCK($1)
 451 $3
 452 FINISH_ARRAY_FUNCTION')dnl
 453 define(MASKED_ARRAY_FUNCTION,
 454 `START_MASKED_ARRAY_FUNCTION
 455 $2
 456 START_MASKED_ARRAY_BLOCK($1)
 457 $3
 458 FINISH_MASKED_ARRAY_FUNCTION')dnl