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

/* Implementation of the MAXLOC intrinsic
   Copyright (C) 2017-2018 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_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)

#define HAVE_BACK_ARG 1

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

}

extern void maxloc0_8_s1 (gfc_array_i8 * const restrict retarray, 
	gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len);
export_proto(maxloc0_8_s1);

void
maxloc0_8_s1 (gfc_array_i8 * const restrict retarray, 
	gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride;
  const GFC_INTEGER_1 *base;
  GFC_INTEGER_8 * restrict dest;
  index_type rank;
  index_type n;

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

  if (retarray->base_addr == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
      GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
      retarray->offset = 0;
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
    }
  else
    {
      if (unlikely (compile_options.bounds_check))
	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
				"MAXLOC");
    }

  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  dest = retarray->base_addr;
  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)
	{
	  /* Set the return value.  */
	  for (n = 0; n < rank; n++)
	    dest[n * dstride] = 0;
	  return;
	}
    }

  base = array->base_addr;

  /* Initialize the return value.  */
  for (n = 0; n < rank; n++)
    dest[n * dstride] = 1;
  {

  const GFC_INTEGER_1 *maxval;
   maxval = NULL;

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

    if (maxval == NULL || (back ? compare_fcn (base, maxval, len) >= 0 :
     		   	   	   compare_fcn (base, maxval, len) > 0))
    {
      maxval = base;
      for (n = 0; n < rank; n++)
        dest[n * dstride] = count[n] + 1;
    }
	  /* 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]);
    }
  }
}


extern void mmaxloc0_8_s1 (gfc_array_i8 * const restrict, 
	gfc_array_s1 * const restrict, gfc_array_l1 * const restrict , GFC_LOGICAL_4 back,
	gfc_charlen_type len);
export_proto(mmaxloc0_8_s1);

void
mmaxloc0_8_s1 (gfc_array_i8 * const restrict retarray, 
	gfc_array_s1 * const restrict array,
	gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back,
	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];
  index_type dstride;
  GFC_INTEGER_8 *dest;
  const GFC_INTEGER_1 *base;
  GFC_LOGICAL_1 *mbase;
  int rank;
  index_type n;
  int mask_kind;

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

  if (retarray->base_addr == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
      GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
      retarray->offset = 0;
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
    }
  else
    {
      if (unlikely (compile_options.bounds_check))
	{

	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
				  "MAXLOC");
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
				  "MASK argument", "MAXLOC");
	}
    }

  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");

  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  dest = retarray->base_addr;
  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)
	{
	  /* Set the return value.  */
	  for (n = 0; n < rank; n++)
	    dest[n * dstride] = 0;
	  return;
	}
    }

  base = array->base_addr;

  /* Initialize the return value.  */
  for (n = 0; n < rank; n++)
    dest[n * dstride] = 0;
  {

  const GFC_INTEGER_1 *maxval;

  maxval = NULL;

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

  if (*mbase &&
        (maxval == NULL || (back ? compare_fcn (base, maxval, len) >= 0:
		   	   	   compare_fcn (base, maxval, len) > 0)))
    {
      maxval = base;
      for (n = 0; n < rank; n++)
        dest[n * dstride] = count[n] + 1;
    }
	  /* 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]);
    }
  }
}


extern void smaxloc0_8_s1 (gfc_array_i8 * const restrict, 
	gfc_array_s1 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4 back,
	gfc_charlen_type len);
export_proto(smaxloc0_8_s1);

void
smaxloc0_8_s1 (gfc_array_i8 * const restrict retarray, 
	gfc_array_s1 * const restrict array,
	GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back,
	gfc_charlen_type len)
{
  index_type rank;
  index_type dstride;
  index_type n;
  GFC_INTEGER_8 *dest;

  if (*mask)
    {
#ifdef HAVE_BACK_ARG    
      maxloc0_8_s1 (retarray, array, back, len);
#else
      maxloc0_8_s1 (retarray, array, len);
#endif
      return;
    }

  rank = GFC_DESCRIPTOR_RANK (array);

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

  if (retarray->base_addr == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
      GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
      retarray->offset = 0;
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
    }
  else if (unlikely (compile_options.bounds_check))
    {
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
			       "MAXLOC");
    }

  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  dest = retarray->base_addr;
  for (n = 0; n<rank; n++)
    dest[n * dstride] = 0 ;
}
#endif
Commit	Line	Data
ddc9995b	1	/* Implementation of the MAXLOC intrinsic
85ec4feb	2	Copyright (C) 2017-2018 Free Software Foundation, Inc.
ddc9995b 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
	33	#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)
	34
64b1806b TK	35	#define HAVE_BACK_ARG 1
64b1806b TK	36
ddc9995b TK	37	static inline int
	38	compare_fcn (const GFC_INTEGER_1 a, const GFC_INTEGER_1 b, gfc_charlen_type n)
	39	{
	40	if (sizeof (GFC_INTEGER_1) == 1)
	41	return memcmp (a, b, n);
	42	else
	43	return memcmp_char4 (a, b, n);
	44
	45	}
	46
	47	extern void maxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
64b1806b	48	gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len);
ddc9995b TK	49	export_proto(maxloc0_8_s1);
	50
	51	void
	52	maxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
64b1806b	53	gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len)
ddc9995b TK	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_INTEGER_1 *base;
	60	GFC_INTEGER_8 * 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);
fa3c4d47	71	GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
ddc9995b TK	72	retarray->offset = 0;
	73	retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
	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_INTEGER_1 *maxval;
b573f931	106	maxval = NULL;
ddc9995b TK	107
	108	while (base)
	109	{
	110	do
	111	{
	112	/* Implementation start. */
	113
b573f931 TK	114	if (maxval == NULL \|\| (back ? compare_fcn (base, maxval, len) >= 0 :
b573f931 TK	115	compare_fcn (base, maxval, len) > 0))
ddc9995b TK	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_8_s1 (gfc_array_i8 * const restrict,
64b1806b TK	155	gfc_array_s1 * const restrict, gfc_array_l1 * const restrict , GFC_LOGICAL_4 back,
64b1806b TK	156	gfc_charlen_type len);
ddc9995b TK	157	export_proto(mmaxloc0_8_s1);
	158
	159	void
	160	mmaxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
	161	gfc_array_s1 * const restrict array,
64b1806b TK	162	gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back,
64b1806b TK	163	gfc_charlen_type len)
ddc9995b TK	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_8 *dest;
	171	const GFC_INTEGER_1 *base;
	172	GFC_LOGICAL_1 *mbase;
	173	int rank;
	174	index_type n;
	175	int mask_kind;
	176
	177	rank = GFC_DESCRIPTOR_RANK (array);
	178	if (rank <= 0)
	179	runtime_error ("Rank of array needs to be > 0");
	180
	181	if (retarray->base_addr == NULL)
	182	{
	183	GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
fa3c4d47	184	GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
ddc9995b TK	185	retarray->offset = 0;
	186	retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
	187	}
	188	else
	189	{
	190	if (unlikely (compile_options.bounds_check))
	191	{
	192
	193	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
	194	"MAXLOC");
	195	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	196	"MASK argument", "MAXLOC");
	197	}
	198	}
	199
	200	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	201
	202	mbase = mask->base_addr;
	203
	204	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	205	#ifdef HAVE_GFC_LOGICAL_16
	206	\|\| mask_kind == 16
	207	#endif
	208	)
	209	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	210	else
	211	runtime_error ("Funny sized logical array");
	212
	213	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
	214	dest = retarray->base_addr;
	215	for (n = 0; n < rank; n++)
	216	{
	217	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
	218	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	219	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	220	count[n] = 0;
	221	if (extent[n] <= 0)
	222	{
	223	/* Set the return value. */
	224	for (n = 0; n < rank; n++)
	225	dest[n * dstride] = 0;
	226	return;
	227	}
	228	}
	229
	230	base = array->base_addr;
	231
	232	/* Initialize the return value. */
	233	for (n = 0; n < rank; n++)
	234	dest[n * dstride] = 0;
	235	{
	236
	237	const GFC_INTEGER_1 *maxval;
	238
	239	maxval = NULL;
	240
	241	while (base)
	242	{
	243	do
	244	{
	245	/* Implementation start. */
	246
b573f931 TK	247	if (*mbase &&
	248	(maxval == NULL \|\| (back ? compare_fcn (base, maxval, len) >= 0:
	249	compare_fcn (base, maxval, len) > 0)))
ddc9995b TK	250	{
	251	maxval = base;
	252	for (n = 0; n < rank; n++)
	253	dest[n * dstride] = count[n] + 1;
	254	}
	255	/* Implementation end. */
	256	/* Advance to the next element. */
	257	base += sstride[0];
	258	mbase += mstride[0];
	259	}
	260	while (++count[0] != extent[0]);
	261	n = 0;
	262	do
	263	{
	264	/* When we get to the end of a dimension, reset it and increment
	265	the next dimension. */
	266	count[n] = 0;
	267	/* We could precalculate these products, but this is a less
	268	frequently used path so probably not worth it. */
	269	base -= sstride[n] * extent[n];
	270	mbase -= mstride[n] * extent[n];
	271	n++;
	272	if (n >= rank)
	273	{
	274	/* Break out of the loop. */
	275	base = NULL;
	276	break;
	277	}
	278	else
	279	{
	280	count[n]++;
	281	base += sstride[n];
	282	mbase += mstride[n];
	283	}
	284	}
	285	while (count[n] == extent[n]);
	286	}
	287	}
	288	}
	289
	290
	291	extern void smaxloc0_8_s1 (gfc_array_i8 * const restrict,
64b1806b TK	292	gfc_array_s1 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4 back,
64b1806b TK	293	gfc_charlen_type len);
ddc9995b TK	294	export_proto(smaxloc0_8_s1);
	295
	296	void
	297	smaxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
	298	gfc_array_s1 * const restrict array,
