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