mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-02-21 16:59:56 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/64578 ([OOP] Seg-fault and ICE with unlimited polymorphic array pointer function)

Browse Source 
2015-01-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/64578
	* trans-expr.c (gfc_trans_pointer_assignment): Make sure that
	before reinitializing rse, to add the rse.pre to block before
	creating 'ptrtemp'.
	* trans-intrinsic.c (gfc_conv_associated): Deal with the class
	data being a descriptor.

2015-01-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/64578
	* gfortran.dg/unlimited_polymorphic_21.f90: New test

From-SVN: r219802
This commit is contained in:
Paul Thomas 2015-01-17 20:44:07 +00:00
parent 9b5485174b
commit 029b2d5596
4 changed files with 69 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
gcc/fortran/ChangeLog
View File

@ -1,3 +1,12 @@
2015-01-17 Paul Thomas <pault@gcc.gnu.org>
PR fortran/64578
* trans-expr.c (gfc_trans_pointer_assignment): Make sure that
before reinitializing rse, to add the rse.pre to block before
creating 'ptrtemp'.
* trans-intrinsic.c (gfc_conv_associated): Deal with the class
data being a descriptor.
2015-01-17 Andre Vehreschild <vehre@gmx.de>
PR fortran/60357

2
gcc/fortran/trans-expr.c
View File

