From: Paul Thomas Date: Tue, 23 Feb 2021 19:29:04 +0000 (+0000) Subject: Fortran: Fix for class defined operators [PR99124]. X-Git-Tag: basepoints/gcc-12~908 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=29a5298955f777c539c628f51e78b75d8e586c44;p=thirdparty%2Fgcc.git Fortran: Fix for class defined operators [PR99124]. 2021-02-23 Paul Thomas 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. --- diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 11b5dbc7a033..2a91ae743eaa 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 c346183e1299..c67256590935 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 517e3121cc81..2a77d8111b57 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 000000000000..b7d53b84e2a2 --- /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 +! +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 000000000000..490c2ef68de0 --- /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 +! +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