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

/* Implementation of the RESHAPE intrinsic
   Copyright (C) 2002-2017 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>

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"


#if defined (HAVE_GFC_COMPLEX_16)

typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type;


extern void reshape_c16 (gfc_array_c16 * const restrict, 
	gfc_array_c16 * const restrict, 
	shape_type * const restrict,
	gfc_array_c16 * const restrict, 
	shape_type * const restrict);
export_proto(reshape_c16);

void
reshape_c16 (gfc_array_c16 * const restrict ret, 
	gfc_array_c16 * const restrict source, 
	shape_type * const restrict shape,
	gfc_array_c16 * const restrict pad, 
	shape_type * const restrict order)
{
  /* r.* indicates the return array.  */
  index_type rcount[GFC_MAX_DIMENSIONS];
  index_type rextent[GFC_MAX_DIMENSIONS];
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type rdim;
  index_type rsize;
  index_type rs;
  index_type rex;
  GFC_COMPLEX_16 *rptr;
  /* s.* indicates the source array.  */
  index_type scount[GFC_MAX_DIMENSIONS];
  index_type sextent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type sstride0;
  index_type sdim;
  index_type ssize;
  const GFC_COMPLEX_16 *sptr;
  /* p.* indicates the pad array.  */
  index_type pcount[GFC_MAX_DIMENSIONS];
  index_type pextent[GFC_MAX_DIMENSIONS];
  index_type pstride[GFC_MAX_DIMENSIONS];
  index_type pdim;
  index_type psize;
  const GFC_COMPLEX_16 *pptr;

  const GFC_COMPLEX_16 *src;
  int n;
  int dim;
  int sempty, pempty, shape_empty;
  index_type shape_data[GFC_MAX_DIMENSIONS];

  rdim = GFC_DESCRIPTOR_EXTENT(shape,0);
  if (rdim != GFC_DESCRIPTOR_RANK(ret))
    runtime_error("rank of return array incorrect in RESHAPE intrinsic");

  shape_empty = 0;

  for (n = 0; n < rdim; n++)
    {
      shape_data[n] = shape->base_addr[n * GFC_DESCRIPTOR_STRIDE(shape,0)];
      if (shape_data[n] <= 0)
      {
        shape_data[n] = 0;
	shape_empty = 1;
      }
    }

  if (ret->base_addr == NULL)
    {
      index_type alloc_size;

      rs = 1;
      for (n = 0; n < rdim; n++)
	{
	  rex = shape_data[n];

	  GFC_DIMENSION_SET(ret->dim[n], 0, rex - 1, rs);

	  rs *= rex;
	}
      ret->offset = 0;

      if (unlikely (rs < 1))
        alloc_size = 0;
      else
        alloc_size = rs;

      ret->base_addr = xmallocarray (alloc_size, sizeof (GFC_COMPLEX_16));
      ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim;
    }

  if (shape_empty)
    return;

  if (pad)
    {
      pdim = GFC_DESCRIPTOR_RANK (pad);
      psize = 1;
      pempty = 0;
      for (n = 0; n < pdim; n++)
        {
          pcount[n] = 0;
          pstride[n] = GFC_DESCRIPTOR_STRIDE(pad,n);
          pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n);
          if (pextent[n] <= 0)
	    {
	      pempty = 1;
	      pextent[n] = 0;
	    }

          if (psize == pstride[n])
            psize *= pextent[n];
          else
            psize = 0;
        }
      pptr = pad->base_addr;
    }
  else
    {
      pdim = 0;
      psize = 1;
      pempty = 1;
      pptr = NULL;
    }

  if (unlikely (compile_options.bounds_check))
    {
      index_type ret_extent, source_extent;

      rs = 1;
      for (n = 0; n < rdim; n++)
	{
	  rs *= shape_data[n];
	  ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
	  if (ret_extent != shape_data[n])
	    runtime_error("Incorrect extent in return value of RESHAPE"
			  " intrinsic in dimension %ld: is %ld,"
			  " should be %ld", (long int) n+1,
			  (long int) ret_extent, (long int) shape_data[n]);
	}

      source_extent = 1;
      sdim = GFC_DESCRIPTOR_RANK (source);
      for (n = 0; n < sdim; n++)
	{
	  index_type se;
	  se = GFC_DESCRIPTOR_EXTENT(source,n);
	  source_extent *= se > 0 ? se : 0;
	}

      if (rs > source_extent && (!pad || pempty))
	runtime_error("Incorrect size in SOURCE argument to RESHAPE"
		      " intrinsic: is %ld, should be %ld",
		      (long int) source_extent, (long int) rs);

      if (order)
	{
	  int seen[GFC_MAX_DIMENSIONS];
	  index_type v;

	  for (n = 0; n < rdim; n++)
	    seen[n] = 0;

	  for (n = 0; n < rdim; n++)
	    {
	      v = order->base_addr[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1;

	      if (v < 0 || v >= rdim)
		runtime_error("Value %ld out of range in ORDER argument"
			      " to RESHAPE intrinsic", (long int) v + 1);

	      if (seen[v] != 0)
		runtime_error("Duplicate value %ld in ORDER argument to"
			      " RESHAPE intrinsic", (long int) v + 1);
		
	      seen[v] = 1;
	    }
	}
    }

  rsize = 1;
  for (n = 0; n < rdim; n++)
    {
      if (order)
        dim = order->base_addr[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1;
      else
        dim = n;

      rcount[n] = 0;
      rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
      rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim);
      if (rextent[n] < 0)
        rextent[n] = 0;

      if (rextent[n] != shape_data[dim])
        runtime_error ("shape and target do not conform");

      if (rsize == rstride[n])
        rsize *= rextent[n];
      else
        rsize = 0;
      if (rextent[n] <= 0)
        return;
    }

  sdim = GFC_DESCRIPTOR_RANK (source);
  ssize = 1;
  sempty = 0;
  for (n = 0; n < sdim; n++)
    {
      scount[n] = 0;
      sstride[n] = GFC_DESCRIPTOR_STRIDE(source,n);
      sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n);
      if (sextent[n] <= 0)
	{
	  sempty = 1;
	  sextent[n] = 0;
	}

      if (ssize == sstride[n])
        ssize *= sextent[n];
      else
        ssize = 0;
    }

  if (rsize != 0 && ssize != 0 && psize != 0)
    {
      rsize *= sizeof (GFC_COMPLEX_16);
      ssize *= sizeof (GFC_COMPLEX_16);
      psize *= sizeof (GFC_COMPLEX_16);
      reshape_packed ((char *)ret->base_addr, rsize, (char *)source->base_addr,
		      ssize, pad ? (char *)pad->base_addr : NULL, psize);
      return;
    }
  rptr = ret->base_addr;
  src = sptr = source->base_addr;
  rstride0 = rstride[0];
  sstride0 = sstride[0];

  if (sempty && pempty)
    abort ();

  if (sempty)
    {
      /* Pretend we are using the pad array the first time around, too.  */
      src = pptr;
      sptr = pptr;
      sdim = pdim;
      for (dim = 0; dim < pdim; dim++)
	{
	  scount[dim] = pcount[dim];
	  sextent[dim] = pextent[dim];
	  sstride[dim] = pstride[dim];
	  sstride0 = pstride[0];
	}
    }

  while (rptr)
    {
      /* Select between the source and pad arrays.  */
      *rptr = *src;
      /* Advance to the next element.  */
      rptr += rstride0;
      src += sstride0;
      rcount[0]++;
      scount[0]++;

      /* Advance to the next destination element.  */
      n = 0;
      while (rcount[n] == rextent[n])
        {
          /* When we get to the end of a dimension, reset it and increment
             the next dimension.  */
          rcount[n] = 0;
          /* We could precalculate these products, but this is a less
             frequently used path so probably not worth it.  */
          rptr -= rstride[n] * rextent[n];
          n++;
          if (n == rdim)
            {
              /* Break out of the loop.  */
              rptr = NULL;
              break;
            }
          else
            {
              rcount[n]++;
              rptr += rstride[n];
            }
        }
      /* Advance to the next source element.  */
      n = 0;
      while (scount[n] == sextent[n])
        {
          /* When we get to the end of a dimension, reset it and increment
             the next dimension.  */
          scount[n] = 0;
          /* We could precalculate these products, but this is a less
             frequently used path so probably not worth it.  */
          src -= sstride[n] * sextent[n];
          n++;
          if (n == sdim)
            {
              if (sptr && pad)
                {
                  /* Switch to the pad array.  */
                  sptr = NULL;
                  sdim = pdim;
                  for (dim = 0; dim < pdim; dim++)
                    {
                      scount[dim] = pcount[dim];
                      sextent[dim] = pextent[dim];
                      sstride[dim] = pstride[dim];
                      sstride0 = sstride[0];
                    }
                }
              /* We now start again from the beginning of the pad array.  */
              src = pptr;
              break;
            }
          else
            {
              scount[n]++;
              src += sstride[n];
            }
        }
    }
}

