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       GFC_DTYPE_COPY_SETRANK(retarray,array,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   dim = (*pdim) - 1;
 226   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 227
 228
 229   if (unlikely (dim < 0 || dim > rank))
 230     {
 231       runtime_error ("Dim argument incorrect in u_name intrinsic: "
 232                      "is %ld, should be between 1 and %ld",
 233                      (long int) dim + 1, (long int) rank + 1);
 234     }
 235
 236   len = GFC_DESCRIPTOR_EXTENT(array,dim);
 237   if (len <= 0)
 238     return;
 239
 240   mbase = mask->base_addr;
 241
 242   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 243
 244   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 245 #ifdef HAVE_GFC_LOGICAL_16
 246       || mask_kind == 16
 247 #endif
 248       )
 249     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 250   else
 251     runtime_error ("Funny sized logical array");
 252
 253   delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
 254   mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 255
 256   for (n = 0; n < dim; n++)
 257     {
 258       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
 259       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 260       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 261
 262       if (extent[n] < 0)
 263         extent[n] = 0;
 264
 265     }
 266   for (n = dim; n < rank; n++)
 267     {
 268       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
 269       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
 270       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 271
 272       if (extent[n] < 0)
 273         extent[n] = 0;
 274     }
 275
 276   if (retarray->base_addr == NULL)
 277     {
 278       size_t alloc_size, str;
 279
 280       for (n = 0; n < rank; n++)
 281         {
 282           if (n == 0)
 283             str = 1;
 284           else
 285             str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 286
 287           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 288
 289         }
 290
 291       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 292
 293       retarray->offset = 0;
 294       GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
 295
 296       if (alloc_size == 0)
 297         {
 298           /* Make sure we have a zero-sized array.  */
 299           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 300           return;
 301         }
 302       else
 303         retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
 304
 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);
 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       rtype_name result;
 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         *dest = result;
 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 extern void `s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict,
 384         'atype` * const restrict, const index_type * const restrict,
 385         GFC_LOGICAL_4 *'back_arg`, gfc_charlen_type);
 386 export_proto(s'name`'rtype_qual`_'atype_code`);
 387
 388 void
 389 s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray,
 390         'atype` * const restrict array,
 391         const index_type * const restrict pdim,
 392         GFC_LOGICAL_4 * mask 'back_arg`, gfc_charlen_type string_len)
 393 {
 394   index_type count[GFC_MAX_DIMENSIONS];
 395   index_type extent[GFC_MAX_DIMENSIONS];
 396   index_type dstride[GFC_MAX_DIMENSIONS];
 397   'rtype_name * restrict dest;
 398   index_type rank;
 399   index_type n;
 400   index_type dim;
 401
 402
 403   if (*mask)
 404     {
 405 #ifdef HAVE_BACK_ARG
 406       name`'rtype_qual`_'atype_code (retarray, array, pdim, back, string_len);
 407 #else
 408       name`'rtype_qual`_'atype_code (retarray, array, pdim, string_len);
 409 #endif
 410       return;
 411     }
 412   /* Make dim zero based to avoid confusion.  */
 413   dim = (*pdim) - 1;
 414   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 415
 416   if (unlikely (dim < 0 || dim > rank))
 417     {
 418       runtime_error ("Dim argument incorrect in u_name intrinsic: "
 419                      "is %ld, should be between 1 and %ld",
 420                      (long int) dim + 1, (long int) rank + 1);
 421     }
 422
 423   for (n = 0; n < dim; n++)
 424     {
 425       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len;
 426
 427       if (extent[n] <= 0)
 428         extent[n] = 0;
 429     }
 430
 431   for (n = dim; n < rank; n++)
 432     {
 433       extent[n] =
 434         GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
 435
 436       if (extent[n] <= 0)
 437         extent[n] = 0;
 438     }
 439
 440   if (retarray->base_addr == NULL)
 441     {
 442       size_t alloc_size, str;
 443
 444       for (n = 0; n < rank; n++)
 445         {
 446           if (n == 0)
 447             str = 1;
 448           else
 449             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 450
 451           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 452
 453         }
 454
 455       retarray->offset = 0;
 456       GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
 457
 458       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 459
 460       if (alloc_size == 0)
 461         {
 462           /* Make sure we have a zero-sized array.  */
 463           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 464           return;
 465         }
 466       else
 467         retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
 468     }
 469   else
 470     {
 471       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 472         runtime_error ("rank of return array incorrect in"
 473                        " u_name intrinsic: is %ld, should be %ld",
 474                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 475                        (long int) rank);
 476
 477       if (unlikely (compile_options.bounds_check))
 478         {
 479           for (n=0; n < rank; n++)
 480             {
 481               index_type ret_extent;
 482
 483               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 484               if (extent[n] != ret_extent)
 485                 runtime_error ("Incorrect extent in return value of"
 486                                " u_name intrinsic in dimension %ld:"
 487                                " is %ld, should be %ld", (long int) n + 1,
 488                                (long int) ret_extent, (long int) extent[n]);
 489             }
 490         }
 491     }
 492
 493   for (n = 0; n < rank; n++)
 494     {
 495       count[n] = 0;
 496       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 497     }
 498
 499   dest = retarray->base_addr;
 500
 501   while(1)
 502     {
 503       *dest = '$1`;
 504       count[0]++;
 505       dest += dstride[0];
 506       n = 0;
 507       while (count[n] == extent[n])
 508         {
 509           /* When we get to the end of a dimension, reset it and increment
 510              the next dimension.  */
 511           count[n] = 0;
 512           /* We could precalculate these products, but this is a less
 513              frequently used path so probably not worth it.  */
 514           dest -= dstride[n] * extent[n];
 515           n++;
 516           if (n >= rank)
 517             return;
 518           else
 519             {
 520               count[n]++;
 521               dest += dstride[n];
 522             }
 523         }
 524     }
 525 }')dnl
 526 define(ARRAY_FUNCTION,
 527 `START_ARRAY_FUNCTION
 528 $2
 529 START_ARRAY_BLOCK($1)
 530 $3
 531 FINISH_ARRAY_FUNCTION($4)')dnl
 532 define(MASKED_ARRAY_FUNCTION,
 533 `START_MASKED_ARRAY_FUNCTION
 534 $2
 535 START_MASKED_ARRAY_BLOCK
 536 $3
 537 FINISH_MASKED_ARRAY_FUNCTION')dnl