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]

Re: [PATCH,gfortran] Fix PR 16222


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

I turned these into a simple boolean.
I also pulled the checks common to all elements of the iterator out into a 
common routine.

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

Ok. I changed to comment to reflect that this we ensure, not a prerequisite.

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

Ok.

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

What you did was ok, except that forcing the count variable to 
index_integer_kind for integer indices is wrong. I changed the code to use 
the type kind of the loop variable for integer loops, and index_integer_kind 
for real loops. I'm not sure if it's right for real iterators either, but 
it's a relatively safe choice.

Tested on i686-linux.
Applied as attached.

Paul

2004-12-12  Steven G. Kargl  <kargls@comcast.net>
 Paul Brook  <paul@codesourcery.com>

 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.
testsuite/
 * gfortran.dg/real_do_1.f90: New test.
Index: array.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/array.c,v
retrieving revision 1.9
diff -c -p -r1.9 array.c
*** array.c	8 Nov 2004 14:56:37 -0000	1.9
--- array.c	12 Dec 2004 17:57:28 -0000
*************** resolve_array_list (gfc_constructor * p)
*** 1490,1496 ****
    for (; p; p = p->next)
      {
        if (p->iterator != NULL
! 	  && gfc_resolve_iterator (p->iterator) == FAILURE)
  	t = FAILURE;
  
        if (gfc_resolve_expr (p->expr) == FAILURE)
--- 1490,1496 ----
    for (; p; p = p->next)
      {
        if (p->iterator != NULL
! 	  && gfc_resolve_iterator (p->iterator, false) == FAILURE)
  	t = FAILURE;
  
        if (gfc_resolve_expr (p->expr) == FAILURE)
Index: gfortran.h
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.45
diff -c -p -r1.45 gfortran.h
*** gfortran.h	12 Dec 2004 16:30:00 -0000	1.45
--- gfortran.h	12 Dec 2004 17:57:28 -0000
*************** void gfc_resolve (gfc_namespace *);
*** 1743,1749 ****
  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_index (gfc_expr *, int);
  
  /* array.c */
--- 1743,1749 ----
  int gfc_impure_variable (gfc_symbol *);
  int gfc_pure (gfc_symbol *);
  int gfc_elemental (gfc_symbol *);
! try gfc_resolve_iterator (gfc_iterator *, bool);
  try gfc_resolve_index (gfc_expr *, int);
  
  /* array.c */
Index: resolve.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/resolve.c,v
retrieving revision 1.22
diff -c -p -r1.22 resolve.c
*** resolve.c	8 Dec 2004 12:27:47 -0000	1.22
--- resolve.c	12 Dec 2004 18:03:16 -0000
*************** gfc_resolve_expr (gfc_expr * e)
*** 2173,2239 ****
  }
  
  
! /* Resolve the expressions in an iterator structure and require that they all
!    be of integer type.  */
  
! try
! gfc_resolve_iterator (gfc_iterator * iter)
  {
! 
!   if (gfc_resolve_expr (iter->var) == FAILURE)
      return FAILURE;
  
!   if (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0)
      {
!       gfc_error ("Loop variable at %L must be a scalar INTEGER",
! 		 &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->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)
      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)
      return FAILURE;
  
!   if (iter->step->ts.type != BT_INTEGER || iter->step->rank != 0)
      {
!       gfc_error ("Step expression in DO loop at %L must be a scalar INTEGER",
! 		 &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;
!     }
  
    return SUCCESS;
  }
--- 2173,2266 ----
  }
  
  
! /* Resolve an expression from an iterator.  They must be scalar and have
!    INTEGER or (optionally) REAL type.  */
  
! static try
! gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok, const char * name)
  {
!   if (gfc_resolve_expr (expr) == FAILURE)
      return FAILURE;
  
!   if (expr->rank != 0)
      {
!       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",
! 		 &iter->var->where);
        return FAILURE;
      }
  
!   if (gfc_resolve_iterator_expr (iter->start, real_ok,
! 				 "Start expression in DO loop") == FAILURE)
      return FAILURE;
  
