Exemple #1
0
static void
create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
{
  segment_info *s, *next_s;
  tree union_type;
  tree *field_link;
  tree field;
  tree field_init = NULL_TREE;
  record_layout_info rli;
  tree decl;
  bool is_init = false;
  bool is_saved = false;

  /* Declare the variables inside the common block.
     If the current common block contains any equivalence object, then
     make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
     alias analyzer work well when there is no address overlapping for
     common variables in the current common block.  */
  if (saw_equiv)
    union_type = make_node (UNION_TYPE);
  else
    union_type = make_node (RECORD_TYPE);

  rli = start_record_layout (union_type);
  field_link = &TYPE_FIELDS (union_type);

  /* Check for overlapping initializers and replace them with a single,
     artificial field that contains all the data.  */
  if (saw_equiv)
    field = get_init_field (head, union_type, &field_init, rli);
  else
    field = NULL_TREE;

  if (field != NULL_TREE)
    {
      is_init = true;
      *field_link = field;
      field_link = &DECL_CHAIN (field);
    }

  for (s = head; s; s = s->next)
    {
      build_field (s, union_type, rli);

      /* Link the field into the type.  */
      *field_link = s->field;
      field_link = &DECL_CHAIN (s->field);

      /* Has initial value.  */
      if (s->sym->value)
        is_init = true;

      /* Has SAVE attribute.  */
      if (s->sym->attr.save)
        is_saved = true;
    }

  finish_record_layout (rli, true);

  if (com)
    decl = build_common_decl (com, union_type, is_init);
  else
    decl = build_equiv_decl (union_type, is_init, is_saved);

  if (is_init)
    {
      tree ctor, tmp;
      VEC(constructor_elt,gc) *v = NULL;

      if (field != NULL_TREE && field_init != NULL_TREE)
	CONSTRUCTOR_APPEND_ELT (v, field, field_init);
      else
	for (s = head; s; s = s->next)
	  {
	    if (s->sym->value)
	      {
		/* Add the initializer for this field.  */
		tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
					    TREE_TYPE (s->field),
					    s->sym->attr.dimension,
					    s->sym->attr.pointer
					    || s->sym->attr.allocatable, false);

		CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
	      }
	  }

      gcc_assert (!VEC_empty (constructor_elt, v));
      ctor = build_constructor (union_type, v);
      TREE_CONSTANT (ctor) = 1;
      TREE_STATIC (ctor) = 1;
      DECL_INITIAL (decl) = ctor;

#ifdef ENABLE_CHECKING
      {
	tree field, value;
	unsigned HOST_WIDE_INT idx;
	FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
	  gcc_assert (TREE_CODE (field) == FIELD_DECL);
      }
#endif
    }

  /* Build component reference for each variable.  */
  for (s = head; s; s = next_s)
    {
      tree var_decl;

      var_decl = build_decl (s->sym->declared_at.lb->location,
			     VAR_DECL, DECL_NAME (s->field),
			     TREE_TYPE (s->field));
      TREE_STATIC (var_decl) = TREE_STATIC (decl);
      /* Mark the variable as used in order to avoid warnings about
	 unused variables.  */
      TREE_USED (var_decl) = 1;
      if (s->sym->attr.use_assoc)
	DECL_IGNORED_P (var_decl) = 1;
      if (s->sym->attr.target)
	TREE_ADDRESSABLE (var_decl) = 1;
      /* Fake variables are not visible from other translation units. */
      TREE_PUBLIC (var_decl) = 0;

      /* To preserve identifier names in COMMON, chain to procedure
         scope unless at top level in a module definition.  */
      if (com
          && s->sym->ns->proc_name
          && s->sym->ns->proc_name->attr.flavor == FL_MODULE)
	var_decl = pushdecl_top_level (var_decl);
      else
	gfc_add_decl_to_function (var_decl);

      SET_DECL_VALUE_EXPR (var_decl,
			   fold_build3_loc (input_location, COMPONENT_REF,
					    TREE_TYPE (s->field),
					    decl, s->field, NULL_TREE));
      DECL_HAS_VALUE_EXPR_P (var_decl) = 1;
      GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1;

      if (s->sym->attr.assign)
	{
	  gfc_allocate_lang_decl (var_decl);
	  GFC_DECL_ASSIGN (var_decl) = 1;
	  GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field);
	  GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field);
	}

      s->sym->backend_decl = var_decl;

      next_s = s->next;
      free (s);
    }
}
Exemple #2
0
static void
create_common (gfc_common_head *com)
{
  segment_info *s, *next_s;
  tree union_type;
  tree *field_link;
  record_layout_info rli;
  tree decl;
  bool is_init = false;

  /* Declare the variables inside the common block.  */
  union_type = make_node (UNION_TYPE);
  rli = start_record_layout (union_type);
  field_link = &TYPE_FIELDS (union_type);

  for (s = current_common; s; s = s->next)
    {
      build_field (s, union_type, rli);

      /* Link the field into the type.  */
      *field_link = s->field;
      field_link = &TREE_CHAIN (s->field);

      /* Has initial value.  */
      if (s->sym->value)
        is_init = true;
    }
  finish_record_layout (rli, true);

  if (com)
    decl = build_common_decl (com, union_type, is_init);
  else
    decl = build_equiv_decl (union_type, is_init);

  if (is_init)
    {
      tree list, ctor, tmp;
      HOST_WIDE_INT offset = 0;

      list = NULL_TREE;
      for (s = current_common; s; s = s->next)
        {
          if (s->sym->value)
            {
              if (s->offset < offset)
                {
		    /* We have overlapping initializers.  It could either be
		       partially initialized arrays (legal), or the user
		       specified multiple initial values (illegal).
		       We don't implement this yet, so bail out.  */
                  gfc_todo_error ("Initialization of overlapping variables");
                }
	      /* Add the initializer for this field.  */
	      tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
		  TREE_TYPE (s->field), s->sym->attr.dimension,
		  s->sym->attr.pointer || s->sym->attr.allocatable);
	      list = tree_cons (s->field, tmp, list);
              offset = s->offset + s->length;
            }
        }
      gcc_assert (list);
      ctor = build1 (CONSTRUCTOR, union_type, nreverse(list));
      TREE_CONSTANT (ctor) = 1;
      TREE_INVARIANT (ctor) = 1;
      TREE_STATIC (ctor) = 1;
      DECL_INITIAL (decl) = ctor;

#ifdef ENABLE_CHECKING
      for (tmp = CONSTRUCTOR_ELTS (ctor); tmp; tmp = TREE_CHAIN (tmp))
	gcc_assert (TREE_CODE (TREE_PURPOSE (tmp)) == FIELD_DECL);
#endif
    }

  /* Build component reference for each variable.  */
  for (s = current_common; s; s = next_s)
    {
      s->sym->backend_decl = build3 (COMPONENT_REF, TREE_TYPE (s->field),
				     decl, s->field, NULL_TREE);

      next_s = s->next;
      gfc_free (s);
    }
}