[PATCH,gfortran] Fix PR 16222
Steve Kargl
sgk@troutmask.apl.washington.edu
Sat Dec 4 22:41:00 GMT 2004
On Wed, Dec 01, 2004 at 09:22:51PM +0000, Paul Brook wrote:
> On Sunday 28 November 2004 00:51, Steve Kargl wrote:
> > The attached patch fixes PR 16222. Bootstrapped
> > and regression tested on i386-unknown-freebsd6.0.
> >
> > 2004-11-24 Steven G. Kargl <kargls@comcast.net>
> >
> > PR 16222
> > * gfortran.h (gfc_resolve_do_iterator): Add prototype
> > * resolve.c (gfc_resolve_do_iterator): New function; use it
> > * trans-stmt.c (gfc_trans_do): Allow REAL iterator
>
> Duplicating gfc_resolve_iterator seems a bad idea.
>
> I think it would be better to add an extra boolean argument to
> gfc_resolve_iterator which says whether read arguments are allowed.
> You may also want to factor out the individual variable checks into a common
> routine.
I've introduced the two defines INTEGER_ONLY and REAL_OK and
updated gfc_resolve_iterator to permit REAL iterators for
DO loop variables. Other uses of gfc_resolve_iterator use
INTEGER_ONLY.
> Are you deliberately allowing a mixture of integer and real types?
This has been fixed in gfc_resolve_iterator where I use gfc_convert_type
to force start, end, and step to the type and kind type parameter of
the DO loop variable.
> This seems like it deserves at least a -Wsuprising/-Wconversion warning.
I did not put in these options. If you really want them, I'll do it.
> You should also update the comment(s) in gfc_trans_do. Remove the TODO, and
> mention how we handle this case - make the conversion explicit in the
> pseudocode.
I removed the TODO, but did not add a comment about the conversion
because the conversion is actually done resolve.c.
> > /* 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);
>
> The existing code is wrong, and your code is overly complicated. Try:
>
> tree count_one = build_int_cst (TREE_TYPE (count), 1);
> ...
> tmp = build2 (MINUS_EXPR, TREE_TYPE (count), count, count_one);
I don't follow you here. This is probably due to my lack of
understanding of the tree-ssa stuff and the backend. Can you
look at what I did and see if it's accept.
I'll note I did not go to great pains to try to guess at what
the floating pointing iterator means. To give, you a taste
of why FP iterators are bad. These programs produce different
results:
program do1
real x, xmin, xmax, dx
xmin = 0.
xmax = 1.
dx = 0.1
do 1 x = xmin, xmax, dx
print *, x
1 continue
end
program do1
real x
do 1 x = 0, 1, 0.1
print *, x
1 continue
end
Bootstrapped and regression tested with no new regressions on
i386-unknown-freebsd6.0.
2004-12-04 Steven G. Kargl <kargls@comcast.net>
* gfortran.h (INTEGER_ONLY,REAL_OK): New symbols; fix typo in comment
(gfc_resolve_iterator): Update prototype
* array.c (resolve_array_list): Use symbol
* resolve.c (gfc_resolve_iterator): Rewrite function; use symbols
* trans-stmt.c (gfc_trans_do): Permit REAL iterators
--
Steve
-------------- next part --------------
Index: array.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/array.c,v
retrieving revision 1.9
diff -u -b -u -r1.9 array.c
--- array.c 8 Nov 2004 14:56:37 -0000 1.9
+++ array.c 4 Dec 2004 22:13:44 -0000
@@ -1490,7 +1490,7 @@
for (; p; p = p->next)
{
if (p->iterator != NULL
- && gfc_resolve_iterator (p->iterator) == FAILURE)
+ && gfc_resolve_iterator (p->iterator, INTEGER_ONLY) == FAILURE)
t = FAILURE;
if (gfc_resolve_expr (p->expr) == FAILURE)
Index: gfortran.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.44
diff -u -b -u -r1.44 gfortran.h
--- gfortran.h 2 Dec 2004 04:10:24 -0000 1.44
+++ gfortran.h 4 Dec 2004 22:13:45 -0000
@@ -96,7 +96,7 @@
mstring;
-/* Flags to specify which standardi/extension contains a feature. */
+/* Flags to specify which standard/extension contains a feature. */
#define GFC_STD_GNU (1<<5) /* GNU Fortran extension. */
#define GFC_STD_F2003 (1<<4) /* New in F2003. */
/* Note that no features were obsoleted nor deleted in F2003. */
@@ -1737,13 +1737,17 @@
void gfc_free_statement (gfc_code *);
void gfc_free_statements (gfc_code *);
+/* The following defined constants are used in gfc_resolve_iterator to
+ permit or disallow REAL iterators. */
+#define INTEGER_ONLY 0
+#define REAL_OK 1
/* resolve.c */
try gfc_resolve_expr (gfc_expr *);
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 *, const int);
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 4 Dec 2004 22:13:49 -0000
@@ -2177,52 +2177,75 @@
be of integer type. */
try
-gfc_resolve_iterator (gfc_iterator * iter)
+gfc_resolve_iterator (gfc_iterator * iter, const int type)
{
- if (gfc_resolve_expr (iter->var) == FAILURE)
+ if (gfc_resolve_expr (iter->var) == FAILURE
+ || gfc_resolve_expr (iter->start) == FAILURE
+ || gfc_resolve_expr (iter->end) == FAILURE
+ || gfc_resolve_expr (iter->step) == FAILURE)
return FAILURE;
- if (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0)
+ if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
{
- gfc_error ("Loop variable at %L must be a scalar INTEGER",
+ gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
&iter->var->where);
return FAILURE;
}
- if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
+ if (iter->var->rank != 0)
{
- gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
- &iter->var->where);
+ gfc_error ("Loop variable at %L must be a scalar", &iter->var->where);
return FAILURE;
}
- if (gfc_resolve_expr (iter->start) == 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->rank != 0)
+ if (iter->end->rank != 0)
{
- gfc_error ("Start expression in DO loop at %L must be a scalar INTEGER",
- &iter->start->where);
+ gfc_error ("End expression in DO loop at %L must be a scalar",
+ &iter->end->where);
return FAILURE;
}
- if (gfc_resolve_expr (iter->end) == 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->end->ts.type != BT_INTEGER || iter->end->rank != 0)
+ if (type == INTEGER_ONLY)
{
- gfc_error ("End expression in DO loop at %L must be a scalar INTEGER",
- &iter->end->where);
+ if (iter->var->ts.type != BT_INTEGER)
+ {
+ gfc_error ("Loop variable at %L must be an INTEGER",
+ &iter->var->where);
+ return FAILURE;
+ }
+
+ if (iter->start->ts.type != BT_INTEGER)
+ {
+ gfc_error ("Start expression in DO loop at %L must be an INTEGER",
+ &iter->start->where);
return FAILURE;
}
- if (gfc_resolve_expr (iter->step) == FAILURE)
+ if (iter->end->ts.type != BT_INTEGER)
+ {
+ gfc_error ("End expression in DO loop at %L must be an INTEGER",
+ &iter->end->where);
return FAILURE;
+ }
- if (iter->step->ts.type != BT_INTEGER || iter->step->rank != 0)
+ if (iter->step->ts.type != BT_INTEGER)
{
- gfc_error ("Step expression in DO loop at %L must be a scalar INTEGER",
+ gfc_error ("Step expression in DO loop at %L must be an INTEGER",
&iter->step->where);
return FAILURE;
}
@@ -2234,6 +2257,83 @@
&iter->step->where);
return FAILURE;
}
+ }
+
+ if (type == REAL_OK)
+ {
+
+ /* 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_notify_std (GFC_STD_F95_DEL,
+ "REAL DO loop iterator at %L is deleted in Fortran 95",
+ &iter->var->where);
+
+ if (iter->var->ts.type != BT_INTEGER
+ && iter->var->ts.type != BT_REAL)
+ {
+ gfc_error ("Loop variable at %L must be an INTEGER or REAL",
+ &iter->var->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 an INTEGER or REAL",
+ &iter->start->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 an INTEGER or REAL",
+ &iter->end->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 an INTEGER or REAL",
+ &iter->step->where);
+ return FAILURE;
+ }
+
+ if (iter->step->expr_type == EXPR_CONSTANT)
+ {
+ if (iter->step->ts.type == BT_INTEGER
+ && 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;
+ }
+
+ if (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;
+ }
+ }
+ }
+
+ /* start, end, and step must have the same kind 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;
}
@@ -3723,7 +3823,7 @@
case EXEC_DO:
if (code->ext.iterator != NULL)
- gfc_resolve_iterator (code->ext.iterator);
+ gfc_resolve_iterator (code->ext.iterator, REAL_OK);
break;
case EXEC_DO_WHILE:
@@ -4355,7 +4455,7 @@
}
else
{
- if (gfc_resolve_iterator (&d->iter) == FAILURE)
+ if (gfc_resolve_iterator (&d->iter, INTEGER_ONLY) == FAILURE)
return FAILURE;
if (d->iter.start->expr_type != EXPR_CONSTANT
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 4 Dec 2004 22:13:53 -0000
@@ -617,8 +617,7 @@
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)
@@ -670,11 +669,16 @@
/* Initialize loop count. This code is executed before we enter the
loop body. We generate: count = (to + step - from) / step. */
+ count = gfc_create_var (gfc_array_index_type, "count");
tmp = fold (build2 (MINUS_EXPR, type, step, from));
tmp = fold (build2 (PLUS_EXPR, type, to, tmp));
+ if (TREE_CODE (type) == INTEGER_TYPE)
tmp = fold (build2 (TRUNC_DIV_EXPR, type, tmp, step));
-
- count = gfc_create_var (type, "count");
+ else
+ {
+ tmp = fold (build2 (RDIV_EXPR, type, tmp, step));
+ tmp = fold (build1 (FIX_TRUNC_EXPR, gfc_array_index_type, tmp));
+ }
gfc_add_modify_expr (&block, count, tmp);
/* Initialize the DO variable: dovar = from. */
@@ -717,7 +721,7 @@
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, gfc_array_index_type, count, gfc_index_one_node);
gfc_add_modify_expr (&body, count, tmp);
/* End of loop body. */
More information about the Fortran
mailing list