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[GFC_MAX_DIMENSIONS];
     36   const 'atype_name`'` * restrict base;
     37   index_type * restrict dest;
     38   index_type rank;
     39   index_type n;
     40   index_type len;
     41   index_type delta;
     42   index_type dim;
     43   int continue_loop;
     44 
     45   /* Make dim zero based to avoid confusion.  */
     46   rank = GFC_DESCRIPTOR_RANK (array) - 1;
     47   dim = (*pdim) - 1;
     48 
     49   if (unlikely (dim < 0 || dim > rank))
     50     {
     51       runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
     52  		     "is %ld, should be between 1 and %ld",
     53 		     (long int) dim + 1, (long int) rank + 1);
     54     }
     55 
     56   len = GFC_DESCRIPTOR_EXTENT(array,dim);
     57   if (len < 0)
     58     len = 0;
     59   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
     60 
     61   for (n = 0; n < dim; n++)
     62     {
     63       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
     64       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
     65 
     66       if (extent[n] < 0)
     67 	extent[n] = 0;
     68     }
     69   for (n = dim; n < rank; n++)
     70     {
     71       sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
     72       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
     73 
     74       if (extent[n] < 0)
     75 	extent[n] = 0;
     76     }
     77 
     78   if (retarray->base_addr == NULL)
     79     {
     80       size_t alloc_size, str;
     81 
     82       for (n = 0; n < rank; n++)
     83 	{
     84 	  if (n == 0)
     85 	    str = 1;
     86 	  else
     87 	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
     88 
     89 	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
     90 
     91 	}
     92 
     93       retarray->offset = 0;
     94       retarray->dtype.rank = rank;
     95 
     96       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
     97 
     98       retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
     99       if (alloc_size == 0)
    100 	return;
    101     }
    102   else
    103     {
    104       if (rank != GFC_DESCRIPTOR_RANK (retarray))
    105 	runtime_error ("rank of return array incorrect in"
    106 		       " FINDLOC intrinsic: is %ld, should be %ld",
    107 		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
    108 		       (long int) rank);
    109 
    110       if (unlikely (compile_options.bounds_check))
    111 	bounds_ifunction_return ((array_t *) retarray, extent,
    112 				 "return value", "FINDLOC");
    113     }
    114 
    115   for (n = 0; n < rank; n++)
    116     {
    117       count[n] = 0;
    118       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
    119       if (extent[n] <= 0)
    120 	return;
    121     }
    122 
    123   dest = retarray->base_addr;
    124   continue_loop = 1;
    125 
    126   base = array->base_addr;
    127   while (continue_loop)
    128     {
    129       const 'atype_name`'` * restrict src;
    130       index_type result;
    131 
    132       result = 0;
    133       if (back)
    134 	{
    135 	  src = base + (len - 1) * delta * 'base_mult`;
    136 	  for (n = len; n > 0; n--, src -= delta * 'base_mult`)
    137 	    {
    138 	      if ('comparison`'`)
    139 		{
    140 		  result = n;
    141 		  break;
    142 		}
    143 	    }
    144 	}
    145       else
    146 	{
    147 	  src = base;
    148 	  for (n = 1; n <= len; n++, src += delta * 'base_mult`)
    149 	    {
    150 	      if ('comparison`'`)
    151 		{
    152 		  result = n;
    153 		  break;
    154 		}
    155 	    }
    156 	}
    157       *dest = result;
    158 
    159       count[0]++;
    160       base += sstride[0] * 'base_mult`;
    161       dest += dstride[0];
    162       n = 0;
    163       while (count[n] == extent[n])
    164 	{
    165 	  count[n] = 0;
    166 	  base -= sstride[n] * extent[n] * 'base_mult`;
    167 	  dest -= dstride[n] * extent[n];
    168 	  n++;
    169 	  if (n >= rank)
    170 	    {
    171 	      continue_loop = 0;
    172 	      break;
    173 	    }
    174 	  else
    175 	    {
    176 	      count[n]++;
    177 	      base += sstride[n] * 'base_mult`;
    178 	      dest += dstride[n];
    179 	    }
    180 	}
    181     }
    182 }
    183 'header2`'`
    184 {
    185   index_type count[GFC_MAX_DIMENSIONS];
    186   index_type extent[GFC_MAX_DIMENSIONS];
    187   index_type sstride[GFC_MAX_DIMENSIONS];
    188   index_type mstride[GFC_MAX_DIMENSIONS];
    189   index_type dstride[GFC_MAX_DIMENSIONS];
    190   const 'atype_name`'` * restrict base;
    191   const GFC_LOGICAL_1 * restrict mbase;
    192   index_type * restrict dest;
    193   index_type rank;
    194   index_type n;
    195   index_type len;
    196   index_type delta;
    197   index_type mdelta;
    198   index_type dim;
    199   int mask_kind;
    200   int continue_loop;
    201 
    202   /* Make dim zero based to avoid confusion.  */
    203   rank = GFC_DESCRIPTOR_RANK (array) - 1;
    204   dim = (*pdim) - 1;
    205 
    206   if (unlikely (dim < 0 || dim > rank))
    207     {
    208       runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
    209  		     "is %ld, should be between 1 and %ld",
    210 		     (long int) dim + 1, (long int) rank + 1);
    211     }
    212 
    213   len = GFC_DESCRIPTOR_EXTENT(array,dim);
    214   if (len < 0)
    215     len = 0;
    216 
    217   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
    218   mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
    219 
    220   mbase = mask->base_addr;
    221 
    222   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
    223 
    224   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
    225 #ifdef HAVE_GFC_LOGICAL_16
    226       || mask_kind == 16
    227 #endif
    228       )
    229     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
    230   else
    231     internal_error (NULL, "Funny sized logical array");
    232 
    233   for (n = 0; n < dim; n++)
    234     {
    235       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
    236       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
    237       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
    238 
    239       if (extent[n] < 0)
    240 	extent[n] = 0;
    241     }
    242   for (n = dim; n < rank; n++)
    243     {
    244       sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
    245       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
    246       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
    247 
    248       if (extent[n] < 0)
    249 	extent[n] = 0;
    250     }
    251 
    252   if (retarray->base_addr == NULL)
    253     {
    254       size_t alloc_size, str;
    255 
    256       for (n = 0; n < rank; n++)
    257 	{
    258 	  if (n == 0)
    259 	    str = 1;
    260 	  else
    261 	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
    262 
    263 	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
    264 
    265 	}
    266 
    267       retarray->offset = 0;
    268       retarray->dtype.rank = rank;
    269 
    270       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
    271 
    272       retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
    273       if (alloc_size == 0)
    274 	return;
    275     }
    276   else
    277     {
    278       if (rank != GFC_DESCRIPTOR_RANK (retarray))
    279 	runtime_error ("rank of return array incorrect in"
    280 		       " FINDLOC intrinsic: is %ld, should be %ld",
    281 		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
    282 		       (long int) rank);
    283 
    284       if (unlikely (compile_options.bounds_check))
    285 	bounds_ifunction_return ((array_t *) retarray, extent,
    286 				 "return value", "FINDLOC");
    287     }
    288 
    289   for (n = 0; n < rank; n++)
    290     {
    291       count[n] = 0;
    292       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
    293       if (extent[n] <= 0)
    294 	return;
    295     }
    296 
    297   dest = retarray->base_addr;
    298   continue_loop = 1;
    299 
    300   base = array->base_addr;
    301   while (continue_loop)
    302     {
    303       const 'atype_name`'` * restrict src;
    304       const GFC_LOGICAL_1 * restrict msrc;
    305       index_type result;
    306 
    307       result = 0;
    308       if (back)
    309 	{
    310 	  src = base + (len - 1) * delta * 'base_mult`;
    311 	  msrc = mbase + (len - 1) * mdelta; 
    312 	  for (n = len; n > 0; n--, src -= delta * 'base_mult`, msrc -= mdelta)
    313 	    {
    314 	      if (*msrc && 'comparison`'`)
    315 		{
    316 		  result = n;
    317 		  break;
    318 		}
    319 	    }
    320 	}
    321       else
    322 	{
    323 	  src = base;
    324 	  msrc = mbase;
    325 	  for (n = 1; n <= len; n++, src += delta * 'base_mult`, msrc += mdelta)
    326 	    {
    327 	      if (*msrc && 'comparison`'`)
    328 		{
    329 		  result = n;
    330 		  break;
    331 		}
    332 	    }
    333 	}
    334       *dest = result;
    335 
    336       count[0]++;
    337       base += sstride[0] * 'base_mult`;
    338       mbase += mstride[0];
    339       dest += dstride[0];
    340       n = 0;
    341       while (count[n] == extent[n])
    342 	{
    343 	  count[n] = 0;
    344 	  base -= sstride[n] * extent[n] * 'base_mult`;
    345 	  mbase -= mstride[n] * extent[n];
    346 	  dest -= dstride[n] * extent[n];
    347 	  n++;
    348 	  if (n >= rank)
    349 	    {
    350 	      continue_loop = 0;
    351 	      break;
    352 	    }
    353 	  else
    354 	    {
    355 	      count[n]++;
    356 	      base += sstride[n] * 'base_mult`;
    357 	      dest += dstride[n];
    358 	    }
    359 	}
    360     }
    361 }
    362 'header3`'`
    363 {
    364   index_type count[GFC_MAX_DIMENSIONS];
    365   index_type extent[GFC_MAX_DIMENSIONS];
    366   index_type dstride[GFC_MAX_DIMENSIONS];
    367   index_type * restrict dest;
    368   index_type rank;
    369   index_type n;
    370   index_type len;
    371   index_type dim;
    372   bool continue_loop;
    373 
    374   if (mask == NULL || *mask)
    375     {
    376       findloc1_'atype_code`'` (retarray, array, value, pdim, back'len_arg`'`);
    377       return;
    378     }
    379     /* Make dim zero based to avoid confusion.  */
    380   rank = GFC_DESCRIPTOR_RANK (array) - 1;
    381   dim = (*pdim) - 1;
    382 
    383   if (unlikely (dim < 0 || dim > rank))
    384     {
    385       runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
    386  		     "is %ld, should be between 1 and %ld",
    387 		     (long int) dim + 1, (long int) rank + 1);
    388     }
    389 
    390   len = GFC_DESCRIPTOR_EXTENT(array,dim);
    391   if (len < 0)
    392     len = 0;
    393 
    394   for (n = 0; n < dim; n++)
    395     {
    396       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
    397 
    398       if (extent[n] <= 0)
    399 	extent[n] = 0;
    400     }
    401 
    402   for (n = dim; n < rank; n++)
    403     {
    404       extent[n] =
    405 	GFC_DESCRIPTOR_EXTENT(array,n + 1);
    406 
    407       if (extent[n] <= 0)
    408 	extent[n] = 0;
    409     }
    410 
    411 
    412   if (retarray->base_addr == NULL)
    413     {
    414       size_t alloc_size, str;
    415 
    416       for (n = 0; n < rank; n++)
    417 	{
    418 	  if (n == 0)
    419 	    str = 1;
    420 	  else
    421 	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
    422 
    423 	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
    424 	}
    425 
    426       retarray->offset = 0;
    427       retarray->dtype.rank = rank;
    428 
    429       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
    430 
    431       retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
    432       if (alloc_size == 0)
    433 	return;
    434     }
    435   else
    436     {
    437       if (rank != GFC_DESCRIPTOR_RANK (retarray))
    438 	runtime_error ("rank of return array incorrect in"
    439 		       " FINDLOC intrinsic: is %ld, should be %ld",
    440 		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
    441 		       (long int) rank);
    442 
    443       if (unlikely (compile_options.bounds_check))
    444 	bounds_ifunction_return ((array_t *) retarray, extent,
    445 				 "return value", "FINDLOC");
    446     }
    447 
    448   for (n = 0; n < rank; n++)
    449     {
    450       count[n] = 0;
    451       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
    452       if (extent[n] <= 0)
    453 	return;
    454     }
    455   dest = retarray->base_addr;
    456   continue_loop = 1;
    457 
    458   while (continue_loop)
    459     {
    460       *dest = 0;
    461 
    462       count[0]++;
    463       dest += dstride[0];
    464       n = 0;
    465       while (count[n] == extent[n])
    466 	{
    467 	  count[n] = 0;
    468 	  dest -= dstride[n] * extent[n];
    469 	  n++;
    470 	  if (n >= rank)
    471 	    {
    472 	      continue_loop = 0;
    473 	      break;
    474 	    }
    475 	  else
    476 	    {
    477 	      count[n]++;
    478 	      dest += dstride[n];
    479 	    }
    480 	}
    481     }
    482 }
    483 #endif'
    484