f95-lang.c

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

/* gfortran backend interface
   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
   Inc.
   Contributed by Paul Brook.

This file is part of GCC.

GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2, or (at your option) any later
version.

GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING.  If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.  */

/* f95-lang.c-- GCC backend interface stuff */

/* declare required prototypes: */

#include "config.h"
#include "system.h"
#include "ansidecl.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "tree-gimple.h"
#include "flags.h"
#include "langhooks.h"
#include "langhooks-def.h"
#include "timevar.h"
#include "tm.h"
#include "function.h"
#include "ggc.h"
#include "toplev.h"
#include "target.h"
#include "debug.h"
#include "diagnostic.h"
#include "tree-dump.h"
#include "cgraph.h"

#include "gfortran.h"
#include "trans.h"
#include "trans-types.h"
#include "trans-const.h"

/* Language-dependent contents of an identifier.  */

struct lang_identifier
GTY(())
{
  struct tree_identifier common;
};

/* The resulting tree type.  */

union lang_tree_node
GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"),
     chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)")))
{
  union tree_node GTY((tag ("0"),
		       desc ("tree_node_structure (&%h)"))) generic;
  struct lang_identifier GTY((tag ("1"))) identifier;
};

/* Save and restore the variables in this file and elsewhere
   that keep track of the progress of compilation of the current function.
   Used for nested functions.  */

struct language_function
GTY(())
{
  /* struct gfc_language_function base; */
  struct binding_level *binding_level;
};

/* We don't have a lex/yacc lexer/parser, but toplev expects these to
   exist anyway.  */
void yyerror (const char *str);
int yylex (void);

static void gfc_init_decl_processing (void);
static void gfc_init_builtin_functions (void);

/* Each front end provides its own.  */
static bool gfc_init (void);
static void gfc_finish (void);
static void gfc_print_identifier (FILE *, tree, int);
static bool gfc_mark_addressable (tree);
void do_function_end (void);
int global_bindings_p (void);
void insert_block (tree);
static void gfc_clear_binding_stack (void);
static void gfc_be_parse_file (int);
static void gfc_expand_function (tree);

#undef LANG_HOOKS_NAME
#undef LANG_HOOKS_INIT
#undef LANG_HOOKS_FINISH
#undef LANG_HOOKS_INIT_OPTIONS
#undef LANG_HOOKS_HANDLE_OPTION
#undef LANG_HOOKS_POST_OPTIONS
#undef LANG_HOOKS_PRINT_IDENTIFIER
#undef LANG_HOOKS_PARSE_FILE
#undef LANG_HOOKS_MARK_ADDRESSABLE
#undef LANG_HOOKS_TYPE_FOR_MODE
#undef LANG_HOOKS_TYPE_FOR_SIZE
#undef LANG_HOOKS_UNSIGNED_TYPE
#undef LANG_HOOKS_SIGNED_TYPE
#undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
#undef LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION
#undef LANG_HOOKS_CLEAR_BINDING_STACK

/* Define lang hooks.  */
#define LANG_HOOKS_NAME                 "GNU F95"
#define LANG_HOOKS_INIT                 gfc_init
#define LANG_HOOKS_FINISH               gfc_finish
#define LANG_HOOKS_INIT_OPTIONS         gfc_init_options
#define LANG_HOOKS_HANDLE_OPTION        gfc_handle_option
#define LANG_HOOKS_POST_OPTIONS		gfc_post_options
#define LANG_HOOKS_PRINT_IDENTIFIER     gfc_print_identifier
#define LANG_HOOKS_PARSE_FILE           gfc_be_parse_file
#define LANG_HOOKS_MARK_ADDRESSABLE        gfc_mark_addressable
#define LANG_HOOKS_TYPE_FOR_MODE           gfc_type_for_mode
#define LANG_HOOKS_TYPE_FOR_SIZE           gfc_type_for_size
#define LANG_HOOKS_UNSIGNED_TYPE           gfc_unsigned_type
#define LANG_HOOKS_SIGNED_TYPE             gfc_signed_type
#define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE gfc_signed_or_unsigned_type
#define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION gfc_expand_function
#define LANG_HOOKS_CLEAR_BINDING_STACK     gfc_clear_binding_stack

const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;

/* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
   that have names.  Here so we can clear out their names' definitions
   at the end of the function.  */

/* Tree code classes.  */

#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,

const enum tree_code_class tree_code_type[] = {
#include "tree.def"
};
#undef DEFTREECODE

