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         {
 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   if (mask == NULL)
 229     {
 230       name`'rtype_qual`_'atype_code (retarray, xlen, array, pdim, string_len);
 231       return;
 232     }
 233
 234   assert (xlen == string_len);
 235
 236   dim = (*pdim) - 1;
 237   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 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                  * string_len;
 303
 304       retarray->offset = 0;
 305       retarray->dtype.rank = rank;
 306
 307       if (alloc_size == 0)
 308         {
 309           /* Make sure we have a zero-sized array.  */
 310           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 311           return;
 312         }
 313       else
 314         retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
 315
 316     }
 317   else
 318     {
 319       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 320         runtime_error ("rank of return array incorrect in u_name intrinsic");
 321
 322       if (unlikely (compile_options.bounds_check))
 323         {
 324           bounds_ifunction_return ((array_t *) retarray, extent,
 325                                    "return value", "u_name");
 326           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 327                                 "MASK argument", "u_name");
 328         }
 329     }
 330
 331   for (n = 0; n < rank; n++)
 332     {
 333       count[n] = 0;
 334       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
 335       if (extent[n] <= 0)
 336         return;
 337     }
 338
 339   dest = retarray->base_addr;
 340   base = array->base_addr;
 341
 342   while (base)
 343     {
 344       const atype_name * restrict src;
 345       const GFC_LOGICAL_1 * restrict msrc;
 346
 347       src = base;
 348       msrc = mbase;
 349       {
 350 ')dnl
 351 define(START_MASKED_ARRAY_BLOCK,
 352 `       for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 353           {
 354 ')dnl
 355 define(FINISH_MASKED_ARRAY_FUNCTION,
 356 `         }
 357         memcpy (dest, retval, sizeof (*dest) * string_len);
 358       }
 359       /* Advance to the next element.  */
 360       count[0]++;
 361       base += sstride[0];
 362       mbase += mstride[0];
 363       dest += dstride[0];
 364       n = 0;
 365       while (count[n] == extent[n])
 366         {
 367           /* When we get to the end of a dimension, reset it and increment
 368              the next dimension.  */
 369           count[n] = 0;
 370           /* We could precalculate these products, but this is a less
 371              frequently used path so probably not worth it.  */
 372           base -= sstride[n] * extent[n];
 373           mbase -= mstride[n] * extent[n];
 374           dest -= dstride[n] * extent[n];
 375           n++;
 376           if (n >= rank)
 377             {
 378               /* Break out of the loop.  */
 379               base = NULL;
 380               break;
 381             }
 382           else
 383             {
 384               count[n]++;
 385               base += sstride[n];
 386               mbase += mstride[n];
 387               dest += dstride[n];
 388             }
 389         }
 390     }
 391 }')dnl
 392 define(SCALAR_ARRAY_FUNCTION,
 393 `
 394 void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
 395         gfc_charlen_type, atype * const restrict,
 396         const index_type * const restrict,
 397         GFC_LOGICAL_4 *, gfc_charlen_type);
 398
 399 export_proto(`s'name`'rtype_qual`_'atype_code);
 400
 401 void
 402 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
 403         gfc_charlen_type xlen, atype * const restrict array,
 404         const index_type * const restrict pdim,
 405         GFC_LOGICAL_4 *mask, gfc_charlen_type string_len)
 406
 407 {
 408   index_type count[GFC_MAX_DIMENSIONS];
 409   index_type extent[GFC_MAX_DIMENSIONS];
 410   index_type dstride[GFC_MAX_DIMENSIONS];
 411   rtype_name * restrict dest;
 412   index_type rank;
 413   index_type n;
 414   index_type dim;
 415
 416
 417   if (mask == NULL || *mask)
 418     {
 419       name`'rtype_qual`_'atype_code (retarray, xlen, array, pdim, string_len);
 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);
 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);
 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                  * string_len;
 470
 471       if (alloc_size == 0)
 472         {
 473           /* Make sure we have a zero-sized array.  */
 474           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 475           return;
 476         }
 477       else
 478         retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name));
 479     }
 480   else
 481     {
 482       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 483         runtime_error ("rank of return array incorrect in"
 484                        " u_name intrinsic: is %ld, should be %ld",
 485                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 486                        (long int) rank);
 487
 488       if (unlikely (compile_options.bounds_check))
 489         {
 490           for (n=0; n < rank; n++)
 491             {
 492               index_type ret_extent;
 493
 494               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 495               if (extent[n] != ret_extent)
 496                 runtime_error ("Incorrect extent in return value of"
 497                                " u_name intrinsic in dimension %ld:"
 498                                " is %ld, should be %ld", (long int) n + 1,
 499                                (long int) ret_extent, (long int) extent[n]);
 500             }
 501         }
 502     }
 503
 504   for (n = 0; n < rank; n++)
 505     {
 506       count[n] = 0;
 507       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
 508     }
 509
 510   dest = retarray->base_addr;
 511
 512   while(1)
 513     {
 514       memset (dest, '$1`, sizeof (*dest) * string_len);
 515       count[0]++;
 516       dest += dstride[0];
 517       n = 0;
 518       while (count[n] == extent[n])
 519         {
 520           /* When we get to the end of a dimension, reset it and increment
 521              the next dimension.  */
 522           count[n] = 0;
 523           /* We could precalculate these products, but this is a less
 524              frequently used path so probably not worth it.  */
 525           dest -= dstride[n] * extent[n];
 526           n++;
 527           if (n >= rank)
 528             return;
 529           else
 530             {
 531               count[n]++;
 532               dest += dstride[n];
 533             }
 534         }
 535     }
 536 }')dnl
 537 define(ARRAY_FUNCTION,
 538 `START_ARRAY_FUNCTION($1)
 539 $2
 540 START_ARRAY_BLOCK($1)
 541 $3
 542 FINISH_ARRAY_FUNCTION($4)')dnl
 543 define(MASKED_ARRAY_FUNCTION,
 544 `START_MASKED_ARRAY_FUNCTION
 545 $2
 546 START_MASKED_ARRAY_BLOCK
 547 $3
 548 FINISH_MASKED_ARRAY_FUNCTION')dnl