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