Beispiel #1
0
bool
gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index,
		       mpz_t *repeat)
{
  gfc_ref *ref;
  gfc_expr *init;
  gfc_expr *expr = NULL;
  gfc_constructor *con;
  gfc_constructor *last_con;
  gfc_symbol *symbol;
  gfc_typespec *last_ts;
  mpz_t offset;

  symbol = lvalue->symtree->n.sym;
  init = symbol->value;
  last_ts = &symbol->ts;
  last_con = NULL;
  mpz_init_set_si (offset, 0);

  /* Find/create the parent expressions for subobject references.  */
  for (ref = lvalue->ref; ref; ref = ref->next)
    {
      /* Break out of the loop if we find a substring.  */
      if (ref->type == REF_SUBSTRING)
	{
	  /* A substring should always be the last subobject reference.  */
	  gcc_assert (ref->next == NULL);
	  break;
	}

      /* Use the existing initializer expression if it exists.  Otherwise
	 create a new one.  */
      if (init == NULL)
	expr = gfc_get_expr ();
      else
	expr = init;

      /* Find or create this element.  */
      switch (ref->type)
	{
	case REF_ARRAY:
	  if (ref->u.ar.as->rank == 0)
	    {
	      gcc_assert (ref->u.ar.as->corank > 0);
	      if (init == NULL)
		free (expr);
	      continue;
	    }

	  if (init && expr->expr_type != EXPR_ARRAY)
	    {
	      gfc_error ("%qs at %L already is initialized at %L",
			 lvalue->symtree->n.sym->name, &lvalue->where,
			 &init->where);
	      goto abort;
	    }

	  if (init == NULL)
	    {
	      /* The element typespec will be the same as the array
		 typespec.  */
	      expr->ts = *last_ts;
	      /* Setup the expression to hold the constructor.  */
	      expr->expr_type = EXPR_ARRAY;
	      expr->rank = ref->u.ar.as->rank;
	    }

	  if (ref->u.ar.type == AR_ELEMENT)
	    get_array_index (&ref->u.ar, &offset);
	  else
	    mpz_set (offset, index);

	  /* Check the bounds.  */
	  if (mpz_cmp_si (offset, 0) < 0)
	    {
	      gfc_error ("Data element below array lower bound at %L",
			 &lvalue->where);
	      goto abort;
	    }
	  else if (repeat != NULL
		   && ref->u.ar.type != AR_ELEMENT)
	    {
	      mpz_t size, end;
	      gcc_assert (ref->u.ar.type == AR_FULL
			  && ref->next == NULL);
	      mpz_init_set (end, offset);
	      mpz_add (end, end, *repeat);
	      if (spec_size (ref->u.ar.as, &size))
		{
		  if (mpz_cmp (end, size) > 0)
		    {
		      mpz_clear (size);
		      gfc_error ("Data element above array upper bound at %L",
				 &lvalue->where);
		      goto abort;
		    }
		  mpz_clear (size);
		}

	      con = gfc_constructor_lookup (expr->value.constructor,
					    mpz_get_si (offset));
	      if (!con)
		{
		  con = gfc_constructor_lookup_next (expr->value.constructor,
						     mpz_get_si (offset));
		  if (con != NULL && mpz_cmp (con->offset, end) >= 0)
		    con = NULL;
		}

	      /* Overwriting an existing initializer is non-standard but
		 usually only provokes a warning from other compilers.  */
	      if (con != NULL && con->expr != NULL)
		{
		  /* Order in which the expressions arrive here depends on
		     whether they are from data statements or F95 style
		     declarations.  Therefore, check which is the most
		     recent.  */
		  gfc_expr *exprd;
		  exprd = (LOCATION_LINE (con->expr->where.lb->location)
			   > LOCATION_LINE (rvalue->where.lb->location))
			  ? con->expr : rvalue;
		  if (gfc_notify_std (GFC_STD_GNU,
				      "re-initialization of %qs at %L",
				      symbol->name, &exprd->where) == false)
		    return false;
		}

	      while (con != NULL)
		{
		  gfc_constructor *next_con = gfc_constructor_next (con);

		  if (mpz_cmp (con->offset, end) >= 0)
		    break;
		  if (mpz_cmp (con->offset, offset) < 0)
		    {
		      gcc_assert (mpz_cmp_si (con->repeat, 1) > 0);
		      mpz_sub (con->repeat, offset, con->offset);
		    }
		  else if (mpz_cmp_si (con->repeat, 1) > 0
			   && mpz_get_si (con->offset)
			      + mpz_get_si (con->repeat) > mpz_get_si (end))
		    {
		      int endi;
		      splay_tree_node node
			= splay_tree_lookup (con->base,
					     mpz_get_si (con->offset));
		      gcc_assert (node
				  && con == (gfc_constructor *) node->value
				  && node->key == (splay_tree_key)
						  mpz_get_si (con->offset));
		      endi = mpz_get_si (con->offset)
			     + mpz_get_si (con->repeat);
		      if (endi > mpz_get_si (end) + 1)
			mpz_set_si (con->repeat, endi - mpz_get_si (end));
		      else
			mpz_set_si (con->repeat, 1);
		      mpz_set (con->offset, end);
		      node->key = (splay_tree_key) mpz_get_si (end);
		      break;
		    }
		  else
		    gfc_constructor_remove (con);
		  con = next_con;
		}

	      con = gfc_constructor_insert_expr (&expr->value.constructor,
						 NULL, &rvalue->where,
						 mpz_get_si (offset));
	      mpz_set (con->repeat, *repeat);
	      repeat = NULL;
	      mpz_clear (end);
	      break;
	    }
	  else
	    {
	      mpz_t size;
	      if (spec_size (ref->u.ar.as, &size))
		{
		  if (mpz_cmp (offset, size) >= 0)
		    {
		      mpz_clear (size);
		      gfc_error ("Data element above array upper bound at %L",
		                 &lvalue->where);
		      goto abort;
		    }
		  mpz_clear (size);
		}
	    }

	  con = gfc_constructor_lookup (expr->value.constructor,
					mpz_get_si (offset));
	  if (!con)
	    {
	      con = gfc_constructor_insert_expr (&expr->value.constructor,
						 NULL, &rvalue->where,
						 mpz_get_si (offset));
	    }
	  else if (mpz_cmp_si (con->repeat, 1) > 0)
	    {
	      /* Need to split a range.  */
	      if (mpz_cmp (con->offset, offset) < 0)
		{
		  gfc_constructor *pred_con = con;
		  con = gfc_constructor_insert_expr (&expr->value.constructor,
						     NULL, &con->where,
						     mpz_get_si (offset));
		  con->expr = gfc_copy_expr (pred_con->expr);
		  mpz_add (con->repeat, pred_con->offset, pred_con->repeat);
		  mpz_sub (con->repeat, con->repeat, offset);
		  mpz_sub (pred_con->repeat, offset, pred_con->offset);
		}
	      if (mpz_cmp_si (con->repeat, 1) > 0)
		{
		  gfc_constructor *succ_con;
		  succ_con
		    = gfc_constructor_insert_expr (&expr->value.constructor,
						   NULL, &con->where,
						   mpz_get_si (offset) + 1);
		  succ_con->expr = gfc_copy_expr (con->expr);
		  mpz_sub_ui (succ_con->repeat, con->repeat, 1);
		  mpz_set_si (con->repeat, 1);
		}
	    }
	  break;

	case REF_COMPONENT:
	  if (init == NULL)
	    {
	      /* Setup the expression to hold the constructor.  */
	      expr->expr_type = EXPR_STRUCTURE;
	      expr->ts.type = BT_DERIVED;
	      expr->ts.u.derived = ref->u.c.sym;
	    }
	  else
	    gcc_assert (expr->expr_type == EXPR_STRUCTURE);
	  last_ts = &ref->u.c.component->ts;

	  /* Find the same element in the existing constructor.  */
	  con = find_con_by_component (ref->u.c.component,
				       expr->value.constructor);

	  if (con == NULL)
	    {
	      /* Create a new constructor.  */
	      con = gfc_constructor_append_expr (&expr->value.constructor,
						 NULL, NULL);
	      con->n.component = ref->u.c.component;
	    }
	  break;

	default:
	  gcc_unreachable ();
	}

      if (init == NULL)
	{
	  /* Point the container at the new expression.  */
	  if (last_con == NULL)
	    symbol->value = expr;
	  else
	    last_con->expr = expr;
	}
      init = con->expr;
      last_con = con;
    }

  mpz_clear (offset);
  gcc_assert (repeat == NULL);

  if (ref || last_ts->type == BT_CHARACTER)
    {
      if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
	return false;
      expr = create_character_initializer (init, last_ts, ref, rvalue);
    }
  else
    {
      /* Overwriting an existing initializer is non-standard but usually only
	 provokes a warning from other compilers.  */
      if (init != NULL)
	{
	  /* Order in which the expressions arrive here depends on whether
	     they are from data statements or F95 style declarations.
	     Therefore, check which is the most recent.  */
	  expr = (LOCATION_LINE (init->where.lb->location)
		  > LOCATION_LINE (rvalue->where.lb->location))
	       ? init : rvalue;
	  if (gfc_notify_std (GFC_STD_GNU,
			      "re-initialization of %qs at %L",
			      symbol->name, &expr->where) == false)
	    return false;
	}

      expr = gfc_copy_expr (rvalue);
      if (!gfc_compare_types (&lvalue->ts, &expr->ts))
	gfc_convert_type (expr, &lvalue->ts, 0);
    }

  if (last_con == NULL)
    symbol->value = expr;
  else
    last_con->expr = expr;

  return true;

abort:
  if (!init)
    gfc_free_expr (expr);
  mpz_clear (offset);
  return false;
}
Beispiel #2
0
void
gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
{
    gfc_ref *ref;
    gfc_expr *init;
    gfc_expr *expr;
    gfc_constructor *con;
    gfc_constructor *last_con;
    gfc_symbol *symbol;
    gfc_typespec *last_ts;
    mpz_t offset;

    symbol = lvalue->symtree->n.sym;
    init = symbol->value;
    last_ts = &symbol->ts;
    last_con = NULL;
    mpz_init_set_si (offset, 0);

    /* Find/create the parent expressions for subobject references.  */
    for (ref = lvalue->ref; ref; ref = ref->next)
    {
        /* Break out of the loop if we find a substring.  */
        if (ref->type == REF_SUBSTRING)
        {
            /* A substring should always be the last subobject reference.  */
            gcc_assert (ref->next == NULL);
            break;
        }

        /* Use the existing initializer expression if it exists.  Otherwise
           create a new one.  */
        if (init == NULL)
            expr = gfc_get_expr ();
        else
            expr = init;

        /* Find or create this element.  */
        switch (ref->type)
        {
        case REF_ARRAY:
            if (init == NULL)
            {
                /* The element typespec will be the same as the array
                typespec.  */
                expr->ts = *last_ts;
                /* Setup the expression to hold the constructor.  */
                expr->expr_type = EXPR_ARRAY;
                expr->rank = ref->u.ar.as->rank;
            }
            else
                gcc_assert (expr->expr_type == EXPR_ARRAY);

            if (ref->u.ar.type == AR_ELEMENT)
                get_array_index (&ref->u.ar, &offset);
            else
                mpz_set (offset, index);

            /* Find the same element in the existing constructor.  */
            con = expr->value.constructor;
            con = find_con_by_offset (offset, con);

            if (con == NULL)
            {
                /* Create a new constructor.  */
                con = gfc_get_constructor ();
                mpz_set (con->n.offset, offset);
                gfc_insert_constructor (expr, con);
            }
            break;

        case REF_COMPONENT:
            if (init == NULL)
            {
                /* Setup the expression to hold the constructor.  */
                expr->expr_type = EXPR_STRUCTURE;
                expr->ts.type = BT_DERIVED;
                expr->ts.derived = ref->u.c.sym;
            }
            else
                gcc_assert (expr->expr_type == EXPR_STRUCTURE);
            last_ts = &ref->u.c.component->ts;

            /* Find the same element in the existing constructor.  */
            con = expr->value.constructor;
            con = find_con_by_component (ref->u.c.component, con);

            if (con == NULL)
            {
                /* Create a new constructor.  */
                con = gfc_get_constructor ();
                con->n.component = ref->u.c.component;
                con->next = expr->value.constructor;
                expr->value.constructor = con;
            }
            break;

        default:
            gcc_unreachable ();
        }

        if (init == NULL)
        {
            /* Point the container at the new expression.  */
            if (last_con == NULL)
                symbol->value = expr;
            else
                last_con->expr = expr;
        }
        init = con->expr;
        last_con = con;
    }

    if (ref || last_ts->type == BT_CHARACTER)
        expr = create_character_intializer (init, last_ts, ref, rvalue);
    else
    {
        /* Overwriting an existing initializer is non-standard but usually only
        provokes a warning from other compilers.  */
        if (init != NULL)
        {
            /* Order in which the expressions arrive here depends on whether they
               are from data statements or F95 style declarations. Therefore,
               check which is the most recent.  */
#ifdef USE_MAPPED_LOCATION
            expr = (LOCATION_LINE (init->where.lb->location)
                    > LOCATION_LINE (rvalue->where.lb->location))
                   ? init : rvalue;
#else
            expr = (init->where.lb->linenum > rvalue->where.lb->linenum) ?
                   init : rvalue;
#endif
            gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization "
                            "of '%s' at %L",  symbol->name, &expr->where);
        }

        expr = gfc_copy_expr (rvalue);
        if (!gfc_compare_types (&lvalue->ts, &expr->ts))
            gfc_convert_type (expr, &lvalue->ts, 0);
    }

    if (last_con == NULL)
        symbol->value = expr;
    else
        last_con->expr = expr;
}
gfc_try
gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
{
  gfc_ref *ref;
  gfc_expr *init;
  gfc_expr *expr;
  gfc_constructor *con;
  gfc_constructor *last_con;
  gfc_constructor *pred;
  gfc_symbol *symbol;
  gfc_typespec *last_ts;
  mpz_t offset;
  splay_tree spt;
  splay_tree_node sptn;

  symbol = lvalue->symtree->n.sym;
  init = symbol->value;
  last_ts = &symbol->ts;
  last_con = NULL;
  mpz_init_set_si (offset, 0);

  /* Find/create the parent expressions for subobject references.  */
  for (ref = lvalue->ref; ref; ref = ref->next)
    {
      /* Break out of the loop if we find a substring.  */
      if (ref->type == REF_SUBSTRING)
	{
	  /* A substring should always be the last subobject reference.  */
	  gcc_assert (ref->next == NULL);
	  break;
	}

      /* Use the existing initializer expression if it exists.  Otherwise
	 create a new one.  */
      if (init == NULL)
	expr = gfc_get_expr ();
      else
	expr = init;

      /* Find or create this element.  */
      switch (ref->type)
	{
	case REF_ARRAY:
	  if (init && expr->expr_type != EXPR_ARRAY)
	    {
	      gfc_error ("'%s' at %L already is initialized at %L",
			 lvalue->symtree->n.sym->name, &lvalue->where,
			 &init->where);
	      return FAILURE;
	    }

	  if (init == NULL)
	    {
	      /* The element typespec will be the same as the array
		 typespec.  */
	      expr->ts = *last_ts;
	      /* Setup the expression to hold the constructor.  */
	      expr->expr_type = EXPR_ARRAY;
	      expr->rank = ref->u.ar.as->rank;
	    }

	  if (ref->u.ar.type == AR_ELEMENT)
	    get_array_index (&ref->u.ar, &offset);
	  else
	    mpz_set (offset, index);

	  /* Check the bounds.  */
	  if (mpz_cmp_si (offset, 0) < 0)
	    {
	      gfc_error ("Data element below array lower bound at %L",
			 &lvalue->where);
	      return FAILURE;
	    }
	  else
	    {
	      mpz_t size;
	      if (spec_size (ref->u.ar.as, &size) == SUCCESS)
		{
		  if (mpz_cmp (offset, size) >= 0)
		  {
		    mpz_clear (size);
		    gfc_error ("Data element above array upper bound at %L",
			       &lvalue->where);
		    return FAILURE;
		  }
		  mpz_clear (size);
		}
	    }

	  /* Splay tree containing offset and gfc_constructor.  */
	  spt = expr->con_by_offset;

	  if (spt == NULL)
	    {
	       spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL);
	       expr->con_by_offset = spt; 
	       con = NULL;
	    }
	 else
	  con = find_con_by_offset (spt, offset);

	  if (con == NULL)
	    {
	      splay_tree_key j;

	      /* Create a new constructor.  */
	      con = gfc_get_constructor ();
	      mpz_set (con->n.offset, offset);
	      j = (splay_tree_key) mpz_get_si (offset);
	      sptn = splay_tree_insert (spt, j, (splay_tree_value) con);
	      /* Fix up the linked list.  */
	      sptn = splay_tree_predecessor (spt, j);
	      if (sptn == NULL)
		{  /* Insert at the head.  */
		   con->next = expr->value.constructor;
		   expr->value.constructor = con;
		}
	      else
		{  /* Insert in the chain.  */
		   pred = (gfc_constructor*) sptn->value;
		   con->next = pred->next;
		   pred->next = con;
		}
	    }
	  break;

	case REF_COMPONENT:
	  if (init == NULL)
	    {
	      /* Setup the expression to hold the constructor.  */
	      expr->expr_type = EXPR_STRUCTURE;
	      expr->ts.type = BT_DERIVED;
	      expr->ts.derived = ref->u.c.sym;
	    }
	  else
	    gcc_assert (expr->expr_type == EXPR_STRUCTURE);
	  last_ts = &ref->u.c.component->ts;

	  /* Find the same element in the existing constructor.  */
	  con = expr->value.constructor;
	  con = find_con_by_component (ref->u.c.component, con);

	  if (con == NULL)
	    {
	      /* Create a new constructor.  */
	      con = gfc_get_constructor ();
	      con->n.component = ref->u.c.component;
	      con->next = expr->value.constructor;
	      expr->value.constructor = con;
	    }
	  break;

	default:
	  gcc_unreachable ();
	}

      if (init == NULL)
	{
	  /* Point the container at the new expression.  */
	  if (last_con == NULL)
	    symbol->value = expr;
	  else
	    last_con->expr = expr;
	}
      init = con->expr;
      last_con = con;
    }

  if (ref || last_ts->type == BT_CHARACTER)
    expr = create_character_intializer (init, last_ts, ref, rvalue);
  else
    {
      /* Overwriting an existing initializer is non-standard but usually only
	 provokes a warning from other compilers.  */
      if (init != NULL)
	{
	  /* Order in which the expressions arrive here depends on whether
	     they are from data statements or F95 style declarations.
	     Therefore, check which is the most recent.  */
	  expr = (LOCATION_LINE (init->where.lb->location)
		  > LOCATION_LINE (rvalue->where.lb->location))
	       ? init : rvalue;
	  gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization "
			  "of '%s' at %L", symbol->name, &expr->where);
	}

      expr = gfc_copy_expr (rvalue);
      if (!gfc_compare_types (&lvalue->ts, &expr->ts))
	gfc_convert_type (expr, &lvalue->ts, 0);
    }

  if (last_con == NULL)
    symbol->value = expr;
  else
    last_con->expr = expr;

  return SUCCESS;
}