#endif
Commit	Line	Data
dfb55fdc	1	/* Implementation of the RESHAPE intrinsic
cbe34bb5	2	Copyright (C) 2002-2017 Free Software Foundation, Inc.
644cb69f FXC	3	Contributed by Paul Brook <paul@nowt.org>
644cb69f FXC	4
21d1335b	5	This file is part of the GNU Fortran runtime library (libgfortran).
644cb69f FXC	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
748086b7	10	version 3 of the License, or (at your option) any later version.
644cb69f FXC	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
748086b7 JJ	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/>. */
644cb69f	25
36ae8a61	26	#include "libgfortran.h"
36ae8a61	27
644cb69f FXC	28
	29	#if defined (HAVE_GFC_COMPLEX_16)
	30
	31	typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type;
	32
644cb69f	33
64acfd99 JB	34	extern void reshape_c16 (gfc_array_c16 * const restrict,
	35	gfc_array_c16 * const restrict,
	36	shape_type * const restrict,
	37	gfc_array_c16 * const restrict,
	38	shape_type * const restrict);
644cb69f FXC	39	export_proto(reshape_c16);
	40
	41	void
64acfd99 JB	42	reshape_c16 (gfc_array_c16 * const restrict ret,
	43	gfc_array_c16 * const restrict source,
	44	shape_type * const restrict shape,
	45	gfc_array_c16 * const restrict pad,
	46	shape_type * const restrict order)
