}
-/* 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_loc (input_location, MODIFY_EXPR, void_type_node, lhs,
+ 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 type = TREE_TYPE (base);
tree tmp;
+ 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);
+ }
+
gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
type = TREE_TYPE (type);
}
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_loc (input_location, ADDR_EXPR,
+ 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
}
+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_loc (input_location, TRUTH_AND_EXPR,
+ 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)
if (stat)
*stat = 0;
- // The only time this can happen is the size wraps around.
- if (size < 0)
- {
- 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)
{
- newmem = malloc (MAX (size, 1));
- if (newmem == NULL)
- {
- if (stat)
- *stat = LIBERROR_ALLOCATION;
- else
- runtime_error ("Out of memory");
- }
+ if (stat)
+ *stat = LIBERROR_ALLOCATION;
+ else
+ runtime_error ("Allocation would exceed memory limit");
}
-
return newmem;
} */
tree
-gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
+gfc_allocate_with_status (stmtblock_t * block, tree size, tree status,
+ bool coarray_lib)
{
stmtblock_t alloc_block;
- tree res, tmp, error, msg, cond;
+ tree res, tmp, msg, cond;
tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
/* Evaluate size only once, and make sure it has the right type. */
gfc_add_expr_to_block (block, tmp);
}
- /* 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);
-
- if (status != NULL_TREE && !integer_zerop (status))
- {
- /* 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_loc (input_location, 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_loc (input_location, EQ_EXPR, boolean_type_node,
- status, build_int_cst (TREE_TYPE (status), 0));
- error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
- error, gfc_finish_block (&set_status_block));
- }
-
/* 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_loc (input_location,
- MAX_EXPR, size_type_node, size,
- build_int_cst (size_type_node,
- 1)))));
+ if (coarray_lib)
+ {
+ gfc_add_modify (&alloc_block, res,
+ fold_convert (prvoid_type_node,
+ 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),
+ null_pointer_node, /* token */
+ null_pointer_node, /* stat */
+ null_pointer_node, /* errmsg, errmsg_len */
+ build_int_cst (integer_type_node, 0))));
+ }
+ else
+ {
+ 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_loc (input_location,
+ MAX_EXPR, size_type_node, size,
+ build_int_cst (size_type_node, 1)))));
+ }
msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
- ("Out of memory"));
+ ("Allocation would exceed memory limit"));
tmp = build_call_expr_loc (input_location,
gfor_fndecl_os_error, 1, msg);
build_int_cst (prvoid_type_node, 0)),
tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&alloc_block, tmp);
-
- cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, size,
- build_int_cst (TREE_TYPE (size), 0));
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, error,
- gfc_finish_block (&alloc_block));
- gfc_add_expr_to_block (block, tmp);
+ gfc_add_expr_to_block (block, gfc_finish_block (&alloc_block));
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);
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)
+gfc_allocate_allocatable_with_status (stmtblock_t * block, tree mem, tree size,
+ tree status, gfc_expr* expr)
{
stmtblock_t alloc_block;
tree res, tmp, null_mem, alloc, error;
/* Create a variable to hold the result. */
res = gfc_create_var (type, NULL);
- null_mem = fold_build2_loc (input_location, 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. */
gfc_start_block (&alloc_block);
- tmp = gfc_allocate_with_status (&alloc_block, size, status);
+ tmp = gfc_allocate_with_status (&alloc_block, size, status,
+ gfc_option.coarray == GFC_FCOARRAY_LIB
+ && gfc_expr_attr (expr).codimension);
+
gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
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))
{
fold_convert (pvoid_type_node, mem));
gfc_add_expr_to_block (&set_status_block, tmp);
- tmp = gfc_allocate_with_status (&set_status_block, size, status);
+ tmp = gfc_allocate_with_status (&set_status_block, size, status, false);
gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
gfc_add_modify (&set_status_block,
}
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
- alloc, error);
+ error, alloc);
gfc_add_expr_to_block (block, tmp);
return res;
}
+/* 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_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));
+ 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, 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));
+}
+
+
/* Reallocate MEM so it has SIZE bytes of data. This behaves like the
following pseudo-code:
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");
+ _gfortran_os_error ("Allocation would exceed memory limit");
if (size == 0)
return NULL;
tree
gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
{
- tree msg, res, negative, nonzero, zero, null_result, tmp;
+ tree msg, res, nonzero, zero, 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_loc (input_location, 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_loc (input_location, 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,
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"));
+ ("Allocation would exceed memory limit"));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
null_result,
build_call_expr_loc (input_location,
*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. */
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_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;
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,
+ built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
+ cond = fold_convert (boolean_type_node, cond);
+ return cond;
+}
OSDN Git Service
