trans-decl.c

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

  /* Create the decl for the variable.  */
  decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));

  gfc_set_decl_location (decl, &sym->declared_at);

  /* Symbols from modules should have their assembler names mangled.
     This is done here rather than in gfc_finish_var_decl because it
     is different for string length variables.  */
  if (sym->module)
    SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));

  if (sym->attr.dimension)
    {
      /* Create variables to hold the non-constant bits of array info.  */
      gfc_build_qualified_array (decl, sym);

      /* Remember this variable for allocation/cleanup.  */
      gfc_defer_symbol_init (sym);

      if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
	GFC_DECL_PACKED_ARRAY (decl) = 1;
    }

  gfc_finish_var_decl (decl, sym);

  if (sym->ts.type == BT_CHARACTER)
    {
      /* Character variables need special handling.  */
      gfc_allocate_lang_decl (decl);

      if (TREE_CODE (length) != INTEGER_CST)
	{
	  char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];

	  if (sym->module)
	    {
	      /* Also prefix the mangled name for symbols from modules.  */
	      strcpy (&name[1], sym->name);
	      name[0] = '.';
	      strcpy (&name[1],
		      IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
	      SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
	    }
	  gfc_finish_var_decl (length, sym);
	  gcc_assert (!sym->value);
	}
    }
  sym->backend_decl = decl;

  if (sym->attr.assign)
    {
      gfc_add_assign_aux_vars (sym);
    }

  if (TREE_STATIC (decl) && !sym->attr.use_assoc)
    {
      /* Add static initializer.  */
      DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
	  TREE_TYPE (decl), sym->attr.dimension,
	  sym->attr.pointer || sym->attr.allocatable);
    }

  return decl;
}


/* Substitute a temporary variable in place of the real one.  */

void
gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
{
  save->attr = sym->attr;
  save->decl = sym->backend_decl;

  gfc_clear_attr (&sym->attr);
  sym->attr.referenced = 1;
  sym->attr.flavor = FL_VARIABLE;

  sym->backend_decl = decl;
}


/* Restore the original variable.  */

void
gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
{
  sym->attr = save->attr;
  sym->backend_decl = save->decl;
}


/* Get a basic decl for an external function.  */

tree
gfc_get_extern_function_decl (gfc_symbol * sym)
{
  tree type;
  tree fndecl;
  gfc_expr e;
  gfc_intrinsic_sym *isym;
  gfc_expr argexpr;
  char s[GFC_MAX_SYMBOL_LEN + 13]; /* "f2c_specific" and '\0'.  */
  tree name;
  tree mangled_name;

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

  /* We should never be creating external decls for alternate entry points.
     The procedure may be an alternate entry point, but we don't want/need
     to know that.  */
  gcc_assert (!(sym->attr.entry || sym->attr.entry_master));

  if (sym->attr.intrinsic)
    {
      /* Call the resolution function to get the actual name.  This is
         a nasty hack which relies on the resolution functions only looking
	 at the first argument.  We pass NULL for the second argument
	 otherwise things like AINT get confused.  */
      isym = gfc_find_function (sym->name);
      gcc_assert (isym->resolve.f0 != NULL);

      memset (&e, 0, sizeof (e));
      e.expr_type = EXPR_FUNCTION;

      memset (&argexpr, 0, sizeof (argexpr));
      gcc_assert (isym->formal);
      argexpr.ts = isym->formal->ts;

      if (isym->formal->next == NULL)
	isym->resolve.f1 (&e, &argexpr);
      else
	{
	  /* All specific intrinsics take one or two arguments.  */
	  gcc_assert (isym->formal->next->next == NULL);
	  isym->resolve.f2 (&e, &argexpr, NULL);
	}

      if (gfc_option.flag_f2c
	  && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
	      || e.ts.type == BT_COMPLEX))
	{
	  /* Specific which needs a different implementation if f2c
	     calling conventions are used.  */
	  sprintf (s, "f2c_specific%s", e.value.function.name);
	}
      else
	sprintf (s, "specific%s", e.value.function.name);

      name = get_identifier (s);
      mangled_name = name;
    }
  else
    {
      name = gfc_sym_identifier (sym);
      mangled_name = gfc_sym_mangled_function_id (sym);
    }

  type = gfc_get_function_type (sym);
  fndecl = build_decl (FUNCTION_DECL, name, type);

  SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
  /* If the return type is a pointer, avoid alias issues by setting
     DECL_IS_MALLOC to nonzero. This means that the function should be
     treated as if it were a malloc, meaning it returns a pointer that
     is not an alias.  */
  if (POINTER_TYPE_P (type))
    DECL_IS_MALLOC (fndecl) = 1;

  /* Set the context of this decl.  */
  if (0 && sym->ns && sym->ns->proc_name)
    {
      /* TODO: Add external decls to the appropriate scope.  */
      DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
    }
  else
    {
      /* Global declaration, e.g. intrinsic subroutine.  */
      DECL_CONTEXT (fndecl) = NULL_TREE;
    }

  DECL_EXTERNAL (fndecl) = 1;

  /* This specifies if a function is globally addressable, i.e. it is
     the opposite of declaring static in C.  */
  TREE_PUBLIC (fndecl) = 1;

  /* Set attributes for PURE functions. A call to PURE function in the
     Fortran 95 sense is both pure and without side effects in the C
     sense.  */
  if (sym->attr.pure || sym->attr.elemental)
    {
      if (sym->attr.function && !gfc_return_by_reference (sym))
	DECL_IS_PURE (fndecl) = 1;
      /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
	 parameters and don't use alternate returns (is this
	 allowed?). In that case, calls to them are meaningless, and
	 can be optimized away. See also in build_function_decl().  */
      TREE_SIDE_EFFECTS (fndecl) = 0;
    }

  /* Mark non-returning functions.  */
  if (sym->attr.noreturn)
      TREE_THIS_VOLATILE(fndecl) = 1;

  sym->backend_decl = fndecl;

  if (DECL_CONTEXT (fndecl) == NULL_TREE)
    pushdecl_top_level (fndecl);

  return fndecl;
}


