/* Code translation -- generate GCC trees from gfc_code.
- Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
+ Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
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, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "tree-gimple.h"
-#include <stdio.h>
#include "ggc.h"
#include "toplev.h"
#include "defaults.h"
#include "real.h"
-#include <gmp.h>
-#include <assert.h>
+#include "flags.h"
#include "gfortran.h"
#include "trans.h"
#include "trans-stmt.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");
+
/* Advance along TREE_CHAIN n times. */
{
for (; n > 0; n--)
{
- assert (t != NULL_TREE);
+ gcc_assert (t != NULL_TREE);
t = TREE_CHAIN (t);
}
return t;
{
tree var;
- if (TREE_CODE_CLASS (TREE_CODE (expr)) == 'c')
+ if (CONSTANT_CLASS_P (expr))
return expr;
var = gfc_create_var (TREE_TYPE (expr), NULL);
}
-/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
- A MODIFY_EXPR is an assignment: LHS <- RHS. */
+/* Build a MODIFY_EXPR (or GIMPLE_MODIFY_STMT) node and add it to a
+ given statement block PBLOCK. A MODIFY_EXPR is an assignment:
+ LHS <- RHS. */
void
-gfc_add_modify_expr (stmtblock_t * pblock, tree lhs, tree rhs)
+gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs,
+ bool tuples_p)
{
tree tmp;
for scalar assignments. We should probably have something
similar for aggregates, but right now removing that check just
breaks everything. */
- if (TREE_TYPE (rhs) != TREE_TYPE (lhs)
- && !AGGREGATE_TYPE_P (TREE_TYPE (lhs)))
- abort ();
+ gcc_assert (TREE_TYPE (rhs) == TREE_TYPE (lhs)
+ || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
#endif
- tmp = fold (build_v (MODIFY_EXPR, lhs, rhs));
+ tmp = fold_build2 (tuples_p ? GIMPLE_MODIFY_STMT : MODIFY_EXPR,
+ void_type_node, lhs, rhs);
gfc_add_expr_to_block (pblock, tmp);
}
/* Create a new scope/binding level and initialize a block. Care must be
- taken when translating expessions as any temporaries will be placed in
+ taken when translating expressions as any temporaries will be placed in
the innermost scope. */
void
tree decl;
tree next;
- assert (block->has_scope);
+ gcc_assert (block->has_scope);
block->has_scope = 0;
/* Remember the decls in this scope. */
if (decl)
{
block = poplevel (1, 0, 0);
- expr = build_v (BIND_EXPR, decl, expr, block);
+ expr = build3_v (BIND_EXPR, decl, expr, block);
}
else
poplevel (0, 0, 0);
}
-/* Build an INDIRECT_REF with its natural type. */
-
-tree
-gfc_build_indirect_ref (tree t)
-{
- tree type = TREE_TYPE (t);
- if (!POINTER_TYPE_P (type))
- abort ();
- type = TREE_TYPE (type);
-
- if (TREE_CODE (t) == ADDR_EXPR)
- return TREE_OPERAND (t, 0);
- else
- return build1 (INDIRECT_REF, type, t);
-}
-
-
/* Build an ARRAY_REF with its natural type. */
tree
gfc_build_array_ref (tree base, tree offset)
{
tree type = TREE_TYPE (base);
- if (TREE_CODE (type) != ARRAY_TYPE)
- abort ();
+ gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
type = TREE_TYPE (type);
if (DECL_P (base))
TREE_ADDRESSABLE (base) = 1;
- return build (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
-}
-
-
-/* Given a funcion declaration FNDECL and an argument list ARGLIST,
- build a CALL_EXPR. */
-
-tree
-gfc_build_function_call (tree fndecl, tree arglist)
-{
- tree fn;
- tree call;
+ /* Strip NON_LVALUE_EXPR nodes. */
+ STRIP_TYPE_NOPS (offset);
- fn = gfc_build_addr_expr (NULL, fndecl);
- call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fndecl)), fn, arglist, NULL);
- TREE_SIDE_EFFECTS (call) = 1;
-
- return call;
+ return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
}
/* Generate a runtime error if COND is true. */
void
-gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock)
+gfc_trans_runtime_check (tree cond, const char * msgid, stmtblock_t * pblock,
+ locus * where)
{
stmtblock_t block;
tree body;
tree tmp;
- tree args;
-
- cond = fold (cond);
+ tree arg, arg2;
+ char *message;
+ int line;
if (integer_zerop (cond))
return;
/* The code to generate the error. */
gfc_start_block (&block);
- assert (TREE_CODE (msg) == STRING_CST);
-
- TREE_USED (msg) = 1;
-
- tmp = gfc_build_addr_expr (pchar_type_node, msg);
- args = gfc_chainon_list (NULL_TREE, tmp);
-
- tmp = gfc_build_addr_expr (pchar_type_node, gfc_strconst_current_filename);
- args = gfc_chainon_list (args, tmp);
+ if (where)
+ {
+#ifdef USE_MAPPED_LOCATION
+ line = LOCATION_LINE (where->lb->location);
+#else
+ line = where->lb->linenum;
+#endif
+ asprintf (&message, "At line %d of file %s", line,
+ where->lb->file->filename);
+ }
+ else
+ asprintf (&message, "In file '%s', around line %d",
+ gfc_source_file, input_line + 1);
- tmp = build_int_cst (NULL_TREE, input_line);
- args = gfc_chainon_list (args, tmp);
+ arg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
+ gfc_free(message);
+
+ asprintf (&message, "%s", _(msgid));
+ arg2 = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
+ gfc_free(message);
- tmp = gfc_build_function_call (gfor_fndecl_runtime_error, args);
+ tmp = build_call_expr (gfor_fndecl_runtime_error_at, 2, arg, arg2);
gfc_add_expr_to_block (&block, tmp);
body = gfc_finish_block (&block);
else
{
/* Tell the compiler that this isn't likely. */
- tmp = gfc_chainon_list (NULL_TREE, cond);
- tmp = gfc_chainon_list (tmp, integer_zero_node);
- cond = gfc_build_function_call (built_in_decls[BUILT_IN_EXPECT], tmp);
+ cond = fold_convert (long_integer_type_node, cond);
+ tmp = build_int_cst (long_integer_type_node, 0);
+ cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
+ cond = fold_convert (boolean_type_node, cond);
- tmp = build_v (COND_EXPR, cond, body, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
gfc_add_expr_to_block (pblock, tmp);
}
}
+/* Call malloc to allocate size bytes of memory, with special conditions:
+ + if size < 0, generate a runtime error,
+ + if size == 0, return a NULL pointer,
+ + if malloc returns NULL, issue a runtime error. */
+tree
+gfc_call_malloc (stmtblock_t * block, tree type, tree size)
+{
+ tree tmp, msg, negative, zero, malloc_result, null_result, res;
+ stmtblock_t block2;
+
+ size = gfc_evaluate_now (size, block);
+
+ if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
+ size = fold_convert (size_type_node, size);
+
+ /* Create a variable to hold the result. */
+ res = gfc_create_var (pvoid_type_node, NULL);
+
+ /* size < 0 ? */
+ negative = fold_build2 (LT_EXPR, boolean_type_node, size,
+ build_int_cst (size_type_node, 0));
+ msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
+ ("Attempt to allocate a negative amount of memory."));
+ tmp = fold_build3 (COND_EXPR, void_type_node, negative,
+ build_call_expr (gfor_fndecl_runtime_error, 1, msg),
+ build_empty_stmt ());
+ gfc_add_expr_to_block (block, tmp);
+
+ /* Call malloc and check the result. */
+ gfc_start_block (&block2);
+ gfc_add_modify_expr (&block2, res,
+ build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
+ size));
+ null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
+ build_int_cst (pvoid_type_node, 0));
+ msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
+ ("Memory allocation failed"));
+ tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
+ build_call_expr (gfor_fndecl_os_error, 1, msg),
+ build_empty_stmt ());
+ gfc_add_expr_to_block (&block2, tmp);
+ malloc_result = gfc_finish_block (&block2);
+
+ /* size == 0 */
+ zero = fold_build2 (EQ_EXPR, boolean_type_node, size,
+ build_int_cst (size_type_node, 0));
+ tmp = fold_build2 (MODIFY_EXPR, pvoid_type_node, res,
+ build_int_cst (pvoid_type_node, 0));
+ tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp, malloc_result);
+ gfc_add_expr_to_block (block, tmp);
+
+ if (type != NULL)
+ res = fold_convert (type, res);
+ return res;
+}
+
+
+/* Free a given variable, if it's not NULL. */
+tree
+gfc_call_free (tree var)
+{
+ stmtblock_t block;
+ tree tmp, cond, call;
+
+ if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
+ var = fold_convert (pvoid_type_node, var);
+
+ gfc_start_block (&block);
+ var = gfc_evaluate_now (var, &block);
+ cond = fold_build2 (NE_EXPR, boolean_type_node, var,
+ build_int_cst (pvoid_type_node, 0));
+ call = build_call_expr (built_in_decls[BUILT_IN_FREE], 1, var);
+ tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
+ build_empty_stmt ());
+ gfc_add_expr_to_block (&block, tmp);
+
+ return gfc_finish_block (&block);
+}
+
+
/* Add a statement to a block. */
void
gfc_add_expr_to_block (stmtblock_t * block, tree expr)
{
- assert (block);
+ gcc_assert (block);
if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
return;
- if (TREE_CODE (expr) != STATEMENT_LIST)
- expr = fold (expr);
-
if (block->head)
{
if (TREE_CODE (block->head) != STATEMENT_LIST)
void
gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
{
- assert (append);
- assert (!append->has_scope);
+ gcc_assert (append);
+ gcc_assert (!append->has_scope);
gfc_add_expr_to_block (block, append->head);
append->head = NULL_TREE;
gfc_get_backend_locus (locus * loc)
{
loc->lb = gfc_getmem (sizeof (gfc_linebuf));
- loc->lb->linenum = input_line - 1;
+#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)
{
- input_line = loc->lb->linenum;
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
}
the end of this gfc_code branch. */
for (; code; code = code->next)
{
- gfc_set_backend_locus (&code->loc);
-
if (code->here != 0)
{
res = gfc_trans_label_here (code);
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;
break;
case EXEC_CALL:
- res = gfc_trans_call (code);
+ res = gfc_trans_call (code, false);
+ break;
+
+ case EXEC_ASSIGN_CALL:
+ res = gfc_trans_call (code, true);
break;
case EXEC_RETURN:
res = gfc_trans_select (code);
break;
+ case EXEC_FLUSH:
+ res = gfc_trans_flush (code);
+ break;
+
case EXEC_FORALL:
res = gfc_trans_forall (code);
break;
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
- annotate_with_locus (res, input_location);
-
- /* Add the new statemment to the block. */
+ SET_EXPR_LOCATION (res, input_location);
+
+ /* Add the new statement to the block. */
gfc_add_expr_to_block (&block, res);
}
}
void
gfc_generate_code (gfc_namespace * ns)
{
- gfc_symbol *main_program = NULL;
- symbol_attribute attr;
-
- /* Main program subroutine. */
- if (!ns->proc_name)
+ if (ns->is_block_data)
{
- /* Lots of things get upset if a subroutine doesn't have a symbol, so we
- make one now. Hopefully we've set all the required fields. */
- gfc_get_symbol ("MAIN__", ns, &main_program);
- gfc_clear_attr (&attr);
- attr.flavor = FL_PROCEDURE;
- attr.proc = PROC_UNKNOWN;
- attr.subroutine = 1;
- attr.access = ACCESS_PUBLIC;
- main_program->attr = attr;
- ns->proc_name = main_program;
- gfc_commit_symbols ();
+ gfc_generate_block_data (ns);
+ return;
}
gfc_generate_function_code (ns);