Beispiel #1
0
void
ISO_C_BINDING_PREFIX (c_f_pointer_u0) (void *c_ptr_in,
                                       gfc_array_void *f_ptr_out,
                                       const array_t *shape)
{
  int i = 0;
  int shapeSize = 0;

  GFC_DESCRIPTOR_DATA (f_ptr_out) = c_ptr_in;

  if (shape != NULL)
    {
      f_ptr_out->offset = 0;
      shapeSize = 0;
      
      /* shape's length (rank of the output array) */
      shapeSize = shape->dim[0].ubound + 1 - shape->dim[0].lbound;
      for (i = 0; i < shapeSize; i++)
        {
          /* Lower bound is 1, as specified by the draft.  */
          f_ptr_out->dim[i].lbound = 1;
          /* Have to allow for the SHAPE array to be any valid kind for
             an INTEGER type.  */
#ifdef HAVE_GFC_INTEGER_1
	  if (GFC_DESCRIPTOR_SIZE (shape) == 1)
	    f_ptr_out->dim[i].ubound = ((GFC_INTEGER_1 *) (shape->data))[i];
#endif
#ifdef HAVE_GFC_INTEGER_2
	  if (GFC_DESCRIPTOR_SIZE (shape) == 2)
	    f_ptr_out->dim[i].ubound = ((GFC_INTEGER_2 *) (shape->data))[i];
#endif
#ifdef HAVE_GFC_INTEGER_4
	  if (GFC_DESCRIPTOR_SIZE (shape) == 4)
	    f_ptr_out->dim[i].ubound = ((GFC_INTEGER_4 *) (shape->data))[i];
#endif
#ifdef HAVE_GFC_INTEGER_8
	  if (GFC_DESCRIPTOR_SIZE (shape) == 8)
	    f_ptr_out->dim[i].ubound = ((GFC_INTEGER_8 *) (shape->data))[i];
#endif
#ifdef HAVE_GFC_INTEGER_16
	  if (GFC_DESCRIPTOR_SIZE (shape) == 16)
	    f_ptr_out->dim[i].ubound = ((GFC_INTEGER_16 *) (shape->data))[i];
#endif		
        }

      /* Set the offset and strides.
         offset is (sum of (dim[i].lbound * dim[i].stride) for all
         dims) the -1 means we'll back the data pointer up that much
         perhaps we could just realign the data pointer and not change
         the offset?  */
      f_ptr_out->dim[0].stride = 1;
      f_ptr_out->offset = f_ptr_out->dim[0].lbound * f_ptr_out->dim[0].stride;
      for (i = 1; i < shapeSize; i++)
        {
          f_ptr_out->dim[i].stride = (f_ptr_out->dim[i-1].ubound + 1)
            - f_ptr_out->dim[i-1].lbound;
          f_ptr_out->offset += f_ptr_out->dim[i].lbound
            * f_ptr_out->dim[i].stride;
        }

      f_ptr_out->offset *= -1;

      /* All we know is the rank, so set it, leaving the rest alone.
         Make NO assumptions about the state of dtype coming in!  If we
         shift right by TYPE_SHIFT bits we'll throw away the existing
         rank.  Then, shift left by the same number to shift in zeros
         and or with the new rank.  */
      f_ptr_out->dtype = ((f_ptr_out->dtype >> GFC_DTYPE_TYPE_SHIFT)
                           << GFC_DTYPE_TYPE_SHIFT) | shapeSize;
    }
  index_type len;
  index_type n;
  index_type size;
  index_type arraysize;
  int which;
  GFC_INTEGER_8 sh;
  GFC_INTEGER_8 delta;

  /* The compiler cannot figure out that these are set, initialize
     them to avoid warnings.  */
  len = 0;
  soffset = 0;
  roffset = 0;

  arraysize = size0 ((array_t *) array);
  size = GFC_DESCRIPTOR_SIZE(array);

  if (pwhich)
    which = *pwhich - 1;
  else
    which = 0;

  if (ret->data == NULL)
    {
      int i;

      ret->offset = 0;
      ret->dtype = array->dtype;
      for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
        {
	  index_type ub, str;
Beispiel #3
0
  index_type dstride[GFC_MAX_DIMENSIONS];
  const GFC_LOGICAL_1 * restrict base;
  GFC_LOGICAL_8 * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;
  int src_kind;
  int continue_loop;

  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  src_kind = GFC_DESCRIPTOR_SIZE (array);

  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len < 0)
    len = 0;

  delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

      if (extent[n] < 0)
	extent[n] = 0;
    }
Beispiel #4
0
void
pack_s (gfc_array_char *ret, const gfc_array_char *array,
	const GFC_LOGICAL_4 *mask, const gfc_array_char *vector)
{
  pack_s_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array));
}
void
mminloc0_16_i16 (gfc_array_i16 * retarray, gfc_array_i16 *array,
				  gfc_array_l4 * 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;
  GFC_INTEGER_16 *dest;
  GFC_INTEGER_16 *base;
  GFC_LOGICAL_4 *mbase;
  int 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)
    {
      retarray->dim[0].lbound = 0;
      retarray->dim[0].ubound = rank-1;
      retarray->dim[0].stride = 1;
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
      retarray->offset = 0;
      retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank);
    }
  else
    {
      if (GFC_DESCRIPTOR_RANK (retarray) != 1)
	runtime_error ("rank of return array does not equal 1");

      if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
        runtime_error ("dimension of return array incorrect");

      if (retarray->dim[0].stride == 0)
	retarray->dim[0].stride = 1;
    }

  /* TODO:  It should be a front end job to correctly set the strides.  */

  if (array->dim[0].stride == 0)
    array->dim[0].stride = 1;

  if (mask->dim[0].stride == 0)
    mask->dim[0].stride = 1;

  dstride = retarray->dim[0].stride;
  dest = retarray->data;
  for (n = 0; n < rank; n++)
    {
      sstride[n] = array->dim[n].stride;
      mstride[n] = mask->dim[n].stride;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
      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;
  mbase = mask->data;

  if (GFC_DESCRIPTOR_SIZE (mask) != 4)
    {
      /* This allows the same loop to be used for all logical types.  */
      assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
      for (n = 0; n < rank; n++)
        mstride[n] <<= 1;
      mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
    }


  /* Initialize the return value.  */
  for (n = 0; n < rank; n++)
    dest[n * dstride] = 0;
  {

  GFC_INTEGER_16 minval;

  minval = GFC_INTEGER_16_HUGE;

  while (base)
    {
      {
        /* Implementation start.  */

  if (*mbase && (*base < minval || !dest[0]))
    {
      minval = *base;
      for (n = 0; n < rank; n++)
        dest[n * dstride] = count[n] + 1;
    }
        /* Implementation end.  */
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      mbase += mstride[0];
      n = 0;
      while (count[n] == extent[n])
        {
          /* 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 proabably 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];
            }
        }
    }
  }
}
Beispiel #6
0
static void
spread_internal (gfc_array_char *ret, const gfc_array_char *source,
		 const index_type *along, const index_type *pncopies)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type rdelta = 0;
  index_type rrank;
  index_type rs;
  char *rptr;
  char *dest;
  /* s.* indicates the source array.  */
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type sstride0;
  index_type srank;
  const char *sptr;

  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type n;
  index_type dim;
  index_type ncopies;
  index_type size;

  size = GFC_DESCRIPTOR_SIZE(source);

  srank = GFC_DESCRIPTOR_RANK(source);

  rrank = srank + 1;
  if (rrank > GFC_MAX_DIMENSIONS)
    runtime_error ("return rank too large in spread()");

  if (*along > rrank)
      runtime_error ("dim outside of rank in spread()");

  ncopies = *pncopies;

  if (ret->base_addr == NULL)
    {
      /* The front end has signalled that we need to populate the
	 return array descriptor.  */

      size_t ub, stride;

      ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
      dim = 0;
      rs = 1;
      for (n = 0; n < rrank; n++)
	{
	  stride = rs;
	  if (n == *along - 1)
	    {
	      ub = ncopies - 1;
	      rdelta = rs * size;
	      rs *= ncopies;
	    }
	  else
	    {
	      count[dim] = 0;
	      extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
	      sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
	      rstride[dim] = rs * size;

	      ub = extent[dim]-1;
	      rs *= extent[dim];
	      dim++;
	    }

	  GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
	}
      ret->offset = 0;
      ret->base_addr = xmalloc (rs * size);

      if (rs <= 0)
	return;
    }
  else
    {
      int zero_sized;

      zero_sized = 0;

      dim = 0;
      if (GFC_DESCRIPTOR_RANK(ret) != rrank)
	runtime_error ("rank mismatch in spread()");

      if (compile_options.bounds_check)
	{
	  for (n = 0; n < rrank; n++)
	    {
	      index_type ret_extent;

	      ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
	      if (n == *along - 1)
		{
		  rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);

		  if (ret_extent != ncopies)
		    runtime_error("Incorrect extent in return value of SPREAD"
				  " intrinsic in dimension %ld: is %ld,"
				  " should be %ld", (long int) n+1,
				  (long int) ret_extent, (long int) ncopies);
		}
	      else
		{
		  count[dim] = 0;
		  extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
		  if (ret_extent != extent[dim])
		    runtime_error("Incorrect extent in return value of SPREAD"
				  " intrinsic in dimension %ld: is %ld,"
				  " should be %ld", (long int) n+1,
				  (long int) ret_extent,
				  (long int) extent[dim]);
		    
		  if (extent[dim] <= 0)
		    zero_sized = 1;
		  sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
		  rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
		  dim++;
		}
	    }
	}
      else
	{
	  for (n = 0; n < rrank; n++)
	    {
	      if (n == *along - 1)
		{
		  rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
		}
	      else
		{
		  count[dim] = 0;
		  extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
		  if (extent[dim] <= 0)
		    zero_sized = 1;
		  sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
		  rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
		  dim++;
		}
	    }
	}

      if (zero_sized)
	return;

      if (sstride[0] == 0)
	sstride[0] = size;
    }
  sstride0 = sstride[0];
  rstride0 = rstride[0];
  rptr = ret->base_addr;
  sptr = source->base_addr;

  while (sptr)
    {
      /* Spread this element.  */
      dest = rptr;
      for (n = 0; n < ncopies; n++)
        {
          memcpy (dest, sptr, size);
          dest += rdelta;
        }
      /* Advance to the next element.  */
      sptr += sstride0;
      rptr += rstride0;
      count[0]++;
      n = 0;
      while (count[n] == extent[n])
        {
          /* 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.  */
          sptr -= sstride[n] * extent[n];
          rptr -= rstride[n] * extent[n];
          n++;
          if (n >= srank)
            {
              /* Break out of the loop.  */
              sptr = NULL;
              break;
            }
          else
            {
              count[n]++;
              sptr += sstride[n];
              rptr += rstride[n];
            }
        }
    }
}
void
internal_unpack (gfc_array_char * d, const void * s)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type stride[GFC_MAX_DIMENSIONS];
  index_type stride0;
  index_type dim;
  index_type dsize;
  char *dest;
  const char *src;
  int n;
  int size;

  dest = d->data;
  /* This check may be redundant, but do it anyway.  */
  if (s == dest || !s)
    return;

  size = GFC_DESCRIPTOR_SIZE (d);
  switch (size)
    {
    case 4:
      internal_unpack_4 ((gfc_array_i4 *)d, (const GFC_INTEGER_4 *)s);
      return;

    case 8:
      internal_unpack_8 ((gfc_array_i8 *)d, (const GFC_INTEGER_8 *)s);
      return;
    }

  if (d->dim[0].stride == 0)
    d->dim[0].stride = 1;

  dim = GFC_DESCRIPTOR_RANK (d);
  dsize = 1;
  for (n = 0; n < dim; n++)
    {
      count[n] = 0;
      stride[n] = d->dim[n].stride;
      extent[n] = d->dim[n].ubound + 1 - d->dim[n].lbound;
      if (extent[n] <= 0)
        abort ();

      if (dsize == stride[n])
        dsize *= extent[n];
      else
        dsize = 0;
    }

  src = s;

  if (dsize != 0)
    {
      memcpy (dest, src, dsize * size);
      return;
    }

  stride0 = stride[0] * size;

  while (dest)
    {
      /* Copy the data.  */
      memcpy (dest, src, size);
      /* Advance to the next element.  */
      src += size;
      dest += stride0;
      count[0]++;
      /* Advance to the next source element.  */
      n = 0;
      while (count[n] == extent[n])
        {
          /* 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 proabably not worth it.  */
          dest -= stride[n] * extent[n] * size;
          n++;
          if (n == dim)
            {
              dest = NULL;
              break;
            }
          else
            {
              count[n]++;
              dest += stride[n] * size;
            }
        }
    }
}
Beispiel #8
0
void
unpack0 (gfc_array_char *ret, const gfc_array_char *vector,
	 const gfc_array_l1 *mask, char *field)
{
  gfc_array_char tmp;

  index_type type_size;

  if (unlikely(compile_options.bounds_check))
    unpack_bounds (ret, vector, mask, NULL);

  type_size = GFC_DTYPE_TYPE_SIZE (vector);

  switch (type_size)
    {
    case GFC_DTYPE_LOGICAL_1:
    case GFC_DTYPE_INTEGER_1:
    case GFC_DTYPE_DERIVED_1:
      unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
		  mask, (GFC_INTEGER_1 *) field);
      return;

    case GFC_DTYPE_LOGICAL_2:
    case GFC_DTYPE_INTEGER_2:
      unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
		  mask, (GFC_INTEGER_2 *) field);
      return;

    case GFC_DTYPE_LOGICAL_4:
    case GFC_DTYPE_INTEGER_4:
      unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
		  mask, (GFC_INTEGER_4 *) field);
      return;

    case GFC_DTYPE_LOGICAL_8:
    case GFC_DTYPE_INTEGER_8:
      unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
		  mask, (GFC_INTEGER_8 *) field);
      return;

