/* Code translation -- generate GCC trees from gfc_code.
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free
- Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Free Software Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
static gfc_file *gfc_current_backend_file;
-const char gfc_msg_bounds[] = N_("Array bound mismatch");
const char gfc_msg_fault[] = N_("Array reference out of bounds");
const char gfc_msg_wrong_return[] = N_("Incorrect function return value");
/* Call malloc to allocate size bytes of memory, with special conditions:
- + if size < 0, generate a runtime error,
- + if size == 0, return a malloced area of size 1,
+ + if size <= 0, return a malloced area of size 1,
+ if malloc returns NULL, issue a runtime error. */
tree
gfc_call_malloc (stmtblock_t * block, tree type, tree size)
{
- tree tmp, msg, negative, malloc_result, null_result, res;
+ tree tmp, msg, malloc_result, null_result, res;
stmtblock_t block2;
size = gfc_evaluate_now (size, block);
/* Create a variable to hold the result. */
res = gfc_create_var (prvoid_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_localized_cstring_const
- ("Attempt to allocate a negative amount of memory."));
- tmp = fold_build3 (COND_EXPR, void_type_node, negative,
- build_call_expr_loc (input_location,
- gfor_fndecl_runtime_error, 1, msg),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (block, tmp);
-
- /* Call malloc and check the result. */
+ /* Call malloc. */
gfc_start_block (&block2);
size = fold_build2 (MAX_EXPR, size_type_node, size,
fold_convert (prvoid_type_node,
build_call_expr_loc (input_location,
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_localized_cstring_const
- ("Memory allocation failed"));
- tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
- build_call_expr_loc (input_location,
- gfor_fndecl_os_error, 1, msg),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&block2, tmp);
+
+ /* Optionally check whether malloc was successful. */
+ if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
+ {
+ 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_localized_cstring_const ("Memory allocation failed"));
+ tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
+ build_call_expr_loc (input_location,
+ gfor_fndecl_os_error, 1, msg),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block2, tmp);
+ }
+
malloc_result = gfc_finish_block (&block2);
gfc_add_expr_to_block (block, malloc_result);
return res;
}
+
/* Allocate memory, using an optional status argument.
This function follows the following pseudo-code:
}
else
runtime_error ("Attempting to allocate already allocated array");
+ }
}
expr must be set to the original expression being allocated for its locus
}
-/* Translate an executable statement. */
+/* Translate an executable statement. The tree cond is used by gfc_trans_do.
+ This static function is wrapped by gfc_trans_code_cond and
+ gfc_trans_code. */
-tree
-gfc_trans_code (gfc_code * code)
+static tree
+trans_code (gfc_code * code, tree cond)
{
stmtblock_t block;
tree res;
gfc_add_expr_to_block (&block, res);
}
+ gfc_set_backend_locus (&code->loc);
+
switch (code->op)
{
case EXEC_NOP:
break;
case EXEC_ASSIGN:
- res = gfc_trans_assign (code);
+ if (code->expr1->ts.type == BT_CLASS)
+ res = gfc_trans_class_assign (code);
+ else
+ res = gfc_trans_assign (code);
break;
case EXEC_LABEL_ASSIGN:
break;
case EXEC_POINTER_ASSIGN:
- res = gfc_trans_pointer_assign (code);
+ if (code->expr1->ts.type == BT_CLASS)
+ res = gfc_trans_class_assign (code);
+ else
+ res = gfc_trans_pointer_assign (code);
break;
case EXEC_INIT_ASSIGN:
- res = gfc_trans_init_assign (code);
+ if (code->expr1->ts.type == BT_CLASS)
+ res = gfc_trans_class_assign (code);
+ else
+ res = gfc_trans_init_assign (code);
break;
case EXEC_CONTINUE:
res = NULL_TREE;
break;
+ case EXEC_CRITICAL:
+ res = gfc_trans_critical (code);
+ break;
+
case EXEC_CYCLE:
res = gfc_trans_cycle (code);
break;
break;
case EXEC_STOP:
- res = gfc_trans_stop (code);
+ case EXEC_ERROR_STOP:
+ res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
break;
case EXEC_CALL:
res = gfc_trans_arithmetic_if (code);
break;
+ case EXEC_BLOCK:
+ res = gfc_trans_block_construct (code);
+ break;
+
case EXEC_DO:
- res = gfc_trans_do (code);
+ res = gfc_trans_do (code, cond);
break;
case EXEC_DO_WHILE:
res = gfc_trans_select (code);
break;
+ case EXEC_SELECT_TYPE:
+ /* Do nothing. SELECT TYPE statements should be transformed into
+ an ordinary SELECT CASE at resolution stage.
+ TODO: Add an error message here once this is done. */
+ res = NULL_TREE;
+ break;
+
case EXEC_FLUSH:
res = gfc_trans_flush (code);
break;
+ case EXEC_SYNC_ALL:
+ case EXEC_SYNC_IMAGES:
+ case EXEC_SYNC_MEMORY:
+ res = gfc_trans_sync (code, code->op);
+ break;
+
case EXEC_FORALL:
res = gfc_trans_forall (code);
break;
if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
{
- if (TREE_CODE (res) == STATEMENT_LIST)
- tree_annotate_all_with_location (&res, input_location);
- else
+ if (TREE_CODE (res) != STATEMENT_LIST)
SET_EXPR_LOCATION (res, input_location);
/* Add the new statement to the block. */
}
+/* Translate an executable statement with condition, cond. The condition is
+ used by gfc_trans_do to test for IO result conditions inside implied
+ DO loops of READ and WRITE statements. See build_dt in trans-io.c. */
+
+tree
+gfc_trans_code_cond (gfc_code * code, tree cond)
+{
+ return trans_code (code, cond);
+}
+
+/* Translate an executable statement without condition. */
+
+tree
+gfc_trans_code (gfc_code * code)
+{
+ return trans_code (code, NULL_TREE);
+}
+
+
/* This function is called after a complete program unit has been parsed
and resolved. */
OSDN Git Service
