예제 #1
0
파일: data.c 프로젝트: chinabin/gcc-tiny
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);
}
예제 #2
0
파일: array.c 프로젝트: 5432935/crossbridge
gfc_array_ref *
gfc_copy_array_ref (gfc_array_ref * src)
{
  gfc_array_ref *dest;
  int i;

  if (src == NULL)
    return NULL;

  dest = gfc_get_array_ref ();

  *dest = *src;

  for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
    {
      dest->start[i] = gfc_copy_expr (src->start[i]);
      dest->end[i] = gfc_copy_expr (src->end[i]);
      dest->stride[i] = gfc_copy_expr (src->stride[i]);
    }

  dest->offset = gfc_copy_expr (src->offset);

  return dest;
}
예제 #3
0
static gfc_constructor *
node_copy (splay_tree_node node, void *base)
{
  gfc_constructor *c, *src = (gfc_constructor*)node->value;

  c = XCNEW (gfc_constructor);
  c->base = (gfc_constructor_base)base;
  c->expr = gfc_copy_expr (src->expr);
  c->iterator = gfc_copy_iterator (src->iterator);
  c->where = src->where;
  c->n.component = src->n.component;

  mpz_init_set (c->offset, src->offset);
  mpz_init_set (c->repeat, src->repeat);

  return c;
}
예제 #4
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;
}
예제 #5
0
void
gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue,
                             mpz_t index, mpz_t repeat)
{
    gfc_ref *ref;
    gfc_expr *init, *expr;
    gfc_constructor *con, *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)
    {
        /* 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);

                /* This had better not be the bottom of the reference.
                We can still get to a full array via a component.  */
                gcc_assert (ref->next != NULL);
            }
            else
            {
                mpz_set (offset, index);

                /* We're at a full array or an array section.  This means
                that we've better have found a full array, and that we're
                 at the bottom of the reference.  */
                gcc_assert (ref->u.ar.type == AR_FULL);
                gcc_assert (ref->next == NULL);
            }

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

            /* Create a new constructor.  */
            if (con == NULL)
            {
                con = gfc_get_constructor ();
                mpz_set (con->n.offset, offset);
                if (ref->next == NULL)
                    mpz_set (con->repeat, repeat);
                gfc_insert_constructor (expr, con);
            }
            else
                gcc_assert (ref->next != NULL);
            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;
            }

            /* Since we're only intending to initialize arrays here,
               there better be an inner reference.  */
            gcc_assert (ref->next != NULL);
            break;

        case REF_SUBSTRING:
        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 (last_ts->type == BT_CHARACTER)
        expr = create_character_intializer (init, last_ts, NULL, rvalue);
    else
    {
        /* We should never be overwriting an existing initializer.  */
        gcc_assert (!init);

        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;
}
예제 #6
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;
}
예제 #7
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;
}
예제 #8
0
파일: data.c 프로젝트: chinabin/gcc-tiny
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;
}
예제 #9
0
파일: data.c 프로젝트: chinabin/gcc-tiny
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;
}
예제 #10
0
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;
}
예제 #11
0
static void
gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
{
  gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
  gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
  gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
  gfc_expr *e1, *e2, *e3, *e4;
  gfc_ref *ref;
  tree decl, backend_decl, stmt;
  locus old_loc = gfc_current_locus;
  const char *iname;
  try t;

  decl = OMP_CLAUSE_DECL (c);
  gfc_current_locus = where;

  /* Create a fake symbol for init value.  */
  memset (&init_val_sym, 0, sizeof (init_val_sym));
  init_val_sym.ns = sym->ns;
  init_val_sym.name = sym->name;
  init_val_sym.ts = sym->ts;
  init_val_sym.attr.referenced = 1;
  init_val_sym.declared_at = where;
  init_val_sym.attr.flavor = FL_VARIABLE;
  backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
  init_val_sym.backend_decl = backend_decl;

  /* Create a fake symbol for the outer array reference.  */
  outer_sym = *sym;
  outer_sym.as = gfc_copy_array_spec (sym->as);
  outer_sym.attr.dummy = 0;
  outer_sym.attr.result = 0;
  outer_sym.attr.flavor = FL_VARIABLE;
  outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL);

  /* Create fake symtrees for it.  */
  symtree1 = gfc_new_symtree (&root1, sym->name);
  symtree1->n.sym = sym;
  gcc_assert (symtree1 == root1);

  symtree2 = gfc_new_symtree (&root2, sym->name);
  symtree2->n.sym = &init_val_sym;
  gcc_assert (symtree2 == root2);

  symtree3 = gfc_new_symtree (&root3, sym->name);
  symtree3->n.sym = &outer_sym;
  gcc_assert (symtree3 == root3);

  /* Create expressions.  */
  e1 = gfc_get_expr ();
  e1->expr_type = EXPR_VARIABLE;
  e1->where = where;
  e1->symtree = symtree1;
  e1->ts = sym->ts;
  e1->ref = ref = gfc_get_ref ();
  ref->u.ar.where = where;
  ref->u.ar.as = sym->as;
  ref->u.ar.type = AR_FULL;
  ref->u.ar.dimen = 0;
  t = gfc_resolve_expr (e1);
  gcc_assert (t == SUCCESS);

  e2 = gfc_get_expr ();
  e2->expr_type = EXPR_VARIABLE;
  e2->where = where;
  e2->symtree = symtree2;
  e2->ts = sym->ts;
  t = gfc_resolve_expr (e2);
  gcc_assert (t == SUCCESS);

  e3 = gfc_copy_expr (e1);
  e3->symtree = symtree3;
  t = gfc_resolve_expr (e3);
  gcc_assert (t == SUCCESS);

  iname = NULL;
  switch (OMP_CLAUSE_REDUCTION_CODE (c))
    {
    case PLUS_EXPR:
    case MINUS_EXPR:
      e4 = gfc_add (e3, e1);
      break;
    case MULT_EXPR:
      e4 = gfc_multiply (e3, e1);
      break;
    case TRUTH_ANDIF_EXPR:
      e4 = gfc_and (e3, e1);
      break;
    case TRUTH_ORIF_EXPR:
      e4 = gfc_or (e3, e1);
      break;
    case EQ_EXPR:
      e4 = gfc_eqv (e3, e1);
      break;
    case NE_EXPR:
      e4 = gfc_neqv (e3, e1);
      break;
    case MIN_EXPR:
      iname = "min";
      break;
    case MAX_EXPR:
      iname = "max";
      break;
    case BIT_AND_EXPR:
      iname = "iand";
      break;
    case BIT_IOR_EXPR:
      iname = "ior";
      break;
    case BIT_XOR_EXPR:
      iname = "ieor";
      break;
    default:
      gcc_unreachable ();
    }
  if (iname != NULL)
    {
      memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
      intrinsic_sym.ns = sym->ns;
      intrinsic_sym.name = iname;
      intrinsic_sym.ts = sym->ts;
      intrinsic_sym.attr.referenced = 1;
      intrinsic_sym.attr.intrinsic = 1;
      intrinsic_sym.attr.function = 1;
      intrinsic_sym.result = &intrinsic_sym;
      intrinsic_sym.declared_at = where;

      symtree4 = gfc_new_symtree (&root4, iname);
      symtree4->n.sym = &intrinsic_sym;
      gcc_assert (symtree4 == root4);

      e4 = gfc_get_expr ();
      e4->expr_type = EXPR_FUNCTION;
      e4->where = where;
      e4->symtree = symtree4;
      e4->value.function.isym = gfc_find_function (iname);
      e4->value.function.actual = gfc_get_actual_arglist ();
      e4->value.function.actual->expr = e3;
      e4->value.function.actual->next = gfc_get_actual_arglist ();
      e4->value.function.actual->next->expr = e1;
    }
  /* e1 and e3 have been stored as arguments of e4, avoid sharing.  */
  e1 = gfc_copy_expr (e1);
  e3 = gfc_copy_expr (e3);
  t = gfc_resolve_expr (e4);
  gcc_assert (t == SUCCESS);

  /* Create the init statement list.  */
  pushlevel (0);
  stmt = gfc_trans_assignment (e1, e2, false);
  if (TREE_CODE (stmt) != BIND_EXPR)
    stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
  else
    poplevel (0, 0, 0);
  OMP_CLAUSE_REDUCTION_INIT (c) = stmt;

  /* Create the merge statement list.  */
  pushlevel (0);
  stmt = gfc_trans_assignment (e3, e4, false);
  if (TREE_CODE (stmt) != BIND_EXPR)
    stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
  else
    poplevel (0, 0, 0);
  OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;

  /* And stick the placeholder VAR_DECL into the clause as well.  */
  OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl;

  gfc_current_locus = old_loc;

  gfc_free_expr (e1);
  gfc_free_expr (e2);
  gfc_free_expr (e3);
  gfc_free_expr (e4);
  gfc_free (symtree1);
  gfc_free (symtree2);
  gfc_free (symtree3);
  if (symtree4)
    gfc_free (symtree4);
  gfc_free_array_spec (outer_sym.as);
}

