{Patch, fortran] PR112834 - Class array function selector causes chain of syntax and other spurious errors

{Patch, fortran] PR112834 - Class array function selector causes chain of syntax and other spurious errors

[Paul Richard Thomas]

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

Dear All,

This patch was rescued from my ill-fated and long winded attempt to provide
a fix-up for function selector references, where the function is parsed
after the procedure containing the associate/select type construct (PRs
89645 and 99065). The fix-ups broke down completely once these constructs
were enclosed by another associate construct, where the selector is a
derived type or class function. My inclination now is to introduce two pass
parsing for contained procedures.

Returning to PR112834, the patch is simple enough and is well described by
the change logs. PR111853 was fixed as a side effect of the bigger patch.
Steve Kargl had also posted the same fix on the PR.

Regression tests - OK for trunk and 13-branch?

Paul

[-- Attachment #2: Change.Logs --]
[-- Type: application/octet-stream, Size: 877 bytes --]

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

2023-12-06  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.

[-- Attachment #3: fix.diff --]
[-- Type: text/x-patch, Size: 3946 bytes --]

diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 9e3571d3dbe..cecd2940dcf 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,19 @@ 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 abd3a424f38..c1fa751d0e8 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5131,7 +5131,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;

@@ -5195,6 +5195,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 166b702cd9a..92678b816a1 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 50b71e67234..b70c079fc55 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.  */

[-- Attachment #4: associate_63.f90 --]
[-- Type: text/x-fortran, Size: 1399 bytes --]

! { 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

[-- Attachment #5: pr111853.f90 --]
[-- Type: text/x-fortran, Size: 288 bytes --]

! { 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

Re: {Patch, fortran] PR112834 - Class array function selector causes chain of syntax and other spurious errors

[Jerry D]

On 12/6/23 8:09 AM, Paul Richard Thomas wrote:
> Dear All,
> 
> This patch was rescued from my ill-fated and long winded attempt to 
> provide a fix-up for function selector references, where the function is 
> parsed after the procedure containing the associate/select type 
> construct (PRs 89645 and 99065). The fix-ups broke down completely once 
> these constructs were enclosed by another associate construct, where the 
> selector is a derived type or class function. My inclination now is to 
> introduce two pass parsing for contained procedures.
> 
> Returning to PR112834, the patch is simple enough and is well described 
> by the change logs. PR111853 was fixed as a side effect of the bigger 
> patch. Steve Kargl had also posted the same fix on the PR.
> 
> Regression tests - OK for trunk and 13-branch?
> 
> Paul
> 

Hi Paul, I am taking a crack at this. It looks reasonable to me. 
Certainly OK for trunk, and then, if no fallout, 13 at your discretion.

Regards,

Jerry

Re: {Patch, fortran] PR112834 - Class array function selector causes chain of syntax and other spurious errors

[Harald Anlauf]

Hi Paul,

On 12/6/23 17:09, Paul Richard Thomas wrote:
> Dear All,
>
> This patch was rescued from my ill-fated and long winded attempt to provide
> a fix-up for function selector references, where the function is parsed
> after the procedure containing the associate/select type construct (PRs
> 89645 and 99065). The fix-ups broke down completely once these constructs
> were enclosed by another associate construct, where the selector is a
> derived type or class function. My inclination now is to introduce two pass
> parsing for contained procedures.
>
> Returning to PR112834, the patch is simple enough and is well described by
> the change logs. PR111853 was fixed as a side effect of the bigger patch.
> Steve Kargl had also posted the same fix on the PR.

the patch looks good, but could you please check the coding style?

@@ -6550,7 +6551,19 @@ 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)

Adding a line break before the second '&&' makes it more readable.

+	selector->ts = expr2->symtree->n.sym->result->ts;

@@ -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)

There should be whitespace before AND after '=='.

+	{
+	  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)

> Regression tests - OK for trunk and 13-branch?
>
> Paul
>

Thanks for the patch!

Harald

Re: {Patch, fortran] PR112834 - Class array function selector causes chain of syntax and other spurious errors

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 3698 bytes --]

Hi Harald,

(Written 17th but left in intray by mistake.)

Thanks for the review. I will make sure that the intended changes are
incorporated.

I haven't applied it yet because I was so heavily engaged in trying to make
two pass parsing work that I didn't want the interruption. As it happens,
it was obvious by yesterday that it was going to be considerably more
difficult than I anticipated. I have posted the patch to PR89645, together
with a list of testsuite failures. Many of these are so obscure that I
didn't have any idea how to put them right. I reverted to the fix-up patch
and, having come at it with fresh eyes, have fixed the problems that I was
having with it. It is regesting as I write.

My order of work between now and the Christmas break is:
1] Apply the agreed patch for PR112459; -now done
2]               -ditto-               for PR112834; -now done
3] Generate testcases for PR89645 and all its variants (especially with
class replacing derived types); and
4] Prepare the whole lot for submission to the list.

My local test for PR87477 now shows " 43 successes out of  43 tests" :-)

Regards

Paul


On Wed, 6 Dec 2023 at 19:35, Harald Anlauf <anlauf@gmx.de> wrote:

> Hi Paul,
>
> On 12/6/23 17:09, Paul Richard Thomas wrote:
> > Dear All,
> >
> > This patch was rescued from my ill-fated and long winded attempt to
> provide
> > a fix-up for function selector references, where the function is parsed
> > after the procedure containing the associate/select type construct (PRs
> > 89645 and 99065). The fix-ups broke down completely once these constructs
> > were enclosed by another associate construct, where the selector is a
> > derived type or class function. My inclination now is to introduce two
> pass
> > parsing for contained procedures.
> >
> > Returning to PR112834, the patch is simple enough and is well described
> by
> > the change logs. PR111853 was fixed as a side effect of the bigger patch.
> > Steve Kargl had also posted the same fix on the PR.
>
> the patch looks good, but could you please check the coding style?
>
> @@ -6550,7 +6551,19 @@ 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)
>
> Adding a line break before the second '&&' makes it more readable.
>
> +       selector->ts = expr2->symtree->n.sym->result->ts;
>
> @@ -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)
>
> There should be whitespace before AND after '=='.
>
> +       {
> +         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)
>
> > Regression tests - OK for trunk and 13-branch?
> >
> > Paul
> >
>
> Thanks for the patch!
>
> Harald
>
>