Fortran: Fix for class defined operators [PR99124].

2021-02-23  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/99124
	* resolve.c (resolve_fl_procedure): Include class results in
	the test for F2018, C15100.
	* trans-array.c (get_class_info_from_ss): Do not use the saved
	descriptor to obtain the class expression for variables. Use
	gfc_get_class_from_expr instead.

gcc/testsuite/
	PR fortran/99124
	* gfortran.dg/class_defined_operator_2.f03 : New test.
	* gfortran.dg/elemental_result_2.f90 : New test.
	* gfortran.dg/class_assign_4.f90: Correct the non-conforming
	elemental function with an allocatable result with an operator
	interface with array dummies and result.

5 files changed, 86 insertions, 8 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 11b5dbc..2a91ae7 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -13051,6 +13051,7 @@ static bool
 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
 {
   gfc_formal_arglist *arg;
+  bool allocatable_or_pointer;
 
   if (sym->attr.function
       && !resolve_fl_var_and_proc (sym, mp_flag))
@@ -13235,8 +13236,16 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
   /* F2018, C15100: "The result of an elemental function shall be scalar,
      and shall not have the POINTER or ALLOCATABLE attribute."  The scalar
      pointer is tested and caught elsewhere.  */
+  if (sym->result)
+    allocatable_or_pointer = sym->result->ts.type == BT_CLASS
+			     && CLASS_DATA (sym->result) ?
+			     (CLASS_DATA (sym->result)->attr.allocatable
+			      || CLASS_DATA (sym->result)->attr.pointer) :
+			     (sym->result->attr.allocatable
+			      || sym->result->attr.pointer);
+
   if (sym->attr.elemental && sym->result
-      && (sym->result->attr.allocatable || sym->result->attr.pointer))
+      && allocatable_or_pointer)
     {
       gfc_error ("Function result variable %qs at %L of elemental "
 		 "function %qs shall not have an ALLOCATABLE or POINTER "
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index c346183..c672565 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -1167,8 +1167,11 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
       && rhs_ss->info->expr->ts.type == BT_CLASS
       && rhs_ss->info->data.array.descriptor)
     {
-      rhs_class_expr
-	= gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
+      if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
+	rhs_class_expr
+	  = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
+      else
+	rhs_class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
       unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
       if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
 	rhs_function = true;
diff --git a/gcc/testsuite/gfortran.dg/class_assign_4.f90 b/gcc/testsuite/gfortran.dg/class_assign_4.f90
index 517e312..2a77d81 100644
--- a/gcc/testsuite/gfortran.dg/class_assign_4.f90
+++ b/gcc/testsuite/gfortran.dg/class_assign_4.f90
@@ -11,17 +11,19 @@ module m
   type :: t1
     integer :: i
   CONTAINS
-    PROCEDURE :: add_t1
-    GENERIC :: OPERATOR(+) => add_t1
   end type
   type, extends(t1) :: t2
     real :: r
   end type
 
+  interface operator(+)
+    module procedure add_t1
+  end interface
+
 contains
-  impure elemental function add_t1 (a, b) result (c)
-    class(t1), intent(in) :: a, b
-    class(t1), allocatable :: c
+  function add_t1 (a, b) result (c)
+    class(t1), intent(in) :: a(:), b(:)
+    class(t1), allocatable :: c(:)
     allocate (c, source = a)
     c%i = a%i + b%i
     select type (c)
diff --git a/gcc/testsuite/gfortran.dg/class_defined_operator_2.f03 b/gcc/testsuite/gfortran.dg/class_defined_operator_2.f03
new file mode 100644
index 0000000..b7d53b8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_defined_operator_2.f03
@@ -0,0 +1,31 @@
+! { dg-do run }
+!
+! Test the fix for PR99124 which used to ICE as shown.
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+module m
+   type t
+      integer :: i
+   contains
+      procedure :: f
+      generic :: operator(+) => f
+   end type
+contains
+   elemental function f(a, b) result(c)
+      class(t), intent(in) :: a, b
+      type(t) :: c
+      c = t(a%i + b%i)
+   end
+end
+program p
+   use m
+   class(t), allocatable :: x(:), y(:), z
+   allocate (x, source = [t(1), t(2)])
+   allocate (y, source = [t(1), t(2)])
+   x = x(2) + y                               ! ICE
+   if (any (x%i .ne. [3, 4])) stop 1
+   z = x(1)
+   x = z + y                                  ! ICE
+   if (any (x%i .ne. [4, 5])) stop 2
+end
diff --git a/gcc/testsuite/gfortran.dg/elemental_result_2.f90 b/gcc/testsuite/gfortran.dg/elemental_result_2.f90
new file mode 100644
index 0000000..490c2ef
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/elemental_result_2.f90
@@ -0,0 +1,33 @@
+! { dg-do compile }
+!
+! Test part of the fix for PR99124 which adds errors for class results
+! That violate F2018, C15100.
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+module m
+   type t
+      integer :: i
+   contains
+      procedure :: f
+      generic :: operator(+) => f
+   end type
+contains
+   elemental function f(a, b) &
+   result(c)                     ! { dg-error "shall not have an ALLOCATABLE or POINTER attribute" }
+      class(t), intent(in) :: a, b
+      class(t), allocatable :: c
+      c = t(a%i + b%i)
+   end
+   elemental function g(a, b) &
+   result(c)                     ! { dg-error "shall not have an ALLOCATABLE or POINTER attribute" }
+      class(t), intent(in) :: a, b
+      class(t), pointer :: c
+      c => null ()
+   end
+   elemental function h(a, b) &  ! { dg-error "must have a scalar result" }
+   result(c)                     ! { dg-error "must be dummy, allocatable or pointer" }
+      class(t), intent(in) :: a, b
+      class(t) :: c(2)
+   end
+end