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