Skip to content

R
riscv-gcc-1
Commit 7ab92584 by Steven Bosscher Committed by Steven Bosscher
Options

Make sure types in assignments are compatible. 

2004-06-29  Steven Bosscher  <stevenb@suse.de>

	Make sure types in assignments are compatible.  Mostly mechanical.
	* trans-const.h (gfc_index_one_node): New define.
	* trans-array.c (gfc_trans_allocate_array_storage,
	gfc_trans_allocate_temp_array, gfc_trans_array_constructor_subarray,
	gfc_trans_array_constructor_value, gfc_trans_array_constructor,
	gfc_conv_array_ubound, gfc_conv_array_ref,
	gfc_trans_scalarized_loop_end, gfc_conv_section_startstride,
	gfc_conv_ss_startstride, gfc_conv_loop_setup, gfc_array_init_size,
	gfc_trans_array_bounds, gfc_trans_dummy_array_bias,
	gfc_conv_expr_descriptor, gfc_trans_deferred_array): Use the correct
	types in assignments, conversions and conditionals for expressions.
	* trans-expr.c (gfc_conv_expr_present, gfc_conv_substring,
	gfc_conv_unary_op, gfc_conv_cst_int_power, gfc_conv_string_tmp,
	gfc_conv_function_call, gfc_trans_pointer_assignment,
	gfc_trans_scalar_assign): Likewise.
	* trans-intrinsic.c (build_fixbound_expr, gfc_conv_intrinsic_bound,
	gfc_conv_intrinsic_anyall, gfc_conv_intrinsic_count,
	gfc_conv_intrinsic_minmaxloc, gfc_conv_intrinsic_btest,
	gfc_conv_intrinsic_singlebitop, gfc_conv_intrinsic_ishft,
	gfc_conv_intrinsic_ishftc, gfc_conv_intrinsic_strcmp,
	gfc_conv_allocated, gfc_conv_associated,
	gfc_conv_intrinsic_rrspacing, gfc_conv_intrinsic_trim): Likewise.
	* trans-io.c (set_string): Likewise.
	* trans-stmt.c (gfc_trans_do, gfc_trans_forall_loop,
	gfc_do_allocate, generate_loop_for_temp_to_lhs,
	generate_loop_for_rhs_to_temp, compute_inner_temp_size,
	compute_overall_iter_number, gfc_trans_assign_need_temp,
	gfc_trans_pointer_assign_need_temp, gfc_trans_forall_1,
	gfc_evaluate_where_mask, gfc_trans_where_assign,
	gfc_trans_where_2): Likewise.
	* trans-types.c (gfc_get_character_type, gfc_build_array_type,
	gfc_get_nodesc_array_type, gfc_get_array_type_bounds): Likewise.

	* trans.c (gfc_add_modify_expr): Add sanity check that types
	for the lhs and rhs are the same for scalar assignments.

