Fortran: Fix for regression in ASSOCIATE [PR112316]

2023-11-02  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/112316
	* parse.cc (parse_associate): Remove condition that caused this
	regression.

gcc/testsuite/
	PR fortran/112316
	* gfortran.dg/pr112316.f90: New test.

diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index e103ebee5572d0e25d438c82107c2494eaad94b0..abd3a424f385ae912707e64c32363490132a2d84 100644 (file)
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5133,6 +5133,7 @@ parse_associate (void)
     {
       gfc_symbol* sym;
       gfc_expr *target;
+      int rank;
 
       if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
        gcc_unreachable ();
@@ -5196,62 +5197,57 @@ parse_associate (void)
            }
        }
 
-      if (target->rank)
+      rank = target->rank;
+      /* Fixup cases where the ranks are mismatched.  */
+      if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
        {
-         int rank = 0;
-         rank = target->rank;
-         /* When the rank is greater than zero then sym will be an array.  */
-         if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
+         if ((!CLASS_DATA (sym)->as && rank != 0)
+              || (CLASS_DATA (sym)->as
+                  && CLASS_DATA (sym)->as->rank != rank))
            {
-             if ((!CLASS_DATA (sym)->as && rank != 0)
-                 || (CLASS_DATA (sym)->as
-                     && CLASS_DATA (sym)->as->rank != rank))
+             /* Don't just (re-)set the attr and as in the sym.ts,
+             because this modifies the target's attr and as.  Copy the
+             data and do a build_class_symbol.  */
+             symbol_attribute attr = CLASS_DATA (target)->attr;
+             int corank = gfc_get_corank (target);
+             gfc_typespec type;
+
+             if (rank || corank)
                {
-                 /* Don't just (re-)set the attr and as in the sym.ts,
-                    because this modifies the target's attr and as.  Copy the
-                    data and do a build_class_symbol.  */
-                 symbol_attribute attr = CLASS_DATA (target)->attr;
-                 int corank = gfc_get_corank (target);
-                 gfc_typespec type;
-
-                 if (rank || corank)
-                   {
-                     as = gfc_get_array_spec ();
-                     as->type = AS_DEFERRED;
-                     as->rank = rank;
-                     as->corank = corank;
-                     attr.dimension = rank ? 1 : 0;
-                     attr.codimension = corank ? 1 : 0;
-                   }
-                 else
-                   {
-                     as = NULL;
-                     attr.dimension = attr.codimension = 0;
-                   }
-                 attr.class_ok = 0;
-                 type = CLASS_DATA (sym)->ts;
-                 if (!gfc_build_class_symbol (&type,
-                                              &attr, &as))
-                   gcc_unreachable ();
-                 sym->ts = type;
-                 sym->ts.type = BT_CLASS;
-                 sym->attr.class_ok = 1;
+                 as = gfc_get_array_spec ();
+                 as->type = AS_DEFERRED;
+                 as->rank = rank;
+                 as->corank = corank;
+                 attr.dimension = rank ? 1 : 0;
+                 attr.codimension = corank ? 1 : 0;
                }
              else
-               sym->attr.class_ok = 1;
-           }
-         else if ((!sym->as && rank != 0)
-                  || (sym->as && sym->as->rank != rank))
-           {
-             as = gfc_get_array_spec ();
-             as->type = AS_DEFERRED;
-             as->rank = rank;
-             as->corank = gfc_get_corank (target);
-             sym->as = as;
-             sym->attr.dimension = 1;
-             if (as->corank)
-               sym->attr.codimension = 1;
+               {
+                 as = NULL;
+                 attr.dimension = attr.codimension = 0;
+               }
+             attr.class_ok = 0;
+             type = CLASS_DATA (sym)->ts;
+             if (!gfc_build_class_symbol (&type, &attr, &as))
+               gcc_unreachable ();
+             sym->ts = type;
+             sym->ts.type = BT_CLASS;
+             sym->attr.class_ok = 1;
            }
+         else
+           sym->attr.class_ok = 1;
+       }
+      else if ((!sym->as && rank != 0)
+              || (sym->as && sym->as->rank != rank))
+       {
+         as = gfc_get_array_spec ();
+         as->type = AS_DEFERRED;
+         as->rank = rank;
+         as->corank = gfc_get_corank (target);
+         sym->as = as;
+         sym->attr.dimension = 1;
+         if (as->corank)
+           sym->attr.codimension = 1;
        }
     }
 

diff --git a/gcc/testsuite/gfortran.dg/pr112316.f90 b/gcc/testsuite/gfortran.dg/pr112316.f90
new file mode 100644 (file)
index 0000000..df4dad7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr112316.f90
@@ -0,0 +1,79 @@
+! { dg-do compile }
+!
+! This contains both testcases in the PR
+!
+! Contributed by Tomas Trnka  <trnka@scm.com>
+!
+! First testcase
+module BogusPointerArgError
+   implicit none
+
+   type :: AType
+   end type
+
+contains
+
+   subroutine A ()
+
+      class(AType), allocatable :: x
+
+      allocate(x)
+      call B (x)                       ! Was an error here
+   end subroutine
+
+   subroutine B (y)
+      class(AType), intent(in)    :: y
+   end subroutine
+
+   subroutine C (z)
+      class(AType), intent(in) :: z(:)
+
+      associate (xxx => z(1))
+      end associate
+
+   end subroutine
+
+end module
+
+! Second testcase
+module AModule
+   implicit none
+   private
+
+   public AType
+
+   type, abstract :: AType
+   contains
+      generic, public :: assignment(=) => Assign
+
+      procedure, private :: Assign
+   end type AType
+
+contains
+
+   subroutine Assign(lhs, rhs)
+      class(AType), intent(inout) :: lhs
+      class(AType), intent(in)    :: rhs
+   end subroutine
+
+end module AModule
+
+
+
+module ICEGetDescriptorField
+   use AModule
+   implicit none
+
+contains
+
+   subroutine Foo (x)
+      class(AType), intent(in)    :: x(:)
+
+      class(AType), allocatable :: y
+
+      associate (xxx => x(1))
+         y = xxx                       ! Was an ICE here
+      end associate
+   end subroutine
+
+end module ICEGetDescriptorField