/* Table indexed by tree code giving number of expression
   operands beyond the fixed part of the node structure.
   Not used for types or decls.  */

#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,

const unsigned char tree_code_length[] = {
#include "tree.def"
};
#undef DEFTREECODE

/* Names of tree components.
   Used for printing out the tree and error messages.  */
#define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,

const char *const tree_code_name[] = {
#include "tree.def"
};
#undef DEFTREECODE


#define NULL_BINDING_LEVEL (struct binding_level *) NULL

/* A chain of binding_level structures awaiting reuse.  */

static GTY(()) struct binding_level *free_binding_level;

/* The elements of `ridpointers' are identifier nodes
   for the reserved type names and storage classes.
   It is indexed by a RID_... value.  */
tree *ridpointers = NULL;

/* language-specific flags.  */

static void
gfc_expand_function (tree fndecl)
{
  tree t;

  if (DECL_INITIAL (fndecl)
      && BLOCK_SUBBLOCKS (DECL_INITIAL (fndecl)))
    {
      /* Local static equivalenced variables are never seen by
	 check_global_declarations, so we need to output debug
	 info by hand.  */

      t = BLOCK_SUBBLOCKS (DECL_INITIAL (fndecl));
      for (t = BLOCK_VARS (t); t; t = TREE_CHAIN (t))
	if (TREE_CODE (t) == VAR_DECL && DECL_HAS_VALUE_EXPR_P (t)
	    && TREE_STATIC (t))
	  {
	    tree expr = DECL_VALUE_EXPR (t);

	    if (TREE_CODE (expr) == COMPONENT_REF
		&& TREE_CODE (TREE_OPERAND (expr, 0)) == VAR_DECL
		&& TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0)))
		   == UNION_TYPE
		&& cgraph_varpool_node (TREE_OPERAND (expr, 0))->needed
		&& errorcount == 0 && sorrycount == 0)
	      {
		timevar_push (TV_SYMOUT);
		(*debug_hooks->global_decl) (t);
		timevar_pop (TV_SYMOUT);
	      }
	  }
    }

  tree_rest_of_compilation (fndecl);
}


/* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
   or validate its data type for an `if' or `while' statement or ?..: exp.

   This preparation consists of taking the ordinary
   representation of an expression expr and producing a valid tree
   boolean expression describing whether expr is nonzero.  We could
   simply always do build_binary_op (NE_EXPR, expr, boolean_false_node, 1),
   but we optimize comparisons, &&, ||, and !.

   The resulting type should always be `boolean_type_node'.
   This is much simpler than the corresponding C version because we have a
   distinct boolean type.  */

tree
gfc_truthvalue_conversion (tree expr)
{
  switch (TREE_CODE (TREE_TYPE (expr)))
    {
    case BOOLEAN_TYPE:
      if (TREE_TYPE (expr) == boolean_type_node)
	return expr;
      else if (COMPARISON_CLASS_P (expr))
	{
	  TREE_TYPE (expr) = boolean_type_node;
	  return expr;
	}
      else if (TREE_CODE (expr) == NOP_EXPR)
        return build1 (NOP_EXPR, boolean_type_node,
	               TREE_OPERAND (expr, 0));
      else
        return build1 (NOP_EXPR, boolean_type_node, expr);

    case INTEGER_TYPE:
      if (TREE_CODE (expr) == INTEGER_CST)
	return integer_zerop (expr) ? boolean_false_node : boolean_true_node;
      else
        return build2 (NE_EXPR, boolean_type_node, expr, integer_zero_node);

    default:
      internal_error ("Unexpected type in truthvalue_conversion");
    }
}

static void
gfc_create_decls (void)
{
  /* GCC builtins.  */
  gfc_init_builtin_functions ();

  /* Runtime/IO library functions.  */
  gfc_build_builtin_function_decls ();

  gfc_init_constants ();
}

static void
gfc_be_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
{
  int errors;
  int warnings;

  gfc_create_decls ();
  gfc_parse_file ();
  gfc_generate_constructors ();

  cgraph_finalize_compilation_unit ();
  cgraph_optimize ();

  /* Tell the frontent about any errors.  */
  gfc_get_errors (&warnings, &errors);
  errorcount += errors;
  warningcount += warnings;
}

/* Initialize everything.  */

