Fortran: Fix problems with class array function selectors [PR112834]

2023-12-16  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/112834
	* match.cc (build_associate_name): Fix whitespace issues.
	(select_type_set_tmp): If the selector is of unknown type, go
	the SELECT TYPE selector to see if this is a function and, if
	the result is available, use its typespec.
	* parse.cc (parse_associate): Again, use the function result if
	the type of the selector result is unknown.
	* trans-stmt.cc (trans_associate_var): The expression has to be
	of type class, for class_target to be true. Convert and fix
	class functions. Pass the fixed expression.

	PR fortran/111853
	* resolve.cc (gfc_expression_rank): Avoid null dereference.

gcc/testsuite/
	PR fortran/112834
	* gfortran.dg/associate_63.f90 : New test.

	PR fortran/111853
	* gfortran.dg/pr111853.f90 : New test.

6 files changed, 109 insertions, 6 deletions

diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 9e3571d..df9adb3 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -6436,9 +6436,9 @@ build_associate_name (const char *name, gfc_expr **e1, gfc_expr **e2)
 
   sym = expr1->symtree->n.sym;
   if (expr2->ts.type == BT_UNKNOWN)
-      sym->attr.untyped = 1;
+    sym->attr.untyped = 1;
   else
-  copy_ts_from_selector_to_associate (expr1, expr2);
+    copy_ts_from_selector_to_associate (expr1, expr2);
 
   sym->attr.flavor = FL_VARIABLE;
   sym->attr.referenced = 1;
@@ -6527,6 +6527,7 @@ select_type_set_tmp (gfc_typespec *ts)
   gfc_symtree *tmp = NULL;
   gfc_symbol *selector = select_type_stack->selector;
   gfc_symbol *sym;
+  gfc_expr *expr2;
 
   if (!ts)
     {
@@ -6550,7 +6551,20 @@ select_type_set_tmp (gfc_typespec *ts)
       sym = tmp->n.sym;
       gfc_add_type (sym, ts, NULL);
 
-      if (selector->ts.type == BT_CLASS && selector->attr.class_ok
+      /* If the SELECT TYPE selector is a function we might be able to obtain
+	 a typespec from the result. Since the function might not have been
+	 parsed yet we have to check that there is indeed a result symbol.  */
+      if (selector->ts.type == BT_UNKNOWN
+	  && gfc_state_stack->construct
+
+	  && (expr2 = gfc_state_stack->construct->expr2)
+	  && expr2->expr_type == EXPR_FUNCTION
+	  && expr2->symtree
+	  && expr2->symtree->n.sym && expr2->symtree->n.sym->result)
+	selector->ts = expr2->symtree->n.sym->result->ts;
+
+      if (selector->ts.type == BT_CLASS
+	  && selector->attr.class_ok
 	  && selector->ts.u.derived && CLASS_DATA (selector))
 	{
 	  sym->attr.pointer
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 9b4c392..042a6ad 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5136,7 +5136,7 @@ parse_associate (void)
   gfc_current_ns = my_ns;
   for (a = new_st.ext.block.assoc; a; a = a->next)
     {
-      gfc_symbol* sym;
+      gfc_symbol *sym, *tsym;
       gfc_expr *target;
       int rank;
 
@@ -5200,6 +5200,16 @@ parse_associate (void)
 	      sym->ts.type = BT_DERIVED;
 	      sym->ts.u.derived = derived;
 	    }
+	  else if (target->symtree && (tsym = target->symtree->n.sym))
+	    {
+	      sym->ts = tsym->result ? tsym->result->ts : tsym->ts;
+	      if (sym->ts.type == BT_CLASS)
+		{
+		  if (CLASS_DATA (sym)->as)
+		    target->rank = CLASS_DATA (sym)->as->rank;
+		  sym->attr.class_ok = 1;
+		}
+	    }
 	}
 
       rank = target->rank;
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 4fe0e72..2925f7d 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5669,7 +5669,7 @@ gfc_expression_rank (gfc_expr *e)
       if (ref->type != REF_ARRAY)
 	continue;
 
-      if (ref->u.ar.type == AR_FULL)
+      if (ref->u.ar.type == AR_FULL && ref->u.ar.as)
 	{
 	  rank = ref->u.ar.as->rank;
 	  break;
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 5530e89..517b7aa 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -1746,6 +1746,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
   e = sym->assoc->target;
 
   class_target = (e->expr_type == EXPR_VARIABLE)
+		    && e->ts.type == BT_CLASS
 		    && (gfc_is_class_scalar_expr (e)
 			|| gfc_is_class_array_ref (e, NULL));
 
@@ -2037,7 +2038,12 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 
       /* Class associate-names come this way because they are
 	 unconditionally associate pointers and the symbol is scalar.  */
-      if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
+      if (sym->ts.type == BT_CLASS && e->expr_type == EXPR_FUNCTION)
+	{
+	  gfc_conv_expr (&se, e);
+	  se.expr = gfc_evaluate_now (se.expr, &se.pre);
+	}
+      else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
 	{
 	  tree target_expr;
 	  /* For a class array we need a descriptor for the selector.  */
diff --git a/gcc/testsuite/gfortran.dg/associate_63.f90 b/gcc/testsuite/gfortran.dg/associate_63.f90
new file mode 100644
index 0000000..67c7559
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_63.f90
@@ -0,0 +1,57 @@
+! { dg-do run }
+!
+! Test the fix for PR112834 in which class array function selectors caused
+! problems for both ASSOCIATE and SELECT_TYPE.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+module m
+  implicit none
+  type t
+    integer :: i = 0
+  end type t
+  integer :: i = 0
+  type(t), parameter :: test_array (2) = [t(42),t(84)], &
+                        test_scalar = t(99)
+end module m
+module class_selectors
+  use m
+  implicit none
+  private
+  public foo2
+contains
+  function bar3() result(res)
+    class(t), allocatable :: res(:)
+    allocate (res, source = test_array)
+  end
+
+  subroutine foo2()
+    associate (var1 => bar3())
+      if (any (var1%i .ne. test_array%i)) stop 1
+      if (var1(2)%i .ne. test_array(2)%i) stop 2
+      associate (zzz3 => var1%i)
+        if (any (zzz3 .ne. test_array%i)) stop 3
+        if (zzz3(2) .ne. test_array(2)%i) stop 4
+      end associate
+      select type (x => var1)
+        type is (t)
+          if (any (x%i .ne. test_array%i)) stop 5
+          if (x(2)%i .ne. test_array(2)%i) stop 6
+        class default
+          stop 7
+      end select
+    end associate
+
+    select type (y => bar3 ())
+      type is (t)
+        if (any (y%i .ne. test_array%i)) stop 8
+        if (y(2)%i .ne. test_array(2)%i) stop 9
+       class default
+        stop 10
+    end select
+  end subroutine foo2
+end module class_selectors
+
+  use class_selectors
+  call foo2
+end
diff --git a/gcc/testsuite/gfortran.dg/pr111853.f90 b/gcc/testsuite/gfortran.dg/pr111853.f90
new file mode 100644
index 0000000..8f0b266
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr111853.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+!
+! A null dereference fixed
+!
+! Contributed by Daniel Otero  <canu7@yahoo.es>
+!
+subroutine foo (rvec)
+  TYPE vec_rect_2D_real_acc
+    INTEGER :: arr
+  END TYPE
+  CLASS(vec_rect_2D_real_acc)  rvec
+
+  ASSOCIATE (arr=>rvec%arr)
+    call bar(arr*arr)
+  end associate
+end