[thirdparty/gcc.git] / libgfortran / generated / findloc1_s4.c

/* Implementation of the FINDLOC intrinsic
   Copyright (C) 2018-2019 Free Software Foundation, Inc.
   Contributed by Thomas König <tk@tkoenig.net>

This file is part of the GNU Fortran 95 runtime library (libgfortran).

Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.

You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
<http://www.gnu.org/licenses/>.  */

#include "libgfortran.h"
#include <assert.h>

#if defined (HAVE_GFC_UINTEGER_4)
extern void findloc1_s4 (gfc_array_index_type * const restrict retarray,
		         gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
			 const index_type * restrict pdim, GFC_LOGICAL_4 back,
			 gfc_charlen_type len_array, gfc_charlen_type len_value);
export_proto(findloc1_s4);

extern void
findloc1_s4 (gfc_array_index_type * const restrict retarray,
	    gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
	    const index_type * restrict pdim, GFC_LOGICAL_4 back,
	    gfc_charlen_type len_array, gfc_charlen_type len_value)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  const GFC_UINTEGER_4 * restrict base;
  index_type * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;
  int continue_loop;

  /* Make dim zero based to avoid confusion.  */
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
  dim = (*pdim) - 1;

  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 1);
    }

  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len < 0)
    len = 0;
  delta = GFC_DESCRIPTOR_STRIDE(array,dim);

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

      if (extent[n] < 0)
	extent[n] = 0;
    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);

      if (extent[n] < 0)
	extent[n] = 0;
    }

  if (retarray->base_addr == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
	{
	  if (n == 0)
	    str = 1;
	  else
	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);

	}

      retarray->offset = 0;
      retarray->dtype.rank = rank;

      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];

      retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;
	}
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " FINDLOC intrinsic: is %ld, should be %ld",
		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
		       (long int) rank);

      if (unlikely (compile_options.bounds_check))
	bounds_ifunction_return ((array_t *) retarray, extent,
				 "return value", "FINDLOC");
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
      if (extent[n] <= 0)
	return;
    }

  dest = retarray->base_addr;
  continue_loop = 1;

  base = array->base_addr;
  while (continue_loop)
    {
      const GFC_UINTEGER_4 * restrict src;
      index_type result;

      result = 0;
      if (back)
	{
	  src = base + (len - 1) * delta * len_array;
	  for (n = len; n > 0; n--, src -= delta * len_array)
	    {
	      if (compare_string_char4 (len_array, src, len_value, value) == 0)
		{
		  result = n;
		  break;
		}
	    }
	}
      else
	{
	  src = base;
	  for (n = 1; n <= len; n++, src += delta * len_array)
	    {
	      if (compare_string_char4 (len_array, src, len_value, value) == 0)
		{
		  result = n;
		  break;
		}
	    }
	}
      *dest = result;

      count[0]++;
      base += sstride[0] * len_array;
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
	{
	  count[n] = 0;
	  base -= sstride[n] * extent[n] * len_array;
	  dest -= dstride[n] * extent[n];
	  n++;
	  if (n >= rank)
	    {
	      continue_loop = 0;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n] * len_array;
	      dest += dstride[n];
	    }
	}
    }
}
extern void mfindloc1_s4 (gfc_array_index_type * const restrict retarray,
		         gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
			 const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
			 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
export_proto(mfindloc1_s4);

extern void
mfindloc1_s4 (gfc_array_index_type * const restrict retarray,
	    gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
	    const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
	    GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type mstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  const GFC_UINTEGER_4 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  index_type * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  index_type dim;
  int mask_kind;
  int continue_loop;

  /* Make dim zero based to avoid confusion.  */
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
  dim = (*pdim) - 1;

  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 1);
    }

  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len < 0)
    len = 0;

  delta = GFC_DESCRIPTOR_STRIDE(array,dim);
  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);

  mbase = mask->base_addr;

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
      || mask_kind == 16