#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_LOGICAL_16:
    case GFC_DTYPE_INTEGER_16:
      unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
		   mask, (GFC_INTEGER_16 *) field);
      return;
#endif

    case GFC_DTYPE_REAL_4:
      unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
		  mask, (GFC_REAL_4 *) field);
      return;

    case GFC_DTYPE_REAL_8:
      unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector,
		  mask, (GFC_REAL_8  *) field);
      return;

/* FIXME: This here is a hack, which will have to be removed when
   the array descriptor is reworked.  Currently, we don't store the
   kind value for the type, but only the size.  Because on targets with
   __float128, we have sizeof(logn double) == sizeof(__float128),
   we cannot discriminate here and have to fall back to the generic
   handling (which is suboptimal).  */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_REAL_10
    case GFC_DTYPE_REAL_10:
      unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
		   mask, (GFC_REAL_10 *) field);
      return;
# endif

# ifdef HAVE_GFC_REAL_16
    case GFC_DTYPE_REAL_16:
      unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
		   mask, (GFC_REAL_16 *) field);
      return;
# endif
#endif

    case GFC_DTYPE_COMPLEX_4:
      unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
		  mask, (GFC_COMPLEX_4 *) field);
      return;

    case GFC_DTYPE_COMPLEX_8:
      unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
		  mask, (GFC_COMPLEX_8 *) field);
      return;

/* FIXME: This here is a hack, which will have to be removed when
   the array descriptor is reworked.  Currently, we don't store the
   kind value for the type, but only the size.  Because on targets with
   __float128, we have sizeof(logn double) == sizeof(__float128),
   we cannot discriminate here and have to fall back to the generic
   handling (which is suboptimal).  */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_COMPLEX_10
    case GFC_DTYPE_COMPLEX_10:
      unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
		   mask, (GFC_COMPLEX_10 *) field);
      return;
# endif

# ifdef HAVE_GFC_COMPLEX_16
    case GFC_DTYPE_COMPLEX_16:
      unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
		   mask, (GFC_COMPLEX_16 *) field);
      return;
# endif
#endif

    case GFC_DTYPE_DERIVED_2:
      if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(vector->base_addr)
	  || GFC_UNALIGNED_2(field))
	break;
      else
	{
	  unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
		      mask, (GFC_INTEGER_2 *) field);
	  return;
	}

    case GFC_DTYPE_DERIVED_4:
      if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(vector->base_addr)
	  || GFC_UNALIGNED_4(field))
	break;
      else
	{
	  unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
		      mask, (GFC_INTEGER_4 *) field);
	  return;
	}

    case GFC_DTYPE_DERIVED_8:
      if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(vector->base_addr)
	  || GFC_UNALIGNED_8(field))
	break;
      else
	{
	  unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
		      mask, (GFC_INTEGER_8 *) field);
	  return;
	}

#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_DERIVED_16:
      if (GFC_UNALIGNED_16(ret->base_addr)
	  || GFC_UNALIGNED_16(vector->base_addr)
	  || GFC_UNALIGNED_16(field))
	break;
      else
	{
	  unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
		       mask, (GFC_INTEGER_16 *) field);
	  return;
	}
