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

/* Implementation of the MAXLOC intrinsic
   Copyright (C) 2017-2024 Free Software Foundation, Inc.
   Contributed by Thomas Koenig

This file is part of the GNU Fortran 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 <stdlib.h>
#include <string.h>
#include <assert.h>
#include <limits.h>


#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_UINTEGER_4)

static inline int
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
{
  if (sizeof (GFC_UINTEGER_4) == 1)
    return memcmp (a, b, n);
  else
    return memcmp_char4 (a, b, n);

}

#define INITVAL 0

extern void maxval0_s4 (GFC_UINTEGER_4 * restrict,
        gfc_charlen_type,
	gfc_array_s4 * const restrict array, gfc_charlen_type);
export_proto(maxval0_s4);

void
maxval0_s4 (GFC_UINTEGER_4 * restrict ret,
        gfc_charlen_type xlen,
	gfc_array_s4 * const restrict array, gfc_charlen_type len)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  const GFC_UINTEGER_4 *base;
  index_type rank;
  index_type n;

  rank = GFC_DESCRIPTOR_RANK (array);
  if (rank <= 0)
    runtime_error ("Rank of array needs to be > 0");

  assert (xlen == len);

  /* Initialize return value.  */
  memset (ret, INITVAL, sizeof(*ret) * len);

  for (n = 0; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
      count[n] = 0;
      if (extent[n] <= 0)
        return;
    }

  base = array->base_addr;

  {

  const GFC_UINTEGER_4 *retval;
   retval = ret;

  while (base)
    {
      do
	{
	  /* Implementation start.  */

  if (compare_fcn (base, retval, len) > 0)
    {
      retval = base;
    }
	  /* Implementation end.  */
	  /* Advance to the next element.  */
	  base += sstride[0];
	}
      while (++count[0] != extent[0]);
      n = 0;
      do
	{
	  /* When we get to the end of a dimension, reset it and increment
	     the next dimension.  */
	  count[n] = 0;
	  /* We could precalculate these products, but this is a less
	     frequently used path so probably not worth it.  */
	  base -= sstride[n] * extent[n];
	  n++;
	  if (n >= rank)
	    {
	      /* Break out of the loop.  */
	      base = NULL;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	    }
	}
      while (count[n] == extent[n]);
    }
   memcpy (ret, retval, len * sizeof (*ret));
  }
}


extern void mmaxval0_s4 (GFC_UINTEGER_4 * restrict,
       gfc_charlen_type, gfc_array_s4 * const restrict array,
       gfc_array_l1 * const restrict mask, gfc_charlen_type len);
export_proto(mmaxval0_s4);

void
mmaxval0_s4 (GFC_UINTEGER_4 * const restrict ret,
	gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
	gfc_array_l1 * const restrict mask, gfc_charlen_type len)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type mstride[GFC_MAX_DIMENSIONS];
  const GFC_UINTEGER_4 *base;
  GFC_LOGICAL_1 *mbase;
  int rank;
  index_type n;
  int mask_kind;

  if (mask == NULL)
    {
      maxval0_s4 (ret, xlen, array, len);
      return;
    }

  rank = GFC_DESCRIPTOR_RANK (array);
  if (rank <= 0)
    runtime_error ("Rank of array needs to be > 0");

  assert (xlen == len);

/* Initialize return value.  */
  memset (ret, INITVAL, sizeof(*ret) * len);

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  mbase = mask->base_addr;

  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
    runtime_error ("Funny sized logical array");

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

  base = array->base_addr;
  {

  const GFC_UINTEGER_4 *retval;

  retval = ret;

  while (base)
    {
      do
	{
	  /* Implementation start.  */

  if (*mbase && compare_fcn (base, retval, len) > 0)
    {
      retval = base;
    }
	  /* Implementation end.  */
	  /* Advance to the next element.  */
	  base += sstride[0];
	  mbase += mstride[0];
	}
      while (++count[0] != extent[0]);
      n = 0;
      do
	{
	  /* When we get to the end of a dimension, reset it and increment
	     the next dimension.  */
	  count[n] = 0;
	  /* We could precalculate these products, but this is a less
	     frequently used path so probably not worth it.  */
	  base -= sstride[n] * extent[n];
	  mbase -= mstride[n] * extent[n];
	  n++;
	  if (n >= rank)
	    {
	      /* Break out of the loop.  */
	      base = NULL;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      mbase += mstride[n];
	    }
	}
      while (count[n] == extent[n]);
    }
    memcpy (ret, retval, len * sizeof (*ret));
  }
}


