Home | History | Annotate | Line # | Download | only in m4 
      1 `/* Implementation of the FINDLOC intrinsic
      2    Copyright (C) 2018-2024 Free Software Foundation, Inc.
      3    Contributed by Thomas Knig <tk (a] tkoenig.net>
      4 
      5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
      6 
      7 Libgfortran is free software; you can redistribute it and/or
      8 modify it under the terms of the GNU General Public
      9 License as published by the Free Software Foundation; either
     10 version 3 of the License, or (at your option) any later version.
     11 
     12 Libgfortran is distributed in the hope that it will be useful,
     13 but WITHOUT ANY WARRANTY; without even the implied warranty of
     14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     15 GNU General Public License for more details.
     16 
     17 Under Section 7 of GPL version 3, you are granted additional
     18 permissions described in the GCC Runtime Library Exception, version
     19 3.1, as published by the Free Software Foundation.
     20 
     21 You should have received a copy of the GNU General Public License and
     22 a copy of the GCC Runtime Library Exception along with this program;
     23 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
     24 <http://www.gnu.org/licenses/>.  */
     25 
     26 #include "libgfortran.h"
     27 #include <assert.h>
     28 
     29 #if defined (HAVE_'atype_name`)
     30 'header1`
     31 {
     32   index_type count[GFC_MAX_DIMENSIONS];
     33   index_type extent[GFC_MAX_DIMENSIONS];
     34   index_type sstride[GFC_MAX_DIMENSIONS];
     35   index_type dstride;
     36   const 'atype_name` *base;
     37   index_type * restrict dest;
     38   index_type rank;
     39   index_type n;
     40   index_type sz;
     41 
     42   rank = GFC_DESCRIPTOR_RANK (array);
     43   if (rank <= 0)
     44     runtime_error ("Rank of array needs to be > 0");
     45 
     46   if (retarray->base_addr == NULL)
     47     {
     48       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
     49       retarray->dtype.rank = 1;
     50       retarray->offset = 0;
     51       retarray->base_addr = xmallocarray (rank, sizeof (index_type));
     52     }
     53   else
     54     {
     55       if (unlikely (compile_options.bounds_check))
     56 	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
     57 				"FINDLOC");
     58     }
     59 
     60   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
     61   dest = retarray->base_addr;
     62 
     63   /* Set the return value.  */
     64   for (n = 0; n < rank; n++)
     65     dest[n * dstride] = 0;
     66 
     67   sz = 1;
     68   for (n = 0; n < rank; n++)
     69     {
     70       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
     71       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
     72       sz *= extent[n];
     73       if (extent[n] <= 0)
     74 	return;
     75     }
     76 
     77     for (n = 0; n < rank; n++)
     78       count[n] = 0;
     79 
     80   if (back)
     81     {
     82       base = array->base_addr + (sz - 1) * 'base_mult`'`;
     83 
     84       while (1)
     85         {
     86 	  do
     87 	    {
     88 	      if (unlikely('comparison`))
     89 	        {
     90 		  for (n = 0; n < rank; n++)
     91 		    dest[n * dstride] = extent[n] - count[n];
     92 
     93 		  return;
     94 		}
     95 	      base -= sstride[0] * 'base_mult`'`;
     96 	    } while(++count[0] != extent[0]);
     97 
     98 	  n = 0;
     99 	  do
    100 	    {
    101 	      /* When we get to the end of a dimension, reset it and increment
    102 		 the next dimension.  */
    103 	      count[n] = 0;
    104 	      /* We could precalculate these products, but this is a less
    105 		 frequently used path so probably not worth it.  */
    106 	      base += sstride[n] * extent[n] * 'base_mult`'`;
    107 	      n++;
    108 	      if (n >= rank)
    109 	        return;
    110 	      else
    111 		{
    112 		  count[n]++;
    113 		  base -= sstride[n] * 'base_mult`'`;
    114 		}
    115 	    } while (count[n] == extent[n]);      
    116 	}
    117     }
    118   else
    119     {
    120       base = array->base_addr;
    121       while (1)
    122         {
    123 	  do
    124 	    {
    125 	      if (unlikely('comparison`))
    126 	        {
    127 		  for (n = 0; n < rank; n++)
    128 		    dest[n * dstride] = count[n] + 1;
    129 
    130 		  return;
    131 		}
    132 	      base += sstride[0] * 'base_mult`'`;
    133 	    } while(++count[0] != extent[0]);
    134 
    135 	  n = 0;
    136 	  do
    137 	    {
    138 	      /* When we get to the end of a dimension, reset it and increment
    139 		 the next dimension.  */
    140 	      count[n] = 0;
    141 	      /* We could precalculate these products, but this is a less
    142 		 frequently used path so probably not worth it.  */
    143 	      base -= sstride[n] * extent[n] * 'base_mult`'`;
    144 	      n++;
    145 	      if (n >= rank)
    146 	        return;
    147 	      else
    148 		{
    149 		  count[n]++;
    150 		  base += sstride[n] * 'base_mult`'`;
    151 		}
    152 	    } while (count[n] == extent[n]);
    153 	}
    154     }
    155   return;
    156 }
    157 
    158 'header2`
    159 {
    160   index_type count[GFC_MAX_DIMENSIONS];
    161   index_type extent[GFC_MAX_DIMENSIONS];
    162   index_type sstride[GFC_MAX_DIMENSIONS];
    163   index_type mstride[GFC_MAX_DIMENSIONS];
    164   index_type dstride;
    165   const 'atype_name` *base;
    166   index_type * restrict dest;
    167   GFC_LOGICAL_1 *mbase;
    168   index_type rank;
    169   index_type n;
    170   int mask_kind;
    171   index_type sz;
    172 
    173   rank = GFC_DESCRIPTOR_RANK (array);
    174   if (rank <= 0)
    175     runtime_error ("Rank of array needs to be > 0");
    176 
    177   if (retarray->base_addr == NULL)
    178     {
    179       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
    180       retarray->dtype.rank = 1;
    181       retarray->offset = 0;
    182       retarray->base_addr = xmallocarray (rank, sizeof (index_type));
    183     }
    184   else
    185     {
    186       if (unlikely (compile_options.bounds_check))
    187 	{
    188 	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
    189 				  "FINDLOC");
    190 	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
    191 				"MASK argument", "FINDLOC");
    192 	}
    193     }
    194 
    195   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
    196 
    197   mbase = mask->base_addr;
    198 
    199   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
    200 #ifdef HAVE_GFC_LOGICAL_16
    201       || mask_kind == 16
    202 #endif
    203       )
    204     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
    205   else
    206     internal_error (NULL, "Funny sized logical array");
    207 
    208   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
    209   dest = retarray->base_addr;
    210 
    211   /* Set the return value.  */
    212   for (n = 0; n < rank; n++)
    213     dest[n * dstride] = 0;
    214 
    215   sz = 1;
    216   for (n = 0; n < rank; n++)
    217     {
    218       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
    219       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
    220       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
    221       sz *= extent[n];
    222       if (extent[n] <= 0)
    223 	return;
    224     }
    225 
    226     for (n = 0; n < rank; n++)
    227       count[n] = 0;
    228 
    229   if (back)
    230     {
    231       base = array->base_addr + (sz - 1) * 'base_mult`'`;
    232       mbase = mbase + (sz - 1) * mask_kind;
    233       while (1)
    234         {
    235 	  do
    236 	    {
    237 	      if (unlikely(*mbase && 'comparison`))
    238 	        {
    239 		  for (n = 0; n < rank; n++)
    240 		    dest[n * dstride] = extent[n] - count[n];
    241 
    242 		  return;
    243 		}
    244 	      base -= sstride[0] * 'base_mult`'`;
    245 	      mbase -= mstride[0];
    246 	    } while(++count[0] != extent[0]);
    247 
    248 	  n = 0;
    249 	  do
    250 	    {
    251 	      /* When we get to the end of a dimension, reset it and increment
    252 		 the next dimension.  */
    253 	      count[n] = 0;
    254 	      /* We could precalculate these products, but this is a less
    255 		 frequently used path so probably not worth it.  */
    256 	      base += sstride[n] * extent[n] * 'base_mult`'`;
    257 	      mbase -= mstride[n] * extent[n];
    258 	      n++;
    259 	      if (n >= rank)
    260 		return;
    261 	      else
    262 		{
    263 		  count[n]++;
    264 		  base -= sstride[n] * 'base_mult`'`;
    265 		  mbase += mstride[n];
    266 		}
    267 	    } while (count[n] == extent[n]);      
    268 	}
    269     }
    270   else
    271     {
    272       base = array->base_addr;
    273       while (1)
    274         {
    275 	  do
    276 	    {
    277 	      if (unlikely(*mbase && 'comparison`))
    278 	        {
    279 		  for (n = 0; n < rank; n++)
    280 		    dest[n * dstride] = count[n] + 1;
    281 
    282 		  return;
    283 		}
    284 	      base += sstride[0] * 'base_mult`'`;
    285 	      mbase += mstride[0];
    286 	    } while(++count[0] != extent[0]);
    287 
    288 	  n = 0;
    289 	  do
    290 	    {
    291 	      /* When we get to the end of a dimension, reset it and increment
    292 		 the next dimension.  */
    293 	      count[n] = 0;
    294 	      /* We could precalculate these products, but this is a less
    295 		 frequently used path so probably not worth it.  */
    296 	      base -= sstride[n] * extent[n] * 'base_mult`'`;
    297 	      mbase -= mstride[n] * extent[n];
    298 	      n++;
    299 	      if (n >= rank)
    300 		return;
    301 	      else
    302 		{
    303 		  count[n]++;
    304 		  base += sstride[n]* 'base_mult`'`;
    305 		  mbase += mstride[n];
    306 		}
    307 	    } while (count[n] == extent[n]);
    308 	}
    309     }
    310   return;
    311 }
    312 
    313 'header3`
    314 {
    315   index_type rank;
    316   index_type dstride;
    317   index_type * restrict dest;
    318   index_type n;
    319 
    320   if (mask == NULL || *mask)
    321     {
    322       findloc0_'atype_code` (retarray, array, value, back'len_arg`);
    323       return;
    324     }
    325 
    326   rank = GFC_DESCRIPTOR_RANK (array);
    327 
    328   if (rank <= 0)
    329     internal_error (NULL, "Rank of array needs to be > 0");
    330 
    331   if (retarray->base_addr == NULL)
    332     {
    333       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
    334       retarray->dtype.rank = 1;
    335       retarray->offset = 0;
    336       retarray->base_addr = xmallocarray (rank, sizeof (index_type));
    337     }
    338   else if (unlikely (compile_options.bounds_check))
    339     {
    340        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
    341 			       "FINDLOC");
    342     }
    343 
    344   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
    345   dest = retarray->base_addr;
    346   for (n = 0; n<rank; n++)
    347     dest[n * dstride] = 0 ;
    348 }
    349 
    350 #endif'
    351