[patch, fortran] Handling of .and. and .or. expressions

[Thomas Koenig <tkoenig at netcologne dot de>]

Hello world,

the attached patch introduces the following changes:

If a logical .and. or .or. expression contains a reference to a function
which is impure and which also does not behave like a pure function
(i.e. does not have the implicit_pure attribute set), it emits a
warning with -Wsurprising that the function might not be evaluated.
(-Wsurprising is enabled by -Wall).

It special cases the idiom  if (associated(m) .and. m%t) which
people appear to use.

And, if there is an expression like   func() .and. flag , it
reverses the test as an optimization. The middle end should be
capable of doing this, but apparently it doesn't, so the front
end might as well do this.

What it does not do is one part of PR 57160, i.e. warn against
if (a /= 0 .and. 1/a > 5) which people who are used to C might
also like to write.

There is already quite some discussion in the PRs, especially 85599,
where not all people were of the same opinion. Let us see where the
discussion here leads us.

Regression-tested (which found one bug in the testsuite).

OK for trunk?

Regards

	Thomas

2018-06-11  Thomas Koenig  <tkoenig@gcc.gnu.org>

        PR fortran/57160
        PR fortran/85599
        * dump-parse-tree (show_attr): Add handling of implicit_pure.
        * resolve.c (impure_function_callback): New function.
        (resolve_operator): Call it vial gfc_expr_walker. Special-case
        if (associated(m) .and. m%t).  If an .and. or .or. expression
        has a function or a non-function, exchange the operands.

2018-06-11  Thomas Koenig  <tkoenig@gcc.gnu.org>

        PR fortran/57160
        PR fortran/85599
        * gfortran.dg/logical_evaluation_1.f90: New test.
        * gfortran.dg/alloc_comp_default_init_2.f90: Fix code which
        implicitly depends on short-circuiting.

Index: fortran/dump-parse-tree.c
===================================================================
--- fortran/dump-parse-tree.c	(Revision 261388)
+++ fortran/dump-parse-tree.c	(Arbeitskopie)
@@ -716,6 +716,8 @@ show_attr (symbol_attribute *attr, const char * mo
     fputs (" ELEMENTAL", dumpfile);
   if (attr->pure)
     fputs (" PURE", dumpfile);
+  if (attr->implicit_pure)
+    fputs (" IMPLICIT_PURE", dumpfile);
   if (attr->recursive)
     fputs (" RECURSIVE", dumpfile);
 
Index: fortran/resolve.c
===================================================================
--- fortran/resolve.c	(Revision 261388)
+++ fortran/resolve.c	(Arbeitskopie)
@@ -3807,7 +3807,43 @@ lookup_uop_fuzzy (const char *op, gfc_symtree *uop
   return gfc_closest_fuzzy_match (op, candidates);
 }
 
+/* Callback finding an impure function as an operand to an .and. or
+   .or.  expression.  Remember the last function warned about to
+   avoid double warnings when recursing.  */
 
+static int
+impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+			  void *data)
+{
+  gfc_expr *f = *e;
+  const char *name;
+  static gfc_expr *last = NULL;
+  bool *found = (bool *) data;
+
+  if (f->expr_type == EXPR_FUNCTION)
+    {
+      *found = 1;
+      if (f != last && !pure_function (f, &name))
+	{
+	  /* This could still be a function without side effects, i.e.
+	     implicit pure.  Do not warn for that case.  */
+	  if (f->symtree == NULL || f->symtree->n.sym == NULL
+	      || !gfc_implicit_pure (f->symtree->n.sym))
+	    {
+	      if (name)
+		gfc_warning (OPT_Wsurprising, "Impure function %qs at %L "
+			     "might not be evaluated", name, &f->where);
+	      else
+		gfc_warning (OPT_Wsurprising, "Impure function at %L "
+			     "might not be evaluated", &f->where);
+	    }
+	}
+      last = f;
+    }
+
+  return 0;
+}
+
 /* Resolve an operator expression node.  This can involve replacing the
    operation with a user defined function call.  */
 
