Index: gfortran.h =================================================================== RCS file: /cvs/gcc/gcc/gcc/fortran/gfortran.h,v retrieving revision 1.43 diff -u -b -u -r1.43 gfortran.h --- gfortran.h 20 Nov 2004 01:44:45 -0000 1.43 +++ gfortran.h 27 Nov 2004 23:42:20 -0000 @@ -1741,6 +1744,7 @@ int gfc_pure (gfc_symbol *); int gfc_elemental (gfc_symbol *); try gfc_resolve_iterator (gfc_iterator *); +try gfc_resolve_do_iterator (gfc_iterator *); try gfc_resolve_index (gfc_expr *, int); /* array.c */ Index: resolve.c =================================================================== RCS file: /cvs/gcc/gcc/gcc/fortran/resolve.c,v retrieving revision 1.21 diff -u -b -u -r1.21 resolve.c --- resolve.c 8 Nov 2004 14:56:39 -0000 1.21 +++ resolve.c 27 Nov 2004 23:42:29 -0000 @@ -2239,6 +2240,106 @@ } +/* Resolve the expressions in a DO iterator structure. */ + +try +gfc_resolve_do_iterator (gfc_iterator * iter) +{ + + if (gfc_resolve_expr (iter->var) == FAILURE) + return FAILURE; + + if (iter->var->rank != 0) + { + gfc_error ("DO loop variable at %L must be a scalar", iter->var->where); + return FAILURE; + } + + /* Fortran 77 did not prohibit a REAL DO loop iterator. + Fortran 90 states that this is obsolescent. + Fortran 95 explicitly deletes a REAL DO loop iterator. */ + if (iter->var->ts.type == BT_REAL) + gfc_warning ("REAL DO loop iterator at %L is obsolescent in " + "Fortran 90 and deleted in Fortran 95", &iter->var->where); + + if (iter->var->ts.type != BT_INTEGER && iter->var->ts.type != BT_REAL) + { + gfc_error ("DO loop variable at %L must be INTEGER or REAL", + &iter->var->where); + 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", + &iter->var->where); + return FAILURE; + } + + if (gfc_resolve_expr (iter->start) == FAILURE) + return FAILURE; + + if (iter->start->rank != 0) + { + gfc_error ("Start expression in DO loop at %L must be a scalar", + &iter->start->where); + return FAILURE; + } + + if (iter->start->ts.type != BT_INTEGER && iter->start->ts.type != BT_REAL) + { + gfc_error ("Start expression in DO loop at %L must be INTEGER or REAL", + &iter->start->where); + return FAILURE; + } + + if (gfc_resolve_expr (iter->end) == FAILURE) + return FAILURE; + + if (iter->end->rank != 0) + { + gfc_error ("End expression in DO loop at %L must be a scalar", + &iter->end->where); + return FAILURE; + } + + if (iter->end->ts.type != BT_INTEGER && iter->end->ts.type != BT_REAL) + { + gfc_error ("End expression in DO loop at %L must be INTEGER or REAL", + &iter->end->where); + return FAILURE; + } + + if (gfc_resolve_expr (iter->step) == FAILURE) + return FAILURE; + + if (iter->step->rank != 0) + { + gfc_error ("Step expression in DO loop at %L must be a scalar", + &iter->step->where); + return FAILURE; + } + + if (iter->step->ts.type != BT_INTEGER && iter->step->ts.type != BT_REAL) + { + gfc_error ("Step expression in DO loop at %L must be INTEGER or REAL", + &iter->step->where); + return FAILURE; + } + + if (iter->step->ts.type == BT_INTEGER + && 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; + } + + return SUCCESS; +} + + /* Resolve a list of FORALL iterators. */ static void @@ -3723,7 +3824,7 @@ case EXEC_DO: if (code->ext.iterator != NULL) - gfc_resolve_iterator (code->ext.iterator); + gfc_resolve_do_iterator (code->ext.iterator); break; case EXEC_DO_WHILE: Index: trans-stmt.c =================================================================== RCS file: /cvs/gcc/gcc/gcc/fortran/trans-stmt.c,v retrieving revision 1.18 diff -u -b -u -r1.18 trans-stmt.c --- trans-stmt.c 8 Nov 2004 14:56:41 -0000 1.18 +++ trans-stmt.c 27 Nov 2004 23:42:36 -0000 @@ -674,8 +674,17 @@ tmp = fold (build2 (PLUS_EXPR, type, to, tmp)); tmp = fold (build2 (TRUNC_DIV_EXPR, type, tmp, step)); + if (TREE_CODE (type) == INTEGER_TYPE) + { count = gfc_create_var (type, "count"); gfc_add_modify_expr (&block, count, tmp); + } + else + { + count = gfc_create_var (gfc_array_index_type, "count"); + tmp = fold (build1 (FIX_TRUNC_EXPR, gfc_array_index_type, tmp)); + gfc_add_modify_expr (&block, count, tmp); + } /* Initialize the DO variable: dovar = from. */ gfc_add_modify_expr (&block, dovar, from); @@ -717,7 +726,10 @@ gfc_add_modify_expr (&body, dovar, tmp); /* Decrement the loop count. */ + if (TREE_CODE (type) == INTEGER_TYPE) tmp = build2 (MINUS_EXPR, type, count, gfc_index_one_node); + else + tmp = build2 (MINUS_EXPR, gfc_array_index_type, count, gfc_index_one_node); gfc_add_modify_expr (&body, count, tmp); /* End of loop body. */