Home | History | Annotate | Line # | Download | only in 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 define(START_FOREACH_FUNCTION,
      6 `
      7 extern void name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 
      8 	atype * const restrict array, GFC_LOGICAL_4);
      9 export_proto(name`'rtype_qual`_'atype_code);
     10 
     11 void
     12 name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 
     13 	atype * const restrict array, GFC_LOGICAL_4 back)
     14 {
     15   index_type count[GFC_MAX_DIMENSIONS];
     16   index_type extent[GFC_MAX_DIMENSIONS];
     17   index_type sstride[GFC_MAX_DIMENSIONS];
     18   index_type dstride;
     19   const atype_name *base;
     20   rtype_name * restrict dest;
     21   index_type rank;
     22   index_type n;
     23 
     24   rank = GFC_DESCRIPTOR_RANK (array);
     25   if (rank <= 0)
     26     runtime_error ("Rank of array needs to be > 0");
     27 
     28   if (retarray->base_addr == NULL)
     29     {
     30       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
     31       retarray->dtype.rank = 1;
     32       retarray->offset = 0;
     33       retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
     34     }
     35   else
     36     {
     37       if (unlikely (compile_options.bounds_check))
     38 	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
     39 				"u_name");
     40     }
     41 
     42   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
     43   dest = retarray->base_addr;
     44   for (n = 0; n < rank; n++)
     45     {
     46       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
     47       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
     48       count[n] = 0;
     49       if (extent[n] <= 0)
     50 	{
     51 	  /* Set the return value.  */
     52 	  for (n = 0; n < rank; n++)
     53 	    dest[n * dstride] = 0;
     54 	  return;
     55 	}
     56     }
     57 
     58   base = array->base_addr;
     59 
     60   /* Initialize the return value.  */
     61   for (n = 0; n < rank; n++)
     62     dest[n * dstride] = 1;
     63   {
     64 ')dnl
     65 define(START_FOREACH_BLOCK,
     66 `  while (base)
     67     {
     68 	  /* Implementation start.  */
     69 ')dnl
     70 define(FINISH_FOREACH_FUNCTION,
     71 `	  /* Implementation end.  */
     72 	  /* Advance to the next element.  */
     73 	  base += sstride[0];
     74 	}
     75       while (++count[0] != extent[0]);
     76       n = 0;
     77       do
     78 	{
     79 	  /* When we get to the end of a dimension, reset it and increment
     80 	     the next dimension.  */
     81 	  count[n] = 0;
     82 	  /* We could precalculate these products, but this is a less
     83 	     frequently used path so probably not worth it.  */
     84 	  base -= sstride[n] * extent[n];
     85 	  n++;
     86 	  if (n >= rank)
     87 	    {
     88 	      /* Break out of the loop.  */
     89 	      base = NULL;
     90 	      break;
     91 	    }
     92 	  else
     93 	    {
     94 	      count[n]++;
     95 	      base += sstride[n];
     96 	    }
     97 	}
     98       while (count[n] == extent[n]);
     99     }
    100   }
    101 }')dnl
    102 define(START_MASKED_FOREACH_FUNCTION,
    103 `
    104 extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict, 
    105 	atype * const restrict, gfc_array_l1 * const restrict,
    106 	GFC_LOGICAL_4);
    107 export_proto(`m'name`'rtype_qual`_'atype_code);
    108 
    109 void
    110 `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 
    111 	atype * const restrict array,
    112 	gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back)
    113 {
    114   index_type count[GFC_MAX_DIMENSIONS];
    115   index_type extent[GFC_MAX_DIMENSIONS];
    116   index_type sstride[GFC_MAX_DIMENSIONS];
    117   index_type mstride[GFC_MAX_DIMENSIONS];
    118   index_type dstride;
    119   rtype_name *dest;
    120   const atype_name *base;
    121   GFC_LOGICAL_1 *mbase;
    122   int rank;
    123   index_type n;
    124   int mask_kind;
    125 
    126 
    127   if (mask == NULL)
    128     {
    129       name`'rtype_qual`_'atype_code (retarray, array, back);
    130       return;
    131     }
    132 
    133   rank = GFC_DESCRIPTOR_RANK (array);
    134   if (rank <= 0)
    135     runtime_error ("Rank of array needs to be > 0");
    136 
    137   if (retarray->base_addr == NULL)
    138     {
    139       GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
    140       retarray->dtype.rank = 1;
    141       retarray->offset = 0;
    142       retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
    143     }
    144   else
    145     {
    146       if (unlikely (compile_options.bounds_check))
    147 	{
    148 
    149 	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
    150 				  "u_name");
    151 	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
    152 				  "MASK argument", "u_name");
    153 	}
    154     }
    155 
    156   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
    157 
    158   mbase = mask->base_addr;
    159 
    160   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
    161 #ifdef HAVE_GFC_LOGICAL_16
    162       || mask_kind == 16
    163 #endif
    164       )
    165     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
    166   else
    167     runtime_error ("Funny sized logical array");
    168 
    169   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
    170   dest = retarray->base_addr;
    171   for (n = 0; n < rank; n++)
    172     {
    173       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
    174       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
    175       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
    176       count[n] = 0;
    177       if (extent[n] <= 0)
    178 	{
    179 	  /* Set the return value.  */
    180 	  for (n = 0; n < rank; n++)
    181 	    dest[n * dstride] = 0;
    182 	  return;
    183 	}
    184     }
    185 
    186   base = array->base_addr;
    187 
    188   /* Initialize the return value.  */
    189   for (n = 0; n < rank; n++)
    190     dest[n * dstride] = 0;
    191   {
    192 ')dnl
    193 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
    194 define(FINISH_MASKED_FOREACH_FUNCTION,
    195 `	  /* Implementation end.  */
    196 	  /* Advance to the next element.  */
    197 	  base += sstride[0];
    198 	  mbase += mstride[0];
    199 	}
    200       while (++count[0] != extent[0]);
    201       n = 0;
    202       do
    203 	{
    204 	  /* When we get to the end of a dimension, reset it and increment
    205 	     the next dimension.  */
    206 	  count[n] = 0;
    207 	  /* We could precalculate these products, but this is a less
    208 	     frequently used path so probably not worth it.  */
    209 	  base -= sstride[n] * extent[n];
    210 	  mbase -= mstride[n] * extent[n];
    211 	  n++;
    212 	  if (n >= rank)
    213 	    {
    214 	      /* Break out of the loop.  */
    215 	      base = NULL;
    216 	      break;
    217 	    }
    218 	  else
    219 	    {
    220 	      count[n]++;
    221 	      base += sstride[n];
    222 	      mbase += mstride[n];
    223 	    }
    224 	}
    225       while (count[n] == extent[n]);
    226     }
    227   }
    228 }')dnl
    229 define(FOREACH_FUNCTION,
    230 `START_FOREACH_FUNCTION
    231 $1
    232 START_FOREACH_BLOCK
    233 $2
    234 FINISH_FOREACH_FUNCTION')dnl
    235 define(MASKED_FOREACH_FUNCTION,
    236 `START_MASKED_FOREACH_FUNCTION
    237 $1
    238 START_MASKED_FOREACH_BLOCK
    239 $2
    240 FINISH_MASKED_FOREACH_FUNCTION')dnl
    241 define(SCALAR_FOREACH_FUNCTION,
    242 `
    243 extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict, 
    244 	atype * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4);
    245 export_proto(`s'name`'rtype_qual`_'atype_code);
    246 
    247 void
    248 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 
    249 	atype * const restrict array,
    250 	GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
    251 {
    252   index_type rank;
    253   index_type dstride;
    254   index_type n;
    255   rtype_name *dest;
    256 
    257   if (mask == NULL || *mask)
    258     {
    259       name`'rtype_qual`_'atype_code (retarray, array, back);
    260       return;
    261     }
    262 
    263   rank = GFC_DESCRIPTOR_RANK (array);
    264 
    265   if (rank <= 0)
    266     runtime_error ("Rank of array needs to be > 0");
    267 
    268   if (retarray->base_addr == NULL)
    269     {
    270       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
    271       retarray->dtype.rank = 1;
    272       retarray->offset = 0;
    273       retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
    274     }
    275   else if (unlikely (compile_options.bounds_check))
    276     {
    277        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
    278 			       "u_name");
    279     }
    280 
    281   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
    282   dest = retarray->base_addr;
    283   for (n = 0; n<rank; n++)
    284     dest[n * dstride] = $1 ;
    285 }')dnl
    286