commit 1beb8cc863225a5f2ba4a52fc3ff1d3320edbfef
Author: Sandra Loosemore <sandra@codesourcery.com>
Date:   Mon Sep 27 07:05:32 2021 -0700

    Fortran: Add diagnostic for F2018:C839 (TS29113:C535c)
    
    2021-10-08 Sandra Loosemore  <sandra@codesourcery.com>
    
            PR fortran/54753
    
    gcc/fortran/
            * interface.c (gfc_compare_actual_formal): Add diagnostic
            for F2018:C839.  Refactor shared code and fix bugs with class
            array info lookup, and extend similar diagnostic from PR94110
            to also cover class types.
    
    gcc/testsuite/
            * gfortran.dg/c-interop/c535c-1.f90: Rewrite and expand.
            * gfortran.dg/c-interop/c535c-2.f90: Remove xfails.
            * gfortran.dg/c-interop/c535c-3.f90: Likewise.
            * gfortran.dg/c-interop/c535c-4.f90: Likewise.
            * gfortran.dg/PR94110.f90: Extend to cover class types.

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index a2fea0e97b8..2a71da75c72 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -3061,6 +3061,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
   unsigned long actual_size, formal_size;
   bool full_array = false;
   gfc_array_ref *actual_arr_ref;
+  gfc_array_spec *fas, *aas;
+  bool pointer_dummy, pointer_arg, allocatable_arg;
 
   actual = *ap;
 
@@ -3329,13 +3331,60 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  return false;
 	}
 
-      if (f->sym->as
-	  && (f->sym->as->type == AS_ASSUMED_SHAPE
-	      || f->sym->as->type == AS_DEFERRED
-	      || (f->sym->as->type == AS_ASSUMED_RANK && f->sym->attr.pointer))
-	  && a->expr->expr_type == EXPR_VARIABLE
-	  && a->expr->symtree->n.sym->as
-	  && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
+      /* Class array variables and expressions store array info in a
+	 different place from non-class objects; consolidate the logic
+	 to access it here instead of repeating it below.  Note that
+	 pointer_arg and allocatable_arg are not fully general and are
+	 only used in a specific situation below with an assumed-rank
+	 argument.  */
+      if (f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym))
+	{
+	  gfc_component *classdata = CLASS_DATA (f->sym);
+	  fas = classdata->as;
+	  pointer_dummy = classdata->attr.class_pointer;
+	}
+      else
+	{
+	  fas = f->sym->as;
+	  pointer_dummy = f->sym->attr.pointer;
+	}
+
+      if (a->expr->expr_type != EXPR_VARIABLE)
+	{
+	  aas = NULL;
+	  pointer_arg = false;
+	  allocatable_arg = false;
+	}
+      else if (a->expr->ts.type == BT_CLASS
+	       && a->expr->symtree->n.sym
+	       && CLASS_DATA (a->expr->symtree->n.sym))
+	{
+	  gfc_component *classdata = CLASS_DATA (a->expr->symtree->n.sym);
+	  aas = classdata->as;
+	  pointer_arg = classdata->attr.class_pointer;
+	  allocatable_arg = classdata->attr.allocatable;
+	}
+      else
+	{
+	  aas = a->expr->symtree->n.sym->as;
+	  pointer_arg = a->expr->symtree->n.sym->attr.pointer;
+	  allocatable_arg = a->expr->symtree->n.sym->attr.allocatable;
+	}
+
+      /* F2018:9.5.2(2) permits assumed-size whole array expressions as
+	 actual arguments only if the shape is not required; thus it
+	 cannot be passed to an assumed-shape array dummy.
+	 F2018:15.5.2.(2) permits passing a nonpointer actual to an
+	 intent(in) pointer dummy argument and this is accepted by
+	 the compare_pointer check below, but this also requires shape
+	 information.
+	 There's more discussion of this in PR94110.  */
+      if (fas
+	  && (fas->type == AS_ASSUMED_SHAPE
+	      || fas->type == AS_DEFERRED
+	      || (fas->type == AS_ASSUMED_RANK && pointer_dummy))
+	  && aas
+	  && aas->type == AS_ASSUMED_SIZE
 	  && (a->expr->ref == NULL
 	      || (a->expr->ref->type == REF_ARRAY
 		  && a->expr->ref->u.ar.type == AR_FULL)))
