[Patch, fortran] PR87477 - [meta-bug] [F03] issues concerning the ASSOCIATE statement

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 1043 bytes --]

Hi All,

This started out as the search for a fix to pr109948 and evolved to roll in
5 other prs.

Basically parse_associate was far too clunky and, in anycase, existing
functions in resolve.cc were well capable of doing the determination of the
target expression rank. While I was checking the comments, the lightbulb
flashed with respect to prs 102109/112/190 and the chunk dealing with
function results of unknown type was born.

Thanks to the changes in parse.cc, the problem in pr99326 migrated
upstream to the resolution and the chunklet in resolve.cc was an obvious
fix.

I am minded to s/{ dg-do run}/{ dg-do compile } for all six testcases. At
the testing stage, I wanted to check that the testcases actually did what
they are supposed to do :-)

Bootstraps and regtests OK - good for head?

Paul

PS I need to do some housekeeping on pr87477 now. Some of the blockers have
"fixed themselves" and others are awaiting backporting. I think that there
are only 4 or so left, of which 89645 and 99065 are the most difficult to
deal with.

[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 13255 bytes --]

diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 5e2a95688d2..3947444f17c 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -4919,6 +4919,7 @@ parse_associate (void)
   gfc_state_data s;
   gfc_statement st;
   gfc_association_list* a;
+  gfc_array_spec *as;
 
   gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
 
