trans-types.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

  return decl;
}


/* Copy the backend_decl and component backend_decls if
   the two derived type symbols are "equal", as described
   in 4.4.2 and resolved by gfc_compare_derived_types.  */

static int
copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
{
  gfc_component *to_cm;
  gfc_component *from_cm;

  if (from->backend_decl == NULL
	|| !gfc_compare_derived_types (from, to))
    return 0;

  to->backend_decl = from->backend_decl;

  to_cm = to->components;
  from_cm = from->components;

  /* Copy the component declarations.  If a component is itself
     a derived type, we need a copy of its component declarations.
     This is done by recursing into gfc_get_derived_type and
     ensures that the component's component declarations have
     been built.  If it is a character, we need the character 
     length, as well.  */
  for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
    {
      to_cm->backend_decl = from_cm->backend_decl;
      if (from_cm->ts.type == BT_DERIVED)
	gfc_get_derived_type (to_cm->ts.derived);

      else if (from_cm->ts.type == BT_CHARACTER)
	to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl;
    }

  return 1;
}


/* Build a tree node for a derived type.  If there are equal
   derived types, with different local names, these are built
   at the same time.  If an equal derived type has been built
   in a parent namespace, this is used.  */

static tree
gfc_get_derived_type (gfc_symbol * derived)
{
  tree typenode, field, field_type, fieldlist;
  gfc_component *c;
  gfc_dt_list *dt;
  gfc_namespace * ns;

  gcc_assert (derived && derived->attr.flavor == FL_DERIVED);

  /* derived->backend_decl != 0 means we saw it before, but its
     components' backend_decl may have not been built.  */
  if (derived->backend_decl)
    {
      /* Its components' backend_decl have been built.  */
      if (TYPE_FIELDS (derived->backend_decl))
        return derived->backend_decl;
      else
        typenode = derived->backend_decl;
    }
  else
    {
      /* In a module, if an equal derived type is already available in the
	 specification block, use its backend declaration and those of its
	 components, rather than building anew so that potential dummy and
	 actual arguments use the same TREE_TYPE.  Non-module structures,
	 need to be built, if found, because the order of visits to the 
	 namespaces is different.  */

      for (ns = derived->ns->parent; ns; ns = ns->parent)
	{
	  for (dt = ns->derived_types; dt; dt = dt->next)
	    {
	      if (derived->module == NULL
		    && dt->derived->backend_decl == NULL
		    && gfc_compare_derived_types (dt->derived, derived))
		gfc_get_derived_type (dt->derived);

	      if (copy_dt_decls_ifequal (dt->derived, derived))
		break;
	    }
	  if (derived->backend_decl)
	    goto other_equal_dts;
	}

      /* We see this derived type first time, so build the type node.  */
      typenode = make_node (RECORD_TYPE);
      TYPE_NAME (typenode) = get_identifier (derived->name);
      TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
      derived->backend_decl = typenode;
    }

  /* Go through the derived type components, building them as
     necessary. The reason for doing this now is that it is
     possible to recurse back to this derived type through a
     pointer component (PR24092). If this happens, the fields
     will be built and so we can return the type.  */
  for (c = derived->components; c; c = c->next)
    {
      if (c->ts.type != BT_DERIVED)
	continue;

      if (!c->pointer || c->ts.derived->backend_decl == NULL)
	c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
    }

  if (TYPE_FIELDS (derived->backend_decl))
    return derived->backend_decl;

  /* Build the type member list. Install the newly created RECORD_TYPE
     node as DECL_CONTEXT of each FIELD_DECL.  */
  fieldlist = NULL_TREE;
  for (c = derived->components; c; c = c->next)
    {
      if (c->ts.type == BT_DERIVED)
        field_type = c->ts.derived->backend_decl;
      else
	{
	  if (c->ts.type == BT_CHARACTER)
	    {
	      /* Evaluate the string length.  */
	      gfc_conv_const_charlen (c->ts.cl);
	      gcc_assert (c->ts.cl->backend_decl);
	    }

	  field_type = gfc_typenode_for_spec (&c->ts);
	}

      /* This returns an array descriptor type.  Initialization may be
         required.  */
      if (c->dimension)
	{
	  if (c->pointer)
	    {
	      /* Pointers to arrays aren't actually pointer types.  The
	         descriptors are separate, but the data is common.  */
	      field_type = gfc_build_array_type (field_type, c->as);
	    }
	  else
	    field_type = gfc_get_nodesc_array_type (field_type, c->as, 3);
	}
      else if (c->pointer)
	field_type = build_pointer_type (field_type);

      field = gfc_add_field_to_struct (&fieldlist, typenode,
				       get_identifier (c->name),
				       field_type);

      DECL_PACKED (field) |= TYPE_PACKED (typenode);

      gcc_assert (field);
      if (!c->backend_decl)
	c->backend_decl = field;
    }

  /* Now we have the final fieldlist.  Record it, then lay out the
     derived type, including the fields.  */
  TYPE_FIELDS (typenode) = fieldlist;

  gfc_finish_type (typenode);

  derived->backend_decl = typenode;

other_equal_dts:
  /* Add this backend_decl to all the other, equal derived types and
     their components in this namespace.  */
  for (dt = derived->ns->derived_types; dt; dt = dt->next)
    copy_dt_decls_ifequal (derived, dt->derived);

  return derived->backend_decl;
}