@ -7075,6 +7075,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
rse.expr = gfc_class_data_get (rse.expr);
else
{
gfc_add_block_to_block (&block, &rse.pre);
tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
gfc_add_modify (&lse.pre, tmp, rse.expr);
@ -7146,6 +7147,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
}
else
{
gfc_add_block_to_block (&block, &rse.pre);
tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
gfc_add_modify (&lse.pre, tmp, rse.expr);

102
gcc/fortran/trans-intrinsic.c
View File

@ -186,7 +186,7 @@ gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
{
/* For __float128, the story is a bit different, because we return
a decl to a library function rather than a built-in. */
gfc_intrinsic_map_t *m;
gfc_intrinsic_map_t *m;
for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
;
@ -294,8 +294,8 @@ gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
nargs = gfc_intrinsic_argument_list_length (expr);
args = XALLOCAVEC (tree, nargs);
/* Evaluate all the arguments passed. Whilst we're only interested in the
first one here, there are other parts of the front-end that assume this
/* Evaluate all the arguments passed. Whilst we're only interested in the
first one here, there are other parts of the front-end that assume this
and will trigger an ICE if it's not the case. */
type = gfc_typenode_for_spec (&expr->ts);
gcc_assert (expr->value.function.actual->expr);
@ -540,7 +540,7 @@ gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
nargs = gfc_intrinsic_argument_list_length (expr);
args = XALLOCAVEC (tree, nargs);
/* Evaluate the argument, we process all arguments even though we only
/* Evaluate the argument, we process all arguments even though we only
use the first one for code generation purposes. */
type = gfc_typenode_for_spec (&expr->ts);
gcc_assert (expr->value.function.actual->expr);
@ -1237,7 +1237,7 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
/* Send data to a remove coarray. */
static tree
conv_caf_send (gfc_code *code) {
gfc_expr *lhs_expr, *rhs_expr;
@ -1520,7 +1520,7 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
extent = gfc_extent(i)
ml = m
m = m/extent
if (i >= min_var)
if (i >= min_var)
goto exit_label
i++
}
@ -1547,10 +1547,10 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
return;
}
m = gfc_create_var (type, NULL);
ml = gfc_create_var (type, NULL);
loop_var = gfc_create_var (integer_type_node, NULL);
min_var = gfc_create_var (integer_type_node, NULL);
m = gfc_create_var (type, NULL);
ml = gfc_create_var (type, NULL);
loop_var = gfc_create_var (integer_type_node, NULL);
min_var = gfc_create_var (integer_type_node, NULL);
/* m = this_image () - 1. */
gfc_add_modify (&se->pre, m, tmp);
@ -1584,7 +1584,7 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
extent = fold_convert (type, extent);
/* m = m/extent. */
gfc_add_modify (&loop, m,
gfc_add_modify (&loop, m,
fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
m, extent));
@ -1907,7 +1907,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
ubound = gfc_conv_descriptor_ubound_get (desc, bound);
lbound = gfc_conv_descriptor_lbound_get (desc, bound);
/* 13.14.53: Result value for LBOUND
Case (i): For an array section or for an array expression other than a
@ -2257,7 +2257,7 @@ gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
/* Remainder function MOD(A, P) = A - INT(A / P) * P
MODULO(A, P) = A - FLOOR (A / P) * P
MODULO(A, P) = A - FLOOR (A / P) * P
The obvious algorithms above are numerically instable for large
arguments, hence these intrinsics are instead implemented via calls
@ -2316,7 +2316,7 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
In order to calculate the result accurately, we use the fmod
function as follows.
res = fmod (arg, arg2);
if (res)
{
@ -2328,7 +2328,7 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
=> As two nested ternary exprs:
res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
: copysign (0., arg2);
*/
@ -2349,15 +2349,15 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
boolean_type_node, test, test2);
test = gfc_evaluate_now (test, &se->pre);
se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
fold_build2_loc (input_location,
fold_build2_loc (input_location,
PLUS_EXPR,
type, tmp, args[1]),
type, tmp, args[1]),
tmp);
}
else
{
tree expr1, copysign, cscall;
copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
expr->ts.kind);
test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
args[0], zero);
@ -2366,13 +2366,13 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
boolean_type_node, test, test2);
expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
fold_build2_loc (input_location,
fold_build2_loc (input_location,
PLUS_EXPR,
type, tmp, args[1]),
type, tmp, args[1]),
tmp);
test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
tmp, zero);
cscall = build_call_expr_loc (input_location, copysign, 2, zero,
cscall = build_call_expr_loc (input_location, copysign, 2, zero,
args[1]);
se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
expr1, cscall);
@ -2839,7 +2839,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
tree cond, isnan;
val = args[i];
val = args[i];
/* Handle absent optional arguments by ignoring the comparison. */
if (argexpr->expr->expr_type == EXPR_VARIABLE
@ -2847,7 +2847,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
&& TREE_CODE (val) == INDIRECT_REF)
cond = fold_build2_loc (input_location,
NE_EXPR, boolean_type_node,
TREE_OPERAND (val, 0),
TREE_OPERAND (val, 0),
build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
else
{
@ -3387,19 +3387,19 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
gfc_add_modify (&ifblock2, val,
fold_build2_loc (input_location, RDIV_EXPR, type, scale,
absX));
res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
gfc_build_const (type, integer_one_node));
gfc_add_modify (&ifblock2, resvar, res1);
gfc_add_modify (&ifblock2, scale, absX);
res1 = gfc_finish_block (&ifblock2);
res1 = gfc_finish_block (&ifblock2);
gfc_init_block (&ifblock3);
gfc_add_modify (&ifblock3, val,
fold_build2_loc (input_location, RDIV_EXPR, type, absX,
scale));
res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
gfc_add_modify (&ifblock3, resvar, res2);
res2 = gfc_finish_block (&ifblock3);
@ -3407,7 +3407,7 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
absX, scale);
tmp = build3_v (COND_EXPR, cond, res1, res2);
gfc_add_expr_to_block (&ifblock1, tmp);
gfc_add_expr_to_block (&ifblock1, tmp);
tmp = gfc_finish_block (&ifblock1);
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
@ -3415,7 +3415,7 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
gfc_build_const (type, integer_zero_node));
tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
gfc_add_expr_to_block (&block, tmp);
}
else
{
@ -4786,7 +4786,7 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
For INTEGER kinds smaller than the C 'int' type, we have to subtract the
difference in bit size between the argument of LEADZ and the C int. */
static void
gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
{
@ -4848,7 +4848,7 @@ gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
{
/* We end up here if the argument type is larger than 'long long'.
We generate this code:
if (x & (ULL_MAX << ULL_SIZE) != 0)
return clzll ((unsigned long long) (x >> ULLSIZE));
else
@ -4904,7 +4904,7 @@ gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
The conditional expression is necessary because the result of TRAILZ(0)
is defined, but the result of __builtin_ctz(0) is undefined for most
targets. */
static void
gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
{
@ -4959,7 +4959,7 @@ gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
{
/* We end up here if the argument type is larger than 'long long'.
We generate this code:
if ((x & ULL_MAX) == 0)
return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
else
@ -5010,7 +5010,7 @@ gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
/* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
for types larger than "long long", we call the long long built-in for
the lower and higher bits and combine the result. */
static void
gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
{
@ -5076,7 +5076,7 @@ gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
call2 = build_call_expr_loc (input_location, func, 1,
fold_convert (long_long_unsigned_type_node,
arg2));
/* Combine the results. */
if (parity)
se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type,
@ -5411,7 +5411,7 @@ gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
{
tree arg, allones, type, utype, res, cond, bitsize;
int i;
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
arg = gfc_evaluate_now (arg, &se->pre);
@ -5743,7 +5743,7 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
gfc_add_block_to_block (&se->pre, &argse.pre);
/* Unusually, for an intrinsic, size does not exclude
an optional arg2, so we must test for it. */
an optional arg2, so we must test for it. */
if (actual->expr->expr_type == EXPR_VARIABLE
&& actual->expr->symtree->n.sym->attr.dummy
&& actual->expr->symtree->n.sym->attr.optional)
@ -5813,7 +5813,7 @@ size_of_string_in_bytes (int kind, tree string_length)
{
tree bytesize;
int i = gfc_validate_kind (BT_CHARACTER, kind, false);
bytesize = build_int_cst (gfc_array_index_type,
gfc_character_kinds[i].bit_size / 8);
@ -5970,7 +5970,7 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
tree type, result_type, tmp;
arg = expr->value.function.actual->expr;
gfc_init_se (&argse, NULL);
result_type = gfc_get_int_type (expr->ts.kind);
@ -5986,7 +5986,7 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
}
gfc_conv_expr_reference (&argse, arg);
type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
argse.expr));
}
else
@ -6001,12 +6001,12 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
}
type = gfc_get_element_type (TREE_TYPE (argse.expr));
}
/* Obtain the argument's word length. */
if (arg->ts.type == BT_CHARACTER)
tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
else
tmp = size_in_bytes (type);
tmp = size_in_bytes (type);
tmp = fold_convert (result_type, tmp);
done:
@ -6195,7 +6195,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
argse.string_length);
else
tmp = fold_convert (gfc_array_index_type,
size_in_bytes (source_type));
size_in_bytes (source_type));
/* Obtain the size of the array in bytes. */
extent = gfc_create_var (gfc_array_index_type, NULL);
@ -6553,8 +6553,12 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
&& arg1->expr->symtree->n.sym->attr.dummy)
arg1se.expr = build_fold_indirect_ref_loc (input_location,
arg1se.expr);
if (arg1->expr->ts.type == BT_CLASS)
if (arg1->expr->ts.type == BT_CLASS)
{
tmp2 = gfc_class_data_get (arg1se.expr);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
tmp2 = gfc_conv_descriptor_data_get (tmp2);
}
else
tmp2 = arg1se.expr;
}
@ -6749,7 +6753,7 @@ gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
/* The argument to SELECTED_INT_KIND is INTEGER(4). */
type = gfc_get_int_type (4);
type = gfc_get_int_type (4);
arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
/* Convert it to the required type. */
@ -6790,7 +6794,7 @@ gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
gfc_convert_type (actual->expr, &ts, 2);
}
gfc_conv_expr_reference (&argse, actual->expr);
}
}
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
@ -7022,8 +7026,8 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
else
gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
/* Create a temporary variable for loc return value. Without this,
/* Create a temporary variable for loc return value. Without this,
we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
gfc_add_modify (&se->pre, temp_var, se->expr);
@ -8698,7 +8702,7 @@ conv_co_collective (gfc_code *code)
case GFC_ISYM_CO_SUM:
fndecl = gfor_fndecl_co_sum;
break;
default:
default:
gcc_unreachable ();
}
@ -9174,7 +9178,7 @@ conv_intrinsic_atomic_cas (gfc_code *code)
build_int_cst (NULL, MEMMODEL_RELAXED),
build_int_cst (NULL, MEMMODEL_RELAXED));
gfc_add_expr_to_block (&block, tmp);
if (stat != NULL_TREE)
gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
gfc_add_block_to_block (&block, &post_block);

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2015-01-17 Paul Thomas <pault@gcc.gnu.org>
PR fortran/64578
* gfortran.dg/unlimited_polymorphic_21.f90: New test
2015-01-17 Andre Vehreschild <vehre@gmx.de>
PR fortran/60357