OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

builtin-types.def (BT_FN_PTR_PTR_SIZE): New type. 

* builtin-types.def (BT_FN_PTR_PTR_SIZE): New type.
	* builtins.def (BUILT_IN_REALLOC): New builtin.

	* trans-array.c (gfc_grow_array): Use gfc_call_realloc.
	(gfc_array_allocate): Use gfc_allocate_with_status and
	gfc_allocate_array_with_status.
	(gfc_array_deallocate): Use gfc_deallocate_with_status.
	(gfc_trans_dealloc_allocated): Use gfc_deallocate_with_status.
	* trans-stmt.c (gfc_trans_allocate): Use gfc_allocate_with_status.
	(gfc_trans_deallocate): Use gfc_deallocate_with_status.
	* trans.c (gfc_allocate_with_status, gfc_allocate_array_with_status,
	gfc_deallocate_with_status, gfc_call_realloc): New functions.
	* trans.h (gfc_allocate_with_status, gfc_allocate_array_with_status,
	gfc_deallocate_with_status, gfc_call_realloc): New prototypes.
	(gfor_fndecl_internal_realloc, gfor_fndecl_allocate,
	gfor_fndecl_allocate_array, gfor_fndecl_deallocate): Remove.
	* f95-lang.c (gfc_init_builtin_functions): Create decl for
	BUILT_IN_REALLOC.
	* trans-decl.c (gfor_fndecl_internal_realloc,
	gfor_fndecl_allocate, gfor_fndecl_allocate_array,
	gfor_fndecl_deallocate): Remove function decls.
	(gfc_build_builtin_function_decls): Likewise.

	* runtime/memory.c (internal_realloc, allocate, allocate_array,
	deallocate): Remove functions.
	* gfortran.map (_gfortran_allocate, _gfortran_allocate_array,
	_gfortran_deallocate, _gfortran_internal_realloc): Remove symbols.
	* libgfortran.h (error_codes): Add comment.

	* gfortran.dg/alloc_comp_basics_1.f90: Update check.
	* gfortran.dg/alloc_comp_constructor_1.f90: Update check.

From-SVN: r127897
This commit is contained in:
Francois-Xavier Coudert 2007-08-29 12:44:32 +00:00 committed by François-Xavier Coudert
parent 31fa49984f
commit 4376b7cf2b
17 changed files with 452 additions and 205 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gcc/ChangeLog
View File

@ -1,3 +1,8 @@
2007-08-29 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* gcc/builtin-types.def (BT_FN_PTR_PTR_SIZE): New type.
* gcc/builtins.def (BUILT_IN_REALLOC): New builtin.
2007-08-29 Douglas Gregor <doug.gregor@gmail.com>
PR c++/33194

2
gcc/builtin-types.def
View File

@ -289,6 +289,8 @@ DEF_FUNCTION_TYPE_2 (BT_FN_INT_CONST_STRING_VALIST_ARG,
BT_INT, BT_CONST_STRING, BT_VALIST_ARG)
DEF_FUNCTION_TYPE_2 (BT_FN_PTR_SIZE_SIZE,
BT_PTR, BT_SIZE, BT_SIZE)
DEF_FUNCTION_TYPE_2 (BT_FN_PTR_PTR_SIZE,
BT_PTR, BT_PTR, BT_SIZE)
DEF_FUNCTION_TYPE_2 (BT_FN_COMPLEX_FLOAT_COMPLEX_FLOAT_COMPLEX_FLOAT,
BT_COMPLEX_FLOAT, BT_COMPLEX_FLOAT, BT_COMPLEX_FLOAT)
DEF_FUNCTION_TYPE_2 (BT_FN_COMPLEX_DOUBLE_COMPLEX_DOUBLE_COMPLEX_DOUBLE,

1
gcc/builtins.def
View File

@ -687,6 +687,7 @@ DEF_GCC_BUILTIN (BUILT_IN_POPCOUNTIMAX, "popcountimax", BT_FN_INT_UINTMAX
DEF_GCC_BUILTIN (BUILT_IN_POPCOUNTL, "popcountl", BT_FN_INT_ULONG, ATTR_CONST_NOTHROW_LIST)
DEF_GCC_BUILTIN (BUILT_IN_POPCOUNTLL, "popcountll", BT_FN_INT_ULONGLONG, ATTR_CONST_NOTHROW_LIST)
DEF_GCC_BUILTIN (BUILT_IN_PREFETCH, "prefetch", BT_FN_VOID_CONST_PTR_VAR, ATTR_NOVOPS_LIST)
DEF_LIB_BUILTIN (BUILT_IN_REALLOC, "realloc", BT_FN_PTR_PTR_SIZE, ATTR_NOTHROW_LIST)
DEF_GCC_BUILTIN (BUILT_IN_RETURN, "return", BT_FN_VOID_PTR, ATTR_NORETURN_NOTHROW_LIST)
DEF_GCC_BUILTIN (BUILT_IN_RETURN_ADDRESS, "return_address", BT_FN_PTR_UINT, ATTR_NULL)
DEF_GCC_BUILTIN (BUILT_IN_SAVEREGS, "saveregs", BT_FN_PTR_VAR, ATTR_NULL)

22
gcc/fortran/ChangeLog
View File

@ -1,3 +1,25 @@
2007-08-29 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* trans-array.c (gfc_grow_array): Use gfc_call_realloc.
(gfc_array_allocate): Use gfc_allocate_with_status and
gfc_allocate_array_with_status.
(gfc_array_deallocate): Use gfc_deallocate_with_status.
(gfc_trans_dealloc_allocated): Use gfc_deallocate_with_status.
* trans-stmt.c (gfc_trans_allocate): Use gfc_allocate_with_status.
(gfc_trans_deallocate): Use gfc_deallocate_with_status.
* trans.c (gfc_allocate_with_status, gfc_allocate_array_with_status,
gfc_deallocate_with_status, gfc_call_realloc): New functions.
* trans.h (gfc_allocate_with_status, gfc_allocate_array_with_status,
gfc_deallocate_with_status, gfc_call_realloc): New prototypes.
(gfor_fndecl_internal_realloc, gfor_fndecl_allocate,
gfor_fndecl_allocate_array, gfor_fndecl_deallocate): Remove.
* f95-lang.c (gfc_init_builtin_functions): Create decl for
BUILT_IN_REALLOC.
* trans-decl.c (gfor_fndecl_internal_realloc,
gfor_fndecl_allocate, gfor_fndecl_allocate_array,
gfor_fndecl_deallocate): Remove function decls.
(gfc_build_builtin_function_decls): Likewise.
2007-08-28 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/33055

6
gcc/fortran/f95-lang.c
View File

@ -1036,6 +1036,12 @@ gfc_init_builtin_functions (void)
"malloc", false);
DECL_IS_MALLOC (built_in_decls[BUILT_IN_MALLOC]) = 1;
tmp = tree_cons (NULL_TREE, pvoid_type_node, void_list_node);
tmp = tree_cons (NULL_TREE, size_type_node, tmp);
ftype = build_function_type (pvoid_type_node, tmp);
gfc_define_builtin ("__builtin_realloc", ftype, BUILT_IN_REALLOC,
"realloc", false);
tmp = tree_cons (NULL_TREE, void_type_node, void_list_node);
ftype = build_function_type (integer_type_node, tmp);
gfc_define_builtin ("__builtin_isnan", ftype, BUILT_IN_ISNAN,

39
gcc/fortran/trans-array.c
View File

@ -843,17 +843,11 @@ gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
/* Calculate the new array size. */
size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
arg1 = build2 (MULT_EXPR, gfc_array_index_type, tmp,
fold_convert (gfc_array_index_type, size));
arg1 = build2 (MULT_EXPR, size_type_node, fold_convert (size_type_node, tmp),
fold_convert (size_type_node, size));
/* Pick the realloc function. */
if (gfc_index_integer_kind == 4 || gfc_index_integer_kind == 8)
tmp = gfor_fndecl_internal_realloc;
else
gcc_unreachable ();
/* Set the new data pointer. */
tmp = build_call_expr (tmp, 2, arg0, arg1);
/* Call the realloc() function. */
tmp = gfc_call_realloc (pblock, arg0, arg1);
gfc_conv_descriptor_data_set (pblock, desc, tmp);
}
@ -3571,7 +3565,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
{
tree tmp;
tree pointer;
tree allocate;
tree offset;
tree size;
gfc_expr **lower;
@ -3629,22 +3622,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
pointer = gfc_conv_descriptor_data_get (se->expr);
STRIP_NOPS (pointer);
if (TYPE_PRECISION (gfc_array_index_type) == 32 ||
TYPE_PRECISION (gfc_array_index_type) == 64)
{
if (allocatable_array)
allocate = gfor_fndecl_allocate_array;
else
allocate = gfor_fndecl_allocate;
}
else
gcc_unreachable ();
/* The allocate_array variants take the old pointer as first argument. */
if (allocatable_array)
tmp = build_call_expr (allocate, 3, pointer, size, pstat);
tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat);
else
tmp = build_call_expr (allocate, 2, size, pstat);
tmp = gfc_allocate_with_status (&se->pre, size, pstat);
tmp = build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
gfc_add_expr_to_block (&se->pre, tmp);
@ -3680,7 +3662,7 @@ gfc_array_deallocate (tree descriptor, tree pstat)
STRIP_NOPS (var);
/* Parameter is the address of the data component. */
tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, pstat);
tmp = gfc_deallocate_with_status (var, pstat, false);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
@ -4998,7 +4980,6 @@ tree
gfc_trans_dealloc_allocated (tree descriptor)
{
tree tmp;
tree ptr;
tree var;
stmtblock_t block;
@ -5006,13 +4987,11 @@ gfc_trans_dealloc_allocated (tree descriptor)
var = gfc_conv_descriptor_data_get (descriptor);
STRIP_NOPS (var);
tmp = gfc_create_var (gfc_array_index_type, NULL);
ptr = build_fold_addr_expr (tmp);
/* Call array_deallocate with an int* present in the second argument.
/* Call array_deallocate with an int * present in the second argument.
Although it is ignored here, it's presence ensures that arrays that
are already deallocated are ignored. */
tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, ptr);
tmp = gfc_deallocate_with_status (var, NULL_TREE, true);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */

29
gcc/fortran/trans-decl.c
View File

@ -73,10 +73,6 @@ tree gfc_static_ctors;
/* Function declarations for builtin library functions. */
tree gfor_fndecl_internal_realloc;
tree gfor_fndecl_allocate;
tree gfor_fndecl_allocate_array;
tree gfor_fndecl_deallocate;
tree gfor_fndecl_pause_numeric;
tree gfor_fndecl_pause_string;
tree gfor_fndecl_stop_numeric;
@ -2273,35 +2269,10 @@ void
gfc_build_builtin_function_decls (void)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
gfor_fndecl_internal_realloc =
gfc_build_library_function_decl (get_identifier
(PREFIX("internal_realloc")),
pvoid_type_node, 2, pvoid_type_node,
gfc_array_index_type);
gfor_fndecl_allocate =
gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
pvoid_type_node, 2,
gfc_array_index_type, gfc_pint4_type_node);
DECL_IS_MALLOC (gfor_fndecl_allocate) = 1;
gfor_fndecl_allocate_array =
gfc_build_library_function_decl (get_identifier (PREFIX("allocate_array")),
pvoid_type_node, 3, pvoid_type_node,
gfc_array_index_type, gfc_pint4_type_node);
DECL_IS_MALLOC (gfor_fndecl_allocate_array) = 1;
gfor_fndecl_deallocate =
gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
void_type_node, 2, pvoid_type_node,
gfc_pint4_type_node);
gfor_fndecl_stop_numeric =
gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
void_type_node, 1, gfc_int4_type_node);
/* Stop doesn't return. */
TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;

15
gcc/fortran/trans-stmt.c
View File

