Exemple #1
0
static void
get_array_index (gfc_array_ref *ar, mpz_t *offset)
{
  gfc_expr *e;
  int i;
  mpz_t delta;
  mpz_t tmp;

  mpz_init (tmp);
  mpz_set_si (*offset, 0);
  mpz_init_set_si (delta, 1);
  for (i = 0; i < ar->dimen; i++)
    {
      e = gfc_copy_expr (ar->start[i]);
      gfc_simplify_expr (e, 1);

      if ((gfc_is_constant_expr (ar->as->lower[i]) == 0)
	  || (gfc_is_constant_expr (ar->as->upper[i]) == 0)
	  || (gfc_is_constant_expr (e) == 0))
	gfc_error ("non-constant array in DATA statement %L", &ar->where);

      mpz_set (tmp, e->value.integer);
      gfc_free_expr (e);
      mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
      mpz_mul (tmp, tmp, delta);
      mpz_add (*offset, tmp, *offset);

      mpz_sub (tmp, ar->as->upper[i]->value.integer,
	       ar->as->lower[i]->value.integer);
      mpz_add_ui (tmp, tmp, 1);
      mpz_mul (delta, tmp, delta);
    }
  mpz_clear (delta);
  mpz_clear (tmp);
}
Exemple #2
0
static void
get_array_index (gfc_array_ref * ar, mpz_t * offset)
{
    gfc_expr *e;
    int i;
    try re;
    mpz_t delta;
    mpz_t tmp;

    mpz_init (tmp);
    mpz_set_si (*offset, 0);
    mpz_init_set_si (delta, 1);
    for (i = 0; i < ar->dimen; i++)
    {
        e = gfc_copy_expr (ar->start[i]);
        re = gfc_simplify_expr (e, 1);

        if ((gfc_is_constant_expr (ar->as->lower[i]) == 0)
                || (gfc_is_constant_expr (ar->as->upper[i]) == 0)
                || (gfc_is_constant_expr (e) == 0))
            gfc_error ("non-constant array in DATA statement %L.", &ar->where);
        mpz_set (tmp, e->value.integer);
        mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
        mpz_mul (tmp, tmp, delta);
        mpz_add (*offset, tmp, *offset);

        mpz_sub (tmp, ar->as->upper[i]->value.integer,
                 ar->as->lower[i]->value.integer);
        mpz_add_ui (tmp, tmp, 1);
        mpz_mul (delta, tmp, delta);
    }
    mpz_clear (delta);
    mpz_clear (tmp);
}


/* Find if there is a constructor which offset is equal to OFFSET.  */

