#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "tree-gimple.h"
#include "ggc.h"
#include "toplev.h"
#include "defaults.h"
#include "real.h"
#include "gfortran.h"
#include "trans.h"
#include "trans-stmt.h"
#include "trans-array.h"
#include "trans-types.h"
#include "trans-const.h"
static gfc_file *gfc_current_backend_file;
char gfc_msg_bounds[] = N_("Array bound mismatch");
char gfc_msg_fault[] = N_("Array reference out of bounds");
char gfc_msg_wrong_return[] = N_("Incorrect function return value");
tree
gfc_advance_chain (tree t, int n)
{
for (; n > 0; n--)
{
gcc_assert (t != NULL_TREE);
t = TREE_CHAIN (t);
}
return t;
}
tree
gfc_chainon_list (tree list, tree add)
{
tree l;
l = tree_cons (NULL_TREE, add, NULL_TREE);
return chainon (list, l);
}
static inline void
remove_suffix (char *name, int len)
{
int i;
for (i = 2; i < 8 && len > i; i++)
{
if (name[len - i] == '.')
{
name[len - i] = '\0';
break;
}
}
}
tree
gfc_create_var_np (tree type, const char *prefix)
{
return create_tmp_var_raw (type, prefix);
}
tree
gfc_create_var (tree type, const char *prefix)
{
tree tmp;
tmp = gfc_create_var_np (type, prefix);
pushdecl (tmp);
return tmp;
}
tree
gfc_evaluate_now (tree expr, stmtblock_t * pblock)
{
tree var;
if (CONSTANT_CLASS_P (expr))
return expr;
var = gfc_create_var (TREE_TYPE (expr), NULL);
gfc_add_modify_expr (pblock, var, expr);
return var;
}
void
gfc_add_modify_expr (stmtblock_t * pblock, tree lhs, tree rhs)
{
tree tmp;
#ifdef ENABLE_CHECKING
gcc_assert (TREE_TYPE (rhs) == TREE_TYPE (lhs)
|| AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
#endif
tmp = fold_build2 (MODIFY_EXPR, void_type_node, lhs, rhs);
gfc_add_expr_to_block (pblock, tmp);
}
void
gfc_start_block (stmtblock_t * block)
{
pushlevel (0);
block->has_scope = 1;
block->head = NULL_TREE;
}
void
gfc_init_block (stmtblock_t * block)
{
block->head = NULL_TREE;
block->has_scope = 0;
}
void
gfc_merge_block_scope (stmtblock_t * block)
{
tree decl;
tree next;
gcc_assert (block->has_scope);
block->has_scope = 0;
decl = getdecls ();
poplevel (0, 0, 0);
while (decl != NULL_TREE)
{
next = TREE_CHAIN (decl);
TREE_CHAIN (decl) = NULL_TREE;
pushdecl (decl);
decl = next;
}
}
tree
gfc_finish_block (stmtblock_t * stmtblock)
{
tree decl;
tree expr;
tree block;
expr = stmtblock->head;
if (!expr)
expr = build_empty_stmt ();
stmtblock->head = NULL_TREE;
if (stmtblock->has_scope)
{
decl = getdecls ();
if (decl)
{
block = poplevel (1, 0, 0);
expr = build3_v (BIND_EXPR, decl, expr, block);
}
else
poplevel (0, 0, 0);
}
return expr;
}
tree
gfc_build_addr_expr (tree type, tree t)
{
tree base_type = TREE_TYPE (t);
tree natural_type;
if (type && POINTER_TYPE_P (type)
&& TREE_CODE (base_type) == ARRAY_TYPE
&& TYPE_MAIN_VARIANT (TREE_TYPE (type))
== TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
natural_type = type;
else
natural_type = build_pointer_type (base_type);
if (TREE_CODE (t) == INDIRECT_REF)
{
if (!type)
type = natural_type;
t = TREE_OPERAND (t, 0);
natural_type = TREE_TYPE (t);
}
else
{
if (DECL_P (t))
TREE_ADDRESSABLE (t) = 1;
t = build1 (ADDR_EXPR, natural_type, t);
}
if (type && natural_type != type)
t = convert (type, t);
return t;
}
tree
gfc_build_array_ref (tree base, tree offset)
{
tree type = TREE_TYPE (base);
gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
type = TREE_TYPE (type);
if (DECL_P (base))
TREE_ADDRESSABLE (base) = 1;
return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
}
void
gfc_trans_runtime_check (tree cond, const char * msgid, stmtblock_t * pblock,
locus * where)
{
stmtblock_t block;
tree body;
tree tmp;
tree args;
char * message;
int line;
if (integer_zerop (cond))
return;
gfc_start_block (&block);
if (where)
{
#ifdef USE_MAPPED_LOCATION
line = LOCATION_LINE (where->lb->location);
#else
line = where->lb->linenum;
#endif
asprintf (&message, "%s (in file '%s', at line %d)", _(msgid),
where->lb->file->filename, line);
}
else
asprintf (&message, "%s (in file '%s', around line %d)", _(msgid),
gfc_source_file, input_line + 1);
tmp = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
gfc_free(message);
args = gfc_chainon_list (NULL_TREE, tmp);
tmp = build_function_call_expr (gfor_fndecl_runtime_error, args);
gfc_add_expr_to_block (&block, tmp);
body = gfc_finish_block (&block);
if (integer_onep (cond))
{
gfc_add_expr_to_block (pblock, body);
}
else
{
cond = fold_convert (long_integer_type_node, cond);
tmp = gfc_chainon_list (NULL_TREE, cond);
tmp = gfc_chainon_list (tmp, build_int_cst (long_integer_type_node, 0));
cond = build_function_call_expr (built_in_decls[BUILT_IN_EXPECT], tmp);
cond = fold_convert (boolean_type_node, cond);
tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
gfc_add_expr_to_block (pblock, tmp);
}
}
void
gfc_add_expr_to_block (stmtblock_t * block, tree expr)
{
gcc_assert (block);
if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
return;
if (block->head)
{
if (TREE_CODE (block->head) != STATEMENT_LIST)
{
tree tmp;
tmp = block->head;
block->head = NULL_TREE;
append_to_statement_list (tmp, &block->head);
}
append_to_statement_list (expr, &block->head);
}
else
block->head = expr;
}
void
gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
{
gcc_assert (append);
gcc_assert (!append->has_scope);
gfc_add_expr_to_block (block, append->head);
append->head = NULL_TREE;
}
void
gfc_get_backend_locus (locus * loc)
{
loc->lb = gfc_getmem (sizeof (gfc_linebuf));
#ifdef USE_MAPPED_LOCATION
loc->lb->location = input_location;
#else
loc->lb->linenum = input_line;
#endif
loc->lb->file = gfc_current_backend_file;
}
void
gfc_set_backend_locus (locus * loc)
{
gfc_current_backend_file = loc->lb->file;
#ifdef USE_MAPPED_LOCATION
input_location = loc->lb->location;
#else
input_line = loc->lb->linenum;
input_filename = loc->lb->file->filename;
#endif
}
tree
gfc_trans_code (gfc_code * code)
{
stmtblock_t block;
tree res;
if (!code)
return build_empty_stmt ();
gfc_start_block (&block);
for (; code; code = code->next)
{
if (code->here != 0)
{
res = gfc_trans_label_here (code);
gfc_add_expr_to_block (&block, res);
}
switch (code->op)
{
case EXEC_NOP:
res = NULL_TREE;
break;
case EXEC_ASSIGN:
res = gfc_trans_assign (code);
break;
case EXEC_LABEL_ASSIGN:
res = gfc_trans_label_assign (code);
break;
case EXEC_POINTER_ASSIGN:
res = gfc_trans_pointer_assign (code);
break;
case EXEC_INIT_ASSIGN:
res = gfc_trans_init_assign (code);
break;
case EXEC_CONTINUE:
res = NULL_TREE;
break;
case EXEC_CYCLE:
res = gfc_trans_cycle (code);
break;
case EXEC_EXIT:
res = gfc_trans_exit (code);
break;
case EXEC_GOTO:
res = gfc_trans_goto (code);
break;
case EXEC_ENTRY:
res = gfc_trans_entry (code);
break;
case EXEC_PAUSE:
res = gfc_trans_pause (code);
break;
case EXEC_STOP:
res = gfc_trans_stop (code);
break;
case EXEC_CALL:
res = gfc_trans_call (code, false);
break;
case EXEC_ASSIGN_CALL:
res = gfc_trans_call (code, true);
break;
case EXEC_RETURN:
res = gfc_trans_return (code);
break;
case EXEC_IF:
res = gfc_trans_if (code);
break;
case EXEC_ARITHMETIC_IF:
res = gfc_trans_arithmetic_if (code);
break;
case EXEC_DO:
res = gfc_trans_do (code);
break;
case EXEC_DO_WHILE:
res = gfc_trans_do_while (code);
break;
case EXEC_SELECT:
res = gfc_trans_select (code);
break;
case EXEC_FLUSH:
res = gfc_trans_flush (code);
break;
case EXEC_FORALL:
res = gfc_trans_forall (code);
break;
case EXEC_WHERE:
res = gfc_trans_where (code);
break;
case EXEC_ALLOCATE:
res = gfc_trans_allocate (code);
break;
case EXEC_DEALLOCATE:
res = gfc_trans_deallocate (code);
break;
case EXEC_OPEN:
res = gfc_trans_open (code);
break;
case EXEC_CLOSE:
res = gfc_trans_close (code);
break;
case EXEC_READ:
res = gfc_trans_read (code);
break;
case EXEC_WRITE:
res = gfc_trans_write (code);
break;
case EXEC_IOLENGTH:
res = gfc_trans_iolength (code);
break;
case EXEC_BACKSPACE:
res = gfc_trans_backspace (code);
break;
case EXEC_ENDFILE:
res = gfc_trans_endfile (code);
break;
case EXEC_INQUIRE:
res = gfc_trans_inquire (code);
break;
case EXEC_REWIND:
res = gfc_trans_rewind (code);
break;
case EXEC_TRANSFER:
res = gfc_trans_transfer (code);
break;
case EXEC_DT_END:
res = gfc_trans_dt_end (code);
break;
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DO:
case EXEC_OMP_FLUSH:
case EXEC_OMP_MASTER:
case EXEC_OMP_ORDERED:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
case EXEC_OMP_WORKSHARE:
res = gfc_trans_omp_directive (code);
break;
default:
internal_error ("gfc_trans_code(): Bad statement code");
}
gfc_set_backend_locus (&code->loc);
if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
{
if (TREE_CODE (res) == STATEMENT_LIST)
annotate_all_with_locus (&res, input_location);
else
SET_EXPR_LOCATION (res, input_location);
gfc_add_expr_to_block (&block, res);
}
}
return gfc_finish_block (&block);
}
void
gfc_generate_code (gfc_namespace * ns)
{
if (ns->is_block_data)
{
gfc_generate_block_data (ns);
return;
}
gfc_generate_function_code (ns);
}
void
gfc_generate_module_code (gfc_namespace * ns)
{
gfc_namespace *n;
gfc_generate_module_vars (ns);
for (n = ns->contained; n; n = n->sibling)
{
if (!n->proc_name)
continue;
gfc_create_function_decl (n);
}
for (n = ns->contained; n; n = n->sibling)
{
if (!n->proc_name)
continue;
gfc_generate_function_code (n);
}
}