@ -3565,11 +3565,7 @@ gfc_trans_allocate (gfc_code * code)
TREE_USED (error_label) = 1;
}
else
{
pstat = integer_zero_node;
stat = error_label = NULL_TREE;
}
pstat = stat = error_label = NULL_TREE;
for (al = code->ext.alloc_list; al != NULL; al = al->next)
{
@ -3590,7 +3586,7 @@ gfc_trans_allocate (gfc_code * code)
if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE)
tmp = se.string_length;
tmp = build_call_expr (gfor_fndecl_allocate, 2, tmp, pstat);
tmp = gfc_allocate_with_status (&se.pre, tmp, pstat);
tmp = build2 (MODIFY_EXPR, void_type_node, se.expr,
fold_convert (TREE_TYPE (se.expr), tmp));
gfc_add_expr_to_block (&se.pre, tmp);
@ -3679,10 +3675,7 @@ gfc_trans_deallocate (gfc_code * code)
gfc_add_modify_expr (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
}
else
{
pstat = apstat = null_pointer_node;
stat = astat = NULL_TREE;
}
pstat = apstat = stat = astat = NULL_TREE;
for (al = code->ext.alloc_list; al != NULL; al = al->next)
{
@ -3720,7 +3713,7 @@ gfc_trans_deallocate (gfc_code * code)
tmp = gfc_array_deallocate (se.expr, pstat);
else
{
tmp = build_call_expr (gfor_fndecl_deallocate, 2, se.expr, pstat);
tmp = gfc_deallocate_with_status (se.expr, pstat, false);
gfc_add_expr_to_block (&se.pre, tmp);
tmp = build2 (MODIFY_EXPR, void_type_node,

373
gcc/fortran/trans.c
View File

@ -473,6 +473,222 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size)
return res;
}
/* The status variable of allocate statement is set to ERROR_ALLOCATION
when the allocation wasn't successful. This value needs to be kept in
sync with libgfortran/libgfortran.h. */
#define ERROR_ALLOCATION 5014
/* Allocate memory, using an optional status argument.
This function follows the following pseudo-code:
void *
allocate (size_t size, integer_type* stat)
{
void *newmem;
if (stat)
*stat = 0;
// The only time this can happen is the size wraps around.
if (size < 0)
{
if (stat)
{
*stat = ERROR_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 = ERROR_ALLOCATION;
else
runtime_error ("Out of memory");
}
}
return newmem;
} */
tree
gfc_allocate_with_status (stmtblock_t * block, 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;
/* 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);
/* Set the optional status variable to zero. */
if (status != NULL_TREE && !integer_zerop (status))
{
tmp = fold_build2 (MODIFY_EXPR, status_type,
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);
}
/* Generate the block of code handling (size < 0). */
msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
("Attempt to allocate negative amount of memory. "
"Possible integer overflow"));
error = build_call_expr (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_expr (&set_status_block,
build1 (INDIRECT_REF, status_type, status),
build_int_cst (status_type, ERROR_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));
}
/* 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))));
msg = gfc_build_addr_expr (pchar_type_node,
gfc_build_cstring_const ("Out of memory"));
tmp = build_call_expr (gfor_fndecl_os_error, 1, msg);
if (status != NULL_TREE && !integer_zerop (status))
{
/* 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,
build1 (INDIRECT_REF, status_type, status),
build_int_cst (status_type, ERROR_ALLOCATION));
tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
tmp2);
}
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));
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
error to allocate it again.
This function follows the following pseudo-code:
void *
allocate_array (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 = ERROR_ALLOCATION;
return mem;
}
else
runtime_error ("Attempting to allocate already allocated array");
} */
tree
gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
tree status)
{
stmtblock_t alloc_block;
tree res, tmp, null_mem, alloc, error, msg;
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));
/* If mem is NULL, we call gfc_allocate_with_status. */
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_cstring_const
("Attempting to allocate already allocated array"));
error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
if (status != NULL_TREE && !integer_zerop (status))
{
tree status_type = TREE_TYPE (TREE_TYPE (status));
stmtblock_t set_status_block;
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);
tmp = gfc_allocate_with_status (&set_status_block, size, status);
gfc_add_modify_expr (&set_status_block, res, fold_convert (type, tmp));
gfc_add_modify_expr (&set_status_block,
build1 (INDIRECT_REF, status_type, status),
build_int_cst (status_type, ERROR_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));
}
tmp = fold_build3 (COND_EXPR, void_type_node, null_mem, alloc, error);
gfc_add_expr_to_block (block, tmp);
return res;
}
/* Free a given variable, if it's not NULL. */
tree
@ -497,6 +713,163 @@ gfc_call_free (tree var)
}
/* User-deallocate; we emit the code directly from the front-end, and the
logic is the same as the previous library function:
void
deallocate (void *pointer, GFC_INTEGER_4 * stat)
{
if (!pointer)
{
if (stat)
*stat = 1;
else
runtime_error ("Attempt to DEALLOCATE unallocated memory.");
}
else
{
free (pointer);
if (stat)
*stat = 0;
}
}
In this front-end version, status doesn't have to be GFC_INTEGER_4.
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). */
tree
gfc_deallocate_with_status (tree pointer, tree status, bool can_fail)
{
stmtblock_t null, non_null;
tree cond, tmp, error, msg;
cond = fold_build2 (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_cstring_const
("Attempt to DEALLOCATE unallocated memory."));
error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
}
else
error = build_empty_stmt ();
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,
build1 (INDIRECT_REF, status_type, status),
build_int_cst (status_type, 1));
error = fold_build3 (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));
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 (NE_EXPR, boolean_type_node, status,
build_int_cst (TREE_TYPE (status), 0));
tmp = fold_build2 (MODIFY_EXPR, status_type,
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 ());
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));
}
/* 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.");
mem = realloc (mem, size);
if (!mem && size != 0)
_gfortran_os_error ("Out of memory");
if (size == 0)
return NULL;
return mem;
} */
tree
gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
{
tree msg, res, negative, zero, null_result, tmp;
tree type = TREE_TYPE (mem);
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 (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_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,
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));
zero = fold_build2 (EQ_EXPR, boolean_type_node, size,
build_int_cst (size_type_node, 0));
null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
zero);
msg = gfc_build_addr_expr (pchar_type_node,
gfc_build_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));
tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp,
build_empty_stmt ());
gfc_add_expr_to_block (block, tmp);
return res;
}
/* Add a statement to a block. */
void

