#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"
struct lang_identifier
GTY(())
{
struct tree_identifier common;
};
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;
};
struct language_function
GTY(())
{
tree named_labels;
tree shadowed_labels;
int returns_value;
int returns_abnormally;
int warn_about_return_type;
int extern_inline;
struct binding_level *binding_level;
};
void yyerror (const char *str);
int yylex (void);
static void gfc_init_decl_processing (void);
static void gfc_init_builtin_functions (void);
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_TRUTHVALUE_CONVERSION
#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_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_TRUTHVALUE_CONVERSION gfc_truthvalue_conversion
#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;
#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
const enum tree_code_class tree_code_type[] = {
#include "tree.def"
};
#undef DEFTREECODE
#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
const unsigned char tree_code_length[] = {
#include "tree.def"
};
#undef DEFTREECODE
#define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
const char *const tree_code_name[] = {
#include "tree.def"
};
#undef DEFTREECODE
static tree named_labels;
#define NULL_BINDING_LEVEL (struct binding_level *) NULL
static GTY(()) struct binding_level *free_binding_level;
tree *ridpointers = NULL;
static void
gfc_expand_function (tree fndecl)
{
tree_rest_of_compilation (fndecl);
}
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)
{
gfc_init_builtin_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 ();
gfc_get_errors (&warnings, &errors);
errorcount += errors;
warningcount += warnings;
}
static bool
gfc_init (void)
{
#ifdef USE_MAPPED_LOCATION
linemap_add (&line_table, LC_ENTER, false, gfc_option.source, 1);
linemap_add (&line_table, LC_RENAME, false, "<built-in>", 0);
#endif
gfc_init_decl_processing ();
gfc_static_ctors = NULL_TREE;
gfc_init_1 ();
if (gfc_new_file (gfc_option.source, gfc_option.source_form) != SUCCESS)
fatal_error ("can't open input file: %s", gfc_option.source);
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;
}
struct binding_level
GTY(())
{
tree names;
tree blocks;
struct binding_level *level_chain;
};
static GTY(()) struct binding_level *current_binding_level = NULL;
static GTY(()) struct binding_level *global_binding_level;
static struct binding_level clear_binding_level = { NULL, NULL, NULL };
int
global_bindings_p (void)
{
return current_binding_level == global_binding_level ? -1 : 0;
}
tree
getdecls (void)
{
return current_binding_level->names;
}
void
pushlevel (int ignore ATTRIBUTE_UNUSED)
{
struct binding_level *newlevel
= (struct binding_level *) ggc_alloc (sizeof (struct binding_level));
*newlevel = clear_binding_level;
newlevel->level_chain = current_binding_level;
current_binding_level = newlevel;
}
tree
poplevel (int keep, int reverse, int functionbody)
{
tree block_node = NULL_TREE;
tree decl_chain;
tree subblock_chain = current_binding_level->blocks;
tree subblock_node;
decl_chain = (reverse) ? nreverse (current_binding_level->names)
: current_binding_level->names;
if (keep || functionbody)
block_node = build_block (keep ? decl_chain : 0, 0, subblock_chain, 0, 0);
for (subblock_node = subblock_chain; subblock_node;
subblock_node = TREE_CHAIN (subblock_node))
BLOCK_SUPERCONTEXT (subblock_node) = block_node;
for (subblock_node = decl_chain; subblock_node;
subblock_node = TREE_CHAIN (subblock_node))
if (DECL_NAME (subblock_node) != 0)
if (DECL_EXTERNAL (subblock_node))
{
if (TREE_USED (subblock_node))
TREE_USED (DECL_NAME (subblock_node)) = 1;
if (TREE_ADDRESSABLE (subblock_node))
TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1;
}
current_binding_level = current_binding_level->level_chain;
if (functionbody)
{
DECL_INITIAL (current_function_decl) = block_node;
BLOCK_VARS (block_node) = 0;
}
else if (block_node)
{
current_binding_level->blocks
= chainon (current_binding_level->blocks, block_node);
}
else if (subblock_chain)
current_binding_level->blocks
= chainon (current_binding_level->blocks, subblock_chain);
if (block_node)
TREE_USED (block_node) = 1;
return block_node;
}
void
insert_block (tree block)
{
TREE_USED (block) = 1;
current_binding_level->blocks
= chainon (current_binding_level->blocks, block);
}
tree
pushdecl (tree decl)
{
if ((DECL_EXTERNAL (decl)) || (decl == current_function_decl))
DECL_CONTEXT (decl) = 0;
else
DECL_CONTEXT (decl) = current_function_decl;
TREE_CHAIN (decl) = current_binding_level->names;
current_binding_level->names = decl;
if (TREE_CODE (decl) == TYPE_DECL && TYPE_NAME (TREE_TYPE (decl)) == 0)
{
if (DECL_SOURCE_LINE (decl) == 0)
TYPE_NAME (TREE_TYPE (decl)) = decl;
else
TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl);
}
return decl;
}
tree
pushdecl_top_level (tree x)
{
tree t;
struct binding_level *b = current_binding_level;
current_binding_level = global_binding_level;
t = pushdecl (x);
current_binding_level = b;
return t;
}
static void
gfc_clear_binding_stack (void)
{
while (!global_bindings_p ())
poplevel (0, 0, 0);
}
#ifndef CHAR_TYPE_SIZE
#define CHAR_TYPE_SIZE BITS_PER_UNIT
#endif
#ifndef INT_TYPE_SIZE
#define INT_TYPE_SIZE BITS_PER_WORD
#endif
#undef SIZE_TYPE
#define SIZE_TYPE "long unsigned int"
static void
gfc_init_decl_processing (void)
{
current_function_decl = NULL;
named_labels = NULL;
current_binding_level = NULL_BINDING_LEVEL;
free_binding_level = NULL_BINDING_LEVEL;
pushlevel (0);
global_binding_level = current_binding_level;
build_common_tree_nodes (false, false);
set_sizetype (long_unsigned_type_node);
build_common_tree_nodes_2 (0);
gfc_init_kinds ();
gfc_init_types ();
}
bool
gfc_mark_addressable (tree exp)
{
register tree x = exp;
while (1)
switch (TREE_CODE (x))
{
case COMPONENT_REF:
case ADDR_EXPR:
case ARRAY_REF:
case REALPART_EXPR:
case IMAGPART_EXPR:
x = TREE_OPERAND (x, 0);
break;
case CONSTRUCTOR:
TREE_ADDRESSABLE (x) = 1;
return true;
case VAR_DECL:
case CONST_DECL:
case PARM_DECL:
case RESULT_DECL:
if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) && DECL_NONLOCAL (x))
{
if (TREE_PUBLIC (x))
{
error
("global register variable %qs used in nested function",
IDENTIFIER_POINTER (DECL_NAME (x)));
return false;
}
pedwarn ("register variable %qs used in nested function",
IDENTIFIER_POINTER (DECL_NAME (x)));
}
else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
{
if (TREE_PUBLIC (x))
{
error ("address of global register variable %qs requested",
IDENTIFIER_POINTER (DECL_NAME (x)));
return true;
}
#if 0
else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x)))
{
error ("cannot put object with volatile field into register");
return false;
}
#endif
pedwarn ("address of register variable %qs requested",
IDENTIFIER_POINTER (DECL_NAME (x)));
}
case FUNCTION_DECL:
TREE_ADDRESSABLE (x) = 1;
default:
return true;
}
}
int ggc_p = 1;
tree
builtin_function (const char *name,
tree type,
int function_code,
enum built_in_class class,
const char *library_name,
tree attrs ATTRIBUTE_UNUSED)
{
tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
DECL_EXTERNAL (decl) = 1;
TREE_PUBLIC (decl) = 1;
if (library_name)
SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
make_decl_rtl (decl);
pushdecl (decl);
DECL_BUILT_IN_CLASS (decl) = class;
DECL_FUNCTION_CODE (decl) = function_code;
return decl;
}
static void
gfc_define_builtin (const char * name,
tree type,
int code,
const char * library_name,
bool const_p)
{
tree decl;
decl = builtin_function (name, type, code, BUILT_IN_NORMAL,
library_name, NULL_TREE);
if (const_p)
TREE_READONLY (decl) = 1;
built_in_decls[code] = decl;
implicit_built_in_decls[code] = decl;
}
#define DO_DEFINE_MATH_BUILTIN(code, name, argtype, tbase) \
gfc_define_builtin ("__builtin_" name, tbase##double[argtype], \
BUILT_IN_ ## code, name, true); \
gfc_define_builtin ("__builtin_" name "f", tbase##float[argtype], \
BUILT_IN_ ## code ## F, name "f", true);
#define DEFINE_MATH_BUILTIN(code, name, argtype) \
DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_)
#define DEFINE_MATH_BUILTIN_C(code, name, argtype) \
DO_DEFINE_MATH_BUILTIN (code, name, argtype, mfunc_)
static void
build_builtin_fntypes (tree * fntype, tree type)
{
tree tmp;
tmp = tree_cons (NULL_TREE, float_type_node, void_list_node);
fntype[0] = build_function_type (type, tmp);
tmp = tree_cons (NULL_TREE, float_type_node, tmp);
fntype[1] = build_function_type (type, tmp);
tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node);
tmp = tree_cons (NULL_TREE, type, tmp);
fntype[2] = build_function_type (type, tmp);
}
static void
gfc_init_builtin_functions (void)
{
tree mfunc_float[3];
tree mfunc_double[3];
tree mfunc_cfloat[3];
tree mfunc_cdouble[3];
tree func_cfloat_float;
tree func_cdouble_double;
tree ftype;
tree tmp;
build_builtin_fntypes (mfunc_float, float_type_node);
build_builtin_fntypes (mfunc_double, double_type_node);
build_builtin_fntypes (mfunc_cfloat, complex_float_type_node);
build_builtin_fntypes (mfunc_cdouble, complex_double_type_node);
tmp = tree_cons (NULL_TREE, complex_float_type_node, void_list_node);
func_cfloat_float = build_function_type (float_type_node, tmp);
tmp = tree_cons (NULL_TREE, complex_double_type_node, void_list_node);
func_cdouble_double = build_function_type (double_type_node, tmp);
#include "mathbuiltins.def"
gfc_define_builtin ("__builtin_floor", mfunc_double[0],
BUILT_IN_FLOOR, "floor", true);
gfc_define_builtin ("__builtin_floorf", mfunc_float[0],
BUILT_IN_FLOORF, "floorf", true);
gfc_define_builtin ("__builtin_round", mfunc_double[0],
BUILT_IN_ROUND, "round", true);
gfc_define_builtin ("__builtin_roundf", mfunc_float[0],
BUILT_IN_ROUNDF, "roundf", true);
gfc_define_builtin ("__builtin_cabs", func_cdouble_double,
BUILT_IN_CABS, "cabs", true);
gfc_define_builtin ("__builtin_cabsf", func_cfloat_float,
BUILT_IN_CABSF, "cabsf", true);
gfc_define_builtin ("__builtin_copysign", mfunc_double[1],
BUILT_IN_COPYSIGN, "copysign", true);
gfc_define_builtin ("__builtin_copysignf", mfunc_float[1],
BUILT_IN_COPYSIGNF, "copysignf", true);
gfc_define_builtin ("__builtin_pow", mfunc_double[1],
BUILT_IN_POW, "pow", true);
gfc_define_builtin ("__builtin_powf", mfunc_float[1],
BUILT_IN_POWF, "powf", true);
tmp = tree_cons (NULL_TREE, integer_type_node, void_list_node);
ftype = build_function_type (integer_type_node, tmp);
gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ,
"__builtin_clz", true);
tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node);
ftype = build_function_type (integer_type_node, tmp);
gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL,
"__builtin_clzl", true);
tmp = tree_cons (NULL_TREE, long_long_integer_type_node, void_list_node);
ftype = build_function_type (integer_type_node, tmp);
gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL,
"__builtin_clzll", true);
tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node);
tmp = tree_cons (NULL_TREE, long_integer_type_node, tmp);
ftype = build_function_type (long_integer_type_node, tmp);
gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT,
"__builtin_expect", true);
build_common_builtin_nodes ();
targetm.init_builtins ();
}
#undef DEFINE_MATH_BUILTIN_C
#undef DEFINE_MATH_BUILTIN
#include "gt-fortran-f95-lang.h"
#include "gtype-fortran.h"