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