From-SVN: r83877
parent e23667c6
Showing with 138 additions and 59 deletions
gcc/fortran/ChangeLog
2004-06-29 Steven Bosscher <stevenb@suse.de>
Make sure types in assignments are compatible. Mostly mechanical.
* trans-const.h (gfc_index_one_node): New define.
* trans-array.c (gfc_trans_allocate_array_storage,
gfc_trans_allocate_temp_array, gfc_trans_array_constructor_subarray,
gfc_trans_array_constructor_value, gfc_trans_array_constructor,
gfc_conv_array_ubound, gfc_conv_array_ref,
gfc_trans_scalarized_loop_end, gfc_conv_section_startstride,
gfc_conv_ss_startstride, gfc_conv_loop_setup, gfc_array_init_size,
gfc_trans_array_bounds, gfc_trans_dummy_array_bias,
gfc_conv_expr_descriptor, gfc_trans_deferred_array): Use the correct
types in assignments, conversions and conditionals for expressions.
* trans-expr.c (gfc_conv_expr_present, gfc_conv_substring,
gfc_conv_unary_op, gfc_conv_cst_int_power, gfc_conv_string_tmp,
gfc_conv_function_call, gfc_trans_pointer_assignment,
gfc_trans_scalar_assign): Likewise.
* trans-intrinsic.c (build_fixbound_expr, gfc_conv_intrinsic_bound,
gfc_conv_intrinsic_anyall, gfc_conv_intrinsic_count,
gfc_conv_intrinsic_minmaxloc, gfc_conv_intrinsic_btest,
gfc_conv_intrinsic_singlebitop, gfc_conv_intrinsic_ishft,
gfc_conv_intrinsic_ishftc, gfc_conv_intrinsic_strcmp,
gfc_conv_allocated, gfc_conv_associated,
gfc_conv_intrinsic_rrspacing, gfc_conv_intrinsic_trim): Likewise.
* trans-io.c (set_string): Likewise.
* trans-stmt.c (gfc_trans_do, gfc_trans_forall_loop,
gfc_do_allocate, generate_loop_for_temp_to_lhs,
generate_loop_for_rhs_to_temp, compute_inner_temp_size,
compute_overall_iter_number, gfc_trans_assign_need_temp,
gfc_trans_pointer_assign_need_temp, gfc_trans_forall_1,
gfc_evaluate_where_mask, gfc_trans_where_assign,
gfc_trans_where_2): Likewise.
* trans-types.c (gfc_get_character_type, gfc_build_array_type,
gfc_get_nodesc_array_type, gfc_get_array_type_bounds): Likewise.
* trans.c (gfc_add_modify_expr): Add sanity check that types
for the lhs and rhs are the same for scalar assignments.
2004-06-29 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
* dump-parse-tree.c (show_common): New function.
......
gcc/fortran/trans-const.h
......@@ -56,4 +56,6 @@ extern GTY(()) tree gfc_strconst_wrong_return;
/* Integer constants 0..GFC_MAX_DIMENSIONS. */
extern GTY(()) tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
#define gfc_index_zero_node gfc_rank_cst[0]
#define gfc_index_one_node gfc_rank_cst[1]
gcc/fortran/trans-expr.c
......@@ -135,7 +135,8 @@ gfc_conv_expr_present (gfc_symbol * sym)
|| GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
}
return build (NE_EXPR, boolean_type_node, decl, null_pointer_node);
return build (NE_EXPR, boolean_type_node, decl,
fold_convert (TREE_TYPE (decl), null_pointer_node));
}
......@@ -174,9 +175,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
gfc_add_block_to_block (&se->pre, &start.pre);
if (integer_onep (start.expr))
{
gfc_conv_string_parameter (se);
}
gfc_conv_string_parameter (se);
else
{
/* Change the start of the string. */
......@@ -198,7 +197,9 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
gfc_add_block_to_block (&se->pre, &end.pre);
}
tmp =
build (MINUS_EXPR, gfc_strlen_type_node, integer_one_node, start.expr);
build (MINUS_EXPR, gfc_strlen_type_node,
fold_convert (gfc_strlen_type_node, integer_one_node),
start.expr);
tmp = build (PLUS_EXPR, gfc_strlen_type_node, end.expr, tmp);
se->string_length = fold (tmp);
}
......@@ -376,7 +377,8 @@ gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
All other unary operators have an equivalent GIMPLE unary operator */
if (code == TRUTH_NOT_EXPR)
se->expr = build (EQ_EXPR, type, operand.expr, integer_zero_node);
se->expr = build (EQ_EXPR, type, operand.expr,
convert (type, integer_zero_node));
else
se->expr = build1 (code, type, operand.expr);
......@@ -502,24 +504,27 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
{
tmp = build (EQ_EXPR, boolean_type_node, lhs,
integer_minus_one_node);
fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
cond = build (EQ_EXPR, boolean_type_node, lhs,
integer_one_node);
convert (TREE_TYPE (lhs), integer_one_node));
/* If rhs is an even,
result = (lhs == 1 || lhs == -1) ? 1 : 0. */
result = (lhs == 1 || lhs == -1) ? 1 : 0. */
if ((n & 1) == 0)
{
tmp = build (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
se->expr = build (COND_EXPR, type, tmp, integer_one_node,
integer_zero_node);
se->expr = build (COND_EXPR, type, tmp,
convert (type, integer_one_node),
convert (type, integer_zero_node));
return 1;
}
/* If rhs is an odd,
result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
tmp = build (COND_EXPR, type, tmp, integer_minus_one_node,
integer_zero_node);
se->expr = build (COND_EXPR, type, cond, integer_one_node,
tmp = build (COND_EXPR, type, tmp,
convert (type, integer_minus_one_node),
convert (type, integer_zero_node));
se->expr = build (COND_EXPR, type, cond,
convert (type, integer_one_node),
tmp);
return 1;
}
......@@ -675,11 +680,16 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
tree tmp;
tree args;
if (TREE_TYPE (len) != gfc_strlen_type_node)
abort ();
if (gfc_can_put_var_on_stack (len))
{
/* Create a temporary variable to hold the result. */
tmp = fold (build (MINUS_EXPR, TREE_TYPE (len), len, integer_one_node));
tmp = build_range_type (gfc_array_index_type, integer_zero_node, tmp);
tmp = fold (build (MINUS_EXPR, gfc_strlen_type_node, len,
convert (gfc_strlen_type_node,
integer_one_node)));
tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
tmp = build_array_type (gfc_character1_type_node, tmp);
var = gfc_create_var (tmp, "str");
var = gfc_build_addr_expr (type, var);
......@@ -1030,7 +1040,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
/* Zero the first stride to indicate a temporary. */
tmp =
gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
gfc_add_modify_expr (&se->pre, tmp, integer_zero_node);
gfc_add_modify_expr (&se->pre, tmp,
convert (TREE_TYPE (tmp), integer_zero_node));
/* Pass the temporary as the first argument. */
tmp = info->descriptor;
tmp = gfc_build_addr_expr (NULL, tmp);
......@@ -1080,8 +1091,10 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
parmse.expr = null_pointer_node;
if (arg->missing_arg_type == BT_CHARACTER)
{
stringargs = gfc_chainon_list (stringargs,
convert (gfc_strlen_type_node, integer_zero_node));
stringargs =
gfc_chainon_list (stringargs,
convert (gfc_strlen_type_node,
integer_zero_node));
}
}
}
......@@ -1589,7 +1602,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_ss *lss;
gfc_ss *rss;
stmtblock_t block;
tree tmp;
gfc_start_block (&block);
......@@ -1607,7 +1619,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_conv_expr (&rse, expr2);
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
gfc_add_modify_expr (&block, lse.expr, rse.expr);
gfc_add_modify_expr (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr));
gfc_add_block_to_block (&block, &rse.post);
gfc_add_block_to_block (&block, &lse.post);
}
......@@ -1618,9 +1631,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
if (expr2->expr_type == EXPR_NULL)
{
lse.expr = gfc_conv_descriptor_data (lse.expr);
rse.expr = null_pointer_node;
tmp = build_v (MODIFY_EXPR, lse.expr, rse.expr);
gfc_add_expr_to_block (&block, tmp);
rse.expr = fold_convert (TREE_TYPE (lse.expr), null_pointer_node);
gfc_add_modify_expr (&block, lse.expr, rse.expr);
}
else
{
......@@ -1690,7 +1702,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
gfc_add_modify_expr (&block, lse->expr, rse->expr);
gfc_add_modify_expr (&block, lse->expr,
fold_convert (TREE_TYPE (lse->expr), rse->expr));
}
gfc_add_block_to_block (&block, &lse->post);
......
gcc/fortran/trans-intrinsic.c
......@@ -228,7 +228,8 @@ build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
tmp = convert (argtype, intval);
cond = build (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
tmp = build (up ? PLUS_EXPR : MINUS_EXPR, type, intval, integer_one_node);
tmp = build (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
convert (type, integer_one_node));
tmp = build (COND_EXPR, type, cond, intval, tmp);
return tmp;
}
......@@ -651,7 +652,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
bound = argse.expr;
/* Convert from one based to zero based. */
bound = fold (build (MINUS_EXPR, gfc_array_index_type, bound,
integer_one_node));
gfc_index_one_node));
}
/* TODO: don't re-evaluate the descriptor on each iteration. */
......@@ -677,7 +678,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
{
bound = gfc_evaluate_now (bound, &se->pre);
cond = fold (build (LT_EXPR, boolean_type_node, bound,
integer_zero_node));
convert (TREE_TYPE (bound), integer_zero_node)));
tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
tmp = fold (build (GE_EXPR, boolean_type_node, bound, tmp));
cond = fold(build (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp));
......@@ -1172,7 +1173,9 @@ gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
gfc_conv_expr_val (&arrayse, actual->expr);
gfc_add_block_to_block (&body, &arrayse.pre);
tmp = build (op, boolean_type_node, arrayse.expr, integer_zero_node);
tmp = build (op, boolean_type_node, arrayse.expr,
fold_convert (TREE_TYPE (arrayse.expr),
integer_zero_node));
tmp = build_v (COND_EXPR, tmp, found, build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
gfc_add_block_to_block (&body, &arrayse.post);
......@@ -1214,7 +1217,7 @@ gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
type = gfc_typenode_for_spec (&expr->ts);
/* Initialize the result. */
resvar = gfc_create_var (type, "count");
gfc_add_modify_expr (&se->pre, resvar, integer_zero_node);
gfc_add_modify_expr (&se->pre, resvar, convert (type, integer_zero_node));
/* Walk the arguments. */
arrayss = gfc_walk_expr (actual->expr);
......@@ -1232,7 +1235,8 @@ gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
/* Generate the loop body. */
gfc_start_scalarized_body (&loop, &body);
tmp = build (PLUS_EXPR, TREE_TYPE (resvar), resvar, integer_one_node);
tmp = build (PLUS_EXPR, TREE_TYPE (resvar), resvar,
convert (TREE_TYPE (resvar), integer_one_node));
tmp = build_v (MODIFY_EXPR, resvar, tmp);
gfc_init_se (&arrayse, NULL);
......@@ -1453,7 +1457,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
array, in case all elements are equal to the limit.
ie. pos = (ubound >= lbound) ? lbound, lbound - 1; */
tmp = fold (build (MINUS_EXPR, gfc_array_index_type,
loop.from[0], integer_one_node));
loop.from[0], gfc_index_one_node));
cond = fold (build (GE_EXPR, boolean_type_node,
loop.to[0], loop.from[0]));
tmp = fold (build (COND_EXPR, gfc_array_index_type, cond,
......@@ -1522,7 +1526,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
/* Return a value in the range 1..SIZE(array). */
tmp = fold (build (MINUS_EXPR, gfc_array_index_type, loop.from[0],
integer_one_node));
gfc_index_one_node));
tmp = fold (build (MINUS_EXPR, gfc_array_index_type, pos, tmp));
/* And convert to the required type. */
se->expr = convert (type, tmp);
......@@ -1670,9 +1674,10 @@ gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
arg = TREE_VALUE (arg);
type = TREE_TYPE (arg);
tmp = build (LSHIFT_EXPR, type, integer_one_node, arg2);
tmp = build (LSHIFT_EXPR, type, convert (type, integer_one_node), arg2);
tmp = build (BIT_AND_EXPR, type, arg, tmp);
tmp = fold (build (NE_EXPR, boolean_type_node, tmp, integer_zero_node));
tmp = fold (build (NE_EXPR, boolean_type_node, tmp,
convert (type, integer_zero_node)));
type = gfc_typenode_for_spec (&expr->ts);
se->expr = convert (type, tmp);
}
......@@ -1720,7 +1725,8 @@ gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
arg = TREE_VALUE (arg);
type = TREE_TYPE (arg);
tmp = fold (build (LSHIFT_EXPR, type, integer_one_node, arg2));
tmp = fold (build (LSHIFT_EXPR, type,
convert (type, integer_one_node), arg2));
if (set)
op = BIT_IOR_EXPR;
else
......@@ -1783,11 +1789,13 @@ gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
rshift = build (RSHIFT_EXPR, type, arg, tmp);
tmp = build (GT_EXPR, boolean_type_node, arg2, integer_zero_node);
tmp = build (GT_EXPR, boolean_type_node, arg2,
convert (TREE_TYPE (arg2), integer_zero_node));
rshift = build (COND_EXPR, type, tmp, lshift, rshift);
/* Do nothing if shift == 0. */
tmp = build (EQ_EXPR, boolean_type_node, arg2, integer_zero_node);
tmp = build (EQ_EXPR, boolean_type_node, arg2,
convert (TREE_TYPE (arg2), integer_zero_node));
se->expr = build (COND_EXPR, type, tmp, arg, rshift);
}
......@@ -1843,11 +1851,13 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
rrot = build (RROTATE_EXPR, type, arg, tmp);
tmp = build (GT_EXPR, boolean_type_node, arg2, integer_zero_node);
tmp = build (GT_EXPR, boolean_type_node, arg2,
convert (TREE_TYPE (arg2), integer_zero_node));
rrot = build (COND_EXPR, type, tmp, lrot, rrot);
/* Do nothing if shift == 0. */
tmp = build (EQ_EXPR, boolean_type_node, arg2, integer_zero_node);
tmp = build (EQ_EXPR, boolean_type_node, arg2,
convert (TREE_TYPE (arg2), integer_zero_node));
se->expr = build (COND_EXPR, type, tmp, arg, rrot);
}
......@@ -2040,7 +2050,8 @@ gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
se->expr = gfc_build_function_call (gfor_fndecl_compare_string, args);
type = gfc_typenode_for_spec (&expr->ts);
se->expr = build (op, type, se->expr, integer_zero_node);
se->expr = build (op, type, se->expr,
convert (TREE_TYPE (se->expr), integer_zero_node));
}
/* Generate a call to the adjustl/adjustr library function. */
......@@ -2130,7 +2141,8 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
tmp = gfc_conv_descriptor_data (arg1se.expr);
tmp = build (NE_EXPR, boolean_type_node, tmp, null_pointer_node);
tmp = build (NE_EXPR, boolean_type_node, tmp,
fold_convert (TREE_TYPE (tmp), null_pointer_node));
se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
}
......@@ -2176,7 +2188,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
gfc_conv_expr_lhs (&arg1se, arg1->expr);
tmp2 = gfc_conv_descriptor_data (arg1se.expr);
}
tmp = build (NE_EXPR, boolean_type_node, tmp2, null_pointer_node);
tmp = build (NE_EXPR, boolean_type_node, tmp2,
fold_convert (TREE_TYPE (tmp2), null_pointer_node));
se->expr = tmp;
}
else
......@@ -2450,7 +2463,8 @@ gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
cond2 = build (EQ_EXPR, boolean_type_node, rcs.frac, zero);
cond = build (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
tmp = build (COND_EXPR, masktype, cond, integer_zero_node, tmp);
tmp = build (COND_EXPR, masktype, cond,
convert (masktype, integer_zero_node), tmp);
tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
se->expr = tmp;
......@@ -2527,7 +2541,8 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
gfc_add_expr_to_block (&se->pre, tmp);
/* Free the temporary afterwards, if necessary. */
cond = build (GT_EXPR, boolean_type_node, len, integer_zero_node);
cond = build (GT_EXPR, boolean_type_node, len,
convert (TREE_TYPE (len), integer_zero_node));
arglist = gfc_chainon_list (NULL_TREE, var);
tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ());
......
gcc/fortran/trans-io.c
......@@ -404,13 +404,14 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
len = build (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len,
NULL_TREE);
/* Integer variable assigned a format label. */
/* Integer variable assigned a format label. */
if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
{
msg =
gfc_build_string_const (37, "Assigned label is not a format label");
tmp = GFC_DECL_STRING_LEN (se.expr);
tmp = build (LE_EXPR, boolean_type_node, tmp, integer_minus_one_node);
tmp = build (LE_EXPR, boolean_type_node,
tmp, convert (TREE_TYPE (tmp), integer_minus_one_node));
gfc_trans_runtime_check (tmp, msg, &se.pre);
gfc_add_modify_expr (&se.pre, io, GFC_DECL_ASSIGN_ADDR (se.expr));
gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
......@@ -418,7 +419,7 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
else
{
gfc_conv_string_parameter (&se);
gfc_add_modify_expr (&se.pre, io, se.expr);
gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
gfc_add_modify_expr (&se.pre, len, se.string_length);
}
......@@ -432,10 +433,10 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
static void
set_flag (stmtblock_t *block, tree var)
{
tree tmp;
tree tmp, type = TREE_TYPE (var);
tmp = build (COMPONENT_REF, TREE_TYPE(var), ioparm_var, var, NULL_TREE);
gfc_add_modify_expr (block, tmp, integer_one_node);
tmp = build (COMPONENT_REF, type, ioparm_var, var, NULL_TREE);
gfc_add_modify_expr (block, tmp, convert (type, integer_one_node));
}
......
gcc/fortran/trans-types.c
......@@ -290,7 +290,7 @@ gfc_get_character_type (int kind, gfc_charlen * cl)
len = (cl == 0) ? NULL_TREE : cl->backend_decl;
bounds = build_range_type (gfc_array_index_type, integer_one_node, len);
bounds = build_range_type (gfc_array_index_type, gfc_index_one_node, len);
type = build_array_type (base, bounds);
TYPE_STRING_FLAG (type) = 1;
......@@ -493,7 +493,7 @@ gfc_build_array_type (tree type, gfc_array_spec * as)
{
/* Create expressions for the known bounds of the array. */
if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
lbound[n] = integer_one_node;
lbound[n] = gfc_index_one_node;
else
lbound[n] = gfc_conv_array_bound (as->lower[n]);
ubound[n] = gfc_conv_array_bound (as->upper[n]);
......@@ -727,7 +727,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
GFC_TYPE_ARRAY_DTYPE (type) = gfc_get_dtype (etype, as->rank);
GFC_TYPE_ARRAY_RANK (type) = as->rank;
range = build_range_type (gfc_array_index_type, integer_zero_node,
range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
NULL_TREE);
/* TODO: use main type if it is unbounded. */
GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
......@@ -741,7 +741,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
else
range = NULL_TREE;
range = build_range_type (gfc_array_index_type, integer_zero_node, range);
range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
TYPE_DOMAIN (type) = range;
build_pointer_type (etype);
......@@ -806,7 +806,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
/* Build an array descriptor record type. */
if (packed != 0)
stride = integer_one_node;
stride = gfc_index_one_node;
else
stride = NULL_TREE;
......@@ -840,7 +840,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
{
tmp = fold (build (MINUS_EXPR, gfc_array_index_type, upper, lower));
tmp = fold (build (PLUS_EXPR, gfc_array_index_type, tmp,
integer_one_node));
gfc_index_one_node));
stride =
fold (build (MULT_EXPR, gfc_array_index_type, tmp, stride));
/* Check the folding worked. */
......@@ -858,7 +858,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
arraytype =
build_array_type (etype,
build_range_type (gfc_array_index_type,
integer_zero_node, NULL_TREE));
gfc_index_zero_node, NULL_TREE));
arraytype = build_pointer_type (arraytype);
GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
......@@ -885,7 +885,7 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
arraytype =
build_array_type (gfc_get_desc_dim_type (),
build_range_type (gfc_array_index_type,
integer_zero_node,
gfc_index_zero_node,
gfc_rank_cst[dimen - 1]));
decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
......
gcc/fortran/trans.c
......@@ -146,6 +146,16 @@ gfc_add_modify_expr (stmtblock_t * pblock, tree lhs, tree rhs)
{
tree tmp;
#ifdef ENABLE_CHECKING
/* Make sure that the types of the rhs and the lhs are the same
for scalar assignments. We should probably have something
similar for aggregates, but right now removing that check just
breaks everything. */
if (TREE_TYPE (rhs) != TREE_TYPE (lhs)
&& !AGGREGATE_TYPE_P (TREE_TYPE (lhs)))
abort ();
#endif
tmp = fold (build_v (MODIFY_EXPR, lhs, rhs));
gfc_add_expr_to_block (pblock, tmp);
}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment