trans-decl.c

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

/* Apply symbol attributes to a variable, and add it to the function scope.  */

static void
gfc_finish_var_decl (tree decl, gfc_symbol * sym)
{
  /* TREE_ADDRESSABLE means the address of this variable is actually needed.
     This is the equivalent of the TARGET variables.
     We also need to set this if the variable is passed by reference in a
     CALL statement.  */

  /* Set DECL_VALUE_EXPR for Cray Pointees.  */
  if (sym->attr.cray_pointee)
    gfc_finish_cray_pointee (decl, sym);

  if (sym->attr.target)
    TREE_ADDRESSABLE (decl) = 1;
  /* If it wasn't used we wouldn't be getting it.  */
  TREE_USED (decl) = 1;

  /* Chain this decl to the pending declarations.  Don't do pushdecl()
     because this would add them to the current scope rather than the
     function scope.  */
  if (current_function_decl != NULL_TREE)
    {
      if (sym->ns->proc_name->backend_decl == current_function_decl
          || sym->result == sym)
	gfc_add_decl_to_function (decl);
      else
	gfc_add_decl_to_parent_function (decl);
    }

  if (sym->attr.cray_pointee)
    return;

  /* If a variable is USE associated, it's always external.  */
  if (sym->attr.use_assoc)
    {
      DECL_EXTERNAL (decl) = 1;
      TREE_PUBLIC (decl) = 1;
    }
  else if (sym->module && !sym->attr.result && !sym->attr.dummy)
    {
      /* TODO: Don't set sym->module for result or dummy variables.  */
      gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
      /* This is the declaration of a module variable.  */
      TREE_PUBLIC (decl) = 1;
      TREE_STATIC (decl) = 1;
    }

  if ((sym->attr.save || sym->attr.data || sym->value)
      && !sym->attr.use_assoc)
    TREE_STATIC (decl) = 1;
  
  /* Keep variables larger than max-stack-var-size off stack.  */
  if (!sym->ns->proc_name->attr.recursive
      && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
      && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
    TREE_STATIC (decl) = 1;
}


/* Allocate the lang-specific part of a decl.  */

void
gfc_allocate_lang_decl (tree decl)
{
  DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
    ggc_alloc_cleared (sizeof (struct lang_decl));
}

/* Remember a symbol to generate initialization/cleanup code at function
   entry/exit.  */

static void
gfc_defer_symbol_init (gfc_symbol * sym)
{
  gfc_symbol *p;
  gfc_symbol *last;
  gfc_symbol *head;

  /* Don't add a symbol twice.  */
  if (sym->tlink)
    return;

  last = head = sym->ns->proc_name;
  p = last->tlink;

  /* Make sure that setup code for dummy variables which are used in the
     setup of other variables is generated first.  */
  if (sym->attr.dummy)
    {
      /* Find the first dummy arg seen after us, or the first non-dummy arg.
         This is a circular list, so don't go past the head.  */
      while (p != head
             && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
        {
          last = p;
          p = p->tlink;
        }
    }
  /* Insert in between last and p.  */
  last->tlink = sym;
  sym->tlink = p;
}


/* Create an array index type variable with function scope.  */

static tree
create_index_var (const char * pfx, int nest)
{
  tree decl;

  decl = gfc_create_var_np (gfc_array_index_type, pfx);
  if (nest)
    gfc_add_decl_to_parent_function (decl);
  else
    gfc_add_decl_to_function (decl);
  return decl;
}


/* Create variables to hold all the non-constant bits of info for a
   descriptorless array.  Remember these in the lang-specific part of the
   type.  */

static void
gfc_build_qualified_array (tree decl, gfc_symbol * sym)
{
  tree type;
  int dim;
  int nest;

  type = TREE_TYPE (decl);

  /* We just use the descriptor, if there is one.  */
  if (GFC_DESCRIPTOR_TYPE_P (type))
    return;

  gcc_assert (GFC_ARRAY_TYPE_P (type));
  nest = (sym->ns->proc_name->backend_decl != current_function_decl)
	 && !sym->attr.contained;

  for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
    {
      if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
        GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
      /* Don't try to use the unknown bound for assumed shape arrays.  */
      if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
          && (sym->as->type != AS_ASSUMED_SIZE
              || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
        GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);

      if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
        GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
    }
  if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
    {
      GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
							"offset");
      if (nest)
	gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
      else
	gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
    }
}


/* For some dummy arguments we don't use the actual argument directly.
   Instead we create a local decl and use that.  This allows us to perform
   initialization, and construct full type information.  */

static tree
gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
{
  tree decl;
  tree type;
  gfc_array_spec *as;
  char *name;
  int packed;
  int n;
  bool known_size;

  if (sym->attr.pointer || sym->attr.allocatable)
    return dummy;

  /* Add to list of variables if not a fake result variable.  */
  if (sym->attr.result || sym->attr.dummy)
    gfc_defer_symbol_init (sym);

  type = TREE_TYPE (dummy);
  gcc_assert (TREE_CODE (dummy) == PARM_DECL
	  && POINTER_TYPE_P (type));

  /* Do we know the element size?  */
  known_size = sym->ts.type != BT_CHARACTER
	  || INTEGER_CST_P (sym->ts.cl->backend_decl);
  
  if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
    {
      /* For descriptorless arrays with known element size the actual
         argument is sufficient.  */
      gcc_assert (GFC_ARRAY_TYPE_P (type));
      gfc_build_qualified_array (dummy, sym);
      return dummy;
    }

  type = TREE_TYPE (type);
  if (GFC_DESCRIPTOR_TYPE_P (type))
    {
      /* Create a decriptorless array pointer.  */
      as = sym->as;
      packed = 0;
      if (!gfc_option.flag_repack_arrays)
	{
	  if (as->type == AS_ASSUMED_SIZE)
	    packed = 2;
	}
      else
	{
	  if (as->type == AS_EXPLICIT)
	    {
	      packed = 2;
	      for (n = 0; n < as->rank; n++)
		{
		  if (!(as->upper[n]
			&& as->lower[n]
			&& as->upper[n]->expr_type == EXPR_CONSTANT
			&& as->lower[n]->expr_type == EXPR_CONSTANT))
		    packed = 1;
		}
	    }
	  else
	    packed = 1;
	}

      type = gfc_typenode_for_spec (&sym->ts);
      type = gfc_get_nodesc_array_type (type, sym->as, packed);
    }
  else
    {
      /* We now have an expression for the element size, so create a fully
	 qualified type.  Reset sym->backend decl or this will just return the
	 old type.  */
      sym->backend_decl = NULL_TREE;
      type = gfc_sym_type (sym);
      packed = 2;
    }

  ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
  decl = build_decl (VAR_DECL, get_identifier (name), type);

  DECL_ARTIFICIAL (decl) = 1;
  TREE_PUBLIC (decl) = 0;
  TREE_STATIC (decl) = 0;
  DECL_EXTERNAL (decl) = 0;

  /* We should never get deferred shape arrays here.  We used to because of
     frontend bugs.  */
  gcc_assert (sym->as->type != AS_DEFERRED);

  switch (packed)
    {
    case 1:
      GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
      break;

    case 2:
      GFC_DECL_PACKED_ARRAY (decl) = 1;
      break;
    }

  gfc_build_qualified_array (decl, sym);

  if (DECL_LANG_SPECIFIC (dummy))
    DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
  else
    gfc_allocate_lang_decl (decl);

  GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;

  if (sym->ns->proc_name->backend_decl == current_function_decl
      || sym->attr.contained)
    gfc_add_decl_to_function (decl);
  else
    gfc_add_decl_to_parent_function (decl);

  return decl;
}


/* Return a constant or a variable to use as a string length.  Does not
   add the decl to the current scope.  */

static tree
gfc_create_string_length (gfc_symbol * sym)
{
  tree length;

  gcc_assert (sym->ts.cl);
  gfc_conv_const_charlen (sym->ts.cl);
  
  if (sym->ts.cl->backend_decl == NULL_TREE)
    {
      char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];

      /* Also prefix the mangled name.  */
      strcpy (&name[1], sym->name);
      name[0] = '.';
      length = build_decl (VAR_DECL, get_identifier (name),
			   gfc_charlen_type_node);
      DECL_ARTIFICIAL (length) = 1;
      TREE_USED (length) = 1;
      gfc_defer_symbol_init (sym);
      sym->ts.cl->backend_decl = length;
    }

  return sym->ts.cl->backend_decl;
}

