/* 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);
}
{
tree tmp;
tree pointer;
- tree allocate;
tree offset;
tree size;
gfc_expr **lower;
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);
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. */
gfc_trans_dealloc_allocated (tree descriptor)
{
tree tmp;
- tree ptr;
tree var;
stmtblock_t block;
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. */
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
}
+
+/* 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
projects / platform / upstream / gcc.git / commitdiff