static bool
gfc_init (void)
{
#ifdef USE_MAPPED_LOCATION
  linemap_add (&line_table, LC_ENTER, false, gfc_source_file, 1);
  linemap_add (&line_table, LC_RENAME, false, "<built-in>", 0);
#endif

  /* First initialize the backend.  */
  gfc_init_decl_processing ();
  gfc_static_ctors = NULL_TREE;

  /* Then the frontend.  */
  gfc_init_1 ();

  if (gfc_new_file () != SUCCESS)
    fatal_error ("can't open input file: %s", gfc_source_file);
  return true;
}


static void
gfc_finish (void)
{
  gfc_done_1 ();
  gfc_release_include_path ();
  return;
}

static void
gfc_print_identifier (FILE * file ATTRIBUTE_UNUSED,
		      tree node ATTRIBUTE_UNUSED,
		      int indent ATTRIBUTE_UNUSED)
{
  return;
}


/* These functions and variables deal with binding contours.  We only
   need these functions for the list of PARM_DECLs, but we leave the
   functions more general; these are a simplified version of the
   functions from GNAT.  */

/* For each binding contour we allocate a binding_level structure which records
   the entities defined or declared in that contour. Contours include:

        the global one
        one for each subprogram definition
        one for each compound statement (declare block)

   Binding contours are used to create GCC tree BLOCK nodes.  */

struct binding_level
GTY(())
{
  /* A chain of ..._DECL nodes for all variables, constants, functions,
     parameters and type declarations.  These ..._DECL nodes are chained
     through the TREE_CHAIN field. Note that these ..._DECL nodes are stored
     in the reverse of the order supplied to be compatible with the
     back-end.  */
  tree names;
  /* For each level (except the global one), a chain of BLOCK nodes for all
     the levels that were entered and exited one level down from this one.  */
  tree blocks;
  /* The binding level containing this one (the enclosing binding level).  */
  struct binding_level *level_chain;
};

/* The binding level currently in effect.  */
static GTY(()) struct binding_level *current_binding_level = NULL;

/* The outermost binding level. This binding level is created when the
   compiler is started and it will exist through the entire compilation.  */
static GTY(()) struct binding_level *global_binding_level;

/* Binding level structures are initialized by copying this one.  */
static struct binding_level clear_binding_level = { NULL, NULL, NULL };

/* Return nonzero if we are currently in the global binding level.  */

int
global_bindings_p (void)
{
  return current_binding_level == global_binding_level ? -1 : 0;
}

tree
getdecls (void)
{
  return current_binding_level->names;
}

/* Enter a new binding level. The input parameter is ignored, but has to be
   specified for back-end compatibility.  */

void
pushlevel (int ignore ATTRIBUTE_UNUSED)
{
  struct binding_level *newlevel
    = (struct binding_level *) ggc_alloc (sizeof (struct binding_level));

  *newlevel = clear_binding_level;

  /* Add this level to the front of the chain (stack) of levels that are
     active.  */
  newlevel->level_chain = current_binding_level;
  current_binding_level = newlevel;
}

/* Exit a binding level.
   Pop the level off, and restore the state of the identifier-decl mappings
   that were in effect when this level was entered.

   If KEEP is nonzero, this level had explicit declarations, so
   and create a "block" (a BLOCK node) for the level
   to record its declarations and subblocks for symbol table output.

   If FUNCTIONBODY is nonzero, this level is the body of a function,
   so create a block as if KEEP were set and also clear out all
   label names.

   If REVERSE is nonzero, reverse the order of decls before putting
   them into the BLOCK.  */

tree
poplevel (int keep, int reverse, int functionbody)
{
  /* Points to a BLOCK tree node. This is the BLOCK node constructed for the
     binding level that we are about to exit and which is returned by this
     routine.  */
  tree block_node = NULL_TREE;
  tree decl_chain;
  tree subblock_chain = current_binding_level->blocks;
  tree subblock_node;

  /* Reverse the list of XXXX_DECL nodes if desired.  Note that the ..._DECL
     nodes chained through the `names' field of current_binding_level are in
     reverse order except for PARM_DECL node, which are explicitly stored in
     the right order.  */
  decl_chain = (reverse) ? nreverse (current_binding_level->names)
    : current_binding_level->names;

  /* If there were any declarations in the current binding level, or if this
     binding level is a function body, or if there are any nested blocks then
     create a BLOCK node to record them for the life of this function.  */
  if (keep || functionbody)
    block_node = build_block (keep ? decl_chain : 0, subblock_chain, 0, 0);