extern void smaxval0_s4 (GFC_UINTEGER_4 * restrict,
        gfc_charlen_type,
	gfc_array_s4 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
export_proto(smaxval0_s4);

void
smaxval0_s4 (GFC_UINTEGER_4 * restrict ret,
        gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
	GFC_LOGICAL_4 *mask, gfc_charlen_type len)
	
{
  if (mask == NULL || *mask)
    {
      maxval0_s4 (ret, xlen, array, len);
      return;
    }
  memset (ret, INITVAL, sizeof (*ret) * len);
}

#endif
Commit	Line	Data
0ac74254	1	/* Implementation of the MAXLOC intrinsic
a945c346	2	Copyright (C) 2017-2024 Free Software Foundation, Inc.
0ac74254 TK	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
01ce9e31	33	#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_UINTEGER_4)
0ac74254 TK	34
0ac74254 TK	35	static inline int
01ce9e31	36	compare_fcn (const GFC_UINTEGER_4 a, const GFC_UINTEGER_4 b, gfc_charlen_type n)
0ac74254	37	{
01ce9e31	38	if (sizeof (GFC_UINTEGER_4) == 1)
0ac74254 TK	39	return memcmp (a, b, n);
	40	else
	41	return memcmp_char4 (a, b, n);
	42
	43	}
	44
	45	#define INITVAL 0
	46
01ce9e31	47	extern void maxval0_s4 (GFC_UINTEGER_4 * restrict,
0ac74254 TK	48	gfc_charlen_type,
	49	gfc_array_s4 * const restrict array, gfc_charlen_type);
	50	export_proto(maxval0_s4);
	51
	52	void
01ce9e31	53	maxval0_s4 (GFC_UINTEGER_4 * restrict ret,
0ac74254 TK	54	gfc_charlen_type xlen,
	55	gfc_array_s4 * const restrict array, gfc_charlen_type len)
	56	{
	57	index_type count[GFC_MAX_DIMENSIONS];
	58	index_type extent[GFC_MAX_DIMENSIONS];
	59	index_type sstride[GFC_MAX_DIMENSIONS];
01ce9e31	60	const GFC_UINTEGER_4 *base;
0ac74254 TK	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	assert (xlen == len);
	69
	70	/* Initialize return value. */
	71	memset (ret, INITVAL, sizeof(ret) len);
	72
	73	for (n = 0; n < rank; n++)
	74	{
	75	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
	76	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	77	count[n] = 0;
	78	if (extent[n] <= 0)
	79	return;
	80	}
	81
	82	base = array->base_addr;
	83
	84	{
	85
01ce9e31	86	const GFC_UINTEGER_4 *retval;
0ac74254 TK	87	retval = ret;
	88
	89	while (base)
	90	{
	91	do
	92	{
	93	/* Implementation start. */
	94
	95	if (compare_fcn (base, retval, len) > 0)
	96	{
	97	retval = base;
	98	}
	99	/* Implementation end. */
	100	/* Advance to the next element. */
	101	base += sstride[0];
	102	}
	103	while (++count[0] != extent[0]);
	104	n = 0;
	105	do
	106	{
	107	/* When we get to the end of a dimension, reset it and increment
	108	the next dimension. */
	109	count[n] = 0;
	110	/* We could precalculate these products, but this is a less
	111	frequently used path so probably not worth it. */
	112	base -= sstride[n] * extent[n];
	113	n++;
	114	if (n >= rank)
	115	{
	116	/* Break out of the loop. */
	117	base = NULL;
	118	break;
	119	}
	120	else
	121	{
	122	count[n]++;
	123	base += sstride[n];
	124	}
	125	}
	126	while (count[n] == extent[n]);
	127	}
	128	memcpy (ret, retval, len * sizeof (*ret));
	129	}
	130	}
	131
	132
