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