64b1806b TK	299	GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back,
64b1806b TK	300	gfc_charlen_type len)
ddc9995b TK	301	{
	302	index_type rank;
	303	index_type dstride;
	304	index_type n;
	305	GFC_INTEGER_8 *dest;
	306
	307	if (*mask)
	308	{
64b1806b TK	309	#ifdef HAVE_BACK_ARG
	310	maxloc0_8_s1 (retarray, array, back, len);
	311	#else
ddc9995b	312	maxloc0_8_s1 (retarray, array, len);
64b1806b	313	#endif
ddc9995b TK	314	return;
	315	}
	316
	317	rank = GFC_DESCRIPTOR_RANK (array);
	318
	319	if (rank <= 0)
	320	runtime_error ("Rank of array needs to be > 0");
	321
	322	if (retarray->base_addr == NULL)
	323	{
	324	GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
fa3c4d47	325	GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
ddc9995b TK	326	retarray->offset = 0;
	327	retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
	328	}
	329	else if (unlikely (compile_options.bounds_check))
	330	{
	331	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
	332	"MAXLOC");
	333	}
	334
	335	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
	336	dest = retarray->base_addr;
	337	for (n = 0; n<rank; n++)
	338	dest[n * dstride] = 0 ;
	339	}
	340	#endif