/* If a variable is assigned a label, we add another two auxiliary
   variables.  */

static void
gfc_add_assign_aux_vars (gfc_symbol * sym)
{
  tree addr;
  tree length;
  tree decl;

  gcc_assert (sym->backend_decl);

  decl = sym->backend_decl;
  gfc_allocate_lang_decl (decl);
  GFC_DECL_ASSIGN (decl) = 1;
  length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
		       gfc_charlen_type_node);
  addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
		     pvoid_type_node);
  gfc_finish_var_decl (length, sym);
  gfc_finish_var_decl (addr, sym);
  /*  STRING_LENGTH is also used as flag. Less than -1 means that
      ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
      target label's address. Otherwise, value is the length of a format string
      and ASSIGN_ADDR is its address.  */
  if (TREE_STATIC (length))
    DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
  else
    gfc_defer_symbol_init (sym);

  GFC_DECL_STRING_LEN (decl) = length;
  GFC_DECL_ASSIGN_ADDR (decl) = addr;
}

/* Return the decl for a gfc_symbol, create it if it doesn't already
   exist.  */

tree
gfc_get_symbol_decl (gfc_symbol * sym)
{
  tree decl;
  tree etype = NULL_TREE;
  tree length = NULL_TREE;
  tree tmp = NULL_TREE;
  int byref;

  gcc_assert (sym->attr.referenced);

  if (sym->ns && sym->ns->proc_name->attr.function)
    byref = gfc_return_by_reference (sym->ns->proc_name);
  else
    byref = 0;

  if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
    {
      /* Return via extra parameter.  */
      if (sym->attr.result && byref
	  && !sym->backend_decl)
	{
	  sym->backend_decl =
	    DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
	  /* For entry master function skip over the __entry
	     argument.  */
	  if (sym->ns->proc_name->attr.entry_master)
	    sym->backend_decl = TREE_CHAIN (sym->backend_decl);
	}

      /* Dummy variables should already have been created.  */
      gcc_assert (sym->backend_decl);

      /* Create a character length variable.  */
      if (sym->ts.type == BT_CHARACTER)
	{
	  if (sym->ts.cl->backend_decl == NULL_TREE)
	    {
	      length = gfc_create_string_length (sym);
	      if (TREE_CODE (length) != INTEGER_CST)
		{
		  gfc_finish_var_decl (length, sym);
		  gfc_defer_symbol_init (sym);
		}
	    }

	  /* Set the element size of automatic and assumed character length
	     length, dummy, pointer arrays.  */
	  if (sym->attr.pointer && sym->attr.dummy
		&& sym->attr.dimension)
	    {
	      tmp = gfc_build_indirect_ref (sym->backend_decl);
	      etype = gfc_get_element_type (TREE_TYPE (tmp));
	      if (TYPE_SIZE_UNIT (etype) == NULL_TREE)
		{
		  tmp = TYPE_SIZE_UNIT (gfc_character1_type_node);
		  tmp = fold_convert (TREE_TYPE (tmp), sym->ts.cl->backend_decl);
		  TYPE_SIZE_UNIT (etype) = tmp;
		}
	    }
	}

      /* Use a copy of the descriptor for dummy arrays.  */
      if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
        {
          sym->backend_decl =
            gfc_build_dummy_array_decl (sym, sym->backend_decl);
	}

      TREE_USED (sym->backend_decl) = 1;
      if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
	{
	  gfc_add_assign_aux_vars (sym);
	}
      return sym->backend_decl;
    }

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

  /* Catch function declarations.  Only used for actual parameters.  */
  if (sym->attr.flavor == FL_PROCEDURE)
    {
      decl = gfc_get_extern_function_decl (sym);
      return decl;
    }

  if (sym->attr.intrinsic)
    internal_error ("intrinsic variable which isn't a procedure");

  /* Create string length decl first so that they can be used in the
     type declaration.  */
  if (sym->ts.type == BT_CHARACTER)
    length = gfc_create_string_length (sym);