644cb69f FXC	47	{
	48	/* r.* indicates the return array. */
	49	index_type rcount[GFC_MAX_DIMENSIONS];
	50	index_type rextent[GFC_MAX_DIMENSIONS];
	51	index_type rstride[GFC_MAX_DIMENSIONS];
	52	index_type rstride0;
	53	index_type rdim;
	54	index_type rsize;
	55	index_type rs;
	56	index_type rex;
	57	GFC_COMPLEX_16 *rptr;
	58	/* s.* indicates the source array. */
	59	index_type scount[GFC_MAX_DIMENSIONS];
	60	index_type sextent[GFC_MAX_DIMENSIONS];
	61	index_type sstride[GFC_MAX_DIMENSIONS];
	62	index_type sstride0;
	63	index_type sdim;
	64	index_type ssize;
	65	const GFC_COMPLEX_16 *sptr;
	66	/* p.* indicates the pad array. */
	67	index_type pcount[GFC_MAX_DIMENSIONS];
	68	index_type pextent[GFC_MAX_DIMENSIONS];
	69	index_type pstride[GFC_MAX_DIMENSIONS];
	70	index_type pdim;
	71	index_type psize;
	72	const GFC_COMPLEX_16 *pptr;
	73
	74	const GFC_COMPLEX_16 *src;
	75	int n;
	76	int dim;
8c154b65 TK	77	int sempty, pempty, shape_empty;
	78	index_type shape_data[GFC_MAX_DIMENSIONS];
	79
dfb55fdc	80	rdim = GFC_DESCRIPTOR_EXTENT(shape,0);
8c154b65 TK	81	if (rdim != GFC_DESCRIPTOR_RANK(ret))
	82	runtime_error("rank of return array incorrect in RESHAPE intrinsic");
	83
	84	shape_empty = 0;
	85
	86	for (n = 0; n < rdim; n++)
	87	{
21d1335b	88	shape_data[n] = shape->base_addr[n * GFC_DESCRIPTOR_STRIDE(shape,0)];
8c154b65 TK	89	if (shape_data[n] <= 0)
	90	{
	91	shape_data[n] = 0;
	92	shape_empty = 1;
	93	}
	94	}
644cb69f	95
21d1335b	96	if (ret->base_addr == NULL)
644cb69f	97	{
19b76346 TK	98	index_type alloc_size;
19b76346 TK	99
644cb69f	100	rs = 1;
47c07d96	101	for (n = 0; n < rdim; n++)
644cb69f	102	{
8c154b65	103	rex = shape_data[n];
dfb55fdc TK	104
	105	GFC_DIMENSION_SET(ret->dim[n], 0, rex - 1, rs);
	106
644cb69f FXC	107	rs *= rex;
	108	}
	109	ret->offset = 0;
19b76346 TK	110
19b76346 TK	111	if (unlikely (rs < 1))
92e6f3a4	112	alloc_size = 0;
19b76346	113	else
92e6f3a4	114	alloc_size = rs;
19b76346	115
92e6f3a4	116	ret->base_addr = xmallocarray (alloc_size, sizeof (GFC_COMPLEX_16));
644cb69f FXC	117	ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) \| rdim;
644cb69f FXC	118	}
8c154b65 TK	119
	120	if (shape_empty)
	121	return;
