Home | History | Annotate | Line # | Download | only in generated 
      1 /* Implementation of the MAXLOC intrinsic
      2    Copyright (C) 2017-2024 Free Software Foundation, Inc.
      3    Contributed by Thomas Koenig
      4 
      5 This file is part of the GNU Fortran 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 <stdlib.h>
     28 #include <string.h>
     29 #include <assert.h>
     30 #include <limits.h>
     31 
     32 
     33 #if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_16)
     34 
     35 #define HAVE_BACK_ARG 1
     36 
     37 static inline int
     38 compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
     39 {
     40   if (sizeof (GFC_UINTEGER_1) == 1)
     41     return memcmp (a, b, n);
     42   else
     43     return memcmp_char4 (a, b, n);
     44 
     45 }
     46 
     47 extern void maxloc0_16_s1 (gfc_array_i16 * const restrict retarray,
     48 	gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len);
     49 export_proto(maxloc0_16_s1);
     50 
     51 void
     52 maxloc0_16_s1 (gfc_array_i16 * const restrict retarray,
     53 	gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len)
     54 {
     55   index_type count[GFC_MAX_DIMENSIONS];
     56   index_type extent[GFC_MAX_DIMENSIONS];
     57   index_type sstride[GFC_MAX_DIMENSIONS];
     58   index_type dstride;
     59   const GFC_UINTEGER_1 *base;
     60   GFC_INTEGER_16 * restrict dest;
     61   index_type rank;
     62   index_type n;
     63 
     64   rank = GFC_DESCRIPTOR_RANK (array);
     65   if (rank <= 0)
     66     runtime_error ("Rank of array needs to be > 0");
     67 
     68   if (retarray->base_addr == NULL)
     69     {
     70       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
     71       retarray->dtype.rank = 1;
     72       retarray->offset = 0;
     73       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16));
     74     }
     75   else
     76     {
     77       if (unlikely (compile_options.bounds_check))
     78 	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
     79 				"MAXLOC");
     80     }
     81 
     82   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
     83   dest = retarray->base_addr;
     84   for (n = 0; n < rank; n++)
     85     {
     86       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
     87       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
     88       count[n] = 0;
     89       if (extent[n] <= 0)
     90 	{
     91 	  /* Set the return value.  */
     92 	  for (n = 0; n < rank; n++)
     93 	    dest[n * dstride] = 0;
     94 	  return;
     95 	}
     96     }
     97 
     98   base = array->base_addr;
     99 
    100   /* Initialize the return value.  */
    101   for (n = 0; n < rank; n++)
    102     dest[n * dstride] = 1;
    103   {
    104 
    105   const GFC_UINTEGER_1 *maxval;
    106    maxval = NULL;
    107 
    108   while (base)
    109     {
    110       do
    111 	{
    112 	  /* Implementation start.  */
    113 
    114     if (maxval == NULL || (back ? compare_fcn (base, maxval, len) >= 0 :
    115      		   	   	   compare_fcn (base, maxval, len) > 0))
    116     {
    117       maxval = base;
    118       for (n = 0; n < rank; n++)
    119         dest[n * dstride] = count[n] + 1;
    120     }
    121 	  /* Implementation end.  */
    122 	  /* Advance to the next element.  */
    123 	  base += sstride[0];
    124 	}
    125       while (++count[0] != extent[0]);
    126       n = 0;
    127       do
    128 	{
    129 	  /* When we get to the end of a dimension, reset it and increment
    130 	     the next dimension.  */
    131 	  count[n] = 0;
    132 	  /* We could precalculate these products, but this is a less
    133 	     frequently used path so probably not worth it.  */
    134 	  base -= sstride[n] * extent[n];
    135 	  n++;
    136 	  if (n >= rank)
    137 	    {
    138 	      /* Break out of the loop.  */
    139 	      base = NULL;
    140 	      break;
    141 	    }
    142 	  else
    143 	    {
    144 	      count[n]++;
    145 	      base += sstride[n];
    146 	    }
    147 	}
    148       while (count[n] == extent[n]);
    149     }
    150   }
    151 }
    152 
    153 
    154 extern void mmaxloc0_16_s1 (gfc_array_i16 * const restrict,
    155 	gfc_array_s1 * const restrict, gfc_array_l1 * const restrict , GFC_LOGICAL_4 back,
    156 	gfc_charlen_type len);
    157 export_proto(mmaxloc0_16_s1);
    158 
    159 void
    160 mmaxloc0_16_s1 (gfc_array_i16 * const restrict retarray,
    161 	gfc_array_s1 * const restrict array,
    162 	gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back,
    163 	gfc_charlen_type len)
    164 {
    165   index_type count[GFC_MAX_DIMENSIONS];
    166   index_type extent[GFC_MAX_DIMENSIONS];
    167   index_type sstride[GFC_MAX_DIMENSIONS];
    168   index_type mstride[GFC_MAX_DIMENSIONS];
    169   index_type dstride;
    170   GFC_INTEGER_16 *dest;
    171   const GFC_UINTEGER_1 *base;
    172   GFC_LOGICAL_1 *mbase;
    173   int rank;
    174   index_type n;
    175   int mask_kind;
    176 
    177   if (mask == NULL)
    178     {
    179 #ifdef HAVE_BACK_ARG
    180       maxloc0_16_s1 (retarray, array, back, len);
    181 #else
    182       maxloc0_16_s1 (retarray, array, len);
    183 #endif
    184       return;
    185     }
    186 
    187   rank = GFC_DESCRIPTOR_RANK (array);
    188   if (rank <= 0)
    189     runtime_error ("Rank of array needs to be > 0");
    190 
    191   if (retarray->base_addr == NULL)
    192     {
    193       GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
    194       retarray->dtype.rank = 1;
    195       retarray->offset = 0;
    196       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16));
    197     }
    198   else
    199     {
    200       if (unlikely (compile_options.bounds_check))
    201 	{
    202 
    203 	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
    204 				  "MAXLOC");
    205 	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
    206 				  "MASK argument", "MAXLOC");
    207 	}
    208     }
    209 
    210   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
    211 
    212   mbase = mask->base_addr;
    213 
    214   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
    215 #ifdef HAVE_GFC_LOGICAL_16
    216       || mask_kind == 16
    217 #endif
    218       )
    219     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
    220   else
    221     runtime_error ("Funny sized logical array");
    222 
    223   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
    224   dest = retarray->base_addr;
    225   for (n = 0; n < rank; n++)
    226     {
    227       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
    228       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
    229       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
    230       count[n] = 0;
    231       if (extent[n] <= 0)
    232 	{
    233 	  /* Set the return value.  */
    234 	  for (n = 0; n < rank; n++)
    235 	    dest[n * dstride] = 0;
    236 	  return;
    237 	}
    238     }
    239 
    240   base = array->base_addr;
    241 
    242   /* Initialize the return value.  */
    243   for (n = 0; n < rank; n++)
    244     dest[n * dstride] = 0;
    245   {
    246 
    247   const GFC_UINTEGER_1 *maxval;
    248 
    249   maxval = NULL;
    250 
    251   while (base)
    252     {
    253       do
    254 	{
    255 	  /* Implementation start.  */
    256 
    257   if (*mbase &&
    258         (maxval == NULL || (back ? compare_fcn (base, maxval, len) >= 0:
    259 		   	   	   compare_fcn (base, maxval, len) > 0)))
    260     {
    261       maxval = base;
    262       for (n = 0; n < rank; n++)
    263         dest[n * dstride] = count[n] + 1;
    264     }
    265 	  /* Implementation end.  */
    266 	  /* Advance to the next element.  */
    267 	  base += sstride[0];
    268 	  mbase += mstride[0];
    269 	}
    270       while (++count[0] != extent[0]);
    271       n = 0;
    272       do
    273 	{
    274 	  /* When we get to the end of a dimension, reset it and increment
    275 	     the next dimension.  */
    276 	  count[n] = 0;
    277 	  /* We could precalculate these products, but this is a less
    278 	     frequently used path so probably not worth it.  */
    279 	  base -= sstride[n] * extent[n];
    280 	  mbase -= mstride[n] * extent[n];
    281 	  n++;
    282 	  if (n >= rank)
    283 	    {
    284 	      /* Break out of the loop.  */
    285 	      base = NULL;
    286 	      break;
    287 	    }
    288 	  else
    289 	    {
    290 	      count[n]++;
    291 	      base += sstride[n];
    292 	      mbase += mstride[n];
    293 	    }
    294 	}
    295       while (count[n] == extent[n]);
    296     }
    297   }
    298 }
    299 
    300 
    301 extern void smaxloc0_16_s1 (gfc_array_i16 * const restrict,
    302 	gfc_array_s1 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4 back,
    303 	gfc_charlen_type len);
    304 export_proto(smaxloc0_16_s1);
    305 
    306 void
    307 smaxloc0_16_s1 (gfc_array_i16 * const restrict retarray,
    308 	gfc_array_s1 * const restrict array,
    309 	GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back,
    310 	gfc_charlen_type len)
    311 {
    312   index_type rank;
    313   index_type dstride;
    314   index_type n;
    315   GFC_INTEGER_16 *dest;
    316 
    317   if (mask == NULL || *mask)
    318     {
    319 #ifdef HAVE_BACK_ARG
    320       maxloc0_16_s1 (retarray, array, back, len);
    321 #else
    322       maxloc0_16_s1 (retarray, array, len);
    323 #endif
    324       return;
    325     }
    326 
    327   rank = GFC_DESCRIPTOR_RANK (array);
    328 
    329   if (rank <= 0)
    330     runtime_error ("Rank of array needs to be > 0");
    331 
    332   if (retarray->base_addr == NULL)
    333     {
    334       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
    335       retarray->dtype.rank = 1;
    336       retarray->offset = 0;
    337       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16));
    338     }
    339   else if (unlikely (compile_options.bounds_check))
    340     {
    341        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
    342 			       "MAXLOC");
    343     }
    344 
    345   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
    346   dest = retarray->base_addr;
    347   for (n = 0; n<rank; n++)
    348     dest[n * dstride] = 0 ;
    349 }
    350 #endif
    351