[gcc/devel/gccgo] Fortran : False positive for optional arguments PR95446

[Ian Lance Taylor]

https://gcc.gnu.org/g:685d8dafb4a1cb29ee219ad7857614ff66a78022

commit 685d8dafb4a1cb29ee219ad7857614ff66a78022
Author: Mark Eggleston <markeggleston@gcc.gnu.org>
Date:   Mon Jun 1 14:56:00 2020 +0100

    Fortran  : False positive for optional arguments PR95446
    
    Check that there is non-optional argument of the same rank in the
    list of actual arguments.  If there is the warning is not required.
    
    2020-07-01  Steven G. Kargl  <kargl@gcc.gnu.org>
    
    gcc/fortran/
    
            PR fortran/95446
            * resolve.c (resolve_elemental_actual): Add code to check for
            non-optional argument of the same rank.  Revise warning message
            to refer to the Fortran 2018 standard.
    
    2020-07-01  Mark Eggleston  <markeggleston@gcc.gnu.org>
    
    gcc/testsuite/
    
            PR fortran/95446
            * gfortran.dg/elemental_optional_args_6.f90: Remove check
            for warnings that were erroneously output.
            * gfortran.dg/pr95446.f90: New test.

Diff:
---
 gcc/fortran/resolve.c                              | 28 ++++++++++++----
 .../gfortran.dg/elemental_optional_args_6.f90      |  4 +--
 gcc/testsuite/gfortran.dg/pr95446.f90              | 38 ++++++++++++++++++++++
 3 files changed, 62 insertions(+), 8 deletions(-)

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4a2abd00f4a..2a164055ffc 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2277,12 +2277,28 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
 	  && (set_by_optional || arg->expr->rank != rank)
 	  && !(isym && isym->id == GFC_ISYM_CONVERSION))
 	{
-	  gfc_warning (OPT_Wpedantic,
-		       "%qs at %L is an array and OPTIONAL; IF IT IS "
-		       "MISSING, it cannot be the actual argument of an "
-		       "ELEMENTAL procedure unless there is a non-optional "
-		       "argument with the same rank (12.4.1.5)",
-		       arg->expr->symtree->n.sym->name, &arg->expr->where);
+	  bool t = false;
+	  gfc_actual_arglist *a;
+
+	  /* Scan the argument list for a non-optional argument with the
+	     same rank as arg.  */
+	  for (a = arg0; a; a = a->next)
+	    if (a != arg
+		&& a->expr->rank == arg->expr->rank
+		&& !a->expr->symtree->n.sym->attr.optional)
+	      {
+		t = true;
+		break;
+	      }
+
+	  if (!t)
+	    gfc_warning (OPT_Wpedantic,
+			 "%qs at %L is an array and OPTIONAL; If it is not "
+			 "present, then it cannot be the actual argument of "
+			 "an ELEMENTAL procedure unless there is a non-optional"
+			 " argument with the same rank "
+			 "(Fortran 2018, 15.5.2.12)",
+			 arg->expr->symtree->n.sym->name, &arg->expr->where);
 	}
     }
 
diff --git a/gcc/testsuite/gfortran.dg/elemental_optional_args_6.f90 b/gcc/testsuite/gfortran.dg/elemental_optional_args_6.f90
index c19c1df3e2b..56a9db56be2 100644
--- a/gcc/testsuite/gfortran.dg/elemental_optional_args_6.f90
+++ b/gcc/testsuite/gfortran.dg/elemental_optional_args_6.f90
@@ -21,8 +21,8 @@ contains
       integer, optional :: arg1(:)
       integer :: arg2(:)
 !      print *, fun1 (arg1, arg2)
-      if (size (fun1 (arg1, arg2)) /= 2) STOP 1 ! { dg-warning "is an array and OPTIONAL" }
-      if (any (fun1 (arg1, arg2) /= [1,2])) STOP 2 ! { dg-warning "is an array and OPTIONAL" }
+      if (size (fun1 (arg1, arg2)) /= 2) STOP 1
+      if (any (fun1 (arg1, arg2) /= [1,2])) STOP 2
    end subroutine
 
    elemental function fun1 (arg1, arg2)
diff --git a/gcc/testsuite/gfortran.dg/pr95446.f90 b/gcc/testsuite/gfortran.dg/pr95446.f90
new file mode 100644
index 00000000000..86e1019d7af
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr95446.f90
@@ -0,0 +1,38 @@
+! { dg-do compile }
+! { dg-options "-pedantic-errors" }
+!
+! Contributed by Martin Diehl  <m.diehl@mpie.de>
+
+program elemental_optional
+  implicit none
+  integer :: m(5), r(5)
+
+  m = 1
+
+  r = outer()
+  r = outer(m)
+  
+  contains
+
+  function outer(o) result(l)
+    integer, intent(in), optional :: o(:)
+    integer :: u(5), l(5)
+
+    l = inner(o,u)
+
+  end function outer
+
+  elemental function inner(a,b) result(x)
+    integer, intent(in), optional :: a
+    integer, intent(in) :: b
+    integer :: x
+
+    if(present(a)) then
+      x = a*b
+    else
+      x = b
+    endif
+  end function inner
+  
+end program elemental_optional
+