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   /* 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   delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
  72
  73   for (n = 0; n < dim; n++)
  74     {
  75       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
  76       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  77
  78       if (extent[n] < 0)
  79         extent[n] = 0;
  80     }
  81   for (n = dim; n < rank; n++)
  82     {
  83       sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
  84       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
  85
  86       if (extent[n] < 0)
  87         extent[n] = 0;
  88     }
  89
  90   if (retarray->base_addr == NULL)
  91     {
  92       size_t alloc_size, str;
  93
  94       for (n = 0; n < rank; n++)
  95         {
  96           if (n == 0)
  97             str = 1;
  98           else
  99             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 100
 101           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 102
 103         }
 104
 105       retarray->offset = 0;
 106       retarray->dtype.rank = rank;
 107
 108       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 109
 110       retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
 111       if (alloc_size == 0)
 112         return;
 113     }
 114   else
 115     {
 116       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 117         runtime_error ("rank of return array incorrect in"
 118                        " u_name intrinsic: is %ld, should be %ld",
 119                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 120                        (long int) rank);
 121
 122       if (unlikely (compile_options.bounds_check))
 123         bounds_ifunction_return ((array_t *) retarray, extent,
 124                                  "return value", "u_name");
 125     }
 126
 127   for (n = 0; n < rank; n++)
 128     {
 129       count[n] = 0;
 130       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 131       if (extent[n] <= 0)
 132         return;
 133     }
 134
 135   base = array->base_addr;
 136   dest = retarray->base_addr;
 137
 138   continue_loop = 1;
 139   while (continue_loop)
 140     {
 141       const atype_name * restrict src;
 142       rtype_name result;
 143       src = base;
 144       {
 145 ')dnl
 146 define(START_ARRAY_BLOCK,
 147 `       if (len <= 0)
 148           *dest = '$1`;
 149         else
 150           {
 151             for (n = 0; n < len; n++, src += delta)
 152               {
 153 ')dnl
 154 define(FINISH_ARRAY_FUNCTION,
 155 `             }
 156             '$1`
 157             *dest = result;
 158           }
 159       }
 160       /* Advance to the next element.  */
 161       count[0]++;
 162       base += sstride[0];
 163       dest += dstride[0];
 164       n = 0;
 165       while (count[n] == extent[n])
 166         {
 167           /* When we get to the end of a dimension, reset it and increment
 168              the next dimension.  */
 169           count[n] = 0;
 170           /* We could precalculate these products, but this is a less
 171              frequently used path so probably not worth it.  */
 172           base -= sstride[n] * extent[n];
 173           dest -= dstride[n] * extent[n];
 174           n++;
 175           if (n >= rank)
 176             {
 177               /* Break out of the loop.  */
 178               continue_loop = 0;
 179               break;
 180             }
 181           else
 182             {
 183               count[n]++;
 184               base += sstride[n];
 185               dest += dstride[n];
 186             }
 187         }
 188     }
 189 }')dnl
 190 define(START_MASKED_ARRAY_FUNCTION,
 191 `
 192 extern void `m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
 193         'atype` * const restrict, const index_type * const restrict,
 194         gfc_array_l1 * const restrict'back_arg`, gfc_charlen_type);
 195 export_proto(m'name`'rtype_qual`_'atype_code`);
 196
 197 void
 198 m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
 199         'atype` * const restrict array,
 200         const index_type * const restrict pdim,
 201         gfc_array_l1 * const restrict mask'back_arg`,
 202         gfc_charlen_type string_len)
 203 {
 204   index_type count[GFC_MAX_DIMENSIONS];
 205   index_type extent[GFC_MAX_DIMENSIONS];
 206   index_type sstride[GFC_MAX_DIMENSIONS];
 207   index_type dstride[GFC_MAX_DIMENSIONS];
 208   index_type mstride[GFC_MAX_DIMENSIONS];
 209   'rtype_name * restrict dest;
 210   const atype_name * restrict base;
 211   const GFC_LOGICAL_1 * restrict mbase;
 212   index_type rank;
 213   index_type dim;
 214   index_type n;
 215   index_type len;
 216   index_type delta;
 217   index_type mdelta;
 218   int mask_kind;
 219
 220   if (mask == NULL)
 221     {
 222 #ifdef HAVE_BACK_ARG
 223       name`'rtype_qual`_'atype_code (retarray, array, pdim, back, string_len);
 224 #else
 225       name`'rtype_qual`_'atype_code (retarray, array, pdim, string_len);
 226 #endif
 227       return;
 228     }
 229
 230   dim = (*pdim) - 1;
 231   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 232
 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
 298       retarray->offset = 0;
 299       retarray->dtype.rank = rank;
 300
 301       retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
 302       if (alloc_size == 0)
 303         return;
 304     }
 305   else
 306     {
 307       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 308         runtime_error ("rank of return array incorrect in u_name intrinsic");
 309
 310       if (unlikely (compile_options.bounds_check))
 311         {
 312           bounds_ifunction_return ((array_t *) retarray, extent,
 313                                    "return value", "u_name");
 314           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 315                                 "MASK argument", "u_name");
 316         }
 317     }
 318
 319   for (n = 0; n < rank; n++)
 320     {
 321       count[n] = 0;
 322       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 323       if (extent[n] <= 0)
 324         return;
 325     }
 326
 327   dest = retarray->base_addr;
 328   base = array->base_addr;
 329
 330   while (base)
 331     {
 332       const atype_name * restrict src;
 333       const GFC_LOGICAL_1 * restrict msrc;
 334       rtype_name result;
 335       src = base;
 336       msrc = mbase;
 337       {
 338 ')dnl
 339 define(START_MASKED_ARRAY_BLOCK,
 340 `       for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 341           {
 342 ')dnl
 343 define(FINISH_MASKED_ARRAY_FUNCTION,
 344 `         }
 345         *dest = result;
 346       }
 347       /* Advance to the next element.  */
 348       count[0]++;
 349       base += sstride[0];
 350       mbase += mstride[0];
 351       dest += dstride[0];
 352       n = 0;
 353       while (count[n] == extent[n])
 354         {
 355           /* When we get to the end of a dimension, reset it and increment
 356              the next dimension.  */
 357           count[n] = 0;
 358           /* We could precalculate these products, but this is a less
 359              frequently used path so probably not worth it.  */
 360           base -= sstride[n] * extent[n];
 361           mbase -= mstride[n] * extent[n];
 362           dest -= dstride[n] * extent[n];
 363           n++;
 364           if (n >= rank)
 365             {
 366               /* Break out of the loop.  */
 367               base = NULL;
 368               break;
 369             }
 370           else
 371             {
 372               count[n]++;
 373               base += sstride[n];
 374               mbase += mstride[n];
 375               dest += dstride[n];
 376             }
 377         }
 378     }
 379 }')dnl
 380 define(SCALAR_ARRAY_FUNCTION,
 381 `
 382 extern void `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
 383         'atype` * const restrict, const index_type * const restrict,
 384         GFC_LOGICAL_4 *'back_arg`, gfc_charlen_type);
 385 export_proto(s'name`'rtype_qual`_'atype_code`);
 386
 387 void
 388 s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
 389         'atype` * const restrict array,
 390         const index_type * const restrict pdim,
 391         GFC_LOGICAL_4 * mask 'back_arg`, gfc_charlen_type string_len)
 392 {
 393   index_type count[GFC_MAX_DIMENSIONS];
 394   index_type extent[GFC_MAX_DIMENSIONS];
 395   index_type dstride[GFC_MAX_DIMENSIONS];
 396   'rtype_name * restrict dest;
 397   index_type rank;
 398   index_type n;
 399   index_type dim;
 400
 401
 402   if (mask == NULL || *mask)
 403     {
 404 #ifdef HAVE_BACK_ARG
 405       name`'rtype_qual`_'atype_code (retarray, array, pdim, back, string_len);
 406 #else
 407       name`'rtype_qual`_'atype_code (retarray, array, pdim, string_len);
 408 #endif
 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) * string_len;
 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) * string_len;
 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
 459       retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
 460       if (alloc_size == 0)
 461         return;
 462     }
 463   else
 464     {
 465       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 466         runtime_error ("rank of return array incorrect in"
 467                        " u_name intrinsic: is %ld, should be %ld",
 468                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 469                        (long int) rank);
 470
 471       if (unlikely (compile_options.bounds_check))
 472         {
 473           for (n=0; n < rank; n++)
 474             {
 475               index_type ret_extent;
 476
 477               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 478               if (extent[n] != ret_extent)
 479                 runtime_error ("Incorrect extent in return value of"
 480                                " u_name intrinsic in dimension %ld:"
 481                                " is %ld, should be %ld", (long int) n + 1,
 482                                (long int) ret_extent, (long int) extent[n]);
 483             }
 484         }
 485     }
 486
 487   for (n = 0; n < rank; n++)
 488     {
 489       count[n] = 0;
 490       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 491     }
 492
 493   dest = retarray->base_addr;
 494
 495   while(1)
 496     {
 497       *dest = '$1`;
 498       count[0]++;
 499       dest += dstride[0];
 500       n = 0;
 501       while (count[n] == extent[n])
 502         {
 503           /* When we get to the end of a dimension, reset it and increment
 504              the next dimension.  */
 505           count[n] = 0;
 506           /* We could precalculate these products, but this is a less
 507              frequently used path so probably not worth it.  */
 508           dest -= dstride[n] * extent[n];
 509           n++;
 510           if (n >= rank)
 511             return;
 512           else
 513             {
 514               count[n]++;
 515               dest += dstride[n];
 516             }
 517         }
 518     }
 519 }')dnl
 520 define(ARRAY_FUNCTION,
 521 `START_ARRAY_FUNCTION
 522 $2
 523 START_ARRAY_BLOCK($1)
 524 $3
 525 FINISH_ARRAY_FUNCTION($4)')dnl
 526 define(MASKED_ARRAY_FUNCTION,
 527 `START_MASKED_ARRAY_FUNCTION
 528 $2
 529 START_MASKED_ARRAY_BLOCK
 530 $3
 531 FINISH_MASKED_ARRAY_FUNCTION')dnl