Hi Tobias,
â Can you add also a testcase that which triggers the error message you
> see in the unpatched class_assign_4.f90?
> > I was unable to find a way to use a typebound operator with a polymorphic
> > result
> I am confused â the attach testcase does seem to work fine with current
> GCC. (And if we don't have such a testcase, it should be added.)
> Can you elaborate?
>
The polymorphic result must be allocatable or pointer for the dynamic type
to be transmitted. This means that the function cannot be elemental. If the
result of the non-elemental function is an array, gfc responds with:
"Error: Passed-object dummy argument of âfâ at (1) must be scalar"
If the procedure declaration is made nopass, the response is:
"Type-bound operator at (1) cannot be NOPASS"
See the attached elemental_result_2.f90, which tests the new error message.
>From these points, I concluded that a typebound operator could not provide
the required polymorphic array result. If I am wrong about this, please let
me know and I will change the patch accordingly.
The interface operator does not have these constraints and so was
implemented in class_assign_4.f90.
The patch itself LGTM, except for testing the newly shown error message
> and for the confusion about the type-bound operator.
>
All done. Note that the patch has changed slightly in resolve.c because
(1) it was the wrong version and (2) it sporadically segfaulted at line
13240.
Thanks
Paul
! { dg-do compile }
!
! Test part of the fix for PR99124 which adds errors for class results
! That violate F2018, C15100.
!
! Contributed by Gerhard Steinmetz <[email protected]>
!
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
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 11b5dbc7a03..de62266e96b 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,15 @@ 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 c346183e129..c6725659093 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 517e3121cc8..c6c54bbaed2 100644
--- a/gcc/testsuite/gfortran.dg/class_assign_4.f90
+++ b/gcc/testsuite/gfortran.dg/class_assign_4.f90
@@ -11,17 +11,21 @@ module m
type :: t1
integer :: i
CONTAINS
- PROCEDURE :: add_t1
- GENERIC :: OPERATOR(+) => add_t1
+! 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)
