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