@@ -3910,6 +3946,8 @@ resolve_operator (gfc_expr *e)
     case INTRINSIC_NEQV:
       if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
 	{
+	  bool dont_move = false;
+
 	  e->ts.type = BT_LOGICAL;
 	  e->ts.kind = gfc_kind_max (op1, op2);
 	  if (op1->ts.kind < e->ts.kind)
@@ -3916,6 +3954,53 @@ resolve_operator (gfc_expr *e)
 	    gfc_convert_type (op1, &e->ts, 2);
 	  else if (op2->ts.kind < e->ts.kind)
 	    gfc_convert_type (op2, &e->ts, 2);
+
+	  if (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR)
+	    {
+	      bool op1_f, op2_f;
+
+	      op1_f = false;
+	      op2_f = false;
+	      gfc_expr_walker (&op1, impure_function_callback, &op1_f);
+	      gfc_expr_walker (&op2, impure_function_callback, &op2_f);
+
+	      /* Some people code which depends on the short-circuiting that
+		 Fortran does not provide, such as
+
+		 if (associated(m) .and. m%t) then
+
+		 So, warn about this idiom. However, avoid breaking
+		 it on purpose.  */
+
+	      if (op1->expr_type == EXPR_FUNCTION && op1->value.function.isym
+		  && op1->value.function.isym->id == GFC_ISYM_ASSOCIATED)
+		{
+		  gfc_expr *e = op1->value.function.actual->expr;
+		  gfc_expr *en = op1->value.function.actual->next->expr;
+		  if (en == NULL && gfc_check_dependency (e, op2, true))
+		    {
+		      gfc_warning (OPT_Wsurprising, "%qs function call at %L does "
+				   "not guard expression at %L", "ASSOCIATED",
+				   &op1->where, &op2->where);
+		      dont_move = true;
+		    }
+		}
+
+	      /* A bit of optimization: Transfer if (f(x) .and. flag)
+		 into if (flag .and. f(x)), to save evaluation of a
+		 function.  The middle end should be capable of doing
+		 this with a TRUTH_AND_EXPR, but it currently does not do
+		 so. See PR 85599.  */
+
+	      if (!dont_move && op1_f && !op2_f)
+		{
+		  e->value.op.op1 = op2;
+		  e->value.op.op2 = op1;
+		  op1 = e->value.op.op1;
+		  op2 = e->value.op.op2;
+		}
+	    }
+
 	  break;
 	}
 
Index: testsuite/gfortran.dg/alloc_comp_default_init_2.f90
===================================================================
--- testsuite/gfortran.dg/alloc_comp_default_init_2.f90	(Revision 261388)
+++ testsuite/gfortran.dg/alloc_comp_default_init_2.f90	(Arbeitskopie)
@@ -11,7 +11,8 @@ program testprog
   integer, save :: callnb = 0
   type(t_type) :: this
   allocate ( this % chars ( 4))
-  if (.not.recursivefunc (this) .or. (callnb .ne. 10)) STOP 1
+  if (.not.recursivefunc (this)) STOP 1 
+  if (callnb .ne. 10) STOP 2
 contains
   recursive function recursivefunc ( this ) result ( match )
     type(t_type), intent(in) :: this

! { dg-do compile }
! { dg-additional-options "-Wsurprising -fdump-tree-original" }
! PR 85599 - check warning that impure function calls might be removed,
! and that logical expressions involving .and. and .or. will be
! reordered. 

MODULE M1
 TYPE T1
   LOGICAL :: T=.TRUE.
 END TYPE T1
CONTAINS
 SUBROUTINE S1(m)
   TYPE(T1), POINTER :: m
   IF (ASSOCIATED(m) .AND. m%T) THEN ! { dg-warning "does not guard expression" }
    WRITE(6,*) "X"
   ENDIF
 END SUBROUTINE
END MODULE

module x
  logical :: flag = .true.
  integer :: count = 0
contains
  pure function f()
    logical :: f
    f = .true.
  end function f

  function g()
    logical :: g
    g = .false.
  end function g

  real function h()
     h = 1.2
     count = count + 1
  end function h
end module x

program main
  use x
  print *, g() .and. f() ! No warning, because g() follows all the rules of a pure function
  print *, f() .and. flag
  print *, h() > 1.0 .and. flag ! { dg-warning "might not be evaluated" }
  print *, h() < 1.0 .or. flag ! { dg-warning "might not be evaluated" }

end program main
! { dg-final { scan-tree-dump-times "flag &&" 2 "original" } }
! { dg-final { scan-tree-dump-times "flag \\|\\|" 1 "original" } }