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 95 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             *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->data;
 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->data == 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->data = internal_malloc_size (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->data;
 302   base = array->data;
 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 `       if (len <= 0)
 315           *dest = '$1`;
 316         else
 317           {
 318             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 319               {
 320 ')dnl
 321 define(FINISH_MASKED_ARRAY_FUNCTION,
 322 `             }
 323             *dest = result;
 324           }
 325       }
 326       /* Advance to the next element.  */
 327       count[0]++;
 328       base += sstride[0];
 329       mbase += mstride[0];
 330       dest += dstride[0];
 331       n = 0;
 332       while (count[n] == extent[n])
 333         {
 334           /* When we get to the end of a dimension, reset it and increment
 335              the next dimension.  */
 336           count[n] = 0;
 337           /* We could precalculate these products, but this is a less
 338              frequently used path so probably not worth it.  */
 339           base -= sstride[n] * extent[n];
 340           mbase -= mstride[n] * extent[n];
 341           dest -= dstride[n] * extent[n];
 342           n++;
 343           if (n == rank)
 344             {
 345               /* Break out of the look.  */
 346               base = NULL;
 347               break;
 348             }
 349           else
 350             {
 351               count[n]++;
 352               base += sstride[n];
 353               mbase += mstride[n];
 354               dest += dstride[n];
 355             }
 356         }
 357     }
 358 }')dnl
 359 define(SCALAR_ARRAY_FUNCTION,
 360 `
 361 extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
 362         atype * const restrict, const index_type * const restrict,
 363         GFC_LOGICAL_4 *);
 364 export_proto(`s'name`'rtype_qual`_'atype_code);
 365
 366 void
 367 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
 368         atype * const restrict array,
 369         const index_type * const restrict pdim,
 370         GFC_LOGICAL_4 * mask)
 371 {
 372   index_type count[GFC_MAX_DIMENSIONS];
 373   index_type extent[GFC_MAX_DIMENSIONS];
 374   index_type dstride[GFC_MAX_DIMENSIONS];
 375   rtype_name * restrict dest;
 376   index_type rank;
 377   index_type n;
 378   index_type dim;
 379
 380
 381   if (*mask)
 382     {
 383       name`'rtype_qual`_'atype_code (retarray, array, pdim);
 384       return;
 385     }
 386   /* Make dim zero based to avoid confusion.  */
 387   dim = (*pdim) - 1;
 388   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 389
 390   for (n = 0; n < dim; n++)
 391     {
 392       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 393
 394       if (extent[n] <= 0)
 395         extent[n] = 0;
 396     }
 397
 398   for (n = dim; n < rank; n++)
 399     {
 400       extent[n] =
 401         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 402
 403       if (extent[n] <= 0)
 404         extent[n] = 0;
 405     }
 406
 407   if (retarray->data == NULL)
 408     {
 409       size_t alloc_size, str;
 410
 411       for (n = 0; n < rank; n++)
 412         {
 413           if (n == 0)
 414             str = 1;
 415           else
 416             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 417
 418           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 419
 420         }
 421
 422       retarray->offset = 0;
 423       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 424
 425       alloc_size = sizeof (rtype_name) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
 426                    * extent[rank-1];
 427
 428       if (alloc_size == 0)
 429         {
 430           /* Make sure we have a zero-sized array.  */
 431           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 432           return;
 433         }
 434       else
 435         retarray->data = internal_malloc_size (alloc_size);
 436     }
 437   else
 438     {
 439       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 440         runtime_error ("rank of return array incorrect in"
 441                        " u_name intrinsic: is %ld, should be %ld",
 442                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 443                        (long int) rank);
 444
 445       if (unlikely (compile_options.bounds_check))
 446         {
 447           for (n=0; n < rank; n++)
 448             {
 449               index_type ret_extent;
 450
 451               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 452               if (extent[n] != ret_extent)
 453                 runtime_error ("Incorrect extent in return value of"
 454                                " u_name intrinsic in dimension %ld:"
 455                                " is %ld, should be %ld", (long int) n + 1,
 456                                (long int) ret_extent, (long int) extent[n]);
 457             }
 458         }
 459     }
 460
 461   for (n = 0; n < rank; n++)
 462     {
 463       count[n] = 0;
 464       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 465     }
 466
 467   dest = retarray->data;
 468
 469   while(1)
 470     {
 471       *dest = '$1`;
 472       count[0]++;
 473       dest += dstride[0];
 474       n = 0;
 475       while (count[n] == extent[n])
 476         {
 477           /* When we get to the end of a dimension, reset it and increment
 478              the next dimension.  */
 479           count[n] = 0;
 480           /* We could precalculate these products, but this is a less
 481              frequently used path so probably not worth it.  */
 482           dest -= dstride[n] * extent[n];
 483           n++;
 484           if (n == rank)
 485             return;
 486           else
 487             {
 488               count[n]++;
 489               dest += dstride[n];
 490             }
 491         }
 492     }
 493 }')dnl
 494 define(ARRAY_FUNCTION,
 495 `START_ARRAY_FUNCTION
 496 $2
 497 START_ARRAY_BLOCK($1)
 498 $3
 499 FINISH_ARRAY_FUNCTION')dnl
 500 define(MASKED_ARRAY_FUNCTION,
 501 `START_MASKED_ARRAY_FUNCTION
 502 $2
 503 START_MASKED_ARRAY_BLOCK($1)
 504 $3
 505 FINISH_MASKED_ARRAY_FUNCTION')dnl