644cb69f	122
bd72cbc8 TK	123	if (pad)
	124	{
	125	pdim = GFC_DESCRIPTOR_RANK (pad);
	126	psize = 1;
	127	pempty = 0;
	128	for (n = 0; n < pdim; n++)
	129	{
	130	pcount[n] = 0;
dfb55fdc TK	131	pstride[n] = GFC_DESCRIPTOR_STRIDE(pad,n);
dfb55fdc TK	132	pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n);
bd72cbc8 TK	133	if (pextent[n] <= 0)
	134	{
	135	pempty = 1;
	136	pextent[n] = 0;
	137	}
	138
	139	if (psize == pstride[n])
	140	psize *= pextent[n];
	141	else
	142	psize = 0;
	143	}
21d1335b	144	pptr = pad->base_addr;
bd72cbc8 TK	145	}
	146	else
	147	{
	148	pdim = 0;
	149	psize = 1;
	150	pempty = 1;
	151	pptr = NULL;
	152	}
	153
fd7f9754 TK	154	if (unlikely (compile_options.bounds_check))
fd7f9754 TK	155	{
21c74256 TK	156	index_type ret_extent, source_extent;
	157
	158	rs = 1;
	159	for (n = 0; n < rdim; n++)
	160	{
	161	rs *= shape_data[n];
dfb55fdc	162	ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
21c74256 TK	163	if (ret_extent != shape_data[n])
	164	runtime_error("Incorrect extent in return value of RESHAPE"
	165	" intrinsic in dimension %ld: is %ld,"
	166	" should be %ld", (long int) n+1,
	167	(long int) ret_extent, (long int) shape_data[n]);
	168	}
	169
a388c779 TK	170	source_extent = 1;
	171	sdim = GFC_DESCRIPTOR_RANK (source);
	172	for (n = 0; n < sdim; n++)
	173	{
	174	index_type se;
dfb55fdc	175	se = GFC_DESCRIPTOR_EXTENT(source,n);
a388c779 TK	176	source_extent *= se > 0 ? se : 0;
a388c779 TK	177	}
21c74256	178
bd72cbc8	179	if (rs > source_extent && (!pad \|\| pempty))
21c74256 TK	180	runtime_error("Incorrect size in SOURCE argument to RESHAPE"
	181	" intrinsic: is %ld, should be %ld",
	182	(long int) source_extent, (long int) rs);
	183
fd7f9754 TK	184	if (order)
	185	{
	186	int seen[GFC_MAX_DIMENSIONS];
	187	index_type v;
	188
	189	for (n = 0; n < rdim; n++)
	190	seen[n] = 0;
	191
	192	for (n = 0; n < rdim; n++)
	193	{
21d1335b	194	v = order->base_addr[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1;
fd7f9754 TK	195
	196	if (v < 0 \|\| v >= rdim)
	197	runtime_error("Value %ld out of range in ORDER argument"
	198	" to RESHAPE intrinsic", (long int) v + 1);
	199
	200	if (seen[v] != 0)
	201	runtime_error("Duplicate value %ld in ORDER argument to"
	202	" RESHAPE intrinsic", (long int) v + 1);
	203
	204	seen[v] = 1;
	205	}
	206	}
	207	}
	208
644cb69f FXC	209	rsize = 1;
	210	for (n = 0; n < rdim; n++)
	211	{
	212	if (order)
21d1335b	213	dim = order->base_addr[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1;
644cb69f FXC	214	else
	215	dim = n;
	216
	217	rcount[n] = 0;
dfb55fdc TK	218	rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
dfb55fdc TK	219	rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim);
8c154b65	220	if (rextent[n] < 0)
e94471ba	221	rextent[n] = 0;
644cb69f	222
8c154b65	223	if (rextent[n] != shape_data[dim])
644cb69f FXC	224	runtime_error ("shape and target do not conform");
	225
	226	if (rsize == rstride[n])
	227	rsize *= rextent[n];
	228	else
	229	rsize = 0;
	230	if (rextent[n] <= 0)
	231	return;
	232	}
	233
	234	sdim = GFC_DESCRIPTOR_RANK (source);
	235	ssize = 1;
47c07d96	236	sempty = 0;
644cb69f FXC	237	for (n = 0; n < sdim; n++)
	238	{
	239	scount[n] = 0;
dfb55fdc TK	240	sstride[n] = GFC_DESCRIPTOR_STRIDE(source,n);
dfb55fdc TK	241	sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n);
644cb69f	242	if (sextent[n] <= 0)
47c07d96 FXC	243	{
	244	sempty = 1;
	245	sextent[n] = 0;
	246	}
644cb69f FXC	247
	248	if (ssize == sstride[n])
	249	ssize *= sextent[n];
	250	else
	251	ssize = 0;
	252	}
	253
