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