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