static gfc_constructor *
find_con_by_offset (mpz_t offset, gfc_constructor *con)
{
    mpz_t tmp;
    gfc_constructor *ret = NULL;

    mpz_init (tmp);

    for (; con; con = con->next)
    {
        int cmp = mpz_cmp (offset, con->n.offset);

        /* We retain a sorted list, so if we're too large, we're done.  */
        if (cmp < 0)
            break;

        /* Yaye for exact matches.  */
        if (cmp == 0)
        {
            ret = con;
            break;
        }

        /* If the constructor element is a range, match any element.  */
        if (mpz_cmp_ui (con->repeat, 1) > 0)
        {
            mpz_add (tmp, con->n.offset, con->repeat);
            if (mpz_cmp (offset, tmp) < 0)
            {
                ret = con;
                break;
            }
        }
    }

    mpz_clear (tmp);
    return ret;
}
Exemple #3
0
static gfc_expr *
create_character_intializer (gfc_expr * init, gfc_typespec * ts,
                             gfc_ref * ref, gfc_expr * rvalue)
{
    int len;
    int start;
    int end;
    char *dest;

    gfc_extract_int (ts->cl->length, &len);

    if (init == NULL)
    {
        /* Create a new initializer.  */
        init = gfc_get_expr ();
        init->expr_type = EXPR_CONSTANT;
        init->ts = *ts;

        dest = gfc_getmem (len + 1);
        dest[len] = '\0';
        init->value.character.length = len;
        init->value.character.string = dest;
        /* Blank the string if we're only setting a substring.  */
        if (ref != NULL)
            memset (dest, ' ', len);
    }
    else
        dest = init->value.character.string;

    if (ref)
    {
        gfc_expr *start_expr, *end_expr;

        gcc_assert (ref->type == REF_SUBSTRING);

        /* Only set a substring of the destination.  Fortran substring bounds
           are one-based [start, end], we want zero based [start, end).  */
        start_expr = gfc_copy_expr (ref->u.ss.start);
        end_expr = gfc_copy_expr (ref->u.ss.end);

        if ((gfc_simplify_expr (start_expr, 1) == FAILURE)
                || (gfc_simplify_expr (end_expr, 1)) == FAILURE)
        {
            gfc_error ("failure to simplify substring reference in DATA"
                       "statement at %L", &ref->u.ss.start->where);
            return NULL;
        }

        gfc_extract_int (start_expr, &start);
        start--;
        gfc_extract_int (end_expr, &end);
    }
    else
    {
        /* Set the whole string.  */
        start = 0;
        end = len;
    }

    /* Copy the initial value.  */
    len = rvalue->value.character.length;
    if (len > end - start)
    {
        len = end - start;
        gfc_warning_now ("initialization string truncated to match variable "
                         "at %L", &rvalue->where);
    }

    memcpy (&dest[start], rvalue->value.character.string, len);

    /* Pad with spaces.  Substrings will already be blanked.  */
    if (len < end - start && ref == NULL)
        memset (&dest[start + len], ' ', end - (start + len));

    if (rvalue->ts.type == BT_HOLLERITH)
        init->from_H = 1;

    return init;
}
Exemple #4
0
static gfc_expr *
create_character_initializer (gfc_expr *init, gfc_typespec *ts,
			      gfc_ref *ref, gfc_expr *rvalue)
{
  int len, start, end, tlen;
  gfc_char_t *dest;
  bool alloced_init = false;
	    
  gfc_extract_int (ts->u.cl->length, &len);

  if (init == NULL)
    {
      /* Create a new initializer.  */
      init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
      init->ts = *ts;
      alloced_init = true;
    }

  dest = init->value.character.string;

  if (ref)
    {
      gfc_expr *start_expr, *end_expr;

      gcc_assert (ref->type == REF_SUBSTRING);

      /* Only set a substring of the destination.  Fortran substring bounds
	 are one-based [start, end], we want zero based [start, end).  */
      start_expr = gfc_copy_expr (ref->u.ss.start);
      end_expr = gfc_copy_expr (ref->u.ss.end);

      if ((!gfc_simplify_expr(start_expr, 1))
	  || !(gfc_simplify_expr(end_expr, 1)))
	{
	  gfc_error ("failure to simplify substring reference in DATA "
		     "statement at %L", &ref->u.ss.start->where);
	  gfc_free_expr (start_expr);
	  gfc_free_expr (end_expr);
	  if (alloced_init)
	    gfc_free_expr (init);
	  return NULL;
	}

      gfc_extract_int (start_expr, &start);
      gfc_free_expr (start_expr);
      start--;
      gfc_extract_int (end_expr, &end);
      gfc_free_expr (end_expr);
    }
  else
    {
      /* Set the whole string.  */
      start = 0;
      end = len;
    }

  /* Copy the initial value.  */
  if (rvalue->ts.type == BT_HOLLERITH)
    len = rvalue->representation.length - rvalue->ts.u.pad;
  else
    len = rvalue->value.character.length;

  tlen = end - start;
  if (len > tlen)
    {
      if (tlen < 0)
	{
	  gfc_warning_now (0, "Unused initialization string at %L because "
			   "variable has zero length", &rvalue->where);
	  len = 0;
	}
      else
	{
	  gfc_warning_now (0, "Initialization string at %L was truncated to "
			   "fit the variable (%d/%d)", &rvalue->where,
			   tlen, len);
	  len = tlen;
	}
    }

  if (rvalue->ts.type == BT_HOLLERITH)
    {
      int i;
      for (i = 0; i < len; i++)
	dest[start+i] = rvalue->representation.string[i];
    }
  else
    memcpy (&dest[start], rvalue->value.character.string,
	    len * sizeof (gfc_char_t));

  /* Pad with spaces.  Substrings will already be blanked.  */
  if (len < tlen && ref == NULL)
    gfc_wide_memset (&dest[start + len], ' ', end - (start + len));

  if (rvalue->ts.type == BT_HOLLERITH)
    {
      init->representation.length = init->value.character.length;
      init->representation.string
	= gfc_widechar_to_char (init->value.character.string,
				init->value.character.length);
    }

  return init;
}