#endif

    }

  memset (&tmp, 0, sizeof (tmp));
  tmp.dtype = 0;
  tmp.base_addr = field;
  unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector));
}
Beispiel #9
0
void
date_and_time (char *__date,
	       char *__time,
	       char *__zone,
	       gfc_array_i4 *__values,
	       GFC_INTEGER_4 __date_len,
	       GFC_INTEGER_4 __time_len,
	       GFC_INTEGER_4 __zone_len)
{
#define DATE_LEN 8
#define TIME_LEN 10   
#define ZONE_LEN 5
#define VALUES_SIZE 8
  char date[DATE_LEN + 1];
  char timec[TIME_LEN + 1];
  char zone[ZONE_LEN + 1];
  GFC_INTEGER_4 values[VALUES_SIZE];

#ifndef HAVE_NO_DATE_TIME
  time_t lt = time (NULL);
  struct tm local_time = *localtime (&lt);
  struct tm UTC_time = *gmtime (&lt);

  /* All arguments can be derived from VALUES.  */
  values[0] = 1900 + local_time.tm_year;
  values[1] = 1 + local_time.tm_mon;
  values[2] = local_time.tm_mday;
  values[3] = (local_time.tm_min - UTC_time.tm_min +
	       60 * (local_time.tm_hour - UTC_time.tm_hour +
		     24 * (local_time.tm_yday - UTC_time.tm_yday)));
  values[4] = local_time.tm_hour;
  values[5] = local_time.tm_min;
  values[6] = local_time.tm_sec;
#if HAVE_GETTIMEOFDAY
    {
      struct timeval tp;
#  if GETTIMEOFDAY_ONE_ARGUMENT
      if (!gettimeofday (&tp))
#  else
#    if HAVE_STRUCT_TIMEZONE
      struct timezone tzp;

      /* Some systems such as HP-UX, do have struct timezone, but
	 gettimeofday takes void* as the 2nd arg.  However, the
	 effect of passing anything other than a null pointer is
	 unspecified on HPUX.  Configure checks if gettimeofday
	 actually fails with a non-NULL arg and pretends that
	 struct timezone is missing if it does fail.  */
      if (!gettimeofday (&tp, &tzp))
#    else
      if (!gettimeofday (&tp, (void *) 0))
#    endif /* HAVE_STRUCT_TIMEZONE  */
#  endif /* GETTIMEOFDAY_ONE_ARGUMENT  */
	values[7] = tp.tv_usec / 1000;
    }
#else
   values[7] = GFC_INTEGER_4_HUGE;
#endif /* HAVE_GETTIMEOFDAY */

  if (__date)
    {
      snprintf (date, DATE_LEN + 1, "%04d%02d%02d",
		values[0], values[1], values[2]);
    }

  if (__time)
    {
      snprintf (timec, TIME_LEN + 1, "%02d%02d%02d.%03d",
		values[4], values[5], values[6], values[7]);
    }

  if (__zone)
    {
      snprintf (zone, ZONE_LEN + 1, "%+03d%02d",
		values[3] / 60, abs (values[3] % 60));
    }
#else /* if defined HAVE_NO_DATE_TIME  */
  /* We really have *nothing* to return, so return blanks and HUGE(0).  */
    {
      int i;

      memset (date, ' ', DATE_LEN);
      date[DATE_LEN] = '\0';

      memset (timec, ' ', TIME_LEN);
      time[TIME_LEN] = '\0';

      memset (zone, ' ', ZONE_LEN);
      zone[ZONE_LEN] = '\0';

      for (i = 0; i < VALUES_SIZE; i++)
        values[i] = GFC_INTEGER_4_HUGE;
    }
#endif  /* HAVE_NO_DATE_TIME  */

  /* Copy the values into the arguments.  */
  if (__values)
    {
      int i;
      size_t len, delta, elt_size;

      elt_size = GFC_DESCRIPTOR_SIZE (__values);
      len = __values->dim[0].ubound + 1 - __values->dim[0].lbound;
      delta = __values->dim[0].stride;
      if (delta == 0)
	delta = 1;

      assert (len >= VALUES_SIZE);
      /* Cope with different type kinds.  */
      if (elt_size == 4)
        {
	  GFC_INTEGER_4 *vptr4 = __values->data;

	  for (i = 0; i < VALUES_SIZE; i++, vptr4 += delta)
	    {
	      *vptr4 = values[i];
	    }
	}
      else if (elt_size == 8)
        {
	  GFC_INTEGER_8 *vptr8 = (GFC_INTEGER_8 *)__values->data;

	  for (i = 0; i < VALUES_SIZE; i++, vptr8 += delta)
	    {
	      if (values[i] == GFC_INTEGER_4_HUGE)
		*vptr8 = GFC_INTEGER_8_HUGE;
	      else
		*vptr8 = values[i];
	    }
	}
      else 
	abort ();
    }

  if (__zone)
    {
      assert (__zone_len >= ZONE_LEN);
      fstrcpy (__zone, ZONE_LEN, zone, ZONE_LEN);
    }

  if (__time)
    {
      assert (__time_len >= TIME_LEN);
      fstrcpy (__time, TIME_LEN, timec, TIME_LEN);
    }

  if (__date)
    {
      assert (__date_len >= DATE_LEN);
      fstrcpy (__date, DATE_LEN, date, DATE_LEN);
    }
#undef DATE_LEN
#undef TIME_LEN   
#undef ZONE_LEN
#undef VALUES_SIZE
}
void
unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
	 const gfc_array_l4 *mask, const gfc_array_char *field)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type rs;
  char *rptr;
  /* v.* indicates the vector array.  */
  index_type vstride0;
  char *vptr;
  /* f.* indicates the field array.  */
  index_type fstride[GFC_MAX_DIMENSIONS];
  index_type fstride0;
  const char *fptr;
  /* m.* indicates the mask array.  */
  index_type mstride[GFC_MAX_DIMENSIONS];
  index_type mstride0;
  const GFC_LOGICAL_4 *mptr;

  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type n;
  index_type dim;
  index_type size;
  index_type fsize;

  size = GFC_DESCRIPTOR_SIZE (ret);
  /* A field element size of 0 actually means this is a scalar.  */
  fsize = GFC_DESCRIPTOR_SIZE (field);
  if (ret->data == NULL)
    {
      /* The front end has signalled that we need to populate the
	 return array descriptor.  */
      dim = GFC_DESCRIPTOR_RANK (mask);
      rs = 1;
      for (n = 0; n < dim; n++)
	{
	  count[n] = 0;
	  ret->dim[n].stride = rs;
	  ret->dim[n].lbound = 0;
	  ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
	  extent[n] = ret->dim[n].ubound + 1;
	  rstride[n] = ret->dim[n].stride * size;
	  fstride[n] = field->dim[n].stride * fsize;
	  mstride[n] = mask->dim[n].stride;
	  rs *= extent[n];
	}
      ret->base = 0;
      ret->data = internal_malloc_size (rs * size);
    }
  else
    {
      dim = GFC_DESCRIPTOR_RANK (ret);
      for (n = 0; n < dim; n++)
	{
	  count[n] = 0;
	  extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
	  rstride[n] = ret->dim[n].stride * size;
	  fstride[n] = field->dim[n].stride * fsize;
	  mstride[n] = mask->dim[n].stride;
	}
      if (rstride[0] == 0)
	rstride[0] = size;
    }
  if (fstride[0] == 0)
    fstride[0] = fsize;
  if (mstride[0] == 0)
    mstride[0] = 1;

  vstride0 = vector->dim[0].stride * size;
  if (vstride0 == 0)
    vstride0 = size;
  rstride0 = rstride[0];
  fstride0 = fstride[0];
  mstride0 = mstride[0];
  rptr = ret->data;
  fptr = field->data;
  mptr = mask->data;
  vptr = vector->data;

  /* Use the same loop for both logical types. */
  if (GFC_DESCRIPTOR_SIZE (mask) != 4)
    {
      if (GFC_DESCRIPTOR_SIZE (mask) != 8)
        runtime_error ("Funny sized logical array");
      for (n = 0; n < dim; n++)
        mstride[n] <<= 1;
      mstride0 <<= 1;
      mptr = GFOR_POINTER_L8_TO_L4 (mptr);
    }

  while (rptr)
    {
      if (*mptr)
        {
          /* From vector.  */
          memcpy (rptr, vptr, size);
          vptr += vstride0;
        }
      else
        {
          /* From field.  */
          memcpy (rptr, fptr, size);
        }
      /* Advance to the next element.  */
      rptr += rstride0;
      fptr += fstride0;
      mptr += mstride0;
      count[0]++;
      n = 0;
      while (count[n] == extent[n])
        {
          /* 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 proabably not worth it.  */
          rptr -= rstride[n] * extent[n];
          fptr -= fstride[n] * extent[n];
          mptr -= mstride[n] * extent[n];
          n++;
          if (n >= dim)
            {
              /* Break out of the loop.  */
              rptr = NULL;
              break;
            }
          else
            {
              count[n]++;
              rptr += rstride[n];
              fptr += fstride[n];
              mptr += mstride[n];
            }
        }
    }
}
Beispiel #11
0
void *
internal_pack (gfc_array_char * source)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type stride[GFC_MAX_DIMENSIONS];
  index_type stride0;
  index_type dim;
  index_type ssize;
  const char *src;
  char *dest;
  void *destptr;
  int n;
  int packed;
  index_type size;
  int type;

  if (source->dim[0].stride == 0)
    {
      source->dim[0].stride = 1;
      return source->data;
    }

  type = GFC_DESCRIPTOR_TYPE (source);
  size = GFC_DESCRIPTOR_SIZE (source);
  switch (type)
    {
    case GFC_DTYPE_INTEGER:
    case GFC_DTYPE_LOGICAL:
    case GFC_DTYPE_REAL:
      switch (size)
	{
	case 4:
	  return internal_pack_4 ((gfc_array_i4 *)source);
	  
	case 8:
	  return internal_pack_8 ((gfc_array_i8 *)source);
	}
      break;

    case GFC_DTYPE_COMPLEX:
      switch (size)
	{
	case 8:
	  return internal_pack_c4 ((gfc_array_c4 *)source);
	  
	case 16:
	  return internal_pack_c8 ((gfc_array_c8 *)source);
	}
      break;

    default:
      break;
    }

  dim = GFC_DESCRIPTOR_RANK (source);
  ssize = 1;
  packed = 1;
  for (n = 0; n < dim; n++)
    {
      count[n] = 0;
      stride[n] = source->dim[n].stride;
      extent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
      if (extent[n] <= 0)
        {
          /* Do nothing.  */
          packed = 1;
          break;
        }

      if (ssize != stride[n])
        packed = 0;

      ssize *= extent[n];
    }

  if (packed)
    return source->data;

   /* Allocate storage for the destination.  */
  destptr = internal_malloc_size (ssize * size);
  dest = (char *)destptr;
  src = source->data;
  stride0 = stride[0] * size;

  while (src)
    {
      /* Copy the data.  */
      memcpy(dest, src, size);
      /* Advance to the next element.  */
      dest += size;
      src += stride0;
      count[0]++;
      /* Advance to the next source element.  */
      n = 0;
      while (count[n] == extent[n])
        {
          /* 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 proabably not worth it.  */
          src -= stride[n] * extent[n] * size;
          n++;
          if (n == dim)
            {
              src = NULL;
              break;
            }
          else
            {
              count[n]++;
              src += stride[n] * size;
            }
        }
    }
  return destptr;
}
Beispiel #12
0
void
internal_unpack (gfc_array_char * d, const void * s)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type stride[GFC_MAX_DIMENSIONS];
  index_type stride0;
  index_type dim;
  index_type dsize;
  char *dest;
  const char *src;
  int n;
  int size;
  int type_size;

  dest = d->base_addr;
  /* This check may be redundant, but do it anyway.  */
  if (s == dest || !s)
    return;

  type_size = GFC_DTYPE_TYPE_SIZE (d);
  switch (type_size)
    {
    case GFC_DTYPE_INTEGER_1:
    case GFC_DTYPE_LOGICAL_1:
    case GFC_DTYPE_DERIVED_1:
      internal_unpack_1 ((gfc_array_i1 *) d, (const GFC_INTEGER_1 *) s);
      return;

    case GFC_DTYPE_INTEGER_2:
    case GFC_DTYPE_LOGICAL_2:
      internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s);
      return;

    case GFC_DTYPE_INTEGER_4:
    case GFC_DTYPE_LOGICAL_4:
      internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s);
      return;

    case GFC_DTYPE_INTEGER_8:
    case GFC_DTYPE_LOGICAL_8:
      internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s);
      return;

#if defined (HAVE_GFC_INTEGER_16)
    case GFC_DTYPE_INTEGER_16:
    case GFC_DTYPE_LOGICAL_16:
      internal_unpack_16 ((gfc_array_i16 *) d, (const GFC_INTEGER_16 *) s);
      return;
#endif

    case GFC_DTYPE_REAL_4:
      internal_unpack_r4 ((gfc_array_r4 *) d, (const GFC_REAL_4 *) s);
      return;

    case GFC_DTYPE_REAL_8:
      internal_unpack_r8 ((gfc_array_r8 *) d, (const GFC_REAL_8 *) s);
      return;

/* FIXME: This here is a hack, which will have to be removed when
   the array descriptor is reworked.  Currently, we don't store the
   kind value for the type, but only the size.  Because on targets with
   __float128, we have sizeof(logn double) == sizeof(__float128),
   we cannot discriminate here and have to fall back to the generic
   handling (which is suboptimal).  */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# if defined(HAVE_GFC_REAL_10)
    case GFC_DTYPE_REAL_10:
      internal_unpack_r10 ((gfc_array_r10 *) d, (const GFC_REAL_10 *) s);
      return;
# endif

# if defined(HAVE_GFC_REAL_16)
    case GFC_DTYPE_REAL_16:
      internal_unpack_r16 ((gfc_array_r16 *) d, (const GFC_REAL_16 *) s);
      return;
# endif
#endif

    case GFC_DTYPE_COMPLEX_4:
      internal_unpack_c4 ((gfc_array_c4 *)d, (const GFC_COMPLEX_4 *)s);
      return;

    case GFC_DTYPE_COMPLEX_8:
      internal_unpack_c8 ((gfc_array_c8 *)d, (const GFC_COMPLEX_8 *)s);
      return;

/* FIXME: This here is a hack, which will have to be removed when
   the array descriptor is reworked.  Currently, we don't store the
   kind value for the type, but only the size.  Because on targets with
   __float128, we have sizeof(logn double) == sizeof(__float128),
   we cannot discriminate here and have to fall back to the generic
   handling (which is suboptimal).  */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# if defined(HAVE_GFC_COMPLEX_10)
    case GFC_DTYPE_COMPLEX_10:
      internal_unpack_c10 ((gfc_array_c10 *) d, (const GFC_COMPLEX_10 *) s);
      return;
# endif

# if defined(HAVE_GFC_COMPLEX_16)
    case GFC_DTYPE_COMPLEX_16:
      internal_unpack_c16 ((gfc_array_c16 *) d, (const GFC_COMPLEX_16 *) s);
      return;
# endif
#endif

    case GFC_DTYPE_DERIVED_2:
      if (GFC_UNALIGNED_2(d->base_addr) || GFC_UNALIGNED_2(s))
	break;
      else
	{
	  internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s);
	  return;
	}
    case GFC_DTYPE_DERIVED_4:
      if (GFC_UNALIGNED_4(d->base_addr) || GFC_UNALIGNED_4(s))
	break;
      else
	{
	  internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s);
	  return;
	}

    case GFC_DTYPE_DERIVED_8:
      if (GFC_UNALIGNED_8(d->base_addr) || GFC_UNALIGNED_8(s))
	break;
      else
	{
	  internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s);
	  return;
	}

#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_DERIVED_16:
      if (GFC_UNALIGNED_16(d->base_addr) || GFC_UNALIGNED_16(s))
	break;
      else
	{
	  internal_unpack_16 ((gfc_array_i16 *) d, (const GFC_INTEGER_16 *) s);
	  return;
	}
