diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 979e947f9f5..f8038837bdf 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2004-12-12 Steven G. Kargl + Paul Brook + + PR fortran/16222 + * resolve.c (gfc_resolve_iterator_expr): New function. + (gfc_resolve_iterator): Use it. Add real_ok argument. Convert + start, end and stride to correct type. + (resolve_code): Pass extra argument. + * array.c (resolve_array_list): Pass extra argument. + * gfortran.h (gfc_resolve): Add prototype. + * trans-stmt.c (gfc_trans_do): Remove redundant type conversions. + Handle real type iterators. + 2004-12-11 Tobias Schlueter PR fortran/17175 diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 14848282d3a..93668130403 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1490,7 +1490,7 @@ resolve_array_list (gfc_constructor * p) for (; p; p = p->next) { if (p->iterator != NULL - && gfc_resolve_iterator (p->iterator) == FAILURE) + && gfc_resolve_iterator (p->iterator, false) == FAILURE) t = FAILURE; if (gfc_resolve_expr (p->expr) == FAILURE) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 669291c57ac..5d6e24fff01 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1743,7 +1743,7 @@ void gfc_resolve (gfc_namespace *); int gfc_impure_variable (gfc_symbol *); int gfc_pure (gfc_symbol *); int gfc_elemental (gfc_symbol *); -try gfc_resolve_iterator (gfc_iterator *); +try gfc_resolve_iterator (gfc_iterator *, bool); try gfc_resolve_index (gfc_expr *, int); /* array.c */ diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index ecc3a3520ae..c7d3c61e9e5 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2173,23 +2173,50 @@ gfc_resolve_expr (gfc_expr * e) } -/* Resolve the expressions in an iterator structure and require that they all - be of integer type. */ +/* Resolve an expression from an iterator. They must be scalar and have + INTEGER or (optionally) REAL type. */ -try -gfc_resolve_iterator (gfc_iterator * iter) +static try +gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok, const char * name) { - - if (gfc_resolve_expr (iter->var) == FAILURE) + if (gfc_resolve_expr (expr) == FAILURE) return FAILURE; - if (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0) + if (expr->rank != 0) { - gfc_error ("Loop variable at %L must be a scalar INTEGER", - &iter->var->where); + gfc_error ("%s at %L must be a scalar", name, &expr->where); return FAILURE; } + if (!(expr->ts.type == BT_INTEGER + || (expr->ts.type == BT_REAL && real_ok))) + { + gfc_error ("%s at %L must be INTEGER%s", + name, + &expr->where, + real_ok ? " or REAL" : ""); + return FAILURE; + } + return SUCCESS; +} + + +/* Resolve the expressions in an iterator structure. If REAL_OK is + false allow only INTEGER type iterators, otherwise allow REAL types. */ + +try +gfc_resolve_iterator (gfc_iterator * iter, bool real_ok) +{ + + if (iter->var->ts.type == BT_REAL) + gfc_notify_std (GFC_STD_F95_DEL, + "Obsolete: REAL DO loop iterator at %L", + &iter->var->where); + + if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable") + == FAILURE) + return FAILURE; + if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym)) { gfc_error ("Cannot assign to loop variable in PURE procedure at %L", @@ -2197,43 +2224,43 @@ gfc_resolve_iterator (gfc_iterator * iter) return FAILURE; } - if (gfc_resolve_expr (iter->start) == FAILURE) + if (gfc_resolve_iterator_expr (iter->start, real_ok, + "Start expression in DO loop") == FAILURE) return FAILURE; - if (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0) - { - gfc_error ("Start expression in DO loop at %L must be a scalar INTEGER", - &iter->start->where); - return FAILURE; - } - - if (gfc_resolve_expr (iter->end) == FAILURE) + if (gfc_resolve_iterator_expr (iter->end, real_ok, + "End expression in DO loop") == FAILURE) return FAILURE; - if (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0) - { - gfc_error ("End expression in DO loop at %L must be a scalar INTEGER", - &iter->end->where); - return FAILURE; - } - - if (gfc_resolve_expr (iter->step) == FAILURE) + if (gfc_resolve_iterator_expr (iter->step, real_ok, + "Step expression in DO loop") == FAILURE) return FAILURE; - if (iter->step->ts.type != BT_INTEGER || iter->step->rank != 0) + if (iter->step->expr_type == EXPR_CONSTANT) { - gfc_error ("Step expression in DO loop at %L must be a scalar INTEGER", - &iter->step->where); - return FAILURE; + if ((iter->step->ts.type == BT_INTEGER + && mpz_cmp_ui (iter->step->value.integer, 0) == 0) + || (iter->step->ts.type == BT_REAL + && mpfr_sgn (iter->step->value.real) == 0)) + { + gfc_error ("Step expression in DO loop at %L cannot be zero", + &iter->step->where); + return FAILURE; + } } - if (iter->step->expr_type == EXPR_CONSTANT - && mpz_cmp_ui (iter->step->value.integer, 0) == 0) - { - gfc_error ("Step expression in DO loop at %L cannot be zero", - &iter->step->where); - return FAILURE; - } + /* Convert start, end, and step to the same type as var. */ + if (iter->start->ts.kind != iter->var->ts.kind + || iter->start->ts.type != iter->var->ts.type) + gfc_convert_type (iter->start, &iter->var->ts, 2); + + if (iter->end->ts.kind != iter->var->ts.kind + || iter->end->ts.type != iter->var->ts.type) + gfc_convert_type (iter->end, &iter->var->ts, 2); + + if (iter->step->ts.kind != iter->var->ts.kind + || iter->step->ts.type != iter->var->ts.type) + gfc_convert_type (iter->step, &iter->var->ts, 2); return SUCCESS; } @@ -3728,7 +3755,7 @@ resolve_code (gfc_code * code, gfc_namespace * ns) case EXEC_DO: if (code->ext.iterator != NULL) - gfc_resolve_iterator (code->ext.iterator); + gfc_resolve_iterator (code->ext.iterator, true); break; case EXEC_DO_WHILE: @@ -4360,7 +4387,7 @@ resolve_data_variables (gfc_data_variable * d) } else { - if (gfc_resolve_iterator (&d->iter) == FAILURE) + if (gfc_resolve_iterator (&d->iter, false) == FAILURE) return FAILURE; if (d->iter.start->expr_type != EXPR_CONSTANT diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index a403693fc45..e0c9f75e8c5 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -617,8 +617,7 @@ exit_label: TODO: Large loop counts The code above assumes the loop count fits into a signed integer kind, i.e. Does not work for loop counts > 2^31 for integer(kind=4) variables - We must support the full range. - TODO: Real type do variables. */ + We must support the full range. */ tree gfc_trans_do (gfc_code * code) @@ -629,6 +628,7 @@ gfc_trans_do (gfc_code * code) tree to; tree step; tree count; + tree count_one; tree type; tree cond; tree cycle_label; @@ -647,17 +647,17 @@ gfc_trans_do (gfc_code * code) type = TREE_TYPE (dovar); gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, code->ext.iterator->start, type); + gfc_conv_expr_val (&se, code->ext.iterator->start); gfc_add_block_to_block (&block, &se.pre); from = gfc_evaluate_now (se.expr, &block); gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, code->ext.iterator->end, type); + gfc_conv_expr_val (&se, code->ext.iterator->end); gfc_add_block_to_block (&block, &se.pre); to = gfc_evaluate_now (se.expr, &block); gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, code->ext.iterator->step, type); + gfc_conv_expr_val (&se, code->ext.iterator->step); gfc_add_block_to_block (&block, &se.pre); step = gfc_evaluate_now (se.expr, &block); @@ -672,11 +672,24 @@ gfc_trans_do (gfc_code * code) tmp = fold (build2 (MINUS_EXPR, type, step, from)); tmp = fold (build2 (PLUS_EXPR, type, to, tmp)); - tmp = fold (build2 (TRUNC_DIV_EXPR, type, tmp, step)); - - count = gfc_create_var (type, "count"); + if (TREE_CODE (type) == INTEGER_TYPE) + { + tmp = fold (build2 (TRUNC_DIV_EXPR, type, tmp, step)); + count = gfc_create_var (type, "count"); + } + else + { + /* TODO: We could use the same width as the real type. + This would probably cause more problems that it solves + when we implement "long double" types. */ + tmp = fold (build2 (RDIV_EXPR, type, tmp, step)); + tmp = fold (build1 (FIX_TRUNC_EXPR, gfc_array_index_type, tmp)); + count = gfc_create_var (gfc_array_index_type, "count"); + } gfc_add_modify_expr (&block, count, tmp); + count_one = convert (TREE_TYPE (count), integer_one_node); + /* Initialize the DO variable: dovar = from. */ gfc_add_modify_expr (&block, dovar, from); @@ -688,7 +701,8 @@ gfc_trans_do (gfc_code * code) exit_label = gfc_build_label_decl (NULL_TREE); /* Start with the loop condition. Loop until count <= 0. */ - cond = build2 (LE_EXPR, boolean_type_node, count, integer_zero_node); + cond = build2 (LE_EXPR, boolean_type_node, count, + convert (TREE_TYPE (count), integer_zero_node)); tmp = build1_v (GOTO_EXPR, exit_label); TREE_USED (exit_label) = 1; tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); @@ -717,7 +731,7 @@ gfc_trans_do (gfc_code * code) gfc_add_modify_expr (&body, dovar, tmp); /* Decrement the loop count. */ - tmp = build2 (MINUS_EXPR, type, count, gfc_index_one_node); + tmp = build2 (MINUS_EXPR, TREE_TYPE (count), count, count_one); gfc_add_modify_expr (&body, count, tmp); /* End of loop body. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 96706b2dc20..1777427a0fd 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2004-12-12 Steven G. Kargl + Paul Brook + + PR fortran/16222 + * gfortran.dg/real_do_1.f90: New test. + 2004-12-12 Andrew Pinski PR tree-opt/18040 diff --git a/gcc/testsuite/gfortran.dg/real_do_1.f90 b/gcc/testsuite/gfortran.dg/real_do_1.f90 new file mode 100644 index 00000000000..89a9d1b9b59 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/real_do_1.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! Test REAL type iterators in DO loops +program real_do_1 + real x, y + integer n + + n = 0 + y = 1.0 + do x = 1.0, 2.05, 0.1 ! { dg-warning "REAL DO loop" "" } + call check (x, y) + y = y + 0.1 + n = n + 1 + end do + if (n .ne. 11) call abort() +contains +subroutine check (a, b) + real, intent(in) :: a, b + + if (abs (a - b) .gt. 0.00001) call abort() +end subroutine +end program