/* Code translation -- generate GCC trees from gfc_code.
- Copyright (C) 2002, 2003, 2004, 2005 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 "toplev.h"
#include "defaults.h"
#include "real.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. */
}
-/* 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;
|| AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
#endif
- tmp = fold (build2_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);
}
}
-/* Build an INDIRECT_REF with its natural type. */
-
-tree
-gfc_build_indirect_ref (tree t)
-{
- tree type = TREE_TYPE (t);
- gcc_assert (POINTER_TYPE_P (type));
- 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
if (DECL_P (base))
TREE_ADDRESSABLE (base) = 1;
- return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
-}
+ /* Strip NON_LVALUE_EXPR nodes. */
+ STRIP_TYPE_NOPS (offset);
-
-/* 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;
-
- fn = gfc_build_addr_expr (NULL, fndecl);
- call = build3 (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);
- gcc_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 = 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
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)
{
loc->lb = gfc_getmem (sizeof (gfc_linebuf));
#ifdef USE_MAPPED_LOCATION
- loc->lb->location = input_location; /* FIXME adjust?? */
+ loc->lb->location = input_location;
#else
- loc->lb->linenum = input_line - 1;
+ loc->lb->linenum = input_line;
#endif
loc->lb->file = gfc_current_backend_file;
}
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");
}
void
gfc_generate_code (gfc_namespace * ns)
{
- gfc_symbol *main_program = NULL;
- symbol_attribute attr;
-
if (ns->is_block_data)
{
gfc_generate_block_data (ns);
return;
}
- /* Main program subroutine. */
- if (!ns->proc_name)
- {
- /* 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;
- /* Set the location to the first line of code. */
- if (ns->code)
- main_program->declared_at = ns->code->loc;
- ns->proc_name = main_program;
- gfc_commit_symbols ();
- }
-
gfc_generate_function_code (ns);
}
OSDN Git Service
