/* Code translation -- generate GCC trees from gfc_code.
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2012
Free Software Foundation, Inc.
Contributed by Paul Brook
}
-/* 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 (pblock, var, expr);
+ gfc_add_modify_loc (loc, pblock, var, expr);
return var;
}
+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)
+gfc_add_modify_loc (location_t loc, stmtblock_t * pblock, tree lhs, tree rhs)
{
tree tmp;
|| AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
#endif
- tmp = fold_build2 (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. */
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
tree base = get_base_address (t);
if (base && DECL_P (base))
TREE_ADDRESSABLE (base) = 1;
- t = fold_build1 (ADDR_EXPR, natural_type, t);
+ 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_loc (input_location, 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 call to print a runtime error possibly including multiple
arguments and a locus. */
-tree
-gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
-{
- va_list ap;
-
- va_start (ap, msgid);
- return gfc_trans_runtime_error_vararg (error, where, msgid, ap);
-}
-
-tree
-gfc_trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
- va_list ap)
+static tree
+trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
+ va_list ap)
{
stmtblock_t block;
tree tmp;
char *message;
const char *p;
int line, nargs, i;
+ location_t loc;
/* Compute the number of extra arguments from the format string. */
for (p = msgid, nargs = 0; *p; p++)
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 = XALLOCAVEC (tree, nargs + 2);
argarray[1] = arg2;
for (i = 0; i < nargs; i++)
argarray[2 + i] = va_arg (ap, tree);
- va_end (ap);
/* Build the function call to runtime_(warning,error)_at; because of the
variable number of arguments, we can't use build_call_expr_loc dinput_location,
else
fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
- tmp = fold_builtin_call_array (input_location, 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);
}
+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
/* The code to generate the error. */
va_start (ap, msgid);
gfc_add_expr_to_block (&block,
- gfc_trans_runtime_error_vararg (error, where,
- msgid, ap));
+ trans_runtime_error_vararg (error, where,
+ msgid, ap));
if (once)
gfc_add_modify (&block, tmpvar, boolean_false_node);
{
/* 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_loc (input_location,
- 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 (input_location));
+ 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, 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, malloc_result, null_result, res;
+ tree tmp, msg, malloc_result, null_result, res, malloc_tree;
stmtblock_t block2;
size = gfc_evaluate_now (size, block);
/* 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,
- built_in_decls[BUILT_IN_MALLOC], 1, size)));
+ malloc_tree, 1, size)));
/* 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));
+ 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 (COND_EXPR, void_type_node, null_result,
+ 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));
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");
+ if (stat)
+ *stat = LIBERROR_ALLOCATION;
+ else
+ runtime_error ("Allocation would exceed memory limit");
}
- else
- {
- newmem = malloc (MAX (size, 1));
- if (newmem == NULL)
- {
- if (stat)
- *stat = LIBERROR_ALLOCATION;
- else
- runtime_error ("Out of memory");
- }
- }
-
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 (prvoid_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 (TREE_TYPE (status), 0)),
- tmp, build_empty_stmt (input_location));
- 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")));
+
+ 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));
- /* 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_loc (input_location,
- gfor_fndecl_runtime_error, 1, msg);
+ gfc_add_expr_to_block (block, tmp);
+}
- if (status != NULL_TREE && !integer_zerop (status))
+
+/* 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 (&set_status_block,
- fold_build1 (INDIRECT_REF, status_type, status),
- build_int_cst (status_type, LIBERROR_ALLOCATION));
- gfc_add_modify (&set_status_block, res,
- build_int_cst (prvoid_type_node, 0));
-
- tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
- build_int_cst (TREE_TYPE (status), 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 (&alloc_block, res,
- fold_convert (prvoid_type_node,
- build_call_expr_loc (input_location,
- 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_loc (input_location,
- 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 (TREE_TYPE (status), 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 (prvoid_type_node, 0)),
- tmp, build_empty_stmt (input_location));
- 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 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. */
-tree
-gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
- tree status, gfc_expr* expr)
+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;
+ 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 (type, 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 (&alloc_block, res, fold_convert (type, tmp));
+
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB
+ && gfc_expr_attr (expr).codimension)
+ {
+ tree cond;
+
+ 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);
- /* Otherwise, we issue a runtime error or set the status variable. */
+ /* If mem is not NULL, we issue a runtime error or set the
+ status variable. */
if (expr)
{
tree varname;
else
error = gfc_trans_runtime_error (true, NULL,
"Attempting to allocate already allocated"
- "variable");
+ " variable");
- if (status != NULL_TREE && !integer_zerop (status))
+ if (status != NULL_TREE)
{
- tree status_type = TREE_TYPE (TREE_TYPE (status));
- stmtblock_t set_status_block;
-
- gfc_start_block (&set_status_block);
- tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_FREE], 1,
- fold_convert (pvoid_type_node, mem));
- gfc_add_expr_to_block (&set_status_block, tmp);
+ tree status_type = TREE_TYPE (status);
- tmp = gfc_allocate_with_status (&set_status_block, size, status);
- gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
-
- gfc_add_modify (&set_status_block,
- fold_build1 (INDIRECT_REF, status_type, status),
- build_int_cst (status_type, LIBERROR_ALLOCATION));
-
- 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));
+ 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,
- built_in_decls[BUILT_IN_FREE], 1, var);
- tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
- build_empty_stmt (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);
each procedure).
If a runtime-message is possible, `expr' must point to the original
- expression being deallocated for its locus and variable name. */
+ 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_expr* expr)
+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;
+ 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)
+ {
+ 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 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. */
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);
+
+ /* 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,
- built_in_decls[BUILT_IN_FREE], 1,
- fold_convert (pvoid_type_node, pointer));
+ 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 (input_location));
+ 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_loc (input_location,
- gfor_fndecl_runtime_error, 1, msg),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (block, tmp);
-
/* Call realloc and check the result. */
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_REALLOC], 2,
+ builtin_decl_explicit (BUILT_IN_REALLOC), 2,
fold_convert (pvoid_type_node, mem), size);
gfc_add_modify (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);
+ 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_loc (input_location,
- gfor_fndecl_os_error, 1, msg),
- build_empty_stmt (input_location));
- 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 (input_location));
+ ("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;
*chain = expr;
}
-/* Add a statement to a block. */
+
+/* Add a statement at the end of a block. */
void
gfc_add_expr_to_block (stmtblock_t * block, tree expr)
}
+/* 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);
+}
+
+
/* Add a block the end of a block. */
void
}
-/* 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;
}
+/* Restore the saved locus. Only used in conjonction with
+ gfc_save_backend_locus, to free the memory when we are done. */
+
+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. */
{
case EXEC_NOP:
case EXEC_END_BLOCK:
+ case EXEC_END_NESTED_BLOCK:
case EXEC_END_PROCEDURE:
res = NULL_TREE;
break;
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;
- if (code->resolved_isym
- && code->resolved_isym->id == GFC_ISYM_MOVE_ALLOC)
- res = gfc_conv_intrinsic_move_alloc (code);
- else
- res = gfc_trans_call (code, is_mvbits, NULL_TREE,
- NULL_TREE, false);
+
+ res = gfc_trans_call (code, is_mvbits, NULL_TREE,
+ NULL_TREE, false);
}
break;
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_do_while (code);
break;
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;
continue;
gfc_create_function_decl (n, false);
- gcc_assert (DECL_CONTEXT (n->proc_name->backend_decl) == NULL_TREE);
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)
{
- gcc_assert (DECL_CONTEXT (el->sym->backend_decl) == NULL_TREE);
DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
gfc_module_add_decl (entry, el->sym->backend_decl);
}
result = block->init;
add_expr_to_chain (&result, block->code, false);
if (block->cleanup)
- result = build2 (TRY_FINALLY_EXPR, void_type_node, result, block->cleanup);
+ result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
+ result, block->cleanup);
/* Clear the block. */
block->init = 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