01ce9e31	133	extern void mmaxval0_s4 (GFC_UINTEGER_4 * restrict,
0ac74254 TK	134	gfc_charlen_type, gfc_array_s4 * const restrict array,
	135	gfc_array_l1 * const restrict mask, gfc_charlen_type len);
	136	export_proto(mmaxval0_s4);
	137
	138	void
01ce9e31	139	mmaxval0_s4 (GFC_UINTEGER_4 * const restrict ret,
0ac74254 TK	140	gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
	141	gfc_array_l1 * const restrict mask, gfc_charlen_type len)
	142	{
	143	index_type count[GFC_MAX_DIMENSIONS];
	144	index_type extent[GFC_MAX_DIMENSIONS];
	145	index_type sstride[GFC_MAX_DIMENSIONS];
	146	index_type mstride[GFC_MAX_DIMENSIONS];
01ce9e31	147	const GFC_UINTEGER_4 *base;
0ac74254 TK	148	GFC_LOGICAL_1 *mbase;
	149	int rank;
	150	index_type n;
	151	int mask_kind;
	152
2ea47ee9 TK	153	if (mask == NULL)
	154	{
	155	maxval0_s4 (ret, xlen, array, len);
	156	return;
	157	}
	158
0ac74254 TK	159	rank = GFC_DESCRIPTOR_RANK (array);
	160	if (rank <= 0)
	161	runtime_error ("Rank of array needs to be > 0");
	162
	163	assert (xlen == len);
	164
	165	/* Initialize return value. */
	166	memset (ret, INITVAL, sizeof(ret) len);
	167
	168	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	169
	170	mbase = mask->base_addr;
	171
	172	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	173	#ifdef HAVE_GFC_LOGICAL_16
	174	\|\| mask_kind == 16
	175	#endif
	176	)
	177	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	178	else
	179	runtime_error ("Funny sized logical array");
	180
	181	for (n = 0; n < rank; n++)
	182	{
	183	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
	184	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	185	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	186	count[n] = 0;
	187	if (extent[n] <= 0)
	188	return;
	189	}
	190
	191	base = array->base_addr;
	192	{
	193
01ce9e31	194	const GFC_UINTEGER_4 *retval;
0ac74254 TK	195
	196	retval = ret;
	197
	198	while (base)
	199	{
	200	do
	201	{
	202	/* Implementation start. */
	203
	204	if (*mbase && compare_fcn (base, retval, len) > 0)
	205	{
	206	retval = base;
	207	}
	208	/* Implementation end. */
	209	/* Advance to the next element. */
	210	base += sstride[0];
	211	mbase += mstride[0];
	212	}
	213	while (++count[0] != extent[0]);
	214	n = 0;
	215	do
	216	{
	217	/* When we get to the end of a dimension, reset it and increment
	218	the next dimension. */
	219	count[n] = 0;
	220	/* We could precalculate these products, but this is a less
	221	frequently used path so probably not worth it. */
	222	base -= sstride[n] * extent[n];
	223	mbase -= mstride[n] * extent[n];
	224	n++;
	225	if (n >= rank)
	226	{
	227	/* Break out of the loop. */
	228	base = NULL;
	229	break;
	230	}
	231	else
	232	{
	233	count[n]++;
	234	base += sstride[n];
	235	mbase += mstride[n];
	236	}
	237	}
	238	while (count[n] == extent[n]);
	239	}
	240	memcpy (ret, retval, len * sizeof (*ret));
	241	}
	242	}
	243
	244
01ce9e31	245	extern void smaxval0_s4 (GFC_UINTEGER_4 * restrict,
0ac74254 TK	246	gfc_charlen_type,
	247	gfc_array_s4 * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type);
	248	export_proto(smaxval0_s4);
	249
	250	void
01ce9e31	251	smaxval0_s4 (GFC_UINTEGER_4 * restrict ret,
0ac74254 TK	252	gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
	253	GFC_LOGICAL_4 *mask, gfc_charlen_type len)
	254
	255	{
2ea47ee9	256	if (mask == NULL \|\| *mask)
0ac74254 TK	257	{
	258	maxval0_s4 (ret, xlen, array, len);
	259	return;
	260	}
	261	memset (ret, INITVAL, sizeof (ret) len);
	262	}
	263
	264	#endif