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       retarray->dtype.rank = 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   if (mask == NULL)
 214     {
 215 #ifdef HAVE_BACK_ARG
 216       name`'rtype_qual`_'atype_code (retarray, array, pdim, back);
 217 #else
 218       name`'rtype_qual`_'atype_code (retarray, array, pdim);
 219 #endif
 220       return;
 221     }
 222
 223   dim = (*pdim) - 1;
 224   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 225
 226
 227   if (unlikely (dim < 0 || dim > rank))
 228     {
 229       runtime_error ("Dim argument incorrect in u_name intrinsic: "
 230                      "is %ld, should be between 1 and %ld",
 231                      (long int) dim + 1, (long int) rank + 1);
 232     }
 233
 234   len = GFC_DESCRIPTOR_EXTENT(array,dim);
 235   if (len <= 0)
 236     return;
 237
 238   mbase = mask->base_addr;
 239
 240   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 241
 242   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 243 #ifdef HAVE_GFC_LOGICAL_16
 244       || mask_kind == 16
 245 #endif
 246       )
 247     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 248   else
 249     runtime_error ("Funny sized logical array");
 250
 251   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
 252   mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 253
 254   for (n = 0; n < dim; n++)
 255     {
 256       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 257       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 258       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 259
 260       if (extent[n] < 0)
 261         extent[n] = 0;
 262
 263     }
 264   for (n = dim; n < rank; n++)
 265     {
 266       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
 267       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
 268       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 269
 270       if (extent[n] < 0)
 271         extent[n] = 0;
 272     }
 273
 274   if (retarray->base_addr == NULL)
 275     {
 276       size_t alloc_size, str;
 277
 278       for (n = 0; n < rank; n++)
 279         {
 280           if (n == 0)
 281             str = 1;
 282           else
 283             str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 284
 285           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 286
 287         }
 288
 289       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 290
 291       retarray->offset = 0;
 292       retarray->dtype.rank = rank;
 293
 294       if (alloc_size == 0)
 295         {
 296           /* Make sure we have a zero-sized array.  */
 297           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 298           return;
 299         }
 300       else
 301         retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
 302
 303     }
 304   else
 305     {
 306       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 307         runtime_error ("rank of return array incorrect in u_name intrinsic");
 308
 309       if (unlikely (compile_options.bounds_check))
 310         {
 311           bounds_ifunction_return ((array_t *) retarray, extent,
 312                                    "return value", "u_name");
 313           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 314                                 "MASK argument", "u_name");
 315         }
 316     }
 317
 318   for (n = 0; n < rank; n++)
 319     {
 320       count[n] = 0;
 321       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 322       if (extent[n] <= 0)
 323         return;
 324     }
 325
 326   dest = retarray->base_addr;
 327   base = array->base_addr;
 328
 329   while (base)
 330     {
 331       const atype_name * restrict src;
 332       const GFC_LOGICAL_1 * restrict msrc;
 333       rtype_name result;
 334       src = base;
 335       msrc = mbase;
 336       {
 337 ')dnl
 338 define(START_MASKED_ARRAY_BLOCK,
 339 `       for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 340           {
 341 ')dnl
 342 define(FINISH_MASKED_ARRAY_FUNCTION,
 343 `         }
 344         *dest = result;
 345       }
 346       /* Advance to the next element.  */
 347       count[0]++;
 348       base += sstride[0];
 349       mbase += mstride[0];
 350       dest += dstride[0];
 351       n = 0;
 352       while (count[n] == extent[n])
 353         {
 354           /* When we get to the end of a dimension, reset it and increment
 355              the next dimension.  */
 356           count[n] = 0;
 357           /* We could precalculate these products, but this is a less
 358              frequently used path so probably not worth it.  */
 359           base -= sstride[n] * extent[n];
 360           mbase -= mstride[n] * extent[n];
 361           dest -= dstride[n] * extent[n];
 362           n++;
 363           if (n >= rank)
 364             {
 365               /* Break out of the loop.  */
 366               base = NULL;
 367               break;
 368             }
 369           else
 370             {
 371               count[n]++;
 372               base += sstride[n];
 373               mbase += mstride[n];
 374               dest += dstride[n];
 375             }
 376         }
 377     }
 378 }')dnl
 379 define(SCALAR_ARRAY_FUNCTION,
 380 `
 381 extern void `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
 382         'atype` * const restrict, const index_type * const restrict,
 383         GFC_LOGICAL_4 *'back_arg`);
 384 export_proto(s'name`'rtype_qual`_'atype_code);
 385
 386 void
 387 `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
 388         'atype` * const restrict array,
 389         const index_type * const restrict pdim,
 390         GFC_LOGICAL_4 * mask'back_arg`)
 391 {
 392   index_type count[GFC_MAX_DIMENSIONS];
 393   index_type extent[GFC_MAX_DIMENSIONS];
 394   index_type dstride[GFC_MAX_DIMENSIONS];
 395   'rtype_name * restrict dest;
 396   index_type rank;
 397   index_type n;
 398   index_type dim;
 399
 400
 401   if (mask == NULL || *mask)
 402     {
 403 #ifdef HAVE_BACK_ARG
 404       name`'rtype_qual`_'atype_code (retarray, array, pdim, back);
 405 #else
 406       name`'rtype_qual`_'atype_code (retarray, array, pdim);
 407 #endif
 408       return;
 409     }
 410   /* Make dim zero based to avoid confusion.  */
 411   dim = (*pdim) - 1;
 412   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 413
 414   if (unlikely (dim < 0 || dim > rank))
 415     {
 416       runtime_error ("Dim argument incorrect in u_name intrinsic: "
 417                      "is %ld, should be between 1 and %ld",
 418                      (long int) dim + 1, (long int) rank + 1);
 419     }
 420
 421   for (n = 0; n < dim; n++)
 422     {
 423       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 424
 425       if (extent[n] <= 0)
 426         extent[n] = 0;
 427     }
 428
 429   for (n = dim; n < rank; n++)
 430     {
 431       extent[n] =
 432         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 433
 434       if (extent[n] <= 0)
 435         extent[n] = 0;
 436     }
 437
 438   if (retarray->base_addr == NULL)
 439     {
 440       size_t alloc_size, str;
 441
 442       for (n = 0; n < rank; n++)
 443         {
 444           if (n == 0)
 445             str = 1;
 446           else
 447             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 448
 449           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 450
 451         }
 452
 453       retarray->offset = 0;
 454       retarray->dtype.rank = rank;
 455
 456       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 457
 458       if (alloc_size == 0)
 459         {
 460           /* Make sure we have a zero-sized array.  */
 461           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 462           return;
 463         }
 464       else
 465         retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
 466     }
 467   else
 468     {
 469       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 470         runtime_error ("rank of return array incorrect in"
 471                        " u_name intrinsic: is %ld, should be %ld",
 472                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 473                        (long int) rank);
 474
 475       if (unlikely (compile_options.bounds_check))
 476         {
 477           for (n=0; n < rank; n++)
 478             {
 479               index_type ret_extent;
 480
 481               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 482               if (extent[n] != ret_extent)
 483                 runtime_error ("Incorrect extent in return value of"
 484                                " u_name intrinsic in dimension %ld:"
 485                                " is %ld, should be %ld", (long int) n + 1,
 486                                (long int) ret_extent, (long int) extent[n]);
 487             }
 488         }
 489     }
 490
 491   for (n = 0; n < rank; n++)
 492     {
 493       count[n] = 0;
 494       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 495     }
 496
 497   dest = retarray->base_addr;
 498
 499   while(1)
 500     {
 501       *dest = '$1`;
 502       count[0]++;
 503       dest += dstride[0];
 504       n = 0;
 505       while (count[n] == extent[n])
 506         {
 507           /* When we get to the end of a dimension, reset it and increment
 508              the next dimension.  */
 509           count[n] = 0;
 510           /* We could precalculate these products, but this is a less
 511              frequently used path so probably not worth it.  */
 512           dest -= dstride[n] * extent[n];
 513           n++;
 514           if (n >= rank)
 515             return;
 516           else
 517             {
 518               count[n]++;
 519               dest += dstride[n];
 520             }
 521         }
 522     }
 523 }')dnl
 524 define(ARRAY_FUNCTION,
 525 `START_ARRAY_FUNCTION
 526 $2
 527 START_ARRAY_BLOCK($1)
 528 $3
 529 FINISH_ARRAY_FUNCTION($4)')dnl
 530 define(MASKED_ARRAY_FUNCTION,
 531 `START_MASKED_ARRAY_FUNCTION
 532 $2
 533 START_MASKED_ARRAY_BLOCK
 534 $3
 535 FINISH_MASKED_ARRAY_FUNCTION')dnl