@@ -4934,8 +4935,7 @@ parse_associate (void)
   for (a = new_st.ext.block.assoc; a; a = a->next)
     {
       gfc_symbol* sym;
-      gfc_ref *ref;
-      gfc_array_ref *array_ref;
+      gfc_expr *target;
 
       if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
 	gcc_unreachable ();
@@ -4952,6 +4952,7 @@ parse_associate (void)
 	 for parsing component references on the associate-name
 	 in case of association to a derived-type.  */
       sym->ts = a->target->ts;
+      target = a->target;
 
       /* Don’t share the character length information between associate
 	 variable and target if the length is not a compile-time constant,
@@ -4971,31 +4972,37 @@ parse_associate (void)
 	       && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT))
 	sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
 
-      /* Check if the target expression is array valued.  This cannot always
-	 be done by looking at target.rank, because that might not have been
-	 set yet.  Therefore traverse the chain of refs, looking for the last
-	 array ref and evaluate that.  */
-      array_ref = NULL;
-      for (ref = a->target->ref; ref; ref = ref->next)
-	if (ref->type == REF_ARRAY)
-	  array_ref = &ref->u.ar;
-      if (array_ref || a->target->rank)
+      /* Check if the target expression is array valued. This cannot be done
+	 by calling gfc_resolve_expr because the context is unavailable.
+	 However, the references can be resolved and the rank of the target
+	 expression set.  */
+      if (target->ref && gfc_resolve_ref (target)
+	  && target->expr_type != EXPR_ARRAY
+	  && target->expr_type != EXPR_COMPCALL)
+	gfc_expression_rank (target);
+
+      /* Determine whether or not function expressions with unknown type are
+	 structure constructors. If so, the function result can be converted
+	 to be a derived type.
+	 TODO: Deal with references to sibling functions that have not yet been
+	 parsed (PRs 89645 and 99065).  */
+      if (target->expr_type == EXPR_FUNCTION && target->ts.type == BT_UNKNOWN)
 	{
-	  gfc_array_spec *as;
-	  int dim, rank = 0;
-	  if (array_ref)
+	  gfc_symbol *derived;
+	  /* The derived type has a leading uppercase character.  */
+	  gfc_find_symbol (gfc_dt_upper_string (target->symtree->name),
+			   my_ns->parent, 1, &derived);
+	  if (derived && derived->attr.flavor == FL_DERIVED)
 	    {
-	      a->rankguessed = 1;
-	      /* Count the dimension, that have a non-scalar extend.  */
-	      for (dim = 0; dim < array_ref->dimen; ++dim)
-		if (array_ref->dimen_type[dim] != DIMEN_ELEMENT
-		    && !(array_ref->dimen_type[dim] == DIMEN_UNKNOWN
-			 && array_ref->end[dim] == NULL
-			 && array_ref->start[dim] != NULL))
-		  ++rank;
+	      sym->ts.type = BT_DERIVED;
+	      sym->ts.u.derived = derived;
 	    }
-	  else
-	    rank = a->target->rank;
+	}
+
+      if (target->rank)
+	{
+	  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))
 	    {
@@ -5006,8 +5013,8 @@ parse_associate (void)
 		  /* 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 (a->target)->attr;
-		  int corank = gfc_get_corank (a->target);
+		  symbol_attribute attr = CLASS_DATA (target)->attr;
+		  int corank = gfc_get_corank (target);
 		  gfc_typespec type;
 
 		  if (rank || corank)
@@ -5042,7 +5049,7 @@ parse_associate (void)
 	      as = gfc_get_array_spec ();
 	      as->type = AS_DEFERRED;
 	      as->rank = rank;
-	      as->corank = gfc_get_corank (a->target);
+	      as->corank = gfc_get_corank (target);
 	      sym->as = as;
 	      sym->attr.dimension = 1;
 	      if (as->corank)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 83e45f1b693..c0515fd0c97 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -16087,7 +16087,8 @@ resolve_symbol (gfc_symbol *sym)
 
       if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed)
 	   || as->type == AS_ASSUMED_SHAPE)
-	  && !sym->attr.dummy && !sym->attr.select_type_temporary)
+	  && !sym->attr.dummy && !sym->attr.select_type_temporary
+	  && !sym->attr.associate_var)
 	{
 	  if (as->type == AS_ASSUMED_SIZE)
 	    gfc_error ("Assumed size array at %L must be a dummy argument",
diff --git a/gcc/testsuite/gfortran.dg/associate_54.f90 b/gcc/testsuite/gfortran.dg/associate_54.f90
index 680ad5d14a2..8eb95a710b6 100644
--- a/gcc/testsuite/gfortran.dg/associate_54.f90
+++ b/gcc/testsuite/gfortran.dg/associate_54.f90
@@ -24,7 +24,7 @@ contains
   subroutine test_alter_state1 (obj, a)
     class(test_t), intent(inout) :: obj
     integer, intent(in) :: a
-    associate (state => obj%state(TEST_STATES)) ! { dg-error "is used as array" }
+    associate (state => obj%state(TEST_STATES)) ! { dg-error "as array|no IMPLICIT type" }
 !      state = a
       state(TEST_STATE) = a ! { dg-error "array reference of a non-array" }
     end associate
diff --git a/gcc/testsuite/gfortran.dg/pr102109.f90 b/gcc/testsuite/gfortran.dg/pr102109.f90
new file mode 100644
index 00000000000..8f3cecbe239
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr102109.f90
@@ -0,0 +1,20 @@
+! { dg-do run }
+!
+! Contributed by Brad Richardson  <everythingfunctional@protonmail.com>
+!
+program main
+    type :: sub_obj_t
+        integer :: val
+    end type
+
+    type :: compound_obj_t
+        type(sub_obj_t) :: sub_obj
+    end type
+
+    associate(initial_sub_obj => sub_obj_t(42))
+!        print *, initial_sub_obj%val           ! Used to work with this uncommented
+        associate(obj => compound_obj_t(initial_sub_obj))
+            if (obj%sub_obj%val .ne. 42) stop 1
+        end associate
+    end associate
+end program
diff --git a/gcc/testsuite/gfortran.dg/pr102112.f90 b/gcc/testsuite/gfortran.dg/pr102112.f90
new file mode 100644
index 00000000000..cde9cbf52e2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr102112.f90
@@ -0,0 +1,23 @@
+! { dg-do run }
+!
+! Contributed by Brad Richardson  <everythingfunctional@protonmail.com>
+!
+program main
+    implicit none
+
+    type :: sub_t
+        integer :: val
+    end type
+
+    type :: obj_t
+        type(sub_t) :: sub_obj
+    end type
+
+    associate(initial_sub => sub_t(42))
+        associate(obj => obj_t(initial_sub))
+            associate(sub_obj => obj%sub_obj)
+                if (sub_obj%val .ne. 42) stop 1
+            end associate
+        end associate
+    end associate
+end program
diff --git a/gcc/testsuite/gfortran.dg/pr102190.f90 b/gcc/testsuite/gfortran.dg/pr102190.f90
new file mode 100644
index 00000000000..48968430161
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr102190.f90
@@ -0,0 +1,74 @@
+! { dg-do run }
+!
+! Contributed by Brad Richardson  <everythingfunctional@protonmail.com>
+!
+module sub_m
+    type :: sub_t
+        private
+        integer :: val
+    end type
+
+    interface sub_t
+        module procedure constructor
+    end interface
+
+    interface sub_t_val
+        module procedure t_val
+    end interface
+contains
+    function constructor(val) result(sub)
+        integer, intent(in) :: val
+        type(sub_t) :: sub
+
+        sub%val = val
+    end function
+
+    function t_val(val) result(res)
+        integer :: res
+        type(sub_t), intent(in) :: val
+        res = val%val
+    end function
+end module
+
+module obj_m
+    use sub_m, only: sub_t
+    type :: obj_t
+        private
+        type(sub_t) :: sub_obj_
+    contains
+        procedure :: sub_obj
+    end type
+
+    interface obj_t
+        module procedure constructor
+    end interface
+contains
+    function constructor(sub_obj) result(obj)
+        type(sub_t), intent(in) :: sub_obj
+        type(obj_t) :: obj
+
+        obj%sub_obj_ = sub_obj
+    end function
+
+    function sub_obj(self)
+        class(obj_t), intent(in) :: self
+        type(sub_t) :: sub_obj
+
+        sub_obj = self%sub_obj_
+    end function
+end module
+
+program main
+    use sub_m, only: sub_t, sub_t_val
+    use obj_m, only: obj_t
+    type(sub_t), allocatable :: z
+
+    associate(initial_sub => sub_t(42))
+        associate(obj => obj_t(initial_sub))
+            associate(sub_obj => obj%sub_obj())
+              allocate (z, source = obj%sub_obj())
+            end associate
+        end associate
+    end associate
+    if (sub_t_val (z) .ne. 42) stop 1
+end program
diff --git a/gcc/testsuite/gfortran.dg/pr102532.f90 b/gcc/testsuite/gfortran.dg/pr102532.f90
new file mode 100644
index 00000000000..714379a6ac2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr102532.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+subroutine foo
+   character(:), allocatable :: x[:]
+   associate (y => x(:)(2:)) ! { dg-error "Rank mismatch|deferred type parameter" }
+   end associate
+end
+
+subroutine bar
+   character(:), allocatable :: x[:]
+   associate (y => x(:)(:)) ! { dg-error "Rank mismatch|deferred type parameter" }
+   end associate
+end
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/pr109948.f90 b/gcc/testsuite/gfortran.dg/pr109948.f90
new file mode 100644
index 00000000000..4d963539396
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr109948.f90
@@ -0,0 +1,114 @@
+! { dg-do run }
+!
+! Tests the fix for PR109948
+!
+! Contributed by Rimvydas Jasinskas <rimvydas.jas@gmail.com>
+!
+module mm
+  implicit none
+  interface operator(==)
+    module procedure eq_1_2
+  end interface operator(==)
+  private :: eq_1_2
+contains
+  logical function eq_1_2 (x, y)
+    integer, intent(in) :: x(:)
+    real,    intent(in) :: y(:,:)
+    eq_1_2 = .true.
+  end function eq_1_2
+end module mm
+
+program pr109948
+  use mm
+  implicit none
+  type tlap
+    integer,    allocatable :: z(:)
+  end type tlap
+  type ulap
+    type(tlap) :: u(2)
+  end type ulap
+  integer :: pid = 1
+  call comment0         ! Original problem
+  call comment1
+  call comment3 ([5,4,3,2,1])
+  call comment10
+  call comment11 ([5,4,3,2,1])
+contains
+  subroutine comment0
+    type(tlap) :: y_in
+    integer :: x_out(3) =[0.0,0.0,0.0]
+    y_in%z = [1,-2,3]
+    call foo(y_in, x_out)
+    if (any (x_out .ne. [0, -2, 0])) stop 1
+    call foo(y_in, x_out)
+    if (any (x_out .ne. [1, -2, 3])) stop 2
+  end subroutine comment0
+
+  subroutine foo(y, x)
+    type(tlap) :: y
+    integer :: x(:)
+    associate(z=>y%z)
+      if (pid == 1) then
+        where ( z < 0 ) x(:) = z(:)
+      else
+        where ( z > 0 ) x(:) = z(:)
+    endif
+    pid = pid + 1
+    end associate
+  end subroutine foo
+
+  subroutine comment1
+    type(tlap) :: grib
+    integer :: i
+    grib%z = [3,2,1]
+    associate(k=>grib%z)
+      i = k(1)
+      if (any(k==1)) i = 1
+    end associate
+    if (i .eq. 3) stop 3
+  end subroutine comment1
+
+  subroutine comment3(k_2d)
+    implicit none
+    integer :: k_2d(:)
+    integer :: i
+    associate(k=>k_2d)
+      i = k(1)
+      if (any(k==1)) i = 1
+    end associate
+    if (i .eq. 3) stop 4
+  end subroutine comment3
+
+  subroutine comment11(k_2d)
+    implicit none
+    integer :: k_2d(:)
+    integer :: m(1) = 42
+    real    :: r(1,1) = 3.0
+    if ((m == r) .neqv. .true.) stop 5
+    associate (k=>k_2d)
+      if ((k == r) .neqv. .true.) stop 6  ! failed to find user defined operator
+    end associate
+    associate (k=>k_2d(:))
+      if ((k == r) .neqv. .true.) stop 7
+    end associate
+  end subroutine comment11
+
+  subroutine comment10
+    implicit none
+    type(ulap) :: z(2)
+    integer :: i
+    real    :: r(1,1) = 3.0
+    z(1)%u = [tlap([1,2,3]),tlap([4,5,6])]
+    z(2)%u = [tlap([7,8,9]),tlap([10,11,12])]
+    associate (k=>z(2)%u(1)%z)
+      i = k(1)
+      if (any(k==8)) i = 1
+    end associate
+    if (i .ne. 1) stop 8
+    associate (k=>z(1)%u(2)%z)
+      if ((k == r) .neqv. .true.) stop 9
+      if (any (k .ne. [4,5,6])) stop 10
+    end associate
+  end subroutine comment10
+end program pr109948
+
diff --git a/gcc/testsuite/gfortran.dg/pr99326.f90 b/gcc/testsuite/gfortran.dg/pr99326.f90
new file mode 100644
index 00000000000..75d1f50c238
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr99326.f90
@@ -0,0 +1,26 @@
+! { dg-do compile }
+! internal compiler error: in gfc_build_dummy_array_decl, at
+! fortran/trans-decl.cc:1317
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+program p
+   type t0
+     integer :: i
+   end type
+   type t
+      class(t0), allocatable :: a(:)
+   end type
+   class(t0), allocatable :: arg(:)
+   allocate (arg, source = [t0(1), t0(2)])
+   call s(arg)
+contains
+   subroutine s(x)
+      class(t0) :: x(:)
+      type(t) :: z
+      associate (y => x)
+         z%a = y
+      end associate
+   if (size(z%a) .ne. 2) stop 1
+   end
+end

[-- Attachment #3: Change109948.Logs --]
[-- Type: application/octet-stream, Size: 922 bytes --]

Fortran: Fix some problems blocking associate meta-bug [PR87477]

2023-06-01  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/87477
	* parse.cc (parse_associate): Replace the existing evaluation
	of the target rank with calls to gfc_resolve_ref and
	gfc_expression_rank. Identify untyped target function results
	with structure constructors by finding the appropriate derived
	type.
	* resolve.cc (resolve_symbol): Allow associate variables to be
	assumed shape.

gcc/testsuite/
	PR fortran/87477
	* gfortran.dg/associate_54.f90 : Cope with extra error.

	PR fortran/102109
	* gfortran.dg/pr102109.f90 : New test.

	PR fortran/102112
	* gfortran.dg/pr102112.f90 : New test.

	PR fortran/102190
	* gfortran.dg/pr102190.f90 : New test.

	PR fortran/102532
	* gfortran.dg/pr102532.f90 : New test.

	PR fortran/109948
	* gfortran.dg/pr109948.f90 : New test.

	PR fortran/99326
	* gfortran.dg/pr99326.f90 : New test.