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