static tree
gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list, 
			      enum tree_code reduction_code, locus where)
{
  for (; namelist != NULL; namelist = namelist->next)
    if (namelist->sym->attr.referenced)
      {
	tree t = gfc_trans_omp_variable (namelist->sym);
	if (t != error_mark_node)
	  {
	    tree node = build_omp_clause (OMP_CLAUSE_REDUCTION);
	    OMP_CLAUSE_DECL (node) = t;
	    OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code;
	    if (namelist->sym->attr.dimension)
	      gfc_trans_omp_array_reduction (node, namelist->sym, where);
	    list = gfc_trans_add_clause (node, list);
	  }
      }
  return list;
}

static tree
gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
		       locus where)
{
  tree omp_clauses = NULL_TREE, chunk_size, c, old_clauses;
  int list;
  enum omp_clause_code clause_code;
  gfc_se se;

  if (clauses == NULL)
    return NULL_TREE;

  for (list = 0; list < OMP_LIST_NUM; list++)
    {
      gfc_namelist *n = clauses->lists[list];

      if (n == NULL)
	continue;
      if (list >= OMP_LIST_REDUCTION_FIRST
	  && list <= OMP_LIST_REDUCTION_LAST)
	{
	  enum tree_code reduction_code;
	  switch (list)
	    {
	    case OMP_LIST_PLUS:
	      reduction_code = PLUS_EXPR;
	      break;
	    case OMP_LIST_MULT:
	      reduction_code = MULT_EXPR;
	      break;
	    case OMP_LIST_SUB:
	      reduction_code = MINUS_EXPR;
	      break;
	    case OMP_LIST_AND:
	      reduction_code = TRUTH_ANDIF_EXPR;
	      break;
	    case OMP_LIST_OR:
	      reduction_code = TRUTH_ORIF_EXPR;
	      break;
	    case OMP_LIST_EQV:
	      reduction_code = EQ_EXPR;
	      break;
	    case OMP_LIST_NEQV:
	      reduction_code = NE_EXPR;
	      break;
	    case OMP_LIST_MAX:
	      reduction_code = MAX_EXPR;
	      break;
	    case OMP_LIST_MIN:
	      reduction_code = MIN_EXPR;
	      break;
	    case OMP_LIST_IAND:
	      reduction_code = BIT_AND_EXPR;
	      break;
	    case OMP_LIST_IOR:
	      reduction_code = BIT_IOR_EXPR;
	      break;
	    case OMP_LIST_IEOR:
	      reduction_code = BIT_XOR_EXPR;
	      break;
	    default:
	      gcc_unreachable ();
	    }
	  old_clauses = omp_clauses;
	  omp_clauses
	    = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code,
					    where);
	  continue;
	}
      switch (list)
	{
	case OMP_LIST_PRIVATE:
	  clause_code = OMP_CLAUSE_PRIVATE;
	  goto add_clause;
	case OMP_LIST_SHARED:
	  clause_code = OMP_CLAUSE_SHARED;
	  goto add_clause;
	case OMP_LIST_FIRSTPRIVATE:
	  clause_code = OMP_CLAUSE_FIRSTPRIVATE;
	  goto add_clause;
	case OMP_LIST_LASTPRIVATE:
	  clause_code = OMP_CLAUSE_LASTPRIVATE;
	  goto add_clause;
	case OMP_LIST_COPYIN:
	  clause_code = OMP_CLAUSE_COPYIN;
	  goto add_clause;
	case OMP_LIST_COPYPRIVATE:
	  clause_code = OMP_CLAUSE_COPYPRIVATE;
	  /* FALLTHROUGH */
	add_clause:
	  omp_clauses
	    = gfc_trans_omp_variable_list (clause_code, n, omp_clauses);
	  break;
	default:
	  break;
	}
    }

  if (clauses->if_expr)
    {
      tree if_var;

      gfc_init_se (&se, NULL);
      gfc_conv_expr (&se, clauses->if_expr);
      gfc_add_block_to_block (block, &se.pre);
      if_var = gfc_evaluate_now (se.expr, block);
      gfc_add_block_to_block (block, &se.post);

      c = build_omp_clause (OMP_CLAUSE_IF);
      OMP_CLAUSE_IF_EXPR (c) = if_var;
      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
    }

  if (clauses->num_threads)
    {
      tree num_threads;

      gfc_init_se (&se, NULL);
      gfc_conv_expr (&se, clauses->num_threads);
      gfc_add_block_to_block (block, &se.pre);
      num_threads = gfc_evaluate_now (se.expr, block);
      gfc_add_block_to_block (block, &se.post);

      c = build_omp_clause (OMP_CLAUSE_NUM_THREADS);
      OMP_CLAUSE_NUM_THREADS_EXPR (c) = num_threads;
      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
    }

  chunk_size = NULL_TREE;
  if (clauses->chunk_size)
    {
      gfc_init_se (&se, NULL);
      gfc_conv_expr (&se, clauses->chunk_size);
      gfc_add_block_to_block (block, &se.pre);
      chunk_size = gfc_evaluate_now (se.expr, block);
      gfc_add_block_to_block (block, &se.post);
    }

  if (clauses->sched_kind != OMP_SCHED_NONE)
    {
      c = build_omp_clause (OMP_CLAUSE_SCHEDULE);
      OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (c) = chunk_size;
      switch (clauses->sched_kind)
	{
	case OMP_SCHED_STATIC:
	  OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_STATIC;
	  break;
	case OMP_SCHED_DYNAMIC:
	  OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_DYNAMIC;
	  break;
	case OMP_SCHED_GUIDED:
	  OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_GUIDED;
	  break;
	case OMP_SCHED_RUNTIME:
	  OMP_CLAUSE_SCHEDULE_KIND (c) = OMP_CLAUSE_SCHEDULE_RUNTIME;
	  break;
	default:
	  gcc_unreachable ();
	}
      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
    }

  if (clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
    {
      c = build_omp_clause (OMP_CLAUSE_DEFAULT);
      switch (clauses->default_sharing)
	{
	case OMP_DEFAULT_NONE:
	  OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_NONE;
	  break;
	case OMP_DEFAULT_SHARED:
	  OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_SHARED;
	  break;
	case OMP_DEFAULT_PRIVATE:
	  OMP_CLAUSE_DEFAULT_KIND (c) = OMP_CLAUSE_DEFAULT_PRIVATE;
	  break;
	default:
	  gcc_unreachable ();
	}
      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
    }

  if (clauses->nowait)
    {
      c = build_omp_clause (OMP_CLAUSE_NOWAIT);
      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
    }

  if (clauses->ordered)
    {
      c = build_omp_clause (OMP_CLAUSE_ORDERED);
      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
    }

  return omp_clauses;
}
예제 #12
0
파일: trans.c 프로젝트: philscher/gcc
bool
gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
{
  tree tmp;
  gfc_ref *ref;
  gfc_expr *expr;
  gfc_expr *final_expr = NULL;
  gfc_expr *elem_size = NULL;
  bool has_finalizer = false;

  if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS))
    return false;

  if (expr2->ts.type == BT_DERIVED)
    {
      gfc_is_finalizable (expr2->ts.u.derived, &final_expr);
      if (!final_expr)
        return false;
    }

  /* If we have a class array, we need go back to the class
     container. */
  expr = gfc_copy_expr (expr2);

  if (expr->ref && expr->ref->next && !expr->ref->next->next
      && expr->ref->next->type == REF_ARRAY
      && expr->ref->type == REF_COMPONENT
      && strcmp (expr->ref->u.c.component->name, "_data") == 0)
    {
      gfc_free_ref_list (expr->ref);
      expr->ref = NULL;
    }
  else
    for (ref = expr->ref; ref; ref = ref->next)
      if (ref->next && ref->next->next && !ref->next->next->next
         && ref->next->next->type == REF_ARRAY
         && ref->next->type == REF_COMPONENT
         && strcmp (ref->next->u.c.component->name, "_data") == 0)
       {
         gfc_free_ref_list (ref->next);
         ref->next = NULL;
       }

  if (expr->ts.type == BT_CLASS)
    {
      has_finalizer = gfc_is_finalizable (expr->ts.u.derived, NULL);

      if (!expr2->rank && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as)
	expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank;

      final_expr = gfc_copy_expr (expr);
      gfc_add_vptr_component (final_expr);
      gfc_add_component_ref (final_expr, "_final");

      elem_size = gfc_copy_expr (expr);
      gfc_add_vptr_component (elem_size);
      gfc_add_component_ref (elem_size, "_size");
    }

  gcc_assert (final_expr->expr_type == EXPR_VARIABLE);

  tmp = gfc_build_final_call (expr->ts, final_expr, expr,
			      false, elem_size);

  if (expr->ts.type == BT_CLASS && !has_finalizer)
    {
      tree cond;
      gfc_se se;

      gfc_init_se (&se, NULL);
      se.want_pointer = 1;
      gfc_conv_expr (&se, final_expr);
      cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
			      se.expr, build_int_cst (TREE_TYPE (se.expr), 0));

      /* For CLASS(*) not only sym->_vtab->_final can be NULL
	 but already sym->_vtab itself.  */
      if (UNLIMITED_POLY (expr))
	{
	  tree cond2;
	  gfc_expr *vptr_expr;

	  vptr_expr = gfc_copy_expr (expr);
	  gfc_add_vptr_component (vptr_expr);

	  gfc_init_se (&se, NULL);
	  se.want_pointer = 1;
	  gfc_conv_expr (&se, vptr_expr);
	  gfc_free_expr (vptr_expr);

	  cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
				   se.expr,
				   build_int_cst (TREE_TYPE (se.expr), 0));
	  cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
				  boolean_type_node, cond2, cond);
	}

      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
			     cond, tmp, build_empty_stmt (input_location));
    }

  gfc_add_expr_to_block (block, tmp);

  return true;
}
예제 #13
0
파일: trans.c 프로젝트: philscher/gcc
static tree
gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
		      bool fini_coarray, gfc_expr *class_size)
{
  stmtblock_t block;
  gfc_se se;
  tree final_fndecl, array, size, tmp;
  symbol_attribute attr;

  gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
  gcc_assert (var);

  gfc_start_block (&block);
  gfc_init_se (&se, NULL);
  gfc_conv_expr (&se, final_wrapper);
  final_fndecl = se.expr;
  if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
    final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);

  if (ts.type == BT_DERIVED)
    {
      tree elem_size;

      gcc_assert (!class_size);
      elem_size = gfc_typenode_for_spec (&ts);
      elem_size = TYPE_SIZE_UNIT (elem_size);
      size = fold_convert (gfc_array_index_type, elem_size);

      gfc_init_se (&se, NULL);
      se.want_pointer = 1;
      if (var->rank)
	{
	  se.descriptor_only = 1;
	  gfc_conv_expr_descriptor (&se, var);
	  array = se.expr;
	}
      else
	{
	  gfc_conv_expr (&se, var);
	  gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
	  array = se.expr;

	  /* No copy back needed, hence set attr's allocatable/pointer
	     to zero.  */
	  gfc_clear_attr (&attr);
	  gfc_init_se (&se, NULL);
	  array = gfc_conv_scalar_to_descriptor (&se, array, attr);
	  gcc_assert (se.post.head == NULL_TREE);
	}
    }
  else
    {
      gfc_expr *array_expr;
      gcc_assert (class_size);
      gfc_init_se (&se, NULL);
      gfc_conv_expr (&se, class_size);
      gfc_add_block_to_block (&block, &se.pre);
      gcc_assert (se.post.head == NULL_TREE);
      size = se.expr;

      array_expr = gfc_copy_expr (var);
      gfc_init_se (&se, NULL);
      se.want_pointer = 1;
      if (array_expr->rank)
	{
	  gfc_add_class_array_ref (array_expr);
	  se.descriptor_only = 1;
	  gfc_conv_expr_descriptor (&se, array_expr);
	  array = se.expr;
	}
      else
	{
	  gfc_add_data_component (array_expr);
	  gfc_conv_expr (&se, array_expr);
	  gfc_add_block_to_block (&block, &se.pre);
	  gcc_assert (se.post.head == NULL_TREE);
	  array = se.expr;
	  if (TREE_CODE (array) == ADDR_EXPR
	      && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0))))
	    tmp = TREE_OPERAND (array, 0);

	  if (!gfc_is_coarray (array_expr))
	    {
	      /* No copy back needed, hence set attr's allocatable/pointer
		 to zero.  */
	      gfc_clear_attr (&attr);
	      gfc_init_se (&se, NULL);
	      array = gfc_conv_scalar_to_descriptor (&se, array, attr);
	    }
	  gcc_assert (se.post.head == NULL_TREE);
	}
      gfc_free_expr (array_expr);
    }

  if (!POINTER_TYPE_P (TREE_TYPE (array)))
    array = gfc_build_addr_expr (NULL, array);

  gfc_add_block_to_block (&block, &se.pre);
  tmp = build_call_expr_loc (input_location,
			     final_fndecl, 3, array,
			     size, fini_coarray ? boolean_true_node
						: boolean_false_node);
  gfc_add_block_to_block (&block, &se.post);
  gfc_add_expr_to_block (&block, tmp);
  return gfc_finish_block (&block);
}
예제 #14
0
static void
gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
{
  gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL;
  gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL;
  gfc_symbol init_val_sym, outer_sym, intrinsic_sym;
  gfc_expr *e1, *e2, *e3, *e4;
  gfc_ref *ref;
  tree decl, backend_decl, stmt;
  locus old_loc = gfc_current_locus;
  const char *iname;
  gfc_try t;

  decl = OMP_CLAUSE_DECL (c);
  gfc_current_locus = where;

  /* Create a fake symbol for init value.  */
  memset (&init_val_sym, 0, sizeof (init_val_sym));
  init_val_sym.ns = sym->ns;
  init_val_sym.name = sym->name;
  init_val_sym.ts = sym->ts;
  init_val_sym.attr.referenced = 1;
  init_val_sym.declared_at = where;
  init_val_sym.attr.flavor = FL_VARIABLE;
  backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
  init_val_sym.backend_decl = backend_decl;

  /* Create a fake symbol for the outer array reference.  */
  outer_sym = *sym;
  outer_sym.as = gfc_copy_array_spec (sym->as);
  outer_sym.attr.dummy = 0;
  outer_sym.attr.result = 0;
  outer_sym.attr.flavor = FL_VARIABLE;
  outer_sym.backend_decl = create_tmp_var_raw (TREE_TYPE (decl), NULL);

  /* Create fake symtrees for it.  */
  symtree1 = gfc_new_symtree (&root1, sym->name);
  symtree1->n.sym = sym;
  gcc_assert (symtree1 == root1);

  symtree2 = gfc_new_symtree (&root2, sym->name);
  symtree2->n.sym = &init_val_sym;
  gcc_assert (symtree2 == root2);

  symtree3 = gfc_new_symtree (&root3, sym->name);
  symtree3->n.sym = &outer_sym;
  gcc_assert (symtree3 == root3);

  /* Create expressions.  */
  e1 = gfc_get_expr ();
  e1->expr_type = EXPR_VARIABLE;
  e1->where = where;
  e1->symtree = symtree1;
  e1->ts = sym->ts;
  e1->ref = ref = gfc_get_ref ();
  ref->type = REF_ARRAY;
  ref->u.ar.where = where;
  ref->u.ar.as = sym->as;
  ref->u.ar.type = AR_FULL;
  ref->u.ar.dimen = 0;
  t = gfc_resolve_expr (e1);
  gcc_assert (t == SUCCESS);

  e2 = gfc_get_expr ();
  e2->expr_type = EXPR_VARIABLE;
  e2->where = where;
  e2->symtree = symtree2;
  e2->ts = sym->ts;
  t = gfc_resolve_expr (e2);
  gcc_assert (t == SUCCESS);

  e3 = gfc_copy_expr (e1);
  e3->symtree = symtree3;
  t = gfc_resolve_expr (e3);
  gcc_assert (t == SUCCESS);

  iname = NULL;
  switch (OMP_CLAUSE_REDUCTION_CODE (c))
    {
    case PLUS_EXPR:
    case MINUS_EXPR:
      e4 = gfc_add (e3, e1);
      break;
    case MULT_EXPR:
      e4 = gfc_multiply (e3, e1);
      break;
    case TRUTH_ANDIF_EXPR:
      e4 = gfc_and (e3, e1);
      break;
    case TRUTH_ORIF_EXPR:
      e4 = gfc_or (e3, e1);
      break;
    case EQ_EXPR:
      e4 = gfc_eqv (e3, e1);
      break;
    case NE_EXPR:
      e4 = gfc_neqv (e3, e1);
      break;
    case MIN_EXPR:
      iname = "min";
      break;
    case MAX_EXPR:
      iname = "max";
      break;
    case BIT_AND_EXPR:
      iname = "iand";
      break;
    case BIT_IOR_EXPR:
      iname = "ior";
      break;
    case BIT_XOR_EXPR:
      iname = "ieor";
      break;
    default:
      gcc_unreachable ();
    }
  if (iname != NULL)
    {
      memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
      intrinsic_sym.ns = sym->ns;
      intrinsic_sym.name = iname;
      intrinsic_sym.ts = sym->ts;
      intrinsic_sym.attr.referenced = 1;
      intrinsic_sym.attr.intrinsic = 1;
      intrinsic_sym.attr.function = 1;
      intrinsic_sym.result = &intrinsic_sym;
      intrinsic_sym.declared_at = where;

      symtree4 = gfc_new_symtree (&root4, iname);
      symtree4->n.sym = &intrinsic_sym;
      gcc_assert (symtree4 == root4);

      e4 = gfc_get_expr ();
      e4->expr_type = EXPR_FUNCTION;
      e4->where = where;
      e4->symtree = symtree4;
      e4->value.function.isym = gfc_find_function (iname);
      e4->value.function.actual = gfc_get_actual_arglist ();
      e4->value.function.actual->expr = e3;
      e4->value.function.actual->next = gfc_get_actual_arglist ();
      e4->value.function.actual->next->expr = e1;
    }
  /* e1 and e3 have been stored as arguments of e4, avoid sharing.  */
  e1 = gfc_copy_expr (e1);
  e3 = gfc_copy_expr (e3);
  t = gfc_resolve_expr (e4);
  gcc_assert (t == SUCCESS);

  /* Create the init statement list.  */
  pushlevel (0);
  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
      && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
    {
      /* If decl is an allocatable array, it needs to be allocated
	 with the same bounds as the outer var.  */
      tree type = TREE_TYPE (decl), rank, size, esize, ptr;
      stmtblock_t block;

      gfc_start_block (&block);

      gfc_add_modify (&block, decl, outer_sym.backend_decl);
      rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
      size = gfc_conv_descriptor_ubound_get (decl, rank);
      size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
			  gfc_conv_descriptor_lbound_get (decl, rank));
      size = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
			  gfc_index_one_node);
      if (GFC_TYPE_ARRAY_RANK (type) > 1)
	size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
			    gfc_conv_descriptor_stride_get (decl, rank));
      esize = fold_convert (gfc_array_index_type,
			    TYPE_SIZE_UNIT (gfc_get_element_type (type)));
      size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, esize);
      size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
      ptr = gfc_allocate_array_with_status (&block,
					    build_int_cst (pvoid_type_node, 0),
					    size, NULL, NULL);
      gfc_conv_descriptor_data_set (&block, decl, ptr);
      gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false));
      stmt = gfc_finish_block (&block);
    }
  else
    stmt = gfc_trans_assignment (e1, e2, false);
  if (TREE_CODE (stmt) != BIND_EXPR)
    stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
  else
    poplevel (0, 0, 0);
  OMP_CLAUSE_REDUCTION_INIT (c) = stmt;

  /* Create the merge statement list.  */
  pushlevel (0);
  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
      && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (decl)) == GFC_ARRAY_ALLOCATABLE)
    {
      /* If decl is an allocatable array, it needs to be deallocated
	 afterwards.  */
      stmtblock_t block;

      gfc_start_block (&block);
      gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false));
      gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl));
      stmt = gfc_finish_block (&block);
    }
  else
    stmt = gfc_trans_assignment (e3, e4, false);
  if (TREE_CODE (stmt) != BIND_EXPR)
    stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
  else
    poplevel (0, 0, 0);
  OMP_CLAUSE_REDUCTION_MERGE (c) = stmt;

  /* And stick the placeholder VAR_DECL into the clause as well.  */
  OMP_CLAUSE_REDUCTION_PLACEHOLDER (c) = outer_sym.backend_decl;

  gfc_current_locus = old_loc;

  gfc_free_expr (e1);
  gfc_free_expr (e2);
  gfc_free_expr (e3);
  gfc_free_expr (e4);
  gfc_free (symtree1);
  gfc_free (symtree2);
  gfc_free (symtree3);
  if (symtree4)
    gfc_free (symtree4);
  gfc_free_array_spec (outer_sym.as);
}