16
gcc/fortran/trans.h
View File

@ -450,6 +450,18 @@ tree gfc_call_free (tree);
/* Allocate memory after performing a few checks. */
tree gfc_call_malloc (stmtblock_t *, tree, tree);
/* Allocate memory for arrays, with optional status variable. */
tree gfc_allocate_array_with_status (stmtblock_t *, tree, tree, tree);
/* Allocate memory, with optional status variable. */
tree gfc_allocate_with_status (stmtblock_t *, tree, tree);
/* Generate code to deallocate an array. */
tree gfc_deallocate_with_status (tree, tree, bool);
/* Generate code to call realloc(). */
tree gfc_call_realloc (stmtblock_t *, tree, tree);
/* Generate code for an assignment, includes scalarization. */
tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool);
@ -483,10 +495,6 @@ struct gimplify_omp_ctx;
void gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *, tree);
/* Runtime library function decls. */
extern GTY(()) tree gfor_fndecl_internal_realloc;
extern GTY(()) tree gfor_fndecl_allocate;
extern GTY(()) tree gfor_fndecl_allocate_array;
extern GTY(()) tree gfor_fndecl_deallocate;
extern GTY(()) tree gfor_fndecl_pause_numeric;
extern GTY(()) tree gfor_fndecl_pause_string;
extern GTY(()) tree gfor_fndecl_stop_numeric;

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2007-08-29 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* gfortran.dg/alloc_comp_basics_1.f90: Update check.
* gfortran.dg/alloc_comp_constructor_1.f90: Update check.
2007-08-29 Douglas Gregor <doug.gregor@gmail.com>
PR c++/33194

2
gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
View File

