From: Kelvin Li <kli@ca.ibm.com>
Date: Thu, 15 Dec 2022 16:59:08 +0000 (-0500)
Subject: [flang] Semantic-check for procedure pointers with assumed character length
X-Git-Tag: upstream/17.0.6~23668
X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=7fdd0c00e0ab030b64618778c24dc329ce3d1535;p=platform%2Fupstream%2Fllvm.git

[flang] Semantic-check for procedure pointers with assumed character length

Fixes: https://github.com/llvm/llvm-project/issues/59496

Committed on behalf of tislam

Differential Revision: https://reviews.llvm.org/D139333
---

diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 6424325dbcef..2913b7a51d88 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -353,6 +353,9 @@ void CheckHelper::Check(const Symbol &symbol) {
         messages_.Say(
             "An assumed-length CHARACTER(*) function cannot return a POINTER"_err_en_US);
       }
+    } else if (IsPointer(symbol)) {
+      messages_.Say(
+          "A procedure pointer should not have assumed-length CHARACTER(*) result type"_port_en_US);
     }
   }
   if (symbol.attrs().test(Attr::VALUE)) {
diff --git a/flang/test/Semantics/call01.f90 b/flang/test/Semantics/call01.f90
index 1b31053e6f79..714769263c0b 100644
--- a/flang/test/Semantics/call01.f90
+++ b/flang/test/Semantics/call01.f90
@@ -119,9 +119,11 @@ function f14(n) result(res)
 end function
 
 subroutine s01(f1, f2, fp1, fp2)
+  !PORTABILITY: A procedure pointer should not have assumed-length CHARACTER(*) result type
   character*(*) :: f1, f3, fp1
   external :: f1, f3
   pointer :: fp1
+  !PORTABILITY: A procedure pointer should not have assumed-length CHARACTER(*) result type
   procedure(character*(*)), pointer :: fp2
   interface
     character*(*) function f2()
diff --git a/flang/test/Semantics/call31.f90 b/flang/test/Semantics/call31.f90
new file mode 100644
index 000000000000..16c7344d48cb
--- /dev/null
+++ b/flang/test/Semantics/call31.f90
@@ -0,0 +1,34 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -Werror
+! Confirm enforcement of constraint C723 in F2018 for procedure pointers
+
+      module m
+       contains
+        subroutine subr(parg)
+          !PORTABILITY: A procedure pointer should not have assumed-length CHARACTER(*) result type
+          procedure(character(*)), pointer :: parg
+          !PORTABILITY: A procedure pointer should not have assumed-length CHARACTER(*) result type
+          procedure(character(*)), pointer :: plocal
+          print *, parg()
+          plocal => parg
+          call subr_1(plocal)
+        end subroutine
+
+        subroutine subr_1(parg_1)
+          !PORTABILITY: A procedure pointer should not have assumed-length CHARACTER(*) result type
+          procedure(character(*)), pointer :: parg_1
+          print *, parg_1()
+        end subroutine
+      end module
+
+      character(*) function f()
+        f = 'abcdefgh'
+      end function
+
+      program test
+        use m
+        character(4), external :: f
+        procedure(character(4)), pointer :: p
+        p => f
+        call subr(p)
+      end
+