#endif

    default:
      break;
    }

  size = GFC_DESCRIPTOR_SIZE (d);

  dim = GFC_DESCRIPTOR_RANK (d);
  dsize = 1;
  for (n = 0; n < dim; n++)
    {
      count[n] = 0;
      stride[n] = GFC_DESCRIPTOR_STRIDE(d,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(d,n);
      if (extent[n] <= 0)
	return;

      if (dsize == stride[n])
	dsize *= extent[n];
      else
	dsize = 0;
    }

  src = s;

  if (dsize != 0)
    {
      memcpy (dest, src, dsize * size);
      return;
    }

  stride0 = stride[0] * size;

  while (dest)
    {
      /* Copy the data.  */
      memcpy (dest, src, size);
      /* Advance to the next element.  */
      src += size;
      dest += stride0;
      count[0]++;
      /* Advance to the next source element.  */
      n = 0;
      while (count[n] == extent[n])
        {
          /* 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.  */
          dest -= stride[n] * extent[n] * size;
          n++;
          if (n == dim)
            {
              dest = NULL;
              break;
            }
          else
            {
              count[n]++;
              dest += stride[n] * size;
            }
        }
    }
}
void
transpose (gfc_array_char *ret, gfc_array_char *source)
{
  transpose_internal (ret, source, GFC_DESCRIPTOR_SIZE (source));
}
Beispiel #14
0
void
__mmaxloc0_8_r8 (gfc_array_i8 * retarray, gfc_array_r8 *array, gfc_array_l4 * 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;
  GFC_INTEGER_8 *dest;
  GFC_REAL_8 *base;
  GFC_LOGICAL_4 *mbase;
  int rank;
  index_type n;

  rank = GFC_DESCRIPTOR_RANK (array);
  assert (rank > 0);
  assert (GFC_DESCRIPTOR_RANK (retarray) == 1);
  assert (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound == rank);
  assert (GFC_DESCRIPTOR_RANK (mask) == rank);

  if (array->dim[0].stride == 0)
    array->dim[0].stride = 1;
  if (retarray->dim[0].stride == 0)
    retarray->dim[0].stride = 1;
  if (retarray->dim[0].stride == 0)
    retarray->dim[0].stride = 1;

  dstride = retarray->dim[0].stride;
  dest = retarray->data;
  for (n = 0; n < rank; n++)
    {
      sstride[n] = array->dim[n].stride;
      mstride[n] = mask->dim[n].stride;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
      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;
  mbase = mask->data;

  if (GFC_DESCRIPTOR_SIZE (mask) != 4)
    {
      /* This allows the same loop to be used for all logical types.  */
      assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
      for (n = 0; n < rank; n++)
        mstride[n] <<= 1;
      mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
    }


  /* Initialize the return value.  */
  for (n = 0; n < rank; n++)
    dest[n * dstride] = 1;
  {

  GFC_REAL_8 maxval;

  maxval = -GFC_REAL_8_HUGE;

  while (base)
    {
      {
        /* Implementation start.  */

  if (*mbase && *base > maxval)
    {
      maxval = *base;
      for (n = 0; n < rank; n++)
        dest[n * dstride] = count[n] + 1;
    }
        /* Implementation end.  */
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      mbase += mstride[0];
      n = 0;
      while (count[n] == extent[n])
        {
          /* 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 proabably 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];
            }
        }
    }
  }
}
Beispiel #15
0
void
eoshift3_4 (gfc_array_char *ret, gfc_array_char *array,
		       gfc_array_i4 *h, const gfc_array_char *bound,
		       GFC_INTEGER_4 *pwhich)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type roffset;
  char *rptr;
  char *dest;
  /* s.* indicates the source array.  */
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type sstride0;
  index_type soffset;
  const char *sptr;
  const char *src;
  /* h.* indicates the shift array.  */
  index_type hstride[GFC_MAX_DIMENSIONS];
  index_type hstride0;
  const GFC_INTEGER_4 *hptr;
  /* b.* indicates the bound array.  */
  index_type bstride[GFC_MAX_DIMENSIONS];
  index_type bstride0;
  const char *bptr;

  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type dim;
  index_type size;
  index_type len;
  index_type n;
  int which;
  GFC_INTEGER_4 sh;
  GFC_INTEGER_4 delta;

  if (pwhich)
    which = *pwhich - 1;
  else
    which = 0;

  size = GFC_DESCRIPTOR_SIZE (ret);
  if (ret->data == NULL)
    {
      int i;

      ret->data = internal_malloc_size (size * size0 ((array_t *)array));
      ret->base = 0;
      ret->dtype = array->dtype;
      for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
        {
          ret->dim[i].lbound = 0;
          ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound;

          if (i == 0)
            ret->dim[i].stride = 1;
          else
            ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride;
        }
    }


  extent[0] = 1;
  count[0] = 0;
  size = GFC_DESCRIPTOR_SIZE (array);
  n = 0;
  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
    {
      if (dim == which)
        {
          roffset = ret->dim[dim].stride * size;
          if (roffset == 0)
            roffset = size;
          soffset = array->dim[dim].stride * size;
          if (soffset == 0)
            soffset = size;
          len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
        }
      else
        {
          count[n] = 0;
          extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
          rstride[n] = ret->dim[dim].stride * size;
          sstride[n] = array->dim[dim].stride * size;

          hstride[n] = h->dim[n].stride;
          if (bound)
            bstride[n] = bound->dim[n].stride * size;
          else
            bstride[n] = 0;
          n++;
        }
    }
  if (sstride[0] == 0)
    sstride[0] = size;
  if (rstride[0] == 0)
    rstride[0] = size;
  if (hstride[0] == 0)
    hstride[0] = 1;
  if (bound && bstride[0] == 0)
    bstride[0] = size;

  dim = GFC_DESCRIPTOR_RANK (array);
  rstride0 = rstride[0];
  sstride0 = sstride[0];
  hstride0 = hstride[0];
  bstride0 = bstride[0];
  rptr = ret->data;
  sptr = array->data;
  hptr = h->data;
  if (bound)
    bptr = bound->data;
  else
    bptr = zeros;

  while (rptr)
    {
      /* Do the shift for this dimension.  */
      sh = *hptr;
      if (( sh >= 0 ? sh : -sh ) > len)
	{
	  delta = len;
	  sh = len;
	}
      else
	delta = (sh >= 0) ? sh: -sh;

      if (sh > 0)
        {
          src = &sptr[delta * soffset];
          dest = rptr;
        }
      else
        {
          src = sptr;
          dest = &rptr[delta * roffset];
        }
      for (n = 0; n < len - delta; n++)
        {
          memcpy (dest, src, size);
          dest += roffset;
          src += soffset;
        }
      if (sh < 0)
        dest = rptr;
      n = delta;

      while (n--)
        {
          memcpy (dest, bptr, size);
          dest += roffset;
        }

      /* Advance to the next section.  */
      rptr += rstride0;
      sptr += sstride0;
      hptr += hstride0;
      bptr += bstride0;
      count[0]++;
      n = 0;
      while (count[n] == extent[n])
        {
          /* 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 proabably not worth it.  */
          rptr -= rstride[n] * extent[n];
          sptr -= sstride[n] * extent[n];
	  hptr -= hstride[n] * extent[n];
          bptr -= bstride[n] * extent[n];
          n++;
          if (n >= dim - 1)
            {
              /* Break out of the loop.  */
              rptr = NULL;
              break;
            }
          else
            {
              count[n]++;
              rptr += rstride[n];
              sptr += sstride[n];
	      hptr += hstride[n];
              bptr += bstride[n];
            }
        }
    }
}
void
pack (gfc_array_char *ret, const gfc_array_char *array,
      const gfc_array_l1 *mask, const gfc_array_char *vector)
{
  pack_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array));
}
Beispiel #17
0
static void
eoshift2 (gfc_array_char *ret, const gfc_array_char *array,
	  int shift, const gfc_array_char *bound, int which,
	  const char *filler, index_type filler_len)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type roffset;
  char * restrict rptr;
  char *dest;
  /* s.* indicates the source array.  */
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type sstride0;
  index_type soffset;
  const char *sptr;
  const char *src;
  /* b.* indicates the bound array.  */
  index_type bstride[GFC_MAX_DIMENSIONS];
  index_type bstride0;
  const char *bptr;

  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type dim;
  index_type len;
  index_type n;
  index_type arraysize;
  index_type size;

  /* The compiler cannot figure out that these are set, initialize
     them to avoid warnings.  */
  len = 0;
  soffset = 0;
  roffset = 0;

  size = GFC_DESCRIPTOR_SIZE (array);

  arraysize = size0 ((array_t *) array);

  if (ret->base_addr == NULL)
    {
      int i;

      ret->offset = 0;
      ret->dtype = array->dtype;

      /* xmalloc allocates a single byte for zero size.  */
      ret->base_addr = xmalloc (size * arraysize);

      for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
        {
	  index_type ub, str;

          ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;

          if (i == 0)
	    str = 1;
          else
            str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
	      * GFC_DESCRIPTOR_STRIDE(ret,i-1);

	  GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
        }
    }
  else if (unlikely (compile_options.bounds_check))
    {
      bounds_equal_extents ((array_t *) ret, (array_t *) array,
				 "return value", "EOSHIFT");
    }

  if (arraysize == 0)
    return;

  which = which - 1;

  extent[0] = 1;
  count[0] = 0;
  sstride[0] = -1;
  rstride[0] = -1;
  bstride[0] = -1;
  n = 0;
  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
    {
      if (dim == which)
        {
          roffset = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
          if (roffset == 0)
            roffset = size;
          soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
          if (soffset == 0)
            soffset = size;
          len = GFC_DESCRIPTOR_EXTENT(array,dim);
        }
      else
        {
          count[n] = 0;
          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
          rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
          sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
          if (bound)
            bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n);
          else
            bstride[n] = 0;
          n++;
        }
    }
  if (sstride[0] == 0)
    sstride[0] = size;
  if (rstride[0] == 0)
    rstride[0] = size;
  if (bound && bstride[0] == 0)
    bstride[0] = size;

  dim = GFC_DESCRIPTOR_RANK (array);
  rstride0 = rstride[0];
  sstride0 = sstride[0];
  bstride0 = bstride[0];
  rptr = ret->base_addr;
  sptr = array->base_addr;

  if ((shift >= 0 ? shift : -shift ) > len)
    {
      shift = len;
      len = 0;
    }
  else
    {
      if (shift > 0)
	len = len - shift;
      else
	len = len + shift;
    }
  
  if (bound)
    bptr = bound->base_addr;
  else
    bptr = NULL;

  while (rptr)
    {
      /* Do the shift for this dimension.  */
      if (shift > 0)
        {
          src = &sptr[shift * soffset];
          dest = rptr;
        }
      else
        {
          src = sptr;
          dest = &rptr[-shift * roffset];
        }
      for (n = 0; n < len; n++)
        {
          memcpy (dest, src, size);
          dest += roffset;
          src += soffset;
        }
      if (shift >= 0)
        {
          n = shift;
        }
      else
        {
          dest = rptr;
          n = -shift;
        }

      if (bptr)
	while (n--)
	  {
	    memcpy (dest, bptr, size);
	    dest += roffset;
	  }
      else
	while (n--)
	  {
	    index_type i;

	    if (filler_len == 1)
	      memset (dest, filler[0], size);
	    else
	      for (i = 0; i < size ; i += filler_len)
		memcpy (&dest[i], filler, filler_len);

	    dest += roffset;
	  }

      /* Advance to the next section.  */
      rptr += rstride0;
      sptr += sstride0;
      bptr += bstride0;
      count[0]++;
      n = 0;
      while (count[n] == extent[n])
        {
          /* 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.  */
          rptr -= rstride[n] * extent[n];
          sptr -= sstride[n] * extent[n];
          bptr -= bstride[n] * extent[n];
          n++;
          if (n >= dim - 1)
            {
              /* Break out of the loop.  */
              rptr = NULL;
              break;
            }
          else
            {
              count[n]++;
              rptr += rstride[n];
              sptr += sstride[n];
              bptr += bstride[n];
            }
        }
    }
}
Beispiel #18
0
void
__mminval_i4 (gfc_array_i4 * retarray, gfc_array_i4 * array, index_type *pdim, gfc_array_l4 * mask)
{
  index_type count[GFC_MAX_DIMENSIONS - 1];
  index_type extent[GFC_MAX_DIMENSIONS - 1];
  index_type sstride[GFC_MAX_DIMENSIONS - 1];
  index_type dstride[GFC_MAX_DIMENSIONS - 1];
  index_type mstride[GFC_MAX_DIMENSIONS - 1];
  GFC_INTEGER_4 *dest;
  GFC_INTEGER_4 *base;
  GFC_LOGICAL_4 *mbase;
  int rank;
  int dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;

  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
  assert (rank == GFC_DESCRIPTOR_RANK (retarray));
  if (array->dim[0].stride == 0)
    array->dim[0].stride = 1;
  if (retarray->dim[0].stride == 0)
    retarray->dim[0].stride = 1;

  len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  if (len <= 0)
    return;
  delta = array->dim[dim].stride;
  mdelta = mask->dim[dim].stride;

  for (n = 0; n < dim; n++)
    {
      sstride[n] = array->dim[n].stride;
      mstride[n] = mask->dim[n].stride;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = array->dim[n + 1].stride;
      mstride[n] = mask->dim[n + 1].stride;
      extent[n] =
        array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = retarray->dim[n].stride;
      if (extent[n] <= 0)
        return;
    }

  dest = retarray->data;
  base = array->data;
  mbase = mask->data;

  if (GFC_DESCRIPTOR_SIZE (mask) != 4)
    {
      /* This allows the same loop to be used for all logical types.  */
      assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
      for (n = 0; n < rank; n++)
        mstride[n] <<= 1;
      mdelta <<= 1;
      mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
    }

  while (base)
    {
      GFC_INTEGER_4 *src;
      GFC_LOGICAL_4 *msrc;
      GFC_INTEGER_4 result;
      src = base;
      msrc = mbase;
      {

  result = GFC_INTEGER_4_HUGE;
        if (len <= 0)
	  *dest = GFC_INTEGER_4_HUGE;
	else
	  {
	    for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	      {

  if (*msrc && *src < result)
    result = *src;
              }
	    *dest = result;
	  }
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      mbase += mstride[0];
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
        {
          /* 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 proabably not worth it.  */
          base -= sstride[n] * extent[n];
          mbase -= mstride[n] * extent[n];
          dest -= dstride[n] * extent[n];
          n++;
          if (n == rank)
            {
              /* Break out of the look.  */
              base = NULL;
              break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
              mbase += mstride[n];
              dest += dstride[n];
            }
        }
    }
}
Beispiel #19
0
void *
internal_pack (gfc_array_char * source)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type stride[GFC_MAX_DIMENSIONS];
  index_type stride0;
  index_type dim;
  index_type ssize;
  const char *src;
  char *dest;
  void *destptr;
  int n;
  int packed;
  index_type size;
  index_type type_size;

  if (source->base_addr == NULL)
    return NULL;

  type_size = GFC_DTYPE_TYPE_SIZE(source);
  size = GFC_DESCRIPTOR_SIZE (source);
  switch (type_size)
    {
    case GFC_DTYPE_INTEGER_1:
    case GFC_DTYPE_LOGICAL_1:
    case GFC_DTYPE_DERIVED_1:
      return internal_pack_1 ((gfc_array_i1 *) source);

    case GFC_DTYPE_INTEGER_2:
    case GFC_DTYPE_LOGICAL_2:
      return internal_pack_2 ((gfc_array_i2 *) source);

    case GFC_DTYPE_INTEGER_4:
    case GFC_DTYPE_LOGICAL_4:
      return internal_pack_4 ((gfc_array_i4 *) source);
	
    case GFC_DTYPE_INTEGER_8:
    case GFC_DTYPE_LOGICAL_8:
      return internal_pack_8 ((gfc_array_i8 *) source);

#if defined(HAVE_GFC_INTEGER_16)
    case GFC_DTYPE_INTEGER_16:
    case GFC_DTYPE_LOGICAL_16:
      return internal_pack_16 ((gfc_array_i16 *) source);
#endif
    case GFC_DTYPE_REAL_4:
      return internal_pack_r4 ((gfc_array_r4 *) source);

    case GFC_DTYPE_REAL_8:
      return internal_pack_r8 ((gfc_array_r8 *) source);

/* FIXME: This here is a hack, which will have to be removed when
   the array descriptor is reworked.  Currently, we don't store the
   kind value for the type, but only the size.  Because on targets with
   __float128, we have sizeof(logn double) == sizeof(__float128),
   we cannot discriminate here and have to fall back to the generic
   handling (which is suboptimal).  */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# if defined (HAVE_GFC_REAL_10)
    case GFC_DTYPE_REAL_10:
      return internal_pack_r10 ((gfc_array_r10 *) source);
# endif

# if defined (HAVE_GFC_REAL_16)
    case GFC_DTYPE_REAL_16:
      return internal_pack_r16 ((gfc_array_r16 *) source);
# endif
#endif

    case GFC_DTYPE_COMPLEX_4:
      return internal_pack_c4 ((gfc_array_c4 *) source);
	
    case GFC_DTYPE_COMPLEX_8:
      return internal_pack_c8 ((gfc_array_c8 *) source);

/* FIXME: This here is a hack, which will have to be removed when
   the array descriptor is reworked.  Currently, we don't store the
   kind value for the type, but only the size.  Because on targets with
   __float128, we have sizeof(logn double) == sizeof(__float128),
   we cannot discriminate here and have to fall back to the generic
   handling (which is suboptimal).  */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# if defined (HAVE_GFC_COMPLEX_10)
    case GFC_DTYPE_COMPLEX_10:
      return internal_pack_c10 ((gfc_array_c10 *) source);
# endif

# if defined (HAVE_GFC_COMPLEX_16)
    case GFC_DTYPE_COMPLEX_16:
      return internal_pack_c16 ((gfc_array_c16 *) source);
# endif
#endif

    case GFC_DTYPE_DERIVED_2:
      if (GFC_UNALIGNED_2(source->base_addr))
	break;
      else
	return internal_pack_2 ((gfc_array_i2 *) source);

    case GFC_DTYPE_DERIVED_4:
      if (GFC_UNALIGNED_4(source->base_addr))
	break;
      else
	return internal_pack_4 ((gfc_array_i4 *) source);

    case GFC_DTYPE_DERIVED_8:
      if (GFC_UNALIGNED_8(source->base_addr))
	break;
      else
	return internal_pack_8 ((gfc_array_i8 *) source);

#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_DERIVED_16:
      if (GFC_UNALIGNED_16(source->base_addr))
	break;
      else
	return internal_pack_16 ((gfc_array_i16 *) source);
#endif

    default:
      break;
    }

  dim = GFC_DESCRIPTOR_RANK (source);
  ssize = 1;
  packed = 1;
  for (n = 0; n < dim; n++)
    {
      count[n] = 0;
      stride[n] = GFC_DESCRIPTOR_STRIDE(source,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(source,n);
      if (extent[n] <= 0)
        {
          /* Do nothing.  */
          packed = 1;
          break;
        }

      if (ssize != stride[n])
        packed = 0;

      ssize *= extent[n];
    }

  if (packed)
    return source->base_addr;

   /* Allocate storage for the destination.  */
  destptr = xmallocarray (ssize, size);
  dest = (char *)destptr;
  src = source->base_addr;
  stride0 = stride[0] * size;

  while (src)
    {
      /* Copy the data.  */
      memcpy(dest, src, size);
      /* Advance to the next element.  */
      dest += size;
      src += stride0;
      count[0]++;
      /* Advance to the next source element.  */
      n = 0;
      while (count[n] == extent[n])
        {
          /* 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.  */
          src -= stride[n] * extent[n] * size;
          n++;
          if (n == dim)
            {
              src = NULL;
              break;
            }
          else
            {
              count[n]++;
              src += stride[n] * size;
            }
        }
    }
  return destptr;
}
void
date_and_time (char *__date, char *__time, char *__zone,
	       gfc_array_i4 *__values, GFC_INTEGER_4 __date_len,
	       GFC_INTEGER_4 __time_len, GFC_INTEGER_4 __zone_len)
{
  int i;
  char date[DATE_LEN + 1];
  char timec[TIME_LEN + 1];
  char zone[ZONE_LEN + 1];
  GFC_INTEGER_4 values[VALUES_SIZE];

  time_t lt;
  struct tm local_time;
  struct tm UTC_time;

  long usecs;

  if (!gf_gettime (&lt, &usecs))
    {
      values[7] = usecs / 1000;

      localtime_r (&lt, &local_time);
      gmtime_r (&lt, &UTC_time);

      /* All arguments can be derived from VALUES.  */
      values[0] = 1900 + local_time.tm_year;
      values[1] = 1 + local_time.tm_mon;
      values[2] = local_time.tm_mday;
      values[3] = (local_time.tm_min - UTC_time.tm_min +
	           60 * (local_time.tm_hour - UTC_time.tm_hour +
		     24 * (local_time.tm_yday - UTC_time.tm_yday)));
      values[4] = local_time.tm_hour;
      values[5] = local_time.tm_min;
      values[6] = local_time.tm_sec;

      if (__date)
	snprintf (date, DATE_LEN + 1, "%04d%02d%02d",
		  values[0], values[1], values[2]);
      if (__time)
	snprintf (timec, TIME_LEN + 1, "%02d%02d%02d.%03d",
		  values[4], values[5], values[6], values[7]);

      if (__zone)
	snprintf (zone, ZONE_LEN + 1, "%+03d%02d",
		  values[3] / 60, abs (values[3] % 60));
    }
  else
    {
      memset (date, ' ', DATE_LEN);
      date[DATE_LEN] = '\0';

      memset (timec, ' ', TIME_LEN);
      timec[TIME_LEN] = '\0';

      memset (zone, ' ', ZONE_LEN);
      zone[ZONE_LEN] = '\0';

      for (i = 0; i < VALUES_SIZE; i++)
	values[i] = - GFC_INTEGER_4_HUGE;
    }   

  /* Copy the values into the arguments.  */
  if (__values)
    {
      index_type len, delta, elt_size;

      elt_size = GFC_DESCRIPTOR_SIZE (__values);
      len = GFC_DESCRIPTOR_EXTENT(__values,0);
      delta = GFC_DESCRIPTOR_STRIDE(__values,0);
      if (delta == 0)
	delta = 1;
      
      if (unlikely (len < VALUES_SIZE))
	  runtime_error ("Incorrect extent in VALUE argument to"
			 " DATE_AND_TIME intrinsic: is %ld, should"
			 " be >=%ld", (long int) len, (long int) VALUES_SIZE);

      /* Cope with different type kinds.  */
      if (elt_size == 4)
        {
	  GFC_INTEGER_4 *vptr4 = __values->base_addr;

	  for (i = 0; i < VALUES_SIZE; i++, vptr4 += delta)
	    *vptr4 = values[i];
	}
      else if (elt_size == 8)
        {
	  GFC_INTEGER_8 *vptr8 = (GFC_INTEGER_8 *)__values->base_addr;

	  for (i = 0; i < VALUES_SIZE; i++, vptr8 += delta)
	    {
	      if (values[i] == - GFC_INTEGER_4_HUGE)
		*vptr8 = - GFC_INTEGER_8_HUGE;
	      else
		*vptr8 = values[i];
	    }
	}
      else 
	abort ();
    }

  if (__zone)
    fstrcpy (__zone, __zone_len, zone, ZONE_LEN);

  if (__time)
    fstrcpy (__time, __time_len, timec, TIME_LEN);

  if (__date)
    fstrcpy (__date, __date_len, date, DATE_LEN);
}
Beispiel #21
0
void
pack (gfc_array_char *ret, const gfc_array_char *array,
      const gfc_array_l1 *mask, const gfc_array_char *vector)
{
  index_type type_size;
  index_type size;

  type_size = GFC_DTYPE_TYPE_SIZE(array);

  switch(type_size)
    {
    case GFC_DTYPE_LOGICAL_1:
    case GFC_DTYPE_INTEGER_1:
    case GFC_DTYPE_DERIVED_1:
      pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array,
	       (gfc_array_l1 *) mask, (gfc_array_i1 *) vector);
      return;

    case GFC_DTYPE_LOGICAL_2:
    case GFC_DTYPE_INTEGER_2:
      pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
	       (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
      return;

    case GFC_DTYPE_LOGICAL_4:
    case GFC_DTYPE_INTEGER_4:
      pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
	       (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
      return;

    case GFC_DTYPE_LOGICAL_8:
    case GFC_DTYPE_INTEGER_8:
      pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
	       (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
      return;

#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_LOGICAL_16:
    case GFC_DTYPE_INTEGER_16:
      pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
		(gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
      return;
#endif

    case GFC_DTYPE_REAL_4:
      pack_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) array,
	       (gfc_array_l1 *) mask, (gfc_array_r4 *) vector);
      return;

    case GFC_DTYPE_REAL_8:
      pack_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) array,
	       (gfc_array_l1 *) mask, (gfc_array_r8 *) vector);
      return;

/* FIXME: This here is a hack, which will have to be removed when
   the array descriptor is reworked.  Currently, we don't store the
   kind value for the type, but only the size.  Because on targets with
   __float128, we have sizeof(logn double) == sizeof(__float128),
   we cannot discriminate here and have to fall back to the generic
   handling (which is suboptimal).  */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_REAL_10
    case GFC_DTYPE_REAL_10:
      pack_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) array,
		(gfc_array_l1 *) mask, (gfc_array_r10 *) vector);
      return;
# endif

# ifdef HAVE_GFC_REAL_16
    case GFC_DTYPE_REAL_16:
      pack_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) array,
		(gfc_array_l1 *) mask, (gfc_array_r16 *) vector);
      return;
