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

/* Implementation of the RESHAPE
   Copyright 2002, 2006, 2007 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 2 of the License, or (at your option) any later version.

In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file.  (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)

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.

You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING.  If not,
write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */

#include "libgfortran.h"
#include <stdlib.h>
#include <assert.h>


#if defined (HAVE_GFC_REAL_8)

typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type;


extern void reshape_r8 (gfc_array_r8 * const restrict, 
	gfc_array_r8 * const restrict, 
	shape_type * const restrict,
	gfc_array_r8 * const restrict, 
	shape_type * const restrict);
export_proto(reshape_r8);

void
reshape_r8 (gfc_array_r8 * const restrict ret, 
	gfc_array_r8 * const restrict source, 
	shape_type * const restrict shape,
	gfc_array_r8 * 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_REAL_8 *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_REAL_8 *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_REAL_8 *pptr;

  const GFC_REAL_8 *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_REAL_8));
      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_REAL_8);
      ssize *= sizeof (GFC_REAL_8);
      psize *= sizeof (GFC_REAL_8);
      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
ecebfb8b	1	/* Implementation of the RESHAPE
36ae8a61	2	Copyright 2002, 2006, 2007 Free Software Foundation, Inc.
ecebfb8b FXC	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
	10	version 2 of the License, or (at your option) any later version.
	11
	12	In addition to the permissions in the GNU General Public License, the
	13	Free Software Foundation gives you unlimited permission to link the
	14	compiled version of this file into combinations with other programs,
	15	and to distribute those combinations without any restriction coming
	16	from the use of this file. (The General Public License restrictions
	17	do apply in other respects; for example, they cover modification of
	18	the file, and distribution when not linked into a combine
	19	executable.)
	20
	21	Libgfortran is distributed in the hope that it will be useful,
	22	but WITHOUT ANY WARRANTY; without even the implied warranty of
	23	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	24	GNU General Public License for more details.
	25
	26	You should have received a copy of the GNU General Public
	27	License along with libgfortran; see the file COPYING. If not,
	28	write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
	29	Boston, MA 02110-1301, USA. */
	30
36ae8a61	31	#include "libgfortran.h"
ecebfb8b FXC	32	#include <stdlib.h>
ecebfb8b FXC	33	#include <assert.h>
36ae8a61	34
ecebfb8b FXC	35
	36	#if defined (HAVE_GFC_REAL_8)
	37
	38	typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type;
	39
ecebfb8b FXC	40
	41	extern void reshape_r8 (gfc_array_r8 * const restrict,
	42	gfc_array_r8 * const restrict,
	43	shape_type * const restrict,
	44	gfc_array_r8 * const restrict,
	45	shape_type * const restrict);
	46	export_proto(reshape_r8);
	47
	48	void
	49	reshape_r8 (gfc_array_r8 * const restrict ret,
	50	gfc_array_r8 * const restrict source,
	51	shape_type * const restrict shape,
	52	gfc_array_r8 * const restrict pad,
	53	shape_type * const restrict order)
	54	{
	55	/* r.* indicates the return array. */
	56	index_type rcount[GFC_MAX_DIMENSIONS];
	57	index_type rextent[GFC_MAX_DIMENSIONS];
	58	index_type rstride[GFC_MAX_DIMENSIONS];
	59	index_type rstride0;
	60	index_type rdim;
	61	index_type rsize;
	62	index_type rs;
	63	index_type rex;
	64	GFC_REAL_8 *rptr;
	65	/* s.* indicates the source array. */
	66	index_type scount[GFC_MAX_DIMENSIONS];
	67	index_type sextent[GFC_MAX_DIMENSIONS];
	68	index_type sstride[GFC_MAX_DIMENSIONS];
	69	index_type sstride0;
	70	index_type sdim;
	71	index_type ssize;
	72	const GFC_REAL_8 *sptr;
	73	/* p.* indicates the pad array. */
	74	index_type pcount[GFC_MAX_DIMENSIONS];
	75	index_type pextent[GFC_MAX_DIMENSIONS];
	76	index_type pstride[GFC_MAX_DIMENSIONS];
	77	index_type pdim;
	78	index_type psize;
	79	const GFC_REAL_8 *pptr;
	80
	81	const GFC_REAL_8 *src;
	82	int n;
	83	int dim;
8c154b65 TK	84	int sempty, pempty, shape_empty;
	85	index_type shape_data[GFC_MAX_DIMENSIONS];
	86
	87	rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1;
	88	if (rdim != GFC_DESCRIPTOR_RANK(ret))
	89	runtime_error("rank of return array incorrect in RESHAPE intrinsic");
	90
	91	shape_empty = 0;
	92
	93	for (n = 0; n < rdim; n++)
	94	{
	95	shape_data[n] = shape->data[n * shape->dim[0].stride];
	96	if (shape_data[n] <= 0)
	97	{
	98	shape_data[n] = 0;
	99	shape_empty = 1;
	100	}
	101	}
ecebfb8b FXC	102
	103	if (ret->data == NULL)
	104	{
ecebfb8b	105	rs = 1;
47c07d96	106	for (n = 0; n < rdim; n++)
ecebfb8b FXC	107	{
ecebfb8b FXC	108	ret->dim[n].lbound = 0;
8c154b65	109	rex = shape_data[n];
ecebfb8b FXC	110	ret->dim[n].ubound = rex - 1;
	111	ret->dim[n].stride = rs;
	112	rs *= rex;
	113	}
	114	ret->offset = 0;
	115	ret->data = internal_malloc_size ( rs * sizeof (GFC_REAL_8));
	116	ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) \| rdim;
	117	}
