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.

diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 9e3571d3dbe29ee9130453b23c237ed5080557d1..df9adb359a00dca5fa0b8923e6d955bac881d160 100644 (file)
--- 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 9b4c39274bea3cde0a5699e38f3c23fdcbfbc684..042a6ad5e599b185c1f2c11e2005e781aa69cbb2 100644 (file)
--- 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 4fe0e7202e5d0fa2edbe7a99fcb1354bfcb12d53..2925f7da28c9ee4a083f18afb55954d43cced7f8 100644 (file)
--- 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 5530e893a620d126eedeaae50909ec99c87cb350..517b7aaa898d9a671374066c5407eb94ae037b82 100644 (file)
--- 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 (file)
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 (file)
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