@@ -3346,6 +3395,35 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  return false;
 	}
 
+      /* Diagnose F2018 C839 (TS29113 C535c).  Here the problem is
+	 passing an assumed-size array to an INTENT(OUT) assumed-rank
+	 dummy when it doesn't have the size information needed to run
+	 initializers and finalizers.  */
+      if (f->sym->attr.intent == INTENT_OUT
+	  && fas
+	  && fas->type == AS_ASSUMED_RANK
+	  && aas
+	  && ((aas->type == AS_ASSUMED_SIZE
+	       && (a->expr->ref == NULL
+		   || (a->expr->ref->type == REF_ARRAY
+		       && a->expr->ref->u.ar.type == AR_FULL)))
+	      || (aas->type == AS_ASSUMED_RANK
+		  && !pointer_arg
+		  && !allocatable_arg))
+	  && (a->expr->ts.type == BT_CLASS
+	      || (a->expr->ts.type == BT_DERIVED
+		  && (gfc_is_finalizable (a->expr->ts.u.derived, NULL)
+		      || gfc_has_ultimate_allocatable (a->expr)
+		      || gfc_has_default_initializer
+			   (a->expr->ts.u.derived)))))
+	{
+	  if (where)
+	    gfc_error ("Actual argument to assumed-rank INTENT(OUT) "
+		       "dummy %qs at %L cannot be of unknown size",
+		       f->sym->name, where);
+	  return false;
+	}
+
       if (a->expr->expr_type != EXPR_NULL
 	  && compare_pointer (f->sym, a->expr) == 0)
 	{
@@ -3479,7 +3557,7 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  && a->expr->expr_type == EXPR_VARIABLE
 	  && a->expr->symtree->n.sym->as
 	  && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
-	  && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
+	  && !(fas && fas->type == AS_ASSUMED_SHAPE))
 	{
 	  if (where)
 	    gfc_error ("Assumed-shape actual argument at %L is "
@@ -3496,7 +3574,7 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 
       if (f->sym->attr.volatile_
 	  && actual_arr_ref && actual_arr_ref->type == AR_SECTION
-	  && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
+	  && !(fas && fas->type == AS_ASSUMED_SHAPE))
 	{
 	  if (where)
 	    gfc_error ("Array-section actual argument at %L is "
@@ -3514,8 +3592,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  && a->expr->expr_type == EXPR_VARIABLE
 	  && a->expr->symtree->n.sym->attr.pointer
 	  && a->expr->symtree->n.sym->as
-	  && !(f->sym->as
-	       && (f->sym->as->type == AS_ASSUMED_SHAPE
+	  && !(fas
+	       && (fas->type == AS_ASSUMED_SHAPE
 		   || f->sym->attr.pointer)))
 	{
 	  if (where)
diff --git a/gcc/testsuite/gfortran.dg/PR94110.f90 b/gcc/testsuite/gfortran.dg/PR94110.f90
index 9ec70ec857e..4e43332b64e 100644
--- a/gcc/testsuite/gfortran.dg/PR94110.f90
+++ b/gcc/testsuite/gfortran.dg/PR94110.f90
@@ -9,6 +9,16 @@ program asa_p
 
   integer, parameter :: n = 7
 
+  type t
+  end type t
+
+  interface
+    subroutine fc2 (x)
+      import :: t
+      class(t), pointer, intent(in) :: x(..)
+    end subroutine
+  end interface
+
   integer :: p(n)
   integer :: s
 
@@ -84,5 +94,10 @@ contains
     return
   end function sum_p_ar
 
+  subroutine sub1(y)
+    type(t), target :: y(*)
+    call fc2 (y) ! { dg-error "Actual argument for .x. cannot be an assumed-size array" } 
+  end subroutine sub1
+
 end program asa_p
 
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90
index b4047139eaf..2158c35be82 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90
@@ -11,77 +11,154 @@
 ! This test file contains tests that are expected to issue diagnostics
 ! for invalid code.
 
-module m
-
+module t
   type :: t1
     integer :: id
     real :: xyz(3)
   end type
+end module  
 
-contains
+module m
+  use t
+
+  ! Assumed-type dummies are (unlimited) polymorphic too, but F2018:C709
+  ! already prohibits them from being declared intent(out).  So we only
+  ! test dummies of class type that are polymorphic or unlimited
+  ! polymorphic.
+  interface
+    subroutine poly (x, y)
+      use t
+      class(t1) :: x(..)
+      class(t1), intent (out) :: y(..)
+    end subroutine
+    subroutine upoly (x, y)
+      class(*) :: x(..)
+      class(*), intent (out) :: y(..)
+    end subroutine
+  end interface
 
-  subroutine s1_nonpolymorphic (x, y)
-    type(t1) :: x(..)
-    type(t1), intent(out) :: y(..)
-  end subroutine
+contains
 
-  subroutine s1_polymorphic (x, y)  ! { dg-bogus "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
-    class(t1) :: x(..)
-    class(t1), intent(out) :: y(..)
+  ! The known-size calls should all be OK as they do not involve
+  ! assumed-size or assumed-rank actual arguments.
+  subroutine test_known_size_nonpolymorphic (a1, a2, n)
+    integer :: n
+    type(t1) :: a1(n,n), a2(n)
+    call poly (a1, a2)
+    call upoly (a1, a2)
   end subroutine
-
-  subroutine s1_unlimited_polymorphic (x, y)  ! { dg-bogus "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
-    class(*) :: x(..)
-    class(*), intent(out) :: y(..)
+  subroutine test_known_size_polymorphic (a1, a2, n)
+    integer :: n
+    class(t1) :: a1(n,n), a2(n)
+    call poly (a1, a2)
+    call upoly (a1, a2)
   end subroutine
-
-  ! These calls should all be OK as they do not involve assumed-size or
-  ! assumed-rank actual arguments.
-  subroutine test_known_size (a1, a2, n)
+  subroutine test_known_size_unlimited_polymorphic (a1, a2, n)
     integer :: n
-    type(t1) :: a1(n,n), a2(n)
+    class(*) :: a1(n,n), a2(n)
+    call upoly (a1, a2)
+  end subroutine
 
-    call s1_nonpolymorphic (a1, a2)
-    call s1_polymorphic (a1, a2)
-    call s1_unlimited_polymorphic (a1, a2)
+  ! Likewise passing a scalar as the assumed-rank argument.
+  subroutine test_scalar_nonpolymorphic (a1, a2)
+    type(t1) :: a1, a2
+    call poly (a1, a2)
+    call upoly (a1, a2)
+  end subroutine
+  subroutine test_scalar_polymorphic (a1, a2)
+    class(t1) :: a1, a2
+    call poly (a1, a2)
+    call upoly (a1, a2)
+  end subroutine
+  subroutine test_scalar_unlimited_polymorphic (a1, a2)
+    class(*) :: a1, a2
+    call upoly (a1, a2)
+  end subroutine
+  
+  ! The polymorphic cases for assumed-size are bad.
+  subroutine test_assumed_size_nonpolymorphic (a1, a2)
+    type(t1) :: a1(*), a2(*)
+    call poly (a1, a2)  ! OK
+    call upoly (a1, a2)  ! OK
+  end subroutine
+  subroutine test_assumed_size_polymorphic (a1, a2)
+    class(t1) :: a1(*), a2(*)
+    call poly (a1, a2)  ! { dg-error "(A|a)ssumed.rank" }
+    call upoly (a1, a2)  ! { dg-error "(A|a)ssumed.rank" }
+    call poly (a1(5), a2(4:7))
+  end subroutine
+  subroutine test_assumed_size_unlimited_polymorphic (a1, a2)
+    class(*) :: a1(*), a2(*)
+    call upoly (a1, a2)  ! { dg-error "(A|a)ssumed.rank" }
   end subroutine
 
-  ! The calls to the polymorphic functions should be rejected
-  ! with an assumed-size array argument.
-  subroutine test_assumed_size (a1, a2)
+  ! The arguments being passed to poly/upoly in this set are *not*
+  ! assumed size and should not error.
+  subroutine test_not_assumed_size_nonpolymorphic (a1, a2)
     type(t1) :: a1(*), a2(*)
+    call poly (a1(5), a2(4:7))
+    call upoly (a1(5), a2(4:7))
+    call poly (a1(:10), a2(:-5))
+    call upoly (a1(:10), a2(:-5))
+  end subroutine
+  subroutine test_not_assumed_size_polymorphic (a1, a2)
+    class(t1) :: a1(*), a2(*)
+    call poly (a1(5), a2(4:7))
+    call upoly (a1(5), a2(4:7))
+    call poly (a1(:10), a2(:-5))
+    call upoly (a1(:10), a2(:-5))
+  end subroutine
+  subroutine test_not_assumed_size_unlimited_polymorphic (a1, a2)
+    class(*) :: a1(*), a2(*)
+    call upoly (a1(5), a2(4:7))
+    call upoly (a1(:10), a2(:-5))
+  end subroutine
 
-    call s1_nonpolymorphic (a1, a2)
-    call s1_polymorphic (a1, a2)  ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
-    call s1_unlimited_polymorphic (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+  ! Polymorphic assumed-rank without pointer/allocatable is also bad.
+  subroutine test_assumed_rank_nonpolymorphic (a1, a2)
+    type(t1) :: a1(..), a2(..)
+    call poly (a1, a2)  ! OK
+    call upoly (a1, a2)  ! OK
+  end subroutine
+  subroutine test_assumed_rank_polymorphic (a1, a2)
+    class(t1) :: a1(..), a2(..)
+    call poly (a1, a2)  ! { dg-error "(A|a)ssumed.rank" }
+    call upoly (a1, a2)  ! { dg-error "(A|a)ssumed.rank" }
+  end subroutine
+  subroutine test_assumed_rank_unlimited_polymorphic (a1, a2)
+    class(*) :: a1(..), a2(..)
+    call upoly (a1, a2)  ! { dg-error "(A|a)ssumed.rank" }
   end subroutine
 
-  ! These calls should be OK.
-  subroutine test_assumed_rank_pointer (a1, a2)
+  ! Pointer/allocatable assumed-rank should be OK.
+  subroutine test_pointer_nonpolymorphic (a1, a2)
     type(t1), pointer :: a1(..), a2(..)
-
-    call s1_nonpolymorphic (a1, a2)
-    call s1_polymorphic (a1, a2)
-    call s1_unlimited_polymorphic (a1, a2)
+    call poly (a1, a2)
+    call upoly (a1, a2)
+  end subroutine
+  subroutine test_pointer_polymorphic (a1, a2)
+    class(t1), pointer :: a1(..), a2(..)
+    call poly (a1, a2)
+    call upoly (a1, a2)
+  end subroutine
+  subroutine test_pointer_unlimited_polymorphic (a1, a2)
+    class(*), pointer :: a1(..), a2(..)
+    call upoly (a1, a2)
   end subroutine
 
-  ! These calls should be OK.
-  subroutine test_assumed_rank_allocatable (a1, a2)
+  subroutine test_allocatable_nonpolymorphic (a1, a2)
     type(t1), allocatable :: a1(..), a2(..)
-
-    call s1_nonpolymorphic (a1, a2)
-    call s1_polymorphic (a1, a2)
-    call s1_unlimited_polymorphic (a1, a2)
+    call poly (a1, a2)
+    call upoly (a1, a2)
   end subroutine
-  
-  ! The calls to the polymorphic functions should be rejected
-  ! with a nonallocatable nonpointer assumed-rank actual argument.
-  subroutine test_assumed_rank_plain (a1, a2)
-    type(t1) :: a1(..), a2(..)
-
-    call s1_nonpolymorphic (a1, a2)
-    call s1_polymorphic (a1, a2)  ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
-    call s1_unlimited_polymorphic (a1, a2)  ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+  subroutine test_allocatable_polymorphic (a1, a2)
+    class(t1), allocatable :: a1(..), a2(..)
+    call poly (a1, a2)
+    call upoly (a1, a2)
+  end subroutine
+  subroutine test_allocatable_unlimited_polymorphic (a1, a2)
+    class(*), allocatable :: a1(..), a2(..)
+    call upoly (a1, a2)
   end subroutine
 
 end module
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90
index db15ece9809..f232efae9fc 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90
@@ -45,7 +45,7 @@ contains
   subroutine test_assumed_size (a1, a2)
     type(t1) :: a1(*), a2(*)
     
-    call s1 (a1, a2)  !  { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+    call s1 (a1, a2)  !  { dg-error "(A|a)ssumed.rank" }
   end subroutine
 
   ! This call should be OK.
@@ -67,7 +67,7 @@ contains
   subroutine test_assumed_rank_plain (a1, a2)
     type(t1) :: a1(..), a2(..)
 
-    call s1 (a1, a2)  ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+    call s1 (a1, a2)  ! { dg-error "(A|a)ssumed.rank" }
   end subroutine
 
 end module
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90
index 5c224b1f8bd..50840a1ba5f 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90
@@ -1,6 +1,5 @@
 ! PR 54753
 ! { dg-do compile }
-! { dg-ice "pr54753" }
 !
 ! TS 29113
 ! C535c If an assumed-size or nonallocatable nonpointer assumed-rank
@@ -45,7 +44,7 @@ contains
   subroutine test_assumed_size (a1, a2)
     type(t1) :: a1(*), a2(*)
     
-    call s1 (a1, a2)  ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+    call s1 (a1, a2)  ! { dg-error "(A|a)ssumed.rank" }
   end subroutine
 
   ! This call should be OK.
@@ -67,7 +66,7 @@ contains
   subroutine test_assumed_rank_plain (a1, a2)
     type(t1) :: a1(..), a2(..)
 
-    call s1 (a1, a2)  ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+    call s1 (a1, a2)  ! { dg-error "(A|a)ssumed.rank" }
   end subroutine
 
 end module
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90
index ecbb18187dd..dc380baf465 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90
@@ -1,6 +1,5 @@
 ! PR 54753
 ! { dg-do compile }
-! { dg-ice "pr54753" }
 !
 ! TS 29113
 ! C535c If an assumed-size or nonallocatable nonpointer assumed-rank
@@ -45,7 +44,7 @@ contains
   subroutine test_assumed_size (a1, a2)
     type(t1) :: a1(*), a2(*)
     
-    call s1 (a1, a2)  ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+    call s1 (a1, a2)  ! { dg-error "(A|a)ssumed.rank" }
   end subroutine
 
   ! This call should be OK.
@@ -67,7 +66,7 @@ contains
   subroutine test_assumed_rank_plain (a1, a2)
     type(t1) :: a1(..), a2(..)
 
-    call s1 (a1, a2)  ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+    call s1 (a1, a2)  ! { dg-error "(A|a)ssumed.rank" }
   end subroutine
 
 end module