int
gfc_return_by_reference (gfc_symbol * sym)
{
  if (!sym->attr.function)
    return 0;

  if (sym->attr.dimension)
    return 1;

  if (sym->ts.type == BT_CHARACTER)
    return 1;

  /* Possibly return complex numbers by reference for g77 compatibility.
     We don't do this for calls to intrinsics (as the library uses the
     -fno-f2c calling convention), nor for calls to functions which always
     require an explicit interface, as no compatibility problems can
     arise there.  */
  if (gfc_option.flag_f2c
      && sym->ts.type == BT_COMPLEX
      && !sym->attr.intrinsic && !sym->attr.always_explicit)
    return 1;
  
  return 0;
}

static tree
gfc_get_mixed_entry_union (gfc_namespace *ns)
{
  tree type;
  tree decl;
  tree fieldlist;
  char name[GFC_MAX_SYMBOL_LEN + 1];
  gfc_entry_list *el, *el2;

  gcc_assert (ns->proc_name->attr.mixed_entry_master);
  gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);

  snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);

  /* Build the type node.  */
  type = make_node (UNION_TYPE);

  TYPE_NAME (type) = get_identifier (name);
  fieldlist = NULL;

  for (el = ns->entries; el; el = el->next)
    {
      /* Search for duplicates.  */
      for (el2 = ns->entries; el2 != el; el2 = el2->next)
	if (el2->sym->result == el->sym->result)
	  break;

      if (el == el2)
	{
	  decl = build_decl (FIELD_DECL,
			     get_identifier (el->sym->result->name),
			     gfc_sym_type (el->sym->result));
	  DECL_CONTEXT (decl) = type;
	  fieldlist = chainon (fieldlist, decl);
	}
    }

  /* Finish off the type.  */
  TYPE_FIELDS (type) = fieldlist;

  gfc_finish_type (type);
  return type;
}

