/* Code translation -- generate GCC trees from gfc_code.
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
- Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2012
+ Free Software Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include "tree-gimple.h"
-#include "ggc.h"
-#include "toplev.h"
+#include "gimple.h" /* For create_tmp_var_raw. */
+#include "tree-iterator.h"
+#include "diagnostic-core.h" /* For internal_error. */
#include "defaults.h"
-#include "real.h"
#include "flags.h"
#include "gfortran.h"
#include "trans.h"
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");
for (; n > 0; n--)
{
gcc_assert (t != NULL_TREE);
- t = TREE_CHAIN (t);
+ t = DECL_CHAIN (t);
}
return t;
}
-/* Wrap a node in a TREE_LIST node and add it to the end of a list. */
-
-tree
-gfc_chainon_list (tree list, tree add)
-{
- tree l;
-
- l = tree_cons (NULL_TREE, add, NULL_TREE);
-
- return chainon (list, l);
-}
-
-
/* Strip off a legitimate source ending from the input
string NAME of length LEN. */
return a pointer to the VAR_DECL node for this variable. */
tree
-gfc_evaluate_now (tree expr, stmtblock_t * pblock)
+gfc_evaluate_now_loc (location_t loc, tree expr, stmtblock_t * pblock)
{
tree var;
return expr;
var = gfc_create_var (TREE_TYPE (expr), NULL);
- gfc_add_modify_expr (pblock, var, expr);
+ gfc_add_modify_loc (loc, pblock, var, expr);
return var;
}
-/* Build a MODIFY_EXPR (or GIMPLE_MODIFY_STMT) node and add it to a
- given statement block PBLOCK. A MODIFY_EXPR is an assignment:
+tree
+gfc_evaluate_now (tree expr, stmtblock_t * pblock)
+{
+ return gfc_evaluate_now_loc (input_location, expr, pblock);
+}
+
+
+/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
+ A MODIFY_EXPR is an assignment:
LHS <- RHS. */
void
-gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs,
- bool tuples_p)
+gfc_add_modify_loc (location_t loc, stmtblock_t * pblock, tree lhs, tree rhs)
{
tree tmp;
#ifdef ENABLE_CHECKING
+ tree t1, t2;
+ t1 = TREE_TYPE (rhs);
+ t2 = TREE_TYPE (lhs);
/* Make sure that the types of the rhs and the lhs are the same
for scalar assignments. We should probably have something
similar for aggregates, but right now removing that check just
breaks everything. */
- gcc_assert (TREE_TYPE (rhs) == TREE_TYPE (lhs)
+ gcc_assert (t1 == t2
|| AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
#endif
- tmp = fold_build2 (tuples_p ? GIMPLE_MODIFY_STMT : MODIFY_EXPR,
- void_type_node, lhs, rhs);
+ tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, lhs,
+ rhs);
gfc_add_expr_to_block (pblock, tmp);
}
+void
+gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)
+{
+ gfc_add_modify_loc (input_location, pblock, lhs, rhs);
+}
+
+
/* Create a new scope/binding level and initialize a block. Care must be
taken when translating expressions as any temporaries will be placed in
the innermost scope. */
/* Add them to the parent scope. */
while (decl != NULL_TREE)
{
- next = TREE_CHAIN (decl);
- TREE_CHAIN (decl) = NULL_TREE;
+ next = DECL_CHAIN (decl);
+ DECL_CHAIN (decl) = NULL_TREE;
pushdecl (decl);
decl = next;
expr = stmtblock->head;
if (!expr)
- expr = build_empty_stmt ();
+ expr = build_empty_stmt (input_location);
stmtblock->head = NULL_TREE;
tree type_domain = TYPE_DOMAIN (base_type);
if (type_domain && TYPE_MIN_VALUE (type_domain))
min_val = TYPE_MIN_VALUE (type_domain);
- t = fold (build4 (ARRAY_REF, TREE_TYPE (type),
- t, min_val, NULL_TREE, NULL_TREE));
+ t = fold (build4_loc (input_location, ARRAY_REF, TREE_TYPE (type),
+ t, min_val, NULL_TREE, NULL_TREE));
natural_type = type;
}
else
}
else
{
- if (DECL_P (t))
- TREE_ADDRESSABLE (t) = 1;
- t = fold_build1 (ADDR_EXPR, natural_type, t);
+ tree base = get_base_address (t);
+ if (base && DECL_P (base))
+ TREE_ADDRESSABLE (base) = 1;
+ t = fold_build1_loc (input_location, ADDR_EXPR, natural_type, t);
}
if (type && natural_type != type)
{
tree type = TREE_TYPE (base);
tree tmp;
+ tree span;
+
+ if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
+ {
+ gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
+
+ return fold_convert (TYPE_MAIN_VARIANT (type), base);
+ }
+
+ /* Scalar coarray, there is nothing to do. */
+ if (TREE_CODE (type) != ARRAY_TYPE)
+ {
+ gcc_assert (decl == NULL_TREE);
+ gcc_assert (integer_zerop (offset));
+ return base;
+ }
- gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
type = TREE_TYPE (type);
if (DECL_P (base))
if (decl && (TREE_CODE (decl) == FIELD_DECL
|| TREE_CODE (decl) == VAR_DECL
|| TREE_CODE (decl) == PARM_DECL)
- && GFC_DECL_SUBREF_ARRAY_P (decl)
- && !integer_zerop (GFC_DECL_SPAN(decl)))
+ && ((GFC_DECL_SUBREF_ARRAY_P (decl)
+ && !integer_zerop (GFC_DECL_SPAN(decl)))
+ || GFC_DECL_CLASS (decl)))
{
- offset = fold_build2 (MULT_EXPR, gfc_array_index_type,
- offset, GFC_DECL_SPAN(decl));
+ if (GFC_DECL_CLASS (decl))
+ {
+ /* Allow for dummy arguments and other good things. */
+ if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ decl = build_fold_indirect_ref_loc (input_location, decl);
+
+ /* Check if '_data' is an array descriptor. If it is not,
+ the array must be one of the components of the class object,
+ so return a normal array reference. */
+ if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl))))
+ return build4_loc (input_location, ARRAY_REF, type, base,
+ offset, NULL_TREE, NULL_TREE);
+
+ span = gfc_vtable_size_get (decl);
+ }
+ else if (GFC_DECL_SUBREF_ARRAY_P (decl))
+ span = GFC_DECL_SPAN(decl);
+ else
+ gcc_unreachable ();
+
+ offset = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type,
+ offset, span);
tmp = gfc_build_addr_expr (pvoid_type_node, base);
- tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
- tmp, fold_convert (sizetype, offset));
+ tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
tmp = fold_convert (build_pointer_type (type), tmp);
if (!TYPE_STRING_FLAG (type))
- tmp = build_fold_indirect_ref (tmp);
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
return tmp;
}
else
/* Otherwise use a straightforward array reference. */
- return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
+ return build4_loc (input_location, ARRAY_REF, type, base, offset,
+ NULL_TREE, NULL_TREE);
}
-/* Generate a runtime error if COND is true. */
+/* Generate a call to print a runtime error possibly including multiple
+ arguments and a locus. */
-void
-gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
- locus * where, const char * msgid, ...)
+static tree
+trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
+ va_list ap)
{
- va_list ap;
stmtblock_t block;
- tree body;
tree tmp;
- tree tmpvar = NULL;
tree arg, arg2;
tree *argarray;
tree fntype;
char *message;
const char *p;
int line, nargs, i;
-
- if (integer_zerop (cond))
- return;
+ location_t loc;
/* Compute the number of extra arguments from the format string. */
for (p = msgid, nargs = 0; *p; p++)
nargs++;
}
- if (once)
- {
- tmpvar = gfc_create_var (boolean_type_node, "print_warning");
- TREE_STATIC (tmpvar) = 1;
- DECL_INITIAL (tmpvar) = boolean_true_node;
- gfc_add_expr_to_block (pblock, tmpvar);
- }
-
/* The code to generate the error. */
gfc_start_block (&block);
arg = gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const (message));
- gfc_free(message);
+ free (message);
asprintf (&message, "%s", _(msgid));
arg2 = gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const (message));
- gfc_free(message);
+ free (message);
/* Build the argument array. */
- argarray = (tree *) alloca (sizeof (tree) * (nargs + 2));
+ argarray = XALLOCAVEC (tree, nargs + 2);
argarray[0] = arg;
argarray[1] = arg2;
- va_start (ap, msgid);
for (i = 0; i < nargs; i++)
- argarray[2+i] = va_arg (ap, tree);
- va_end (ap);
+ argarray[2 + i] = va_arg (ap, tree);
/* Build the function call to runtime_(warning,error)_at; because of the
- variable number of arguments, we can't use build_call_expr directly. */
+ variable number of arguments, we can't use build_call_expr_loc dinput_location,
+ irectly. */
if (error)
fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
else
fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
- tmp = fold_builtin_call_array (TREE_TYPE (fntype),
- fold_build1 (ADDR_EXPR,
- build_pointer_type (fntype),
- error
- ? gfor_fndecl_runtime_error_at
- : gfor_fndecl_runtime_warning_at),
+ loc = where ? where->lb->location : input_location;
+ tmp = fold_builtin_call_array (loc, TREE_TYPE (fntype),
+ fold_build1_loc (loc, ADDR_EXPR,
+ build_pointer_type (fntype),
+ error
+ ? gfor_fndecl_runtime_error_at
+ : gfor_fndecl_runtime_warning_at),
nargs + 2, argarray);
gfc_add_expr_to_block (&block, tmp);
+ return gfc_finish_block (&block);
+}
+
+
+tree
+gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
+{
+ va_list ap;
+ tree result;
+
+ va_start (ap, msgid);
+ result = trans_runtime_error_vararg (error, where, msgid, ap);
+ va_end (ap);
+ return result;
+}
+
+
+/* Generate a runtime error if COND is true. */
+
+void
+gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
+ locus * where, const char * msgid, ...)
+{
+ va_list ap;
+ stmtblock_t block;
+ tree body;
+ tree tmp;
+ tree tmpvar = NULL;
+
+ if (integer_zerop (cond))
+ return;
+
if (once)
- gfc_add_modify_expr (&block, tmpvar, boolean_false_node);
+ {
+ tmpvar = gfc_create_var (boolean_type_node, "print_warning");
+ TREE_STATIC (tmpvar) = 1;
+ DECL_INITIAL (tmpvar) = boolean_true_node;
+ gfc_add_expr_to_block (pblock, tmpvar);
+ }
+
+ gfc_start_block (&block);
+
+ /* The code to generate the error. */
+ va_start (ap, msgid);
+ gfc_add_expr_to_block (&block,
+ trans_runtime_error_vararg (error, where,
+ msgid, ap));
+
+ if (once)
+ gfc_add_modify (&block, tmpvar, boolean_false_node);
body = gfc_finish_block (&block);
{
/* Tell the compiler that this isn't likely. */
if (once)
- cond = fold_build2 (TRUTH_AND_EXPR, long_integer_type_node, tmpvar,
- cond);
+ cond = fold_build2_loc (where->lb->location, TRUTH_AND_EXPR,
+ long_integer_type_node, tmpvar, cond);
else
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 ());
+ cond = gfc_unlikely (cond);
+ tmp = fold_build3_loc (where->lb->location, COND_EXPR, void_type_node,
+ cond, body,
+ build_empty_stmt (where->lb->location));
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 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, malloc_tree;
stmtblock_t block2;
size = gfc_evaluate_now (size, block);
size = fold_convert (size_type_node, size);
/* Create a variable to hold the result. */
- res = gfc_create_var (pvoid_type_node, NULL);
+ 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 (gfor_fndecl_runtime_error, 1, msg),
- build_empty_stmt ());
- 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,
- build_int_cst (size_type_node, 1));
+ size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size,
+ build_int_cst (size_type_node, 1));
+
+ malloc_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
+ gfc_add_modify (&block2, res,
+ fold_convert (prvoid_type_node,
+ build_call_expr_loc (input_location,
+ malloc_tree, 1, size)));
+
+ /* Optionally check whether malloc was successful. */
+ if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
+ {
+ null_result = fold_build2_loc (input_location, 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_loc (input_location, 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);
+ }
- 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_localized_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);
gfc_add_expr_to_block (block, malloc_result);
return res;
}
+
/* Allocate memory, using an optional status argument.
This function follows the following pseudo-code:
void *
- allocate (size_t size, integer_type* stat)
+ allocate (size_t size, integer_type stat)
{
void *newmem;
- if (stat)
- *stat = 0;
+ if (stat requested)
+ stat = 0;
- // The only time this can happen is the size wraps around.
- if (size < 0)
+ newmem = malloc (MAX (size, 1));
+ if (newmem == NULL)
{
if (stat)
- {
*stat = LIBERROR_ALLOCATION;
- newmem = NULL;
- }
else
- runtime_error ("Attempt to allocate negative amount of memory. "
- "Possible integer overflow");
- }
- else
- {
- newmem = malloc (MAX (size, 1));
- if (newmem == NULL)
- {
- if (stat)
- *stat = LIBERROR_ALLOCATION;
- else
- runtime_error ("Out of memory");
- }
+ runtime_error ("Allocation would exceed memory limit");
}
-
return newmem;
} */
-tree
-gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
+void
+gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
+ tree size, tree status)
{
- stmtblock_t alloc_block;
- tree res, tmp, error, msg, cond;
- tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
+ tree tmp, on_error, error_cond;
+ tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
/* Evaluate size only once, and make sure it has the right type. */
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);
+ /* If successful and stat= is given, set status to 0. */
+ if (status != NULL_TREE)
+ gfc_add_expr_to_block (block,
+ fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+ status, build_int_cst (status_type, 0)));
- /* Set the optional status variable to zero. */
- if (status != NULL_TREE && !integer_zerop (status))
- {
- tmp = fold_build2 (MODIFY_EXPR, status_type,
- fold_build1 (INDIRECT_REF, status_type, status),
- build_int_cst (status_type, 0));
- tmp = fold_build3 (COND_EXPR, void_type_node,
- fold_build2 (NE_EXPR, boolean_type_node,
- status, build_int_cst (status_type, 0)),
- tmp, build_empty_stmt ());
- gfc_add_expr_to_block (block, tmp);
- }
+ /* The allocation itself. */
+ gfc_add_modify (block, pointer,
+ fold_convert (TREE_TYPE (pointer),
+ build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MALLOC), 1,
+ fold_build2_loc (input_location,
+ MAX_EXPR, size_type_node, size,
+ build_int_cst (size_type_node, 1)))));
+
+ /* What to do in case of error. */
+ if (status != NULL_TREE)
+ on_error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+ status, build_int_cst (status_type, LIBERROR_ALLOCATION));
+ else
+ on_error = build_call_expr_loc (input_location, gfor_fndecl_os_error, 1,
+ gfc_build_addr_expr (pchar_type_node,
+ gfc_build_localized_cstring_const
+ ("Allocation would exceed memory limit")));
- /* Generate the block of code handling (size < 0). */
- msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
- ("Attempt to allocate negative amount of memory. "
- "Possible integer overflow"));
- error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
+ error_cond = fold_build2_loc (input_location, EQ_EXPR,
+ boolean_type_node, pointer,
+ build_int_cst (prvoid_type_node, 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_unlikely (error_cond), on_error,
+ build_empty_stmt (input_location));
- if (status != NULL_TREE && !integer_zerop (status))
+ gfc_add_expr_to_block (block, tmp);
+}
+
+
+/* Allocate memory, using an optional status argument.
+
+ This function follows the following pseudo-code:
+
+ void *
+ allocate (size_t size, void** token, int *stat, char* errmsg, int errlen)
{
- /* Set the status variable if it's present. */
- stmtblock_t set_status_block;
-
- gfc_start_block (&set_status_block);
- gfc_add_modify_expr (&set_status_block,
- fold_build1 (INDIRECT_REF, status_type, status),
- build_int_cst (status_type, LIBERROR_ALLOCATION));
- gfc_add_modify_expr (&set_status_block, res,
- build_int_cst (pvoid_type_node, 0));
-
- tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
- build_int_cst (status_type, 0));
- error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
- gfc_finish_block (&set_status_block));
- }
+ void *newmem;
- /* The allocation itself. */
- gfc_start_block (&alloc_block);
- gfc_add_modify_expr (&alloc_block, res,
- build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
- fold_build2 (MAX_EXPR, size_type_node,
- size,
- build_int_cst (size_type_node, 1))));
+ newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen);
+ return newmem;
+ } */
+static void
+gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
+ tree token, tree status, tree errmsg, tree errlen)
+{
+ tree tmp, pstat;
- msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
- ("Out of memory"));
- tmp = build_call_expr (gfor_fndecl_os_error, 1, msg);
+ gcc_assert (token != NULL_TREE);
- if (status != NULL_TREE && !integer_zerop (status))
+ /* Evaluate size only once, and make sure it has the right type. */
+ size = gfc_evaluate_now (size, block);
+ if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
+ size = fold_convert (size_type_node, size);
+
+ /* The allocation itself. */
+ if (status == NULL_TREE)
+ pstat = null_pointer_node;
+ else
+ pstat = gfc_build_addr_expr (NULL_TREE, status);
+
+ if (errmsg == NULL_TREE)
{
- /* Set the status variable if it's present. */
- tree tmp2;
-
- cond = fold_build2 (EQ_EXPR, boolean_type_node, status,
- build_int_cst (status_type, 0));
- tmp2 = fold_build2 (MODIFY_EXPR, status_type,
- fold_build1 (INDIRECT_REF, status_type, status),
- build_int_cst (status_type, LIBERROR_ALLOCATION));
- tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
- tmp2);
+ gcc_assert(errlen == NULL_TREE);
+ errmsg = null_pointer_node;
+ errlen = build_int_cst (integer_type_node, 0);
}
- tmp = fold_build3 (COND_EXPR, void_type_node,
- fold_build2 (EQ_EXPR, boolean_type_node, res,
- build_int_cst (pvoid_type_node, 0)),
- tmp, build_empty_stmt ());
- gfc_add_expr_to_block (&alloc_block, tmp);
-
- cond = fold_build2 (LT_EXPR, boolean_type_node, size,
- build_int_cst (TREE_TYPE (size), 0));
- tmp = fold_build3 (COND_EXPR, void_type_node, cond, error,
- gfc_finish_block (&alloc_block));
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_caf_register, 6,
+ fold_build2_loc (input_location,
+ MAX_EXPR, size_type_node, size,
+ build_int_cst (size_type_node, 1)),
+ build_int_cst (integer_type_node,
+ GFC_CAF_COARRAY_ALLOC),
+ token, pstat, errmsg, errlen);
+
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (pointer), pointer,
+ fold_convert ( TREE_TYPE (pointer), tmp));
gfc_add_expr_to_block (block, tmp);
-
- return res;
}
/* Generate code for an ALLOCATE statement when the argument is an
- allocatable array. If the array is currently allocated, it is an
+ allocatable variable. If the variable is currently allocated, it is an
error to allocate it again.
This function follows the following pseudo-code:
void *
- allocate_array (void *mem, size_t size, integer_type *stat)
+ allocate_allocatable (void *mem, size_t size, integer_type stat)
{
if (mem == NULL)
return allocate (size, stat);
else
{
if (stat)
- {
- free (mem);
- mem = allocate (size, stat);
- *stat = LIBERROR_ALLOCATION;
- return mem;
- }
+ stat = LIBERROR_ALLOCATION;
else
- runtime_error ("Attempting to allocate already allocated array");
- } */
-tree
-gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
- tree status)
+ runtime_error ("Attempting to allocate already allocated variable");
+ }
+ }
+
+ expr must be set to the original expression being allocated for its locus
+ and variable name in case a runtime error has to be printed. */
+void
+gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
+ tree status, tree errmsg, tree errlen, tree label_finish,
+ gfc_expr* expr)
{
stmtblock_t alloc_block;
- tree res, tmp, null_mem, alloc, error, msg;
+ tree tmp, null_mem, alloc, error;
tree type = TREE_TYPE (mem);
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);
- null_mem = fold_build2 (EQ_EXPR, boolean_type_node, mem,
- build_int_cst (type, 0));
+ null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, mem,
+ build_int_cst (type, 0)));
- /* If mem is NULL, we call gfc_allocate_with_status. */
+ /* If mem is NULL, we call gfc_allocate_using_malloc or
+ gfc_allocate_using_lib. */
gfc_start_block (&alloc_block);
- tmp = gfc_allocate_with_status (&alloc_block, size, status);
- gfc_add_modify_expr (&alloc_block, res, fold_convert (type, tmp));
- alloc = gfc_finish_block (&alloc_block);
- /* Otherwise, we issue a runtime error or set the status variable. */
- msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
- ("Attempting to allocate already allocated array"));
- error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB
+ && gfc_expr_attr (expr).codimension)
+ {
+ tree cond;
- if (status != NULL_TREE && !integer_zerop (status))
+ gfc_allocate_using_lib (&alloc_block, mem, size, token, status,
+ errmsg, errlen);
+ if (status != NULL_TREE)
+ {
+ TREE_USED (label_finish) = 1;
+ tmp = build1_v (GOTO_EXPR, label_finish);
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ status, build_zero_cst (TREE_TYPE (status)));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_unlikely (cond), tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&alloc_block, tmp);
+ }
+ }
+ else
+ gfc_allocate_using_malloc (&alloc_block, mem, size, status);
+
+ alloc = gfc_finish_block (&alloc_block);
+
+ /* If mem is not NULL, we issue a runtime error or set the
+ status variable. */
+ if (expr)
{
- tree status_type = TREE_TYPE (TREE_TYPE (status));
- stmtblock_t set_status_block;
+ tree varname;
- gfc_start_block (&set_status_block);
- tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
- fold_convert (pvoid_type_node, mem));
- gfc_add_expr_to_block (&set_status_block, tmp);
+ gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
+ varname = gfc_build_cstring_const (expr->symtree->name);
+ varname = gfc_build_addr_expr (pchar_type_node, varname);
- tmp = gfc_allocate_with_status (&set_status_block, size, status);
- gfc_add_modify_expr (&set_status_block, res, fold_convert (type, tmp));
+ error = gfc_trans_runtime_error (true, &expr->where,
+ "Attempting to allocate already"
+ " allocated variable '%s'",
+ varname);
+ }
+ else
+ error = gfc_trans_runtime_error (true, NULL,
+ "Attempting to allocate already allocated"
+ " variable");
- gfc_add_modify_expr (&set_status_block,
- fold_build1 (INDIRECT_REF, status_type, status),
- build_int_cst (status_type, LIBERROR_ALLOCATION));
+ if (status != NULL_TREE)
+ {
+ tree status_type = TREE_TYPE (status);
- tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
- build_int_cst (status_type, 0));
- error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
- gfc_finish_block (&set_status_block));
+ error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+ status, build_int_cst (status_type, LIBERROR_ALLOCATION));
}
- tmp = fold_build3 (COND_EXPR, void_type_node, null_mem, alloc, error);
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
+ error, alloc);
gfc_add_expr_to_block (block, tmp);
-
- return res;
}
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 ());
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, var,
+ build_int_cst (pvoid_type_node, 0));
+ call = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_FREE),
+ 1, var);
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, call,
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
even when no status variable is passed to us (this is used for
unconditional deallocation generated by the front-end at end of
- each procedure). */
+ each procedure).
+
+ If a runtime-message is possible, `expr' must point to the original
+ expression being deallocated for its locus and variable name.
+
+ For coarrays, "pointer" must be the array descriptor and not its
+ "data" component. */
tree
-gfc_deallocate_with_status (tree pointer, tree status, bool can_fail)
+gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
+ tree errlen, tree label_finish,
+ bool can_fail, gfc_expr* expr, bool coarray)
{
stmtblock_t null, non_null;
- tree cond, tmp, error, msg;
+ tree cond, tmp, error;
+ tree status_type = NULL_TREE;
+ tree caf_decl = NULL_TREE;
+
+ if (coarray)
+ {
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)));
+ caf_decl = pointer;
+ pointer = gfc_conv_descriptor_data_get (caf_decl);
+ STRIP_NOPS (pointer);
+ }
- cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer,
- build_int_cst (TREE_TYPE (pointer), 0));
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
+ build_int_cst (TREE_TYPE (pointer), 0));
/* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
we emit a runtime error. */
gfc_start_block (&null);
if (!can_fail)
{
- msg = gfc_build_addr_expr (pchar_type_node,
- gfc_build_localized_cstring_const
- ("Attempt to DEALLOCATE unallocated memory."));
- error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
+ tree varname;
+
+ gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
+
+ varname = gfc_build_cstring_const (expr->symtree->name);
+ varname = gfc_build_addr_expr (pchar_type_node, varname);
+
+ error = gfc_trans_runtime_error (true, &expr->where,
+ "Attempt to DEALLOCATE unallocated '%s'",
+ varname);
}
else
- error = build_empty_stmt ();
+ error = build_empty_stmt (input_location);
+
+ if (status != NULL_TREE && !integer_zerop (status))
+ {
+ tree cond2;
+
+ status_type = TREE_TYPE (TREE_TYPE (status));
+ cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ status, build_int_cst (TREE_TYPE (status), 0));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+ fold_build1_loc (input_location, INDIRECT_REF,
+ status_type, status),
+ build_int_cst (status_type, 1));
+ error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ cond2, tmp, error);
+ }
+
+ gfc_add_expr_to_block (&null, error);
+
+ /* When POINTER is not NULL, we free it. */
+ gfc_start_block (&non_null);
+ if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB)
+ {
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_FREE), 1,
+ fold_convert (pvoid_type_node, pointer));
+ gfc_add_expr_to_block (&non_null, tmp);
+
+ if (status != NULL_TREE && !integer_zerop (status))
+ {
+ /* We set STATUS to zero if it is present. */
+ tree status_type = TREE_TYPE (TREE_TYPE (status));
+ tree cond2;
+
+ cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ status,
+ build_int_cst (TREE_TYPE (status), 0));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+ fold_build1_loc (input_location, INDIRECT_REF,
+ status_type, status),
+ build_int_cst (status_type, 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_unlikely (cond2), tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&non_null, tmp);
+ }
+ }
+ else
+ {
+ tree caf_type, token, cond2;
+ tree pstat = null_pointer_node;
+
+ if (errmsg == NULL_TREE)
+ {
+ gcc_assert (errlen == NULL_TREE);
+ errmsg = null_pointer_node;
+ errlen = build_zero_cst (integer_type_node);
+ }
+ else
+ {
+ gcc_assert (errlen != NULL_TREE);
+ if (!POINTER_TYPE_P (TREE_TYPE (errmsg)))
+ errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
+ }
+
+ caf_type = TREE_TYPE (caf_decl);
+
+ if (status != NULL_TREE && !integer_zerop (status))
+ {
+ gcc_assert (status_type == integer_type_node);
+ pstat = status;
+ }
+
+ if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+ token = gfc_conv_descriptor_token (caf_decl);
+ else if (DECL_LANG_SPECIFIC (caf_decl)
+ && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+ token = GFC_DECL_TOKEN (caf_decl);
+ else
+ {
+ gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
+ token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
+ }
+
+ token = gfc_build_addr_expr (NULL_TREE, token);
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_caf_deregister, 4,
+ token, pstat, errmsg, errlen);
+ gfc_add_expr_to_block (&non_null, tmp);
+
+ if (status != NULL_TREE)
+ {
+ tree stat = build_fold_indirect_ref_loc (input_location, status);
+
+ TREE_USED (label_finish) = 1;
+ tmp = build1_v (GOTO_EXPR, label_finish);
+ cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ stat, build_zero_cst (TREE_TYPE (stat)));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_unlikely (cond2), tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&non_null, tmp);
+ }
+ }
+
+ return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ gfc_finish_block (&null),
+ gfc_finish_block (&non_null));
+}
+
+
+/* Generate code for deallocation of allocatable scalars (variables or
+ components). Before the object itself is freed, any allocatable
+ subcomponents are being deallocated. */
+
+tree
+gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
+ gfc_expr* expr, gfc_typespec ts)
+{
+ stmtblock_t null, non_null;
+ tree cond, tmp, error;
+
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
+ build_int_cst (TREE_TYPE (pointer), 0));
+
+ /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
+ we emit a runtime error. */
+ gfc_start_block (&null);
+ if (!can_fail)
+ {
+ tree varname;
+
+ gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
+
+ varname = gfc_build_cstring_const (expr->symtree->name);
+ varname = gfc_build_addr_expr (pchar_type_node, varname);
+
+ error = gfc_trans_runtime_error (true, &expr->where,
+ "Attempt to DEALLOCATE unallocated '%s'",
+ varname);
+ }
+ else
+ error = build_empty_stmt (input_location);
if (status != NULL_TREE && !integer_zerop (status))
{
tree status_type = TREE_TYPE (TREE_TYPE (status));
tree cond2;
- cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
- build_int_cst (TREE_TYPE (status), 0));
- tmp = fold_build2 (MODIFY_EXPR, status_type,
- fold_build1 (INDIRECT_REF, status_type, status),
- build_int_cst (status_type, 1));
- error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error);
+ cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ status, build_int_cst (TREE_TYPE (status), 0));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+ fold_build1_loc (input_location, INDIRECT_REF,
+ status_type, status),
+ build_int_cst (status_type, 1));
+ error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ cond2, tmp, error);
}
gfc_add_expr_to_block (&null, error);
/* When POINTER is not NULL, we free it. */
gfc_start_block (&non_null);
- tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
- fold_convert (pvoid_type_node, pointer));
+
+ /* Free allocatable components. */
+ if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
+ {
+ tmp = build_fold_indirect_ref_loc (input_location, pointer);
+ tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
+ gfc_add_expr_to_block (&non_null, tmp);
+ }
+ else if (ts.type == BT_CLASS
+ && ts.u.derived->components->ts.u.derived->attr.alloc_comp)
+ {
+ tmp = build_fold_indirect_ref_loc (input_location, pointer);
+ tmp = gfc_deallocate_alloc_comp (ts.u.derived->components->ts.u.derived,
+ tmp, 0);
+ gfc_add_expr_to_block (&non_null, tmp);
+ }
+
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_FREE), 1,
+ fold_convert (pvoid_type_node, pointer));
gfc_add_expr_to_block (&non_null, tmp);
if (status != NULL_TREE && !integer_zerop (status))
tree status_type = TREE_TYPE (TREE_TYPE (status));
tree cond2;
- cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
- build_int_cst (TREE_TYPE (status), 0));
- tmp = fold_build2 (MODIFY_EXPR, status_type,
- fold_build1 (INDIRECT_REF, status_type, status),
- build_int_cst (status_type, 0));
- tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp,
- build_empty_stmt ());
+ cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ status, build_int_cst (TREE_TYPE (status), 0));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+ fold_build1_loc (input_location, INDIRECT_REF,
+ status_type, status),
+ build_int_cst (status_type, 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
+ tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&non_null, tmp);
}
- return fold_build3 (COND_EXPR, void_type_node, cond,
- gfc_finish_block (&null), gfc_finish_block (&non_null));
+ return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ gfc_finish_block (&null),
+ gfc_finish_block (&non_null));
}
void *
internal_realloc (void *mem, size_t size)
{
- if (size < 0)
- runtime_error ("Attempt to allocate a negative amount of memory.");
res = realloc (mem, size);
if (!res && size != 0)
- _gfortran_os_error ("Out of memory");
-
- if (size == 0)
- return NULL;
+ _gfortran_os_error ("Allocation would exceed memory limit");
return res;
} */
tree
gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
{
- tree msg, res, negative, nonzero, zero, null_result, tmp;
+ tree msg, res, nonzero, null_result, tmp;
tree type = TREE_TYPE (mem);
size = gfc_evaluate_now (size, block);
/* Create a variable to hold the result. */
res = gfc_create_var (type, 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 (gfor_fndecl_runtime_error, 1, msg),
- build_empty_stmt ());
- gfc_add_expr_to_block (block, tmp);
-
/* Call realloc and check the result. */
- tmp = build_call_expr (built_in_decls[BUILT_IN_REALLOC], 2,
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_REALLOC), 2,
fold_convert (pvoid_type_node, mem), size);
- gfc_add_modify_expr (block, res, fold_convert (type, tmp));
- null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
- build_int_cst (pvoid_type_node, 0));
- nonzero = fold_build2 (NE_EXPR, boolean_type_node, size,
- build_int_cst (size_type_node, 0));
- null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
- nonzero);
+ gfc_add_modify (block, res, fold_convert (type, tmp));
+ null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ res, build_int_cst (pvoid_type_node, 0));
+ nonzero = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, size,
+ build_int_cst (size_type_node, 0));
+ null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
+ null_result, nonzero);
msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
- ("Out of memory"));
- 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 (block, tmp);
-
- /* if (size == 0) then the result is NULL. */
- tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0));
- zero = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, nonzero);
- tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp,
- build_empty_stmt ());
+ ("Allocation would exceed memory limit"));
+ tmp = fold_build3_loc (input_location, 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 (block, tmp);
return res;
}
-/* Add a statement to a block. */
-void
-gfc_add_expr_to_block (stmtblock_t * block, tree expr)
-{
- gcc_assert (block);
+/* Add an expression to another one, either at the front or the back. */
+static void
+add_expr_to_chain (tree* chain, tree expr, bool front)
+{
if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
return;
- if (block->head)
+ if (*chain)
{
- if (TREE_CODE (block->head) != STATEMENT_LIST)
+ if (TREE_CODE (*chain) != STATEMENT_LIST)
{
tree tmp;
- tmp = block->head;
- block->head = NULL_TREE;
- append_to_statement_list (tmp, &block->head);
+ tmp = *chain;
+ *chain = NULL_TREE;
+ append_to_statement_list (tmp, chain);
+ }
+
+ if (front)
+ {
+ tree_stmt_iterator i;
+
+ i = tsi_start (*chain);
+ tsi_link_before (&i, expr, TSI_CONTINUE_LINKING);
}
- append_to_statement_list (expr, &block->head);
+ else
+ append_to_statement_list (expr, chain);
}
else
- /* Don't bother creating a list if we only have a single statement. */
- block->head = expr;
+ *chain = expr;
+}
+
+
+/* Add a statement at the end of a block. */
+
+void
+gfc_add_expr_to_block (stmtblock_t * block, tree expr)
+{
+ gcc_assert (block);
+ add_expr_to_chain (&block->head, expr, false);
+}
+
+
+/* Add a statement at the beginning of a block. */
+
+void
+gfc_prepend_expr_to_block (stmtblock_t * block, tree expr)
+{
+ gcc_assert (block);
+ add_expr_to_chain (&block->head, expr, true);
}
}
-/* Get the current locus. The structure may not be complete, and should
- only be used with gfc_set_backend_locus. */
+/* Save the current locus. The structure may not be complete, and should
+ only be used with gfc_restore_backend_locus. */
void
-gfc_get_backend_locus (locus * loc)
+gfc_save_backend_locus (locus * loc)
{
loc->lb = XCNEW (gfc_linebuf);
loc->lb->location = input_location;
}
-/* Translate an executable statement. */
+/* Restore the saved locus. Only used in conjonction with
+ gfc_save_backend_locus, to free the memory when we are done. */
-tree
-gfc_trans_code (gfc_code * code)
+void
+gfc_restore_backend_locus (locus * loc)
+{
+ gfc_set_backend_locus (loc);
+ free (loc->lb);
+}
+
+
+/* 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. */
+
+static tree
+trans_code (gfc_code * code, tree cond)
{
stmtblock_t block;
tree res;
if (!code)
- return build_empty_stmt ();
+ return build_empty_stmt (input_location);
gfc_start_block (&block);
- /* Translate statements one by one to GIMPLE trees until we reach
+ /* Translate statements one by one into GENERIC trees until we reach
the end of this gfc_code branch. */
for (; code; code = code->next)
{
gfc_add_expr_to_block (&block, res);
}
+ gfc_set_backend_locus (&code->loc);
+
switch (code->op)
{
case EXEC_NOP:
+ case EXEC_END_BLOCK:
+ case EXEC_END_NESTED_BLOCK:
+ case EXEC_END_PROCEDURE:
res = NULL_TREE;
break;
case EXEC_ASSIGN:
- res = gfc_trans_assign (code);
+ if (code->expr1->ts.type == BT_CLASS)
+ res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
+ 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->expr1, code->expr2, code->op);
+ 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_init_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_call (code, false);
+ /* For MVBITS we've got the special exception that we need a
+ dependency check, too. */
+ {
+ bool is_mvbits = false;
+
+ if (code->resolved_isym)
+ {
+ res = gfc_conv_intrinsic_subroutine (code);
+ if (res != NULL_TREE)
+ break;
+ }
+
+ if (code->resolved_isym
+ && code->resolved_isym->id == GFC_ISYM_MVBITS)
+ is_mvbits = true;
+
+ res = gfc_trans_call (code, is_mvbits, NULL_TREE,
+ NULL_TREE, false);
+ }
+ break;
+
+ case EXEC_CALL_PPC:
+ res = gfc_trans_call (code, false, NULL_TREE,
+ NULL_TREE, false);
break;
case EXEC_ASSIGN_CALL:
- res = gfc_trans_call (code, true);
+ res = gfc_trans_call (code, true, NULL_TREE,
+ NULL_TREE, false);
break;
case EXEC_RETURN:
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_CONCURRENT:
+ res = gfc_trans_do_concurrent (code);
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_LOCK:
+ case EXEC_UNLOCK:
+ res = gfc_trans_lock_unlock (code, code->op);
+ break;
+
case EXEC_FORALL:
res = gfc_trans_forall (code);
break;
case EXEC_OMP_SINGLE:
case EXEC_OMP_TASK:
case EXEC_OMP_TASKWAIT:
+ case EXEC_OMP_TASKYIELD:
case EXEC_OMP_WORKSHARE:
res = gfc_trans_omp_directive (code);
break;
if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
{
- if (TREE_CODE (res) == STATEMENT_LIST)
- annotate_all_with_locus (&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. */
void
gfc_generate_code (gfc_namespace * ns)
{
+ ompws_flags = 0;
if (ns->is_block_data)
{
gfc_generate_block_data (ns);
gfc_generate_module_code (gfc_namespace * ns)
{
gfc_namespace *n;
+ struct module_htab_entry *entry;
+
+ gcc_assert (ns->proc_name->backend_decl == NULL);
+ ns->proc_name->backend_decl
+ = build_decl (ns->proc_name->declared_at.lb->location,
+ NAMESPACE_DECL, get_identifier (ns->proc_name->name),
+ void_type_node);
+ entry = gfc_find_module (ns->proc_name->name);
+ if (entry->namespace_decl)
+ /* Buggy sourcecode, using a module before defining it? */
+ htab_empty (entry->decls);
+ entry->namespace_decl = ns->proc_name->backend_decl;
gfc_generate_module_vars (ns);
sibling calls. */
for (n = ns->contained; n; n = n->sibling)
{
+ gfc_entry_list *el;
+
if (!n->proc_name)
continue;
- gfc_create_function_decl (n);
+ gfc_create_function_decl (n, false);
+ DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
+ gfc_module_add_decl (entry, n->proc_name->backend_decl);
+ for (el = ns->entries; el; el = el->next)
+ {
+ DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
+ gfc_module_add_decl (entry, el->sym->backend_decl);
+ }
}
for (n = ns->contained; n; n = n->sibling)
}
}
+
+/* Initialize an init/cleanup block with existing code. */
+
+void
+gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
+{
+ gcc_assert (block);
+
+ block->init = NULL_TREE;
+ block->code = code;
+ block->cleanup = NULL_TREE;
+}
+
+
+/* Add a new pair of initializers/clean-up code. */
+
+void
+gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup)
+{
+ gcc_assert (block);
+
+ /* The new pair of init/cleanup should be "wrapped around" the existing
+ block of code, thus the initialization is added to the front and the
+ cleanup to the back. */
+ add_expr_to_chain (&block->init, init, true);
+ add_expr_to_chain (&block->cleanup, cleanup, false);
+}
+
+
+/* Finish up a wrapped block by building a corresponding try-finally expr. */
+
+tree
+gfc_finish_wrapped_block (gfc_wrapped_block* block)
+{
+ tree result;
+
+ gcc_assert (block);
+
+ /* Build the final expression. For this, just add init and body together,
+ and put clean-up with that into a TRY_FINALLY_EXPR. */
+ result = block->init;
+ add_expr_to_chain (&result, block->code, false);
+ if (block->cleanup)
+ result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
+ result, block->cleanup);
+
+ /* Clear the block. */
+ block->init = NULL_TREE;
+ block->code = NULL_TREE;
+ block->cleanup = NULL_TREE;
+
+ return result;
+}
+
+
+/* Helper function for marking a boolean expression tree as unlikely. */
+
+tree
+gfc_unlikely (tree cond)
+{
+ tree tmp;
+
+ cond = fold_convert (long_integer_type_node, cond);
+ tmp = build_zero_cst (long_integer_type_node);
+ cond = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_EXPECT),
+ 2, cond, tmp);
+ cond = fold_convert (boolean_type_node, cond);
+ return cond;
+}
+
+
+/* Helper function for marking a boolean expression tree as likely. */
+
+tree
+gfc_likely (tree cond)
+{
+ tree tmp;
+
+ cond = fold_convert (long_integer_type_node, cond);
+ tmp = build_one_cst (long_integer_type_node);
+ cond = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_EXPECT),
+ 2, cond, tmp);
+ cond = fold_convert (boolean_type_node, cond);
+ return cond;
+}
OSDN Git Service
