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