tree
gfc_get_function_type (gfc_symbol * sym)
{
  tree type;
  tree typelist;
  gfc_formal_arglist *f;
  gfc_symbol *arg;
  int nstr;
  int alternate_return;

  /* Make sure this symbol is a function or a subroutine.  */
  gcc_assert (sym->attr.flavor == FL_PROCEDURE);

  if (sym->backend_decl)
    return TREE_TYPE (sym->backend_decl);

  nstr = 0;
  alternate_return = 0;
  typelist = NULL_TREE;

  if (sym->attr.entry_master)
    {
      /* Additional parameter for selecting an entry point.  */
      typelist = gfc_chainon_list (typelist, gfc_array_index_type);
    }

  /* Some functions we use an extra parameter for the return value.  */
  if (gfc_return_by_reference (sym))
    {
      if (sym->result)
	arg = sym->result;
      else
	arg = sym;

      if (arg->ts.type == BT_CHARACTER)
	gfc_conv_const_charlen (arg->ts.cl);

      type = gfc_sym_type (arg);
      if (arg->ts.type == BT_COMPLEX
	  || arg->attr.dimension
	  || arg->ts.type == BT_CHARACTER)
	type = build_reference_type (type);

      typelist = gfc_chainon_list (typelist, type);
      if (arg->ts.type == BT_CHARACTER)
	typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
    }

  /* Build the argument types for the function.  */
  for (f = sym->formal; f; f = f->next)
    {
      arg = f->sym;
      if (arg)
	{
	  /* Evaluate constant character lengths here so that they can be
	     included in the type.  */
	  if (arg->ts.type == BT_CHARACTER)
	    gfc_conv_const_charlen (arg->ts.cl);

	  if (arg->attr.flavor == FL_PROCEDURE)
	    {
	      type = gfc_get_function_type (arg);
	      type = build_pointer_type (type);
	    }
	  else
	    type = gfc_sym_type (arg);

	  /* Parameter Passing Convention

	     We currently pass all parameters by reference.
	     Parameters with INTENT(IN) could be passed by value.
	     The problem arises if a function is called via an implicit
	     prototype. In this situation the INTENT is not known.
	     For this reason all parameters to global functions must be
	     passed by reference.  Passing by value would potentially
	     generate bad code.  Worse there would be no way of telling that
	     this code was bad, except that it would give incorrect results.

	     Contained procedures could pass by value as these are never
	     used without an explicit interface, and connot be passed as
	     actual parameters for a dummy procedure.  */
	  if (arg->ts.type == BT_CHARACTER)
            nstr++;
	  typelist = gfc_chainon_list (typelist, type);
	}
      else
        {
          if (sym->attr.subroutine)
            alternate_return = 1;
        }
    }

  /* Add hidden string length parameters.  */
  while (nstr--)
    typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);

  typelist = gfc_chainon_list (typelist, void_type_node);

  if (alternate_return)
    type = integer_type_node;
  else if (!sym->attr.function || gfc_return_by_reference (sym))
    type = void_type_node;
  else if (sym->attr.mixed_entry_master)
    type = gfc_get_mixed_entry_union (sym->ns);
  else
    type = gfc_sym_type (sym);

  type = build_function_type (type, typelist);

  return type;
}

/* Language hooks for middle-end access to type nodes.  */

/* Return an integer type with BITS bits of precision,
   that is unsigned if UNSIGNEDP is nonzero, otherwise signed.  */

tree
gfc_type_for_size (unsigned bits, int unsignedp)
{
  if (!unsignedp)
    {
      int i;
      for (i = 0; i <= MAX_INT_KINDS; ++i)
	{
	  tree type = gfc_integer_types[i];
	  if (type && bits == TYPE_PRECISION (type))
	    return type;
	}
    }
  else
    {
      if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
        return unsigned_intQI_type_node;
      if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
	return unsigned_intHI_type_node;
      if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
	return unsigned_intSI_type_node;
      if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
	return unsigned_intDI_type_node;
      if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
	return unsigned_intTI_type_node;
    }

  return NULL_TREE;
}

/* Return a data type that has machine mode MODE.  If the mode is an
   integer, then UNSIGNEDP selects between signed and unsigned types.  */

tree
gfc_type_for_mode (enum machine_mode mode, int unsignedp)
{
  int i;
  tree *base;

  if (GET_MODE_CLASS (mode) == MODE_FLOAT)
    base = gfc_real_types;
  else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
    base = gfc_complex_types;
  else if (SCALAR_INT_MODE_P (mode))
    return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
  else if (VECTOR_MODE_P (mode))
    {
      enum machine_mode inner_mode = GET_MODE_INNER (mode);
      tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
      if (inner_type != NULL_TREE)
        return build_vector_type_for_mode (inner_type, mode);
      return NULL_TREE;
    }
  else
    return NULL_TREE;

  for (i = 0; i <= MAX_REAL_KINDS; ++i)
    {
      tree type = base[i];
      if (type && mode == TYPE_MODE (type))
	return type;
    }

  return NULL_TREE;
}

/* Return a type the same as TYPE except unsigned or
   signed according to UNSIGNEDP.  */

tree
gfc_signed_or_unsigned_type (int unsignedp, tree type)
{
  if (TREE_CODE (type) != INTEGER_TYPE || TYPE_UNSIGNED (type) == unsignedp)
    return type;
  else
    return gfc_type_for_size (TYPE_PRECISION (type), unsignedp);
}

/* Return an unsigned type the same as TYPE in other respects.  */

tree
gfc_unsigned_type (tree type)
{
  return gfc_signed_or_unsigned_type (1, type);
}

/* Return a signed type the same as TYPE in other respects.  */

tree
gfc_signed_type (tree type)
{
  return gfc_signed_or_unsigned_type (0, type);
}

#include "gt-fortran-trans-types.h"