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

/* Implementation of the RESHAPE intrinsic
   Copyright (C) 2002-2016 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"
#include <stdlib.h>
#include <assert.h>


#if defined (HAVE_GFC_COMPLEX_10)

typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type;


extern void reshape_c10 (gfc_array_c10 * const restrict, 
	gfc_array_c10 * const restrict, 
	shape_type * const restrict,
	gfc_array_c10 * const restrict, 
	shape_type * const restrict);
export_proto(reshape_c10);

void
reshape_c10 (gfc_array_c10 * const restrict ret, 
	gfc_array_c10 * const restrict source, 
	shape_type * const restrict shape,
	gfc_array_c10 * 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_10 *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_10 *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_10 *pptr;

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