# endif
#endif

    case GFC_DTYPE_COMPLEX_4:
      pack_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array,
	       (gfc_array_l1 *) mask, (gfc_array_c4 *) vector);
      return;

    case GFC_DTYPE_COMPLEX_8:
      pack_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array,
	       (gfc_array_l1 *) mask, (gfc_array_c8 *) vector);
      return;

/* FIXME: This here is a hack, which will have to be removed when
   the array descriptor is reworked.  Currently, we don't store the
   kind value for the type, but only the size.  Because on targets with
   __float128, we have sizeof(logn double) == sizeof(__float128),
   we cannot discriminate here and have to fall back to the generic
   handling (which is suboptimal).  */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_COMPLEX_10
    case GFC_DTYPE_COMPLEX_10:
      pack_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) array,
		(gfc_array_l1 *) mask, (gfc_array_c10 *) vector);
      return;
# endif

# ifdef HAVE_GFC_COMPLEX_16
    case GFC_DTYPE_COMPLEX_16:
      pack_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) array,
		(gfc_array_l1 *) mask, (gfc_array_c16 *) vector);
      return;
# endif
#endif

      /* For derived types, let's check the actual alignment of the
	 data pointers.  If they are aligned, we can safely call
	 the unpack functions.  */

    case GFC_DTYPE_DERIVED_2:
      if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(array->base_addr)
	  || (vector && GFC_UNALIGNED_2(vector->base_addr)))
	break;
      else
	{
	  pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
		   (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
	  return;
	}

    case GFC_DTYPE_DERIVED_4:
      if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(array->base_addr)
	  || (vector && GFC_UNALIGNED_4(vector->base_addr)))
	break;
      else
	{
	  pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
		   (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
	  return;
	}

    case GFC_DTYPE_DERIVED_8:
      if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(array->base_addr)
	  || (vector && GFC_UNALIGNED_8(vector->base_addr)))
	break;
      else
	{
	  pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
		   (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
	  return;
	}

#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_DERIVED_16:
      if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(array->base_addr)
	  || (vector && GFC_UNALIGNED_16(vector->base_addr)))
	break;
      else
	{
	  pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
		   (gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
	  return;
	}
#endif

    }

  size = GFC_DESCRIPTOR_SIZE (array);
  pack_internal (ret, array, mask, vector, size);
}
Beispiel #22
0
void
pack_i1 (gfc_array_i1 *ret, const gfc_array_i1 *array,
	       const gfc_array_l1 *mask, const gfc_array_i1 *vector)
{
  /* r.* indicates the return array.  */
  index_type rstride0;
  GFC_INTEGER_1 * restrict rptr;
  /* s.* indicates the source array.  */
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type sstride0;
  const GFC_INTEGER_1 *sptr;
  /* m.* indicates the mask array.  */
  index_type mstride[GFC_MAX_DIMENSIONS];
  index_type mstride0;
  const GFC_LOGICAL_1 *mptr;

  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  int zero_sized;
  index_type n;
  index_type dim;
  index_type nelem;
  index_type total;
  int mask_kind;

  dim = GFC_DESCRIPTOR_RANK (array);

  mptr = mask->data;

  /* Use the same loop for all logical types, by using GFC_LOGICAL_1
     and using shifting to address size and endian issues.  */

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
      || mask_kind == 16
#endif
      )
    {
      /*  Do not convert a NULL pointer as we use test for NULL below.  */
      if (mptr)
	mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
    }
  else
    runtime_error ("Funny sized logical array");

  zero_sized = 0;
  for (n = 0; n < dim; n++)
    {
      count[n] = 0;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
      if (extent[n] <= 0)
       zero_sized = 1;
      sstride[n] = array->dim[n].stride;
      mstride[n] = mask->dim[n].stride * mask_kind;
    }
  if (sstride[0] == 0)
    sstride[0] = 1;
  if (mstride[0] == 0)
    mstride[0] = mask_kind;

  if (zero_sized)
    sptr = NULL;
  else
    sptr = array->data;

  if (ret->data == NULL || compile_options.bounds_check)
    {
      /* Count the elements, either for allocating memory or
	 for bounds checking.  */

      if (vector != NULL)
	{
	  /* The return array will have as many
	     elements as there are in VECTOR.  */
	  total = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
	  if (total < 0)
	    {
	      total = 0;
	      vector = NULL;
	    }
	}
      else
	{
	  /* We have to count the true elements in MASK.  */

	  /* TODO: We could speed up pack easily in the case of only
	     few .TRUE. entries in MASK, by keeping track of where we
	     would be in the source array during the initial traversal
	     of MASK, and caching the pointers to those elements. Then,
	     supposed the number of elements is small enough, we would
	     only have to traverse the list, and copy those elements
	     into the result array. In the case of datatypes which fit
	     in one of the integer types we could also cache the
	     value instead of a pointer to it.
	     This approach might be bad from the point of view of
	     cache behavior in the case where our cache is not big
	     enough to hold all elements that have to be copied.  */

	  const GFC_LOGICAL_1 *m = mptr;

	  total = 0;
	  if (zero_sized)
	    m = NULL;

	  while (m)
	    {
	      /* Test this element.  */
	      if (*m)
		total++;

	      /* Advance to the next element.  */
	      m += mstride[0];
	      count[0]++;
	      n = 0;
	      while (count[n] == extent[n])
		{
		  /* When we get to the end of a dimension, reset it
		     and increment the next dimension.  */
		  count[n] = 0;
		  /* We could precalculate this product, but this is a
		     less frequently used path so probably not worth
		     it.  */
		  m -= mstride[n] * extent[n];
		  n++;
		  if (n >= dim)
		    {
		      /* Break out of the loop.  */
		      m = NULL;
		      break;
		    }
		  else
		    {
		      count[n]++;
		      m += mstride[n];
		    }
		}
	    }
	}

      if (ret->data == NULL)
	{
	  /* Setup the array descriptor.  */
	  ret->dim[0].lbound = 0;
	  ret->dim[0].ubound = total - 1;
	  ret->dim[0].stride = 1;

	  ret->offset = 0;
	  if (total == 0)
	    {
	      /* In this case, nothing remains to be done.  */
	      ret->data = internal_malloc_size (1);
	      return;
	    }
	  else
	    ret->data = internal_malloc_size (sizeof (GFC_INTEGER_1) * total);
	}
      else 
	{
	  /* We come here because of range checking.  */
	  index_type ret_extent;

	  ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound;
	  if (total != ret_extent)
	    runtime_error ("Incorrect extent in return value of PACK intrinsic;"
			   " is %ld, should be %ld", (long int) total,
			   (long int) ret_extent);
	}
    }

  rstride0 = ret->dim[0].stride;
  if (rstride0 == 0)
    rstride0 = 1;
  sstride0 = sstride[0];
  mstride0 = mstride[0];
  rptr = ret->data;

  while (sptr && mptr)
    {
      /* Test this element.  */
      if (*mptr)
        {
          /* Add it.  */
	  *rptr = *sptr;
          rptr += rstride0;
        }
      /* Advance to the next element.  */
      sptr += sstride0;
      mptr += mstride0;
      count[0]++;
      n = 0;
      while (count[n] == extent[n])
        {
          /* 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.  */
          sptr -= sstride[n] * extent[n];
          mptr -= mstride[n] * extent[n];
          n++;
          if (n >= dim)
            {
              /* Break out of the loop.  */
              sptr = NULL;
              break;
            }
          else
            {
              count[n]++;
              sptr += sstride[n];
              mptr += mstride[n];
            }
        }
    }

  /* Add any remaining elements from VECTOR.  */
  if (vector)
    {
      n = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
      nelem = ((rptr - ret->data) / rstride0);
      if (n > nelem)
        {
          sstride0 = vector->dim[0].stride;
          if (sstride0 == 0)
            sstride0 = 1;

          sptr = vector->data + sstride0 * nelem;
          n -= nelem;
          while (n--)
            {
	      *rptr = *sptr;
              rptr += rstride0;
              sptr += sstride0;
            }
        }
    }
}
Beispiel #23
0
static void
pack_internal (gfc_array_char *ret, const gfc_array_char *array,
	       const gfc_array_l1 *mask, const gfc_array_char *vector,
	       index_type size)
{
  /* r.* indicates the return array.  */
  index_type rstride0;
  char * restrict rptr;
  /* s.* indicates the source array.  */
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type sstride0;
  const char *sptr;
  /* m.* indicates the mask array.  */
  index_type mstride[GFC_MAX_DIMENSIONS];
  index_type mstride0;
  const GFC_LOGICAL_1 *mptr;

  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type n;
  index_type dim;
  index_type nelem;
  index_type total;
  int mask_kind;

  dim = GFC_DESCRIPTOR_RANK (array);

  sptr = array->base_addr;
  mptr = mask->base_addr;

  /* Use the same loop for all logical types, by using GFC_LOGICAL_1
     and using shifting to address size and endian issues.  */

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
      || mask_kind == 16
#endif
      )
    {
      /*  Don't convert a NULL pointer as we use test for NULL below.  */
      if (mptr)
	mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
    }
  else
    runtime_error ("Funny sized logical array");

  for (n = 0; n < dim; n++)
    {
      count[n] = 0;
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
      sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
    }
  if (sstride[0] == 0)
    sstride[0] = size;
  if (mstride[0] == 0)
    mstride[0] = mask_kind;

  if (ret->base_addr == NULL || unlikely (compile_options.bounds_check))
    {
      /* Count the elements, either for allocating memory or
	 for bounds checking.  */

      if (vector != NULL)
	{
	  /* The return array will have as many
	     elements as there are in VECTOR.  */
	  total = GFC_DESCRIPTOR_EXTENT(vector,0);
	}
      else
	{
	  /* We have to count the true elements in MASK.  */

	  total = count_0 (mask);
	}

      if (ret->base_addr == NULL)
	{
	  /* Setup the array descriptor.  */
	  GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1);

	  ret->offset = 0;
	  /* xmallocarray allocates a single byte for zero size.  */
	  ret->base_addr = xmallocarray (total, size);

	  if (total == 0)
	    return;      /* In this case, nothing remains to be done.  */
	}
      else 
	{
	  /* We come here because of range checking.  */
	  index_type ret_extent;

	  ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0);
	  if (total != ret_extent)
	    runtime_error ("Incorrect extent in return value of PACK intrinsic;"
			   " is %ld, should be %ld", (long int) total,
			   (long int) ret_extent);
	}
    }

  rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
  if (rstride0 == 0)
    rstride0 = size;
  sstride0 = sstride[0];
  mstride0 = mstride[0];
  rptr = ret->base_addr;

  while (sptr && mptr)
    {
      /* Test this element.  */
      if (*mptr)
        {
          /* Add it.  */
          memcpy (rptr, sptr, size);
          rptr += rstride0;
        }
      /* Advance to the next element.  */
      sptr += sstride0;
      mptr += mstride0;
      count[0]++;
      n = 0;
      while (count[n] == extent[n])
        {
          /* 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.  */
          sptr -= sstride[n] * extent[n];
          mptr -= mstride[n] * extent[n];
          n++;
          if (n >= dim)
            {
              /* Break out of the loop.  */
              sptr = NULL;
              break;
            }
          else
            {
              count[n]++;
              sptr += sstride[n];
              mptr += mstride[n];
            }
        }
    }

  /* Add any remaining elements from VECTOR.  */
  if (vector)
    {
      n = GFC_DESCRIPTOR_EXTENT(vector,0);
      nelem = ((rptr - ret->base_addr) / rstride0);
      if (n > nelem)
        {
          sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
          if (sstride0 == 0)
            sstride0 = size;

          sptr = vector->base_addr + sstride0 * nelem;
          n -= nelem;
          while (n--)
            {
              memcpy (rptr, sptr, size);
              rptr += rstride0;
              sptr += sstride0;
            }
        }
    }
}
Beispiel #24
0
void
ISO_C_BINDING_PREFIX (c_f_pointer_u0) (void *c_ptr_in,
                                       gfc_array_void *f_ptr_out,
                                       const array_t *shape)
{
  int i = 0;
  int shapeSize = 0;

  GFC_DESCRIPTOR_DATA (f_ptr_out) = c_ptr_in;

  if (shape != NULL)
    {
      index_type source_stride;
      index_type size;
      char *p;

      f_ptr_out->offset = 0;
      shapeSize = 0;
      p = shape->data;
      size = GFC_DESCRIPTOR_SIZE(shape);

      source_stride = GFC_DESCRIPTOR_STRIDE_BYTES(shape,0);

      /* shape's length (rank of the output array) */
      shapeSize = GFC_DESCRIPTOR_EXTENT(shape,0);
      for (i = 0; i < shapeSize; i++)
        {
	  index_type str, ub;

          /* Have to allow for the SHAPE array to be any valid kind for
             an INTEGER type.  */
	  switch (size)
	    {
#ifdef HAVE_GFC_INTEGER_1
	      case 1:
		ub = *((GFC_INTEGER_1 *) p);
		break;
#endif
#ifdef HAVE_GFC_INTEGER_2
	      case 2:
		ub = *((GFC_INTEGER_2 *) p);
		break;
#endif
#ifdef HAVE_GFC_INTEGER_4
	      case 4:
		ub = *((GFC_INTEGER_4 *) p);
		break;
#endif
#ifdef HAVE_GFC_INTEGER_8
	      case 8:
		ub = *((GFC_INTEGER_8 *) p);
		break;
#endif
#ifdef HAVE_GFC_INTEGER_16
	      case 16:
		ub = *((GFC_INTEGER_16 *) p);
		break;
#endif
	      default:
		internal_error (NULL, "c_f_pointer_u0: Invalid size");
	    }
	  p += source_stride;

	  if (i == 0)
	    {
	      str = 1;
	      f_ptr_out->offset = str;
	    }
	  else
	    {
	      str = GFC_DESCRIPTOR_EXTENT(f_ptr_out,i-1);
	      f_ptr_out->offset += str;
	    }

          /* Lower bound is 1, as specified by the draft.  */
	  GFC_DIMENSION_SET(f_ptr_out->dim[i], 1, ub, str);
        }

      f_ptr_out->offset *= -1;

      /* All we know is the rank, so set it, leaving the rest alone.
         Make NO assumptions about the state of dtype coming in!  If we
         shift right by TYPE_SHIFT bits we'll throw away the existing
         rank.  Then, shift left by the same number to shift in zeros
         and or with the new rank.  */
      f_ptr_out->dtype = ((f_ptr_out->dtype >> GFC_DTYPE_TYPE_SHIFT)
                           << GFC_DTYPE_TYPE_SHIFT) | shapeSize;
    }
Beispiel #25
0
void
mmaxval_r10 (gfc_array_r10 * retarray, gfc_array_r10 * array,
				  index_type *pdim, gfc_array_l4 * mask)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  index_type mstride[GFC_MAX_DIMENSIONS];
  GFC_REAL_10 *dest;
  GFC_REAL_10 *base;
  GFC_LOGICAL_4 *mbase;
  int rank;
  int dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;

  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  /* TODO:  It should be a front end job to correctly set the strides.  */

  if (array->dim[0].stride == 0)
    array->dim[0].stride = 1;

  if (mask->dim[0].stride == 0)
    mask->dim[0].stride = 1;

  len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  if (len <= 0)
    return;
  delta = array->dim[dim].stride;
  mdelta = mask->dim[dim].stride;

  for (n = 0; n < dim; n++)
    {
      sstride[n] = array->dim[n].stride;
      mstride[n] = mask->dim[n].stride;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = array->dim[n + 1].stride;
      mstride[n] = mask->dim[n + 1].stride;
      extent[n] =
        array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
    }

  if (retarray->data == NULL)
    {
      for (n = 0; n < rank; n++)
        {
          retarray->dim[n].lbound = 0;
          retarray->dim[n].ubound = extent[n]-1;
          if (n == 0)
            retarray->dim[n].stride = 1;
          else
            retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
        }

      retarray->data
	 = internal_malloc_size (sizeof (GFC_REAL_10)
		 		 * retarray->dim[rank-1].stride
				 * extent[rank-1]);
      retarray->offset = 0;
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
    }
  else
    {
      if (retarray->dim[0].stride == 0)
	retarray->dim[0].stride = 1;

      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect");
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = retarray->dim[n].stride;
      if (extent[n] <= 0)
        return;
    }

  dest = retarray->data;
  base = array->data;
  mbase = mask->data;

  if (GFC_DESCRIPTOR_SIZE (mask) != 4)
    {
      /* This allows the same loop to be used for all logical types.  */
      assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
      for (n = 0; n < rank; n++)
        mstride[n] <<= 1;
      mdelta <<= 1;
      mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
    }

  while (base)
    {
      GFC_REAL_10 *src;
      GFC_LOGICAL_4 *msrc;
      GFC_REAL_10 result;
      src = base;
      msrc = mbase;
      {

  result = -GFC_REAL_10_HUGE;
        if (len <= 0)
	  *dest = -GFC_REAL_10_HUGE;
	else
	  {
	    for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	      {

  if (*msrc && *src > result)
    result = *src;
              }
	    *dest = result;
	  }
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      mbase += mstride[0];
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
        {
          /* 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 proabably not worth it.  */
          base -= sstride[n] * extent[n];
          mbase -= mstride[n] * extent[n];
          dest -= dstride[n] * extent[n];
          n++;
          if (n == rank)
            {
              /* Break out of the look.  */
              base = NULL;
              break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
              mbase += mstride[n];
              dest += dstride[n];
            }
        }
    }
}
Beispiel #26
0
index_type count_0 (const gfc_array_l1 * array)
{
  const GFC_LOGICAL_1 * restrict base;
  index_type rank;
  int kind;
  int continue_loop;
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type result;
  index_type n;

  rank = GFC_DESCRIPTOR_RANK (array);
  kind = GFC_DESCRIPTOR_SIZE (array);

  base = array->base_addr;

  if (kind == 1 || kind == 2 || kind == 4 || kind == 8
#ifdef HAVE_GFC_LOGICAL_16
      || kind == 16
#endif
    )
    {
      if (base)
	base = GFOR_POINTER_TO_L1 (base, kind);
    }
  else
    internal_error (NULL, "Funny sized logical array in count_0");

  for (n = 0; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
      count[n] = 0;

      if (extent[n] <= 0)
	return 0;
    }

  result = 0;
  continue_loop = 1;
  while (continue_loop)
    {
      if (*base)
	result ++;

      count[0]++;
      base += sstride[0];
      n = 0;
      while (count[n] == extent[n])
	{
	  count[n] = 0;
	  base -= sstride[n] * extent[n];
	  n++;
	  if (n == rank)
	    {
	      continue_loop = 0;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	    }
	}
    }
  return result;
}
Beispiel #27
0
void
unpack0_c8 (gfc_array_c8 *ret, const gfc_array_c8 *vector,
		 const gfc_array_l1 *mask, const GFC_COMPLEX_8 *fptr)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type rs;
  GFC_COMPLEX_8 * restrict rptr;
  /* v.* indicates the vector array.  */
  index_type vstride0;
  GFC_COMPLEX_8 *vptr;
  /* Value for field, this is constant.  */
  const GFC_COMPLEX_8 fval = *fptr;
  /* m.* indicates the mask array.  */
  index_type mstride[GFC_MAX_DIMENSIONS];
  index_type mstride0;
  const GFC_LOGICAL_1 *mptr;

  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type n;
  index_type dim;

  int empty;
  int mask_kind;

  empty = 0;

  mptr = mask->data;

  /* Use the same loop for all logical types, by using GFC_LOGICAL_1
     and using shifting to address size and endian issues.  */

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
      || mask_kind == 16
#endif
      )
    {
      /*  Do not convert a NULL pointer as we use test for NULL below.  */
      if (mptr)
	mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
    }
  else
    runtime_error ("Funny sized logical array");

  if (ret->data == NULL)
    {
      /* The front end has signalled that we need to populate the
	 return array descriptor.  */
      dim = GFC_DESCRIPTOR_RANK (mask);
      rs = 1;
      for (n = 0; n < dim; n++)
	{
	  count[n] = 0;
	  ret->dim[n].stride = rs;
	  ret->dim[n].lbound = 0;
	  ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
	  extent[n] = ret->dim[n].ubound + 1;
	  empty = empty || extent[n] <= 0;
	  rstride[n] = ret->dim[n].stride;
	  mstride[n] = mask->dim[n].stride * mask_kind;
	  rs *= extent[n];
	}
      ret->offset = 0;
      ret->data = internal_malloc_size (rs * sizeof (GFC_COMPLEX_8));
    }
  else
    {
      dim = GFC_DESCRIPTOR_RANK (ret);
      for (n = 0; n < dim; n++)
	{
	  count[n] = 0;
	  extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
	  empty = empty || extent[n] <= 0;
	  rstride[n] = ret->dim[n].stride;
	  mstride[n] = mask->dim[n].stride * mask_kind;
	}
      if (rstride[0] == 0)
	rstride[0] = 1;
    }

  if (empty)
    return;

  if (mstride[0] == 0)
    mstride[0] = 1;

  vstride0 = vector->dim[0].stride;
  if (vstride0 == 0)
    vstride0 = 1;
  rstride0 = rstride[0];
  mstride0 = mstride[0];
  rptr = ret->data;
  vptr = vector->data;

  while (rptr)
    {
      if (*mptr)
        {
	  /* From vector.  */
	  *rptr = *vptr;
	  vptr += vstride0;
        }
      else
        {
	  /* From field.  */
	  *rptr = fval;
        }
      /* Advance to the next element.  */
      rptr += rstride0;
      mptr += mstride0;
      count[0]++;
      n = 0;
      while (count[n] == extent[n])
        {
          /* 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.  */
          rptr -= rstride[n] * extent[n];
          mptr -= mstride[n] * extent[n];
          n++;
          if (n >= dim)
            {
              /* Break out of the loop.  */
              rptr = NULL;
              break;
            }
          else
            {
              count[n]++;
              rptr += rstride[n];
              mptr += mstride[n];
            }
        }
    }
}
Beispiel #28
0
static void
transpose_internal (gfc_array_char *ret, gfc_array_char *source)
{
    /* r.* indicates the return array.  */
    index_type rxstride, rystride;
    char *rptr;
    /* s.* indicates the source array.  */
    index_type sxstride, systride;
    const char *sptr;

    index_type xcount, ycount;
    index_type x, y;
    index_type size;

    assert (GFC_DESCRIPTOR_RANK (source) == 2
            && GFC_DESCRIPTOR_RANK (ret) == 2);

    size = GFC_DESCRIPTOR_SIZE(ret);

    if (ret->base_addr == NULL)
    {
        assert (ret->dtype == source->dtype);

        GFC_DIMENSION_SET(ret->dim[0], 0, GFC_DESCRIPTOR_EXTENT(source,1) - 1,
                          1);

        GFC_DIMENSION_SET(ret->dim[1], 0, GFC_DESCRIPTOR_EXTENT(source,0) - 1,
                          GFC_DESCRIPTOR_EXTENT(source, 1));

        ret->base_addr = xmallocarray (size0 ((array_t*)ret), size);
        ret->offset = 0;
    }
    else if (unlikely (compile_options.bounds_check))
    {
        index_type ret_extent, src_extent;

        ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0);
        src_extent = GFC_DESCRIPTOR_EXTENT(source,1);

        if (src_extent != ret_extent)
            runtime_error ("Incorrect extent in return value of TRANSPOSE"
                           " intrinsic in dimension 1: is %ld,"
                           " should be %ld", (long int) src_extent,
                           (long int) ret_extent);

        ret_extent = GFC_DESCRIPTOR_EXTENT(ret,1);
        src_extent = GFC_DESCRIPTOR_EXTENT(source,0);

        if (src_extent != ret_extent)
            runtime_error ("Incorrect extent in return value of TRANSPOSE"
                           " intrinsic in dimension 2: is %ld,"
                           " should be %ld", (long int) src_extent,
                           (long int) ret_extent);

    }

    sxstride = GFC_DESCRIPTOR_STRIDE_BYTES(source,0);
    systride = GFC_DESCRIPTOR_STRIDE_BYTES(source,1);
    xcount = GFC_DESCRIPTOR_EXTENT(source,0);
    ycount = GFC_DESCRIPTOR_EXTENT(source,1);

    rxstride = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
    rystride = GFC_DESCRIPTOR_STRIDE_BYTES(ret,1);

    rptr = ret->base_addr;
    sptr = source->base_addr;

    for (y = 0; y < ycount; y++)
    {
        for (x = 0; x < xcount; x++)
        {
            memcpy (rptr, sptr, size);

            sptr += sxstride;
            rptr += rystride;
        }
        sptr += systride - (sxstride * xcount);
        rptr += rxstride - (rystride * xcount);
    }
}
Beispiel #29
0
void
unpack1_r4 (gfc_array_r4 *ret, const gfc_array_r4 *vector,
		 const gfc_array_l1 *mask, const gfc_array_r4 *field)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type rs;
  GFC_REAL_4 * restrict rptr;
  /* v.* indicates the vector array.  */
  index_type vstride0;
  GFC_REAL_4 *vptr;
  /* f.* indicates the field array.  */
  index_type fstride[GFC_MAX_DIMENSIONS];
  index_type fstride0;
  const GFC_REAL_4 *fptr;
  /* m.* indicates the mask array.  */
  index_type mstride[GFC_MAX_DIMENSIONS];
  index_type mstride0;
  const GFC_LOGICAL_1 *mptr;

  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type n;
  index_type dim;

  int empty;
  int mask_kind;

  empty = 0;

  mptr = mask->base_addr;

  /* Use the same loop for all logical types, by using GFC_LOGICAL_1
     and using shifting to address size and endian issues.  */

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
      || mask_kind == 16
