This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[PATCH,gfortran] Fix PR 16222]


Whoops, I forgot to CC gcc-patches.

----- Forwarded message from Steve Kargl <sgk@troutmask.apl.washington.edu> -----

Date: Sat, 27 Nov 2004 16:51:48 -0800
From: Steve Kargl <sgk@troutmask.apl.washington.edu>
To: fortran@gcc.gnu.org
Subject: [PATCH,gfortran] Fix PR 16222
Message-ID: <20041128005148.GA16165@troutmask.apl.washington.edu>

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

-- 
Steve

 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.  */


----- End forwarded message -----

-- 
Steve


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]