Subversion Repositories openrisc

dnl Support macro file for intrinsic functions.

dnl Contains the generic sections of the array functions.

dnl This file is part of the GNU Fortran 95 Runtime Library (libgfortran)

dnl Distributed under the GNU GPL with exception.  See COPYING for details.

define(START_FOREACH_FUNCTION,

`

extern void name`'rtype_qual`_'atype_code (rtype * const restrict retarray,

        atype * const restrict array);

export_proto(name`'rtype_qual`_'atype_code);

void

name`'rtype_qual`_'atype_code (rtype * const restrict retarray,

        atype * const restrict array)

{

  index_type count[GFC_MAX_DIMENSIONS];

  index_type extent[GFC_MAX_DIMENSIONS];

  index_type sstride[GFC_MAX_DIMENSIONS];

  index_type dstride;

  const atype_name *base;

  rtype_name * 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->data == NULL)

    {

      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);

      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;

      retarray->offset = 0;

      retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);

    }

  else

    {

      if (unlikely (compile_options.bounds_check))

        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,

                                "u_name");

    }

  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);

  dest = retarray->data;

  for (n = 0; n < rank; n++)

    {

      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,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->data;

  /* Initialize the return value.  */

  for (n = 0; n < rank; n++)

    dest[n * dstride] = 1;

  {

')dnl

define(START_FOREACH_BLOCK,

`  while (base)

    {

      do

        {

          /* Implementation start.  */

')dnl

define(FINISH_FOREACH_FUNCTION,

`         /* 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]);

    }

  }

}')dnl

define(START_MASKED_FOREACH_FUNCTION,

`

extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,

        atype * const restrict, gfc_array_l1 * const restrict);

export_proto(`m'name`'rtype_qual`_'atype_code);

void

`m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,

        atype * const restrict array,

        gfc_array_l1 * const restrict mask)

{

  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;

  rtype_name *dest;

  const atype_name *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->data == NULL)

    {

      GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);

      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;

      retarray->offset = 0;

      retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);

    }

  else

    {

      if (unlikely (compile_options.bounds_check))

        {

          bounds_iforeach_return ((array_t *) retarray, (array_t *) array,

                                  "u_name");

          bounds_equal_extents ((array_t *) mask, (array_t *) array,

                                  "MASK argument", "u_name");

        }

    }

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  mbase = mask->data;

  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->data;

  for (n = 0; n < rank; n++)

    {

      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);

      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->data;

  /* Initialize the return value.  */

  for (n = 0; n < rank; n++)

    dest[n * dstride] = 0;

  {

')dnl

define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl

define(FINISH_MASKED_FOREACH_FUNCTION,

`         /* 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]);

    }

  }

}')dnl

define(FOREACH_FUNCTION,

`START_FOREACH_FUNCTION

$1

START_FOREACH_BLOCK

$2

FINISH_FOREACH_FUNCTION')dnl

define(MASKED_FOREACH_FUNCTION,

`START_MASKED_FOREACH_FUNCTION

$1

START_MASKED_FOREACH_BLOCK

$2

FINISH_MASKED_FOREACH_FUNCTION')dnl

define(SCALAR_FOREACH_FUNCTION,

`

extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,

        atype * const restrict, GFC_LOGICAL_4 *);

export_proto(`s'name`'rtype_qual`_'atype_code);

void

`s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,

        atype * const restrict array,

        GFC_LOGICAL_4 * mask)

{

  index_type rank;

  index_type dstride;

  index_type n;

  rtype_name *dest;

  if (*mask)

    {

      name`'rtype_qual`_'atype_code (retarray, array);

      return;

    }

  rank = GFC_DESCRIPTOR_RANK (array);

  if (rank <= 0)

    runtime_error ("Rank of array needs to be > 0");

  if (retarray->data == NULL)

    {

      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);

      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;

      retarray->offset = 0;

      retarray->data = internal_malloc_size (sizeof (rtype_name) * rank);

    }

  else if (unlikely (compile_options.bounds_check))

    {

       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,

                               "u_name");

    }

  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);

  dest = retarray->data;

  for (n = 0; n<rank; n++)

    dest[n * dstride] = $1 ;

}')dnl