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))
/* 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 "
&& 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;
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)
--- /dev/null
+! { 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
--- /dev/null
+! { 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