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

[Kelvin Li via flang-commits]

Author: Kelvin Li
Date: 2022-12-15T13:36:41-05:00
New Revision: 7fdd0c00e0ab030b64618778c24dc329ce3d1535

URL: https://github.com/llvm/llvm-project/commit/7fdd0c00e0ab030b64618778c24dc329ce3d1535
DIFF: https://github.com/llvm/llvm-project/commit/7fdd0c00e0ab030b64618778c24dc329ce3d1535.diff

LOG: [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

Added: 
    flang/test/Semantics/call31.f90

Modified: 
    flang/lib/Semantics/check-declarations.cpp
    flang/test/Semantics/call01.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 6424325dbcef2..2913b7a51d887 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 1b31053e6f79c..714769263c0b2 100644
--- a/flang/test/Semantics/call01.f90
+++ b/flang/test/Semantics/call01.f90
@@ -119,9 +119,11 @@ end function nested
 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 0000000000000..16c7344d48cb7
--- /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
+