#endif
      )
    {
      /*  Do not convert a NULL pointer as we use test for NULL below.  */
      if (mptr)
	mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
    }
  else
    runtime_error ("Funny sized logical array");

  if (ret->base_addr == NULL)
    {
      /* The front end has signalled that we need to populate the
	 return array descriptor.  */
      dim = GFC_DESCRIPTOR_RANK (mask);
      rs = 1;
      for (n = 0; n < dim; n++)
	{
	  count[n] = 0;
	  GFC_DIMENSION_SET(ret->dim[n], 0,
			    GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
	  extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
	  empty = empty || extent[n] <= 0;
	  rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
	  fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
	  mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	  rs *= extent[n];
	}
      ret->offset = 0;
      ret->base_addr = xmallocarray (rs, sizeof (GFC_REAL_4));
    }
  else
    {
      dim = GFC_DESCRIPTOR_RANK (ret);
      for (n = 0; n < dim; n++)
	{
	  count[n] = 0;
	  extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
	  empty = empty || extent[n] <= 0;
	  rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);
	  fstride[n] = GFC_DESCRIPTOR_STRIDE(field,n);
	  mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	}
      if (rstride[0] == 0)
	rstride[0] = 1;
    }

  if (empty)
    return;

  if (fstride[0] == 0)
    fstride[0] = 1;
  if (mstride[0] == 0)
    mstride[0] = 1;

  vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);
  if (vstride0 == 0)
    vstride0 = 1;
  rstride0 = rstride[0];
  fstride0 = fstride[0];
  mstride0 = mstride[0];
  rptr = ret->base_addr;
  fptr = field->base_addr;
  vptr = vector->base_addr;

  while (rptr)
    {
      if (*mptr)
        {
          /* From vector.  */
	  *rptr = *vptr;
          vptr += vstride0;
        }
      else
        {
          /* From field.  */
	  *rptr = *fptr;
        }
      /* Advance to the next element.  */
      rptr += rstride0;
      fptr += fstride0;
      mptr += mstride0;
      count[0]++;
      n = 0;
      while (count[n] == extent[n])
        {
          /* 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.  */
          rptr -= rstride[n] * extent[n];
          fptr -= fstride[n] * extent[n];
          mptr -= mstride[n] * extent[n];
          n++;
          if (n >= dim)
            {
              /* Break out of the loop.  */
              rptr = NULL;
              break;
            }
          else
            {
              count[n]++;
              rptr += rstride[n];
              fptr += fstride[n];
              mptr += mstride[n];
            }
        }
    }
}
void
spread_scalar (gfc_array_char *ret, const char *source,
	       const index_type *along, const index_type *pncopies)
{
  index_type type_size;

  if (!ret->dtype)
    runtime_error ("return array missing descriptor in spread()");

  type_size = GFC_DTYPE_TYPE_SIZE(ret);
  switch(type_size)
    {
    case GFC_DTYPE_DERIVED_1:
    case GFC_DTYPE_LOGICAL_1:
    case GFC_DTYPE_INTEGER_1:
      spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
			*along, *pncopies);
      return;

    case GFC_DTYPE_LOGICAL_2:
    case GFC_DTYPE_INTEGER_2:
      spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
			*along, *pncopies);
      return;

    case GFC_DTYPE_LOGICAL_4:
    case GFC_DTYPE_INTEGER_4:
      spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
			*along, *pncopies);
      return;

    case GFC_DTYPE_LOGICAL_8:
    case GFC_DTYPE_INTEGER_8:
      spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
			*along, *pncopies);
      return;

