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

/* Implementation of the RESHAPE
   Copyright 2002, 2006, 2007, 2009 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>

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 <stdlib.h>
#include <assert.h>


#if defined (HAVE_GFC_COMPLEX_4)

typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type;


extern void reshape_c4 (gfc_array_c4 * const restrict, 
	gfc_array_c4 * const restrict, 
	shape_type * const restrict,
	gfc_array_c4 * const restrict, 
	shape_type * const restrict);
export_proto(reshape_c4);

void
reshape_c4 (gfc_array_c4 * const restrict ret, 
	gfc_array_c4 * const restrict source, 
	shape_type * const restrict shape,
	gfc_array_c4 * 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_4 *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_4 *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_4 *pptr;

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

  rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
  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->data[n * shape->dim[0].stride];
      if (shape_data[n] <= 0)
      {
        shape_data[n] = 0;
	shape_empty = 1;
      }
    }

  if (ret->data == NULL)
    {
      rs = 1;
      for (n = 0; n < rdim; n++)
	{
	  ret->dim[n].lbound = 0;
	  rex = shape_data[n];
	  ret->dim[n].ubound =  rex - 1;
	  ret->dim[n].stride = rs;
	  rs *= rex;
	}
      ret->offset = 0;
      ret->data = internal_malloc_size ( rs * sizeof (GFC_COMPLEX_4));
      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] = pad->dim[n].stride;
          pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound;
          if (pextent[n] <= 0)
	    {
	      pempty = 1;
	      pextent[n] = 0;
	    }

          if (psize == pstride[n])
            psize *= pextent[n];
          else
            psize = 0;
        }
      pptr = pad->data;
    }
  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 = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
	  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 = source->dim[n].ubound + 1 - source->dim[0].lbound;
	  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->data[n * order->dim[0].stride] - 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->data[n * order->dim[0].stride] - 1;
      else
        dim = n;

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