Dear all,
Fortran allows functions in variable definition contexts when the
result variable is a pointer. We already handle this for the
non-CLASS case (in 11+), but the logic that checks the pointer
attribute was looking in the wrong place for the CLASS case.
Once found, the fix is simple and obvious, see attached patch.
Regtested on x86_64-pc-linux-gnu. OK for mainline?
Thanks,
Harald
From 6406f19855a3b664597d75369f0935d3d31384dc Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
Date: Sun, 14 May 2023 21:53:51 +0200
Subject: [PATCH] Fortran: CLASS pointer function result in variable definition
context [PR109846]
gcc/fortran/ChangeLog:
PR fortran/109846
* expr.cc (gfc_check_vardef_context): Check appropriate pointer
attribute for CLASS vs. non-CLASS function result in variable
definition context.
gcc/testsuite/ChangeLog:
PR fortran/109846
* gfortran.dg/ptr-func-5.f90: New test.
---
gcc/fortran/expr.cc | 2 +-
gcc/testsuite/gfortran.dg/ptr-func-5.f90 | 39 ++++++++++++++++++++++++
2 files changed, 40 insertions(+), 1 deletion(-)
create mode 100644 gcc/testsuite/gfortran.dg/ptr-func-5.f90
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index d91722e6ac6..09a16c9b367 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -6256,7 +6256,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
&& !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result)
&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer)
&& !(sym->attr.flavor == FL_PROCEDURE
- && sym->attr.function && sym->attr.pointer))
+ && sym->attr.function && attr.pointer))
{
if (context)
gfc_error ("%qs in variable definition context (%s) at %L is not"
diff --git a/gcc/testsuite/gfortran.dg/ptr-func-5.f90 b/gcc/testsuite/gfortran.dg/ptr-func-5.f90
new file mode 100644
index 00000000000..05fd56703ca
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ptr-func-5.f90
@@ -0,0 +1,39 @@
+! { dg-do compile }
+! PR fortran/109846
+! CLASS pointer function result in variable definition context
+
+module foo
+ implicit none
+ type :: parameter_list
+ contains
+ procedure :: sublist, sublist_nores
+ end type
+contains
+ function sublist (this) result (slist)
+ class(parameter_list), intent(inout) :: this
+ class(parameter_list), pointer :: slist
+ allocate (slist)
+ end function
+ function sublist_nores (this)
+ class(parameter_list), intent(inout) :: this
+ class(parameter_list), pointer :: sublist_nores
+ allocate (sublist_nores)
+ end function
+end module
+
+program example
+ use foo
+ implicit none
+ type(parameter_list) :: plist
+ call sub1 (plist%sublist())
+ call sub1 (plist%sublist_nores())
+ call sub2 (plist%sublist())
+ call sub2 (plist%sublist_nores())
+contains
+ subroutine sub1 (plist)
+ type(parameter_list), intent(inout) :: plist
+ end subroutine
+ subroutine sub2 (plist)
+ type(parameter_list) :: plist
+ end subroutine
+end program
--
2.35.3