#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_LOGICAL_16:
    case GFC_DTYPE_INTEGER_16:
      spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
			*along, *pncopies);
      return;
#endif

    case GFC_DTYPE_REAL_4:
      spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source,
			*along, *pncopies);
      return;

    case GFC_DTYPE_REAL_8:
      spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source,
			*along, *pncopies);
      return;

#ifdef HAVE_GFC_REAL_10
    case GFC_DTYPE_REAL_10:
      spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source,
			*along, *pncopies);
      return;
#endif

#ifdef HAVE_GFC_REAL_16
    case GFC_DTYPE_REAL_16:
      spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source,
			*along, *pncopies);
      return;
#endif

    case GFC_DTYPE_COMPLEX_4:
      spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source,
			*along, *pncopies);
      return;

    case GFC_DTYPE_COMPLEX_8:
      spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source,
			*along, *pncopies);
      return;

#ifdef HAVE_GFC_COMPLEX_10
    case GFC_DTYPE_COMPLEX_10:
      spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source,
			*along, *pncopies);
      return;
#endif

#ifdef HAVE_GFC_COMPLEX_16
    case GFC_DTYPE_COMPLEX_16:
      spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source,
			*along, *pncopies);
      return;
#endif

    case GFC_DTYPE_DERIVED_2:
      if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(source))
	break;
      else
	{
	  spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
			    *along, *pncopies);
	  return;
	}

    case GFC_DTYPE_DERIVED_4:
      if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(source))
	break;
      else
	{
	  spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
			    *along, *pncopies);
	  return;
	}

    case GFC_DTYPE_DERIVED_8:
      if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(source))
	break;
      else
	{
	  spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
			    *along, *pncopies);
	  return;
	}
#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_DERIVED_16:
      if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(source))
	break;
      else
	{
	  spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
			     *along, *pncopies);
	  return;
	}
#endif
    }

  spread_internal_scalar (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (ret));
}