/* Create a declaration for a procedure.  For external functions (in the C
   sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
   a master function with alternate entry points.  */

static void
build_function_decl (gfc_symbol * sym)
{
  tree fndecl, type;
  symbol_attribute attr;
  tree result_decl;
  gfc_formal_arglist *f;

  gcc_assert (!sym->backend_decl);
  gcc_assert (!sym->attr.external);

  /* Set the line and filename.  sym->declared_at seems to point to the
     last statement for subroutines, but it'll do for now.  */
  gfc_set_backend_locus (&sym->declared_at);

  /* Allow only one nesting level.  Allow public declarations.  */
  gcc_assert (current_function_decl == NULL_TREE
	  || DECL_CONTEXT (current_function_decl) == NULL_TREE);

  type = gfc_get_function_type (sym);
  fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);

  /* Perform name mangling if this is a top level or module procedure.  */
  if (current_function_decl == NULL_TREE)
    SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));

  /* Figure out the return type of the declared function, and build a
     RESULT_DECL for it.  If this is a subroutine with alternate
     returns, build a RESULT_DECL for it.  */
  attr = sym->attr;

  result_decl = NULL_TREE;
  /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
  if (attr.function)
    {
      if (gfc_return_by_reference (sym))
	type = void_type_node;
      else
	{
	  if (sym->result != sym)
	    result_decl = gfc_sym_identifier (sym->result);

	  type = TREE_TYPE (TREE_TYPE (fndecl));
	}
    }
  else
    {
      /* Look for alternate return placeholders.  */
      int has_alternate_returns = 0;
      for (f = sym->formal; f; f = f->next)
	{
	  if (f->sym == NULL)
	    {
	      has_alternate_returns = 1;
	      break;
	    }
	}

      if (has_alternate_returns)
	type = integer_type_node;
      else
	type = void_type_node;
    }

  result_decl = build_decl (RESULT_DECL, result_decl, type);
  DECL_ARTIFICIAL (result_decl) = 1;
  DECL_IGNORED_P (result_decl) = 1;
  DECL_CONTEXT (result_decl) = fndecl;
  DECL_RESULT (fndecl) = result_decl;

  /* Don't call layout_decl for a RESULT_DECL.
     layout_decl (result_decl, 0);  */

  /* If the return type is a pointer, avoid alias issues by setting
     DECL_IS_MALLOC to nonzero. This means that the function should be
     treated as if it were a malloc, meaning it returns a pointer that
     is not an alias.  */
  if (POINTER_TYPE_P (type))
    DECL_IS_MALLOC (fndecl) = 1;

  /* Set up all attributes for the function.  */
  DECL_CONTEXT (fndecl) = current_function_decl;
  DECL_EXTERNAL (fndecl) = 0;

  /* This specifies if a function is globally visible, i.e. it is
     the opposite of declaring static in C.  */
  if (DECL_CONTEXT (fndecl) == NULL_TREE
      && !sym->attr.entry_master)
    TREE_PUBLIC (fndecl) = 1;

  /* TREE_STATIC means the function body is defined here.  */
  TREE_STATIC (fndecl) = 1;

  /* Set attributes for PURE functions. A call to a PURE function in the
     Fortran 95 sense is both pure and without side effects in the C
     sense.  */
  if (attr.pure || attr.elemental)
    {
      /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
	 including a alternate return. In that case it can also be
	 marked as PURE. See also in gfc_get_extern_function_decl().  */
      if (attr.function && !gfc_return_by_reference (sym))
	DECL_IS_PURE (fndecl) = 1;
      TREE_SIDE_EFFECTS (fndecl) = 0;
    }

  /* Layout the function declaration and put it in the binding level
     of the current function.  */
  pushdecl (fndecl);

  sym->backend_decl = fndecl;
}