8c154b65 TK	118
	119	if (shape_empty)
	120	return;
ecebfb8b	121
bd72cbc8 TK	122	if (pad)
	123	{
	124	pdim = GFC_DESCRIPTOR_RANK (pad);
	125	psize = 1;
	126	pempty = 0;
	127	for (n = 0; n < pdim; n++)
	128	{
	129	pcount[n] = 0;
	130	pstride[n] = pad->dim[n].stride;
	131	pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound;
	132	if (pextent[n] <= 0)
	133	{
	134	pempty = 1;
	135	pextent[n] = 0;
	136	}
	137
	138	if (psize == pstride[n])
	139	psize *= pextent[n];
	140	else
	141	psize = 0;
	142	}
	143	pptr = pad->data;
	144	}
	145	else
	146	{
	147	pdim = 0;
	148	psize = 1;
	149	pempty = 1;
	150	pptr = NULL;
	151	}
	152
fd7f9754 TK	153	if (unlikely (compile_options.bounds_check))
fd7f9754 TK	154	{
21c74256 TK	155	index_type ret_extent, source_extent;
	156
	157	rs = 1;
	158	for (n = 0; n < rdim; n++)
	159	{
	160	rs *= shape_data[n];
	161	ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
	162	if (ret_extent != shape_data[n])
	163	runtime_error("Incorrect extent in return value of RESHAPE"
	164	" intrinsic in dimension %ld: is %ld,"
	165	" should be %ld", (long int) n+1,
	166	(long int) ret_extent, (long int) shape_data[n]);
	167	}
	168
a388c779 TK	169	source_extent = 1;
	170	sdim = GFC_DESCRIPTOR_RANK (source);
	171	for (n = 0; n < sdim; n++)
	172	{
	173	index_type se;
	174	se = source->dim[n].ubound + 1 - source->dim[0].lbound;
	175	source_extent *= se > 0 ? se : 0;
	176	}
21c74256	177
bd72cbc8	178	if (rs > source_extent && (!pad \|\| pempty))
21c74256 TK	179	runtime_error("Incorrect size in SOURCE argument to RESHAPE"
	180	" intrinsic: is %ld, should be %ld",
	181	(long int) source_extent, (long int) rs);
	182
fd7f9754 TK	183	if (order)
	184	{
	185	int seen[GFC_MAX_DIMENSIONS];
	186	index_type v;
	187
	188	for (n = 0; n < rdim; n++)
	189	seen[n] = 0;
	190
	191	for (n = 0; n < rdim; n++)
	192	{
	193	v = order->data[n * order->dim[0].stride] - 1;
	194
	195	if (v < 0 \|\| v >= rdim)
	196	runtime_error("Value %ld out of range in ORDER argument"
	197	" to RESHAPE intrinsic", (long int) v + 1);
	198
	199	if (seen[v] != 0)
	200	runtime_error("Duplicate value %ld in ORDER argument to"
	201	" RESHAPE intrinsic", (long int) v + 1);
	202
	203	seen[v] = 1;
	204	}
	205	}
	206	}
	207