@ -139,6 +139,6 @@ contains
end subroutine check_alloc2
end program alloc
! { dg-final { scan-tree-dump-times "deallocate" 24 "original" } }
! { dg-final { scan-tree-dump-times "builtin_free" 24 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
! { dg-final { cleanup-modules "alloc_m" } }

2
gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90
View File

@ -104,5 +104,5 @@ contains
end function blaha
end program test_constructor
! { dg-final { scan-tree-dump-times "deallocate" 18 "original" } }
! { dg-final { scan-tree-dump-times "builtin_free" 19 "original" } }
! { dg-final { cleanup-tree-dump "original" } }

8
libgfortran/ChangeLog
View File

@ -1,3 +1,11 @@
2007-08-29 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* runtime/memory.c (internal_realloc, allocate, allocate_array,
deallocate): Remove functions.
* gfortran.map (_gfortran_allocate, _gfortran_allocate_array,
_gfortran_deallocate, _gfortran_internal_realloc): Remove symbols.
* libgfortran.h (error_codes): Add comment.
2007-08-28 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libfortran/33055

4
libgfortran/gfortran.map
View File

@ -11,8 +11,6 @@ GFORTRAN_1.0 {
_gfortran_all_l16;
_gfortran_all_l4;
_gfortran_all_l8;
_gfortran_allocate;
_gfortran_allocate_array;
_gfortran_any_l16;
_gfortran_any_l4;
_gfortran_any_l8;
@ -60,7 +58,6 @@ GFORTRAN_1.0 {
_gfortran_ctime;
_gfortran_ctime_sub;
_gfortran_date_and_time;
_gfortran_deallocate;
_gfortran_eoshift0_1;
_gfortran_eoshift0_1_char;
_gfortran_eoshift0_2;
@ -167,7 +164,6 @@ GFORTRAN_1.0 {
_gfortran_ierrno_i4;
_gfortran_ierrno_i8;
_gfortran_internal_pack;
_gfortran_internal_realloc;
_gfortran_internal_unpack;
_gfortran_irand;
_gfortran_isatty_l4;

4
libgfortran/libgfortran.h
View File

@ -447,7 +447,9 @@ typedef enum
ERROR_READ_OVERFLOW,
ERROR_INTERNAL,
ERROR_INTERNAL_UNIT,
ERROR_ALLOCATION,
ERROR_ALLOCATION, /* Keep in sync with value used in
gcc/fortran/trans.c
(gfc_allocate_array_with_status). */
ERROR_DIRECT_EOR,
ERROR_SHORT_RECORD,
ERROR_CORRUPT_FILE,

124
libgfortran/runtime/memory.c
View File

@ -38,10 +38,6 @@ Boston, MA 02110-1301, USA. */
performance is desired, but it can help when you're debugging code. */
/* #define GFC_CLEAR_MEMORY */
/* If GFC_CHECK_MEMORY is defined, we do some sanity checks at runtime.
This causes small overhead, but again, it also helps debugging. */
#define GFC_CHECK_MEMORY
void *
get_mem (size_t n)
{
@ -76,123 +72,3 @@ internal_malloc_size (size_t size)
return get_mem (size);
}
/* Reallocate internal memory MEM so it has SIZE bytes of data.
Allocate a new block if MEM is zero, and free the block if
SIZE is 0. */
extern void *internal_realloc (void *, index_type);
export_proto(internal_realloc);
void *
internal_realloc (void *mem, index_type size)
{
#ifdef GFC_CHECK_MEMORY
/* Under normal circumstances, this is _never_ going to happen! */
if (size < 0)
runtime_error ("Attempt to allocate a negative amount of memory.");
#endif
mem = realloc (mem, size);
if (!mem && size != 0)
os_error ("Out of memory.");
if (size == 0)
return NULL;
return mem;
}
/* User-allocate, one call for each member of the alloc-list of an
ALLOCATE statement. */
extern void *allocate (index_type, GFC_INTEGER_4 *) __attribute__ ((malloc));
export_proto(allocate);
void *
allocate (index_type size, GFC_INTEGER_4 * stat)
{
void *newmem;
#ifdef GFC_CHECK_MEMORY
/* The only time this can happen is the size computed by the
frontend wraps around. */
if (size < 0)
{
if (stat)
{
*stat = ERROR_ALLOCATION;
return NULL;
}
else
runtime_error ("Attempt to allocate negative amount of memory. "
"Possible integer overflow");
}
#endif
newmem = malloc (size ? size : 1);
if (!newmem)
{
if (stat)
{
*stat = ERROR_ALLOCATION;
return newmem;
}
else
runtime_error ("ALLOCATE: Out of memory.");
}
if (stat)
*stat = 0;
return newmem;
}
/* Function to call in an ALLOCATE statement when the argument is an
allocatable array. If the array is currently allocated, it is
an error to allocate it again. */
extern void *allocate_array (void *, index_type, GFC_INTEGER_4 *);
export_proto(allocate_array);
void *
allocate_array (void *mem, index_type size, GFC_INTEGER_4 * stat)
{
if (mem == NULL)
return allocate (size, stat);
if (stat)
{
free (mem);
mem = allocate (size, stat);
*stat = ERROR_ALLOCATION;
return mem;
}
runtime_error ("Attempting to allocate already allocated array.");
}
/* User-deallocate; pointer is then NULLified by the front-end. */
extern void deallocate (void *, GFC_INTEGER_4 *);
export_proto(deallocate);
void
deallocate (void *mem, GFC_INTEGER_4 * stat)
{
if (!mem)
{
if (stat)
{
*stat = 1;
return;
}
else
runtime_error ("Internal: Attempt to DEALLOCATE unallocated memory.");
}
free (mem);
if (stat)
*stat = 0;
}