644cb69f FXC	254	if (rsize != 0 && ssize != 0 && psize != 0)
	255	{
	256	rsize *= sizeof (GFC_COMPLEX_16);
	257	ssize *= sizeof (GFC_COMPLEX_16);
	258	psize *= sizeof (GFC_COMPLEX_16);
21d1335b TB	259	reshape_packed ((char )ret->base_addr, rsize, (char )source->base_addr,
21d1335b TB	260	ssize, pad ? (char *)pad->base_addr : NULL, psize);
644cb69f FXC	261	return;
644cb69f FXC	262	}
21d1335b TB	263	rptr = ret->base_addr;
21d1335b TB	264	src = sptr = source->base_addr;
644cb69f FXC	265	rstride0 = rstride[0];
	266	sstride0 = sstride[0];
	267
47c07d96 FXC	268	if (sempty && pempty)
	269	abort ();
	270
	271	if (sempty)
	272	{
042fed79	273	/* Pretend we are using the pad array the first time around, too. */
47c07d96	274	src = pptr;
042fed79	275	sptr = pptr;
47c07d96 FXC	276	sdim = pdim;
	277	for (dim = 0; dim < pdim; dim++)
	278	{
	279	scount[dim] = pcount[dim];
	280	sextent[dim] = pextent[dim];
	281	sstride[dim] = pstride[dim];
042fed79	282	sstride0 = pstride[0];
47c07d96 FXC	283	}
	284	}
	285
644cb69f FXC	286	while (rptr)
	287	{
	288	/* Select between the source and pad arrays. */
	289	rptr = src;
	290	/* Advance to the next element. */
	291	rptr += rstride0;
	292	src += sstride0;
	293	rcount[0]++;
	294	scount[0]++;
47c07d96	295
644cb69f FXC	296	/* Advance to the next destination element. */
	297	n = 0;
	298	while (rcount[n] == rextent[n])
	299	{
	300	/* When we get to the end of a dimension, reset it and increment
	301	the next dimension. */
	302	rcount[n] = 0;
	303	/* We could precalculate these products, but this is a less
5d7adf7a	304	frequently used path so probably not worth it. */
644cb69f FXC	305	rptr -= rstride[n] * rextent[n];
	306	n++;
	307	if (n == rdim)
	308	{
	309	/* Break out of the loop. */
	310	rptr = NULL;
	311	break;
	312	}
	313	else
	314	{
	315	rcount[n]++;
	316	rptr += rstride[n];
	317	}
	318	}
	319	/* Advance to the next source element. */
	320	n = 0;
	321	while (scount[n] == sextent[n])
	322	{
	323	/* When we get to the end of a dimension, reset it and increment
	324	the next dimension. */
	325	scount[n] = 0;
	326	/* We could precalculate these products, but this is a less
5d7adf7a	327	frequently used path so probably not worth it. */
644cb69f FXC	328	src -= sstride[n] * sextent[n];
	329	n++;
	330	if (n == sdim)
	331	{
	332	if (sptr && pad)
	333	{
	334	/* Switch to the pad array. */
	335	sptr = NULL;
	336	sdim = pdim;
	337	for (dim = 0; dim < pdim; dim++)
	338	{
	339	scount[dim] = pcount[dim];
	340	sextent[dim] = pextent[dim];
	341	sstride[dim] = pstride[dim];
	342	sstride0 = sstride[0];
	343	}
	344	}
	345	/* We now start again from the beginning of the pad array. */
	346	src = pptr;
	347	break;
	348	}
	349	else
	350	{
	351	scount[n]++;
	352	src += sstride[n];
	353	}
	354	}
	355	}
	356	}
	357
	358	#endif