ecebfb8b FXC	208	rsize = 1;
	209	for (n = 0; n < rdim; n++)
	210	{
	211	if (order)
	212	dim = order->data[n * order->dim[0].stride] - 1;
	213	else
	214	dim = n;
	215
	216	rcount[n] = 0;
	217	rstride[n] = ret->dim[dim].stride;
	218	rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound;
8c154b65	219	if (rextent[n] < 0)
e94471ba	220	rextent[n] = 0;
ecebfb8b	221
8c154b65	222	if (rextent[n] != shape_data[dim])
ecebfb8b FXC	223	runtime_error ("shape and target do not conform");
	224
	225	if (rsize == rstride[n])
	226	rsize *= rextent[n];
	227	else
	228	rsize = 0;
	229	if (rextent[n] <= 0)
	230	return;
	231	}
	232
	233	sdim = GFC_DESCRIPTOR_RANK (source);
	234	ssize = 1;
47c07d96	235	sempty = 0;
ecebfb8b FXC	236	for (n = 0; n < sdim; n++)
	237	{
	238	scount[n] = 0;
	239	sstride[n] = source->dim[n].stride;
	240	sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
	241	if (sextent[n] <= 0)
47c07d96 FXC	242	{
	243	sempty = 1;
	244	sextent[n] = 0;
	245	}
ecebfb8b FXC	246
	247	if (ssize == sstride[n])
	248	ssize *= sextent[n];
	249	else
	250	ssize = 0;
	251	}
	252
ecebfb8b FXC	253	if (rsize != 0 && ssize != 0 && psize != 0)
	254	{
	255	rsize *= sizeof (GFC_REAL_8);
	256	ssize *= sizeof (GFC_REAL_8);
	257	psize *= sizeof (GFC_REAL_8);
	258	reshape_packed ((char )ret->data, rsize, (char )source->data,
	259	ssize, pad ? (char *)pad->data : NULL, psize);
	260	return;
	261	}
	262	rptr = ret->data;
	263	src = sptr = source->data;
	264	rstride0 = rstride[0];
	265	sstride0 = sstride[0];
	266
47c07d96 FXC	267	if (sempty && pempty)
	268	abort ();
	269
	270	if (sempty)
	271	{
042fed79	272	/* Pretend we are using the pad array the first time around, too. */
47c07d96	273	src = pptr;
042fed79	274	sptr = pptr;
47c07d96 FXC	275	sdim = pdim;
	276	for (dim = 0; dim < pdim; dim++)
	277	{
	278	scount[dim] = pcount[dim];
	279	sextent[dim] = pextent[dim];
	280	sstride[dim] = pstride[dim];
042fed79	281	sstride0 = pstride[0];
47c07d96 FXC	282	}
	283	}
	284
ecebfb8b FXC	285	while (rptr)
	286	{
	287	/* Select between the source and pad arrays. */
	288	rptr = src;
	289	/* Advance to the next element. */
	290	rptr += rstride0;
	291	src += sstride0;
	292	rcount[0]++;
	293	scount[0]++;
47c07d96	294
ecebfb8b FXC	295	/* Advance to the next destination element. */
	296	n = 0;
	297	while (rcount[n] == rextent[n])
	298	{
	299	/* When we get to the end of a dimension, reset it and increment
	300	the next dimension. */
	301	rcount[n] = 0;
	302	/* We could precalculate these products, but this is a less
5d7adf7a	303	frequently used path so probably not worth it. */
ecebfb8b FXC	304	rptr -= rstride[n] * rextent[n];
	305	n++;
	306	if (n == rdim)
	307	{
	308	/* Break out of the loop. */
	309	rptr = NULL;
	310	break;
	311	}
	312	else
	313	{
	314	rcount[n]++;
	315	rptr += rstride[n];
	316	}
	317	}
	318	/* Advance to the next source element. */
	319	n = 0;
	320	while (scount[n] == sextent[n])
	321	{
	322	/* When we get to the end of a dimension, reset it and increment
	323	the next dimension. */
	324	scount[n] = 0;
	325	/* We could precalculate these products, but this is a less
5d7adf7a	326	frequently used path so probably not worth it. */
ecebfb8b FXC	327	src -= sstride[n] * sextent[n];
	328	n++;
	329	if (n == sdim)
	330	{
	331	if (sptr && pad)
	332	{
	333	/* Switch to the pad array. */
	334	sptr = NULL;
	335	sdim = pdim;
	336	for (dim = 0; dim < pdim; dim++)
	337	{
	338	scount[dim] = pcount[dim];
	339	sextent[dim] = pextent[dim];
	340	sstride[dim] = pstride[dim];
	341	sstride0 = sstride[0];
	342	}
	343	}
	344	/* We now start again from the beginning of the pad array. */
	345	src = pptr;
	346	break;
	347	}
	348	else
	349	{
	350	scount[n]++;
	351	src += sstride[n];
	352	}
	353	}
	354	}
	355	}
	356
	357	#endif