[gcc r9-9249] Fortran: Fix for class defined operators [PR99124].
Paul Thomas
pault@gcc.gnu.org
Wed Feb 24 12:14:43 GMT 2021
https://gcc.gnu.org/g:cd34d8b7b50f0f3592deb76983191c3d9a5dbcb9
commit r9-9249-gcd34d8b7b50f0f3592deb76983191c3d9a5dbcb9
Author: Paul Thomas <pault@gcc.gnu.org>
Date: Tue Feb 23 19:29:04 2021 +0000
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.
(cherry picked from commit 29a5298955f777c539c628f51e78b75d8e586c44)
Diff:
---
gcc/fortran/resolve.c | 11 +++++++-
gcc/fortran/trans-array.c | 7 +++--
gcc/testsuite/gfortran.dg/class_assign_4.f90 | 12 ++++----
.../gfortran.dg/class_defined_operator_2.f03 | 31 ++++++++++++++++++++
gcc/testsuite/gfortran.dg/elemental_result_2.f90 | 33 ++++++++++++++++++++++
5 files changed, 86 insertions(+), 8 deletions(-)
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 6b308276e49..764020cfe09 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -12636,6 +12636,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))
@@ -12816,8 +12817,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 723e8360f59..c6efe95e236 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -1236,8 +1236,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..2a77d8111b5 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 00000000000..b7d53b84e2a
--- /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 00000000000..490c2ef68de
--- /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
More information about the Gcc-cvs
mailing list