!   if (gfc_resolve_iterator_expr (iter->end, real_ok,
! 				 "End expression in DO loop") == FAILURE)
!     return FAILURE;
  
!   if (gfc_resolve_iterator_expr (iter->step, real_ok,
! 				 "Step expression in DO loop") == FAILURE)
      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)
! 	  || (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;
! 	}
      }
  
!   /* 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;
  }
*************** resolve_code (gfc_code * code, gfc_names
*** 3728,3734 ****
  
  	case EXEC_DO:
  	  if (code->ext.iterator != NULL)
! 	    gfc_resolve_iterator (code->ext.iterator);
  	  break;
  
  	case EXEC_DO_WHILE:
--- 3755,3761 ----
  
  	case EXEC_DO:
  	  if (code->ext.iterator != NULL)
! 	    gfc_resolve_iterator (code->ext.iterator, true);
  	  break;
  
  	case EXEC_DO_WHILE:
*************** resolve_data_variables (gfc_data_variabl
*** 4360,4366 ****
  	}
        else
  	{
! 	  if (gfc_resolve_iterator (&d->iter) == FAILURE)
  	    return FAILURE;
  
  	  if (d->iter.start->expr_type != EXPR_CONSTANT
--- 4387,4393 ----
  	}
        else
  	{
! 	  if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
  	    return FAILURE;
  
  	  if (d->iter.start->expr_type != EXPR_CONSTANT
Index: trans-stmt.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-stmt.c,v
retrieving revision 1.18
diff -c -p -r1.18 trans-stmt.c
*** trans-stmt.c	8 Nov 2004 14:56:41 -0000	1.18
--- trans-stmt.c	12 Dec 2004 17:57:28 -0000
*************** exit_label:
*** 617,624 ****
     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.  */
  
  tree
  gfc_trans_do (gfc_code * code)
--- 617,623 ----
     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.  */
  
  tree
  gfc_trans_do (gfc_code * code)
*************** gfc_trans_do (gfc_code * code)
*** 629,634 ****
--- 628,634 ----
    tree to;
    tree step;
    tree count;
+   tree count_one;
    tree type;
    tree cond;
    tree cycle_label;
*************** gfc_trans_do (gfc_code * code)
*** 647,663 ****
    type = TREE_TYPE (dovar);
  
    gfc_init_se (&se, NULL);
!   gfc_conv_expr_type (&se, code->ext.iterator->start, type);
    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_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_add_block_to_block (&block, &se.pre);
    step = gfc_evaluate_now (se.expr, &block);
  
--- 647,663 ----
    type = TREE_TYPE (dovar);
  
    gfc_init_se (&se, NULL);
!   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_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_val (&se, code->ext.iterator->step);
    gfc_add_block_to_block (&block, &se.pre);
    step = gfc_evaluate_now (se.expr, &block);
  
*************** gfc_trans_do (gfc_code * code)
*** 672,682 ****
  
    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");
    gfc_add_modify_expr (&block, count, tmp);
  
    /* Initialize the DO variable: dovar = from.  */
    gfc_add_modify_expr (&block, dovar, from);
  
--- 672,695 ----
  
    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
!     {
!       /* 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);
  
*************** gfc_trans_do (gfc_code * code)
*** 688,694 ****
    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);
    tmp = build1_v (GOTO_EXPR, exit_label);
    TREE_USED (exit_label) = 1;
    tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
--- 701,708 ----
    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,
! 		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 ());
*************** gfc_trans_do (gfc_code * code)
*** 717,723 ****
    gfc_add_modify_expr (&body, dovar, tmp);
  
    /* Decrement the loop count.  */
!   tmp = build2 (MINUS_EXPR, type, count, gfc_index_one_node);
    gfc_add_modify_expr (&body, count, tmp);
  
    /* End of loop body.  */
--- 731,737 ----
    gfc_add_modify_expr (&body, dovar, tmp);
  
    /* Decrement the loop count.  */
!   tmp = build2 (MINUS_EXPR, TREE_TYPE (count), count, count_one);
    gfc_add_modify_expr (&body, count, tmp);
  
    /* End of loop body.  */
! { 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

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