#endif
      )
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
  else
    internal_error (NULL, "Funny sized logical array");

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

      if (extent[n] < 0)
	extent[n] = 0;
    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);

      if (extent[n] < 0)
	extent[n] = 0;
    }

  if (retarray->base_addr == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
	{
	  if (n == 0)
	    str = 1;
	  else
	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);

	}

      retarray->offset = 0;
      retarray->dtype.rank = rank;

      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];

      retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;
	}
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " FINDLOC intrinsic: is %ld, should be %ld",
		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
		       (long int) rank);

      if (unlikely (compile_options.bounds_check))
	bounds_ifunction_return ((array_t *) retarray, extent,
				 "return value", "FINDLOC");
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
      if (extent[n] <= 0)
	return;
    }

  dest = retarray->base_addr;
  continue_loop = 1;

  base = array->base_addr;
  while (continue_loop)
    {
      const GFC_UINTEGER_4 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      index_type result;

      result = 0;
      if (back)
	{
	  src = base + (len - 1) * delta * len_array;
	  msrc = mbase + (len - 1) * mdelta; 
	  for (n = len; n > 0; n--, src -= delta * len_array, msrc -= mdelta)
	    {
	      if (*msrc && compare_string_char4 (len_array, src, len_value, value) == 0)
		{
		  result = n;
		  break;
		}
	    }
	}
      else
	{
	  src = base;
	  msrc = mbase;
	  for (n = 1; n <= len; n++, src += delta * len_array, msrc += mdelta)
	    {
	      if (*msrc && compare_string_char4 (len_array, src, len_value, value) == 0)
		{
		  result = n;
		  break;
		}
	    }
	}
      *dest = result;

      count[0]++;
      base += sstride[0] * len_array;
      mbase += mstride[0];
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
	{
	  count[n] = 0;
	  base -= sstride[n] * extent[n] * len_array;
	  mbase -= mstride[n] * extent[n];
	  dest -= dstride[n] * extent[n];
	  n++;
	  if (n >= rank)
	    {
	      continue_loop = 0;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n] * len_array;
	      dest += dstride[n];
	    }
	}
    }
}
extern void sfindloc1_s4 (gfc_array_index_type * const restrict retarray,
		         gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
			 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
			 GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value);
export_proto(sfindloc1_s4);

extern void
sfindloc1_s4 (gfc_array_index_type * const restrict retarray,
	    gfc_array_s4 * const restrict array, GFC_UINTEGER_4 *const restrict value,
	    const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict  mask,
	    GFC_LOGICAL_4 back, gfc_charlen_type len_array, gfc_charlen_type len_value)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  index_type * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type dim;
  bool continue_loop;

  if (mask == NULL || *mask)
    {
      findloc1_s4 (retarray, array, value, pdim, back, len_array, len_value);
      return;
    }
    /* Make dim zero based to avoid confusion.  */
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
  dim = (*pdim) - 1;

  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 1);
    }

  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len < 0)
    len = 0;

  for (n = 0; n < dim; n++)
    {
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

      if (extent[n] <= 0)
	extent[n] = 0;
    }

  for (n = dim; n < rank; n++)
    {
      extent[n] =
	GFC_DESCRIPTOR_EXTENT(array,n + 1);

      if (extent[n] <= 0)
	extent[n] = 0;
    }


  if (retarray->base_addr == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
	{
	  if (n == 0)
	    str = 1;
	  else
	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	}

      retarray->offset = 0;
      retarray->dtype.rank = rank;

      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];

      retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;
	}
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " FINDLOC intrinsic: is %ld, should be %ld",
		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
		       (long int) rank);

      if (unlikely (compile_options.bounds_check))
	bounds_ifunction_return ((array_t *) retarray, extent,
				 "return value", "FINDLOC");
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
      if (extent[n] <= 0)
	return;
    }
  dest = retarray->base_addr;
  continue_loop = 1;

  while (continue_loop)
    {
      *dest = 0;

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