/* Create the DECL_ARGUMENTS for a procedure.  */

static void
create_function_arglist (gfc_symbol * sym)
{
  tree fndecl;
  gfc_formal_arglist *f;
  tree typelist;
  tree arglist;
  tree length;
  tree type;
  tree parm;

  fndecl = sym->backend_decl;

  /* Build formal argument list. Make sure that their TREE_CONTEXT is
     the new FUNCTION_DECL node.  */
  arglist = NULL_TREE;
  typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));

  if (sym->attr.entry_master)
    {
      type = TREE_VALUE (typelist);
      parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
      
      DECL_CONTEXT (parm) = fndecl;
      DECL_ARG_TYPE (parm) = type;
      TREE_READONLY (parm) = 1;
      gfc_finish_decl (parm, NULL_TREE);

      arglist = chainon (arglist, parm);
      typelist = TREE_CHAIN (typelist);
    }

  if (gfc_return_by_reference (sym))
    {
      type = TREE_VALUE (typelist);
      parm = build_decl (PARM_DECL, get_identifier ("__result"), type);

      DECL_CONTEXT (parm) = fndecl;
      DECL_ARG_TYPE (parm) = type;
      TREE_READONLY (parm) = 1;
      DECL_ARTIFICIAL (parm) = 1;
      gfc_finish_decl (parm, NULL_TREE);

      arglist = chainon (arglist, parm);
      typelist = TREE_CHAIN (typelist);

      if (sym->ts.type == BT_CHARACTER)
	{
	  gfc_allocate_lang_decl (parm);

	  /* Length of character result.  */
	  type = TREE_VALUE (typelist);
	  gcc_assert (type == gfc_charlen_type_node);

	  length = build_decl (PARM_DECL,
			       get_identifier (".__result"),
			       type);
	  if (!sym->ts.cl->length)
	    {
	      sym->ts.cl->backend_decl = length;
	      TREE_USED (length) = 1;
	    }
	  gcc_assert (TREE_CODE (length) == PARM_DECL);
	  arglist = chainon (arglist, length);
	  typelist = TREE_CHAIN (typelist);
	  DECL_CONTEXT (length) = fndecl;
	  DECL_ARG_TYPE (length) = type;
	  TREE_READONLY (length) = 1;
	  DECL_ARTIFICIAL (length) = 1;
	  gfc_finish_decl (length, NULL_TREE);
	}
    }

  for (f = sym->formal; f; f = f->next)
    {
      if (f->sym != NULL)	/* ignore alternate returns.  */
	{
	  length = NULL_TREE;

	  type = TREE_VALUE (typelist);

	  /* Build a the argument declaration.  */
	  parm = build_decl (PARM_DECL,
			     gfc_sym_identifier (f->sym), type);

	  /* Fill in arg stuff.  */
	  DECL_CONTEXT (parm) = fndecl;
	  DECL_ARG_TYPE (parm) = type;
	  /* All implementation args are read-only.  */
	  TREE_READONLY (parm) = 1;

	  gfc_finish_decl (parm, NULL_TREE);

	  f->sym->backend_decl = parm;

	  arglist = chainon (arglist, parm);
	  typelist = TREE_CHAIN (typelist);
	}
    }

  /* Add the hidden string length parameters.  */
  parm = arglist;
  for (f = sym->formal; f; f = f->next)
    {
      char name[GFC_MAX_SYMBOL_LEN + 2];
      /* Ignore alternate returns.  */
      if (f->sym == NULL)
	continue;

      if (f->sym->ts.type != BT_CHARACTER)
	continue;

      parm = f->sym->backend_decl;
      type = TREE_VALUE (typelist);
      gcc_assert (type == gfc_charlen_type_node);