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