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