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