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 sstride[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       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 394       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 395
 396       if (extent[n] <= 0)
 397         extent[n] = 0;
 398     }
 399
 400   for (n = dim; n < rank; n++)
 401     {
 402       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
 403       extent[n] =
 404         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 405
 406       if (extent[n] <= 0)
 407         extent[n] = 0;
 408     }
 409
 410   if (retarray->data == NULL)
 411     {
 412       size_t alloc_size, str;
 413
 414       for (n = 0; n < rank; n++)
 415         {
 416           if (n == 0)
 417             str = 1;
 418           else
 419             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 420
 421           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 422
 423         }
 424
 425       retarray->offset = 0;
 426       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 427
 428       alloc_size = sizeof (rtype_name) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
 429                    * extent[rank-1];
 430
 431       if (alloc_size == 0)
 432         {
 433           /* Make sure we have a zero-sized array.  */
 434           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 435           return;
 436         }
 437       else
 438         retarray->data = internal_malloc_size (alloc_size);
 439     }
 440   else
 441     {
 442       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 443         runtime_error ("rank of return array incorrect in"
 444                        " u_name intrinsic: is %ld, should be %ld",
 445                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 446                        (long int) rank);
 447
 448       if (unlikely (compile_options.bounds_check))
 449         {
 450           for (n=0; n < rank; n++)
 451             {
 452               index_type ret_extent;
 453
 454               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 455               if (extent[n] != ret_extent)
 456                 runtime_error ("Incorrect extent in return value of"
 457                                " u_name intrinsic in dimension %ld:"
 458                                " is %ld, should be %ld", (long int) n + 1,
 459                                (long int) ret_extent, (long int) extent[n]);
 460             }
 461         }
 462     }
 463
 464   for (n = 0; n < rank; n++)
 465     {
 466       count[n] = 0;
 467       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 468     }
 469
 470   dest = retarray->data;
 471
 472   while(1)
 473     {
 474       *dest = '$1`;
 475       count[0]++;
 476       dest += dstride[0];
 477       n = 0;
 478       while (count[n] == extent[n])
 479         {
 480           /* When we get to the end of a dimension, reset it and increment
 481              the next dimension.  */
 482           count[n] = 0;
 483           /* We could precalculate these products, but this is a less
 484              frequently used path so probably not worth it.  */
 485           dest -= dstride[n] * extent[n];
 486           n++;
 487           if (n == rank)
 488             return;
 489           else
 490             {
 491               count[n]++;
 492               dest += dstride[n];
 493             }
 494         }
 495     }
 496 }')dnl
 497 define(ARRAY_FUNCTION,
 498 `START_ARRAY_FUNCTION
 499 $2
 500 START_ARRAY_BLOCK($1)
 501 $3
 502 FINISH_ARRAY_FUNCTION')dnl
 503 define(MASKED_ARRAY_FUNCTION,
 504 `START_MASKED_ARRAY_FUNCTION
 505 $2
 506 START_MASKED_ARRAY_BLOCK($1)
 507 $3
 508 FINISH_MASKED_ARRAY_FUNCTION')dnl