[flang-commits] [flang] c2e5f4d - [flang] Add warnings for non-standard C_F_POINTER() usage (#78332)

[via flang-commits]

Author: Peter Klausler
Date: 2024-01-25T13:50:40-08:00
New Revision: c2e5f4d3a14ae5b5c1c7e335a6336774f456e656

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

LOG: [flang] Add warnings for non-standard C_F_POINTER() usage (#78332)

There's a few restrictions in the standard on the Fortran pointer
argument (FPTR=) to the intrinsic subroutine C_F_POINTER() that almost
no compilers enforce. Enforce them here with warnings.

Added: 
    

Modified: 
    flang/lib/Evaluate/intrinsics.cpp
    flang/test/Semantics/c_f_pointer.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index da6d5970089884c..7d2e45dcbe96ded 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2663,13 +2663,28 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
     }
     if (const auto *expr{arguments[1].value().UnwrapExpr()}) {
       int fptrRank{expr->Rank()};
+      auto at{arguments[1]->sourceLocation()};
       if (auto type{expr->GetType()}) {
         if (type->HasDeferredTypeParameter()) {
-          context.messages().Say(arguments[1]->sourceLocation(),
+          context.messages().Say(at,
               "FPTR= argument to C_F_POINTER() may not have a deferred type parameter"_err_en_US);
+        } else if (type->category() == TypeCategory::Derived) {
+          if (type->IsUnlimitedPolymorphic()) {
+            context.messages().Say(at,
+                "FPTR= argument to C_F_POINTER() should not be unlimited polymorphic"_warn_en_US);
+          } else if (!type->GetDerivedTypeSpec().typeSymbol().attrs().test(
+                         semantics::Attr::BIND_C)) {
+            context.messages().Say(at,
+                "FPTR= argument to C_F_POINTER() should not have a derived type that is not BIND(C)"_warn_en_US);
+          }
+        } else if (!IsInteroperableIntrinsicType(
+                       *type, &context.languageFeatures())) {
+          context.messages().Say(at,
+              "FPTR= argument to C_F_POINTER() should not have the non-interoperable intrinsic type %s"_warn_en_US,
+              type->AsFortran());
         }
         if (ExtractCoarrayRef(*expr)) {
-          context.messages().Say(arguments[1]->sourceLocation(),
+          context.messages().Say(at,
               "FPTR= argument to C_F_POINTER() may not be a coindexed object"_err_en_US);
         }
         characteristics::DummyDataObject fptr{
@@ -2678,8 +2693,8 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
         fptr.attrs.set(characteristics::DummyDataObject::Attr::Pointer);
         dummies.emplace_back("fptr"s, std::move(fptr));
       } else {
-        context.messages().Say(arguments[1]->sourceLocation(),
-            "FPTR= argument to C_F_POINTER() must have a type"_err_en_US);
+        context.messages().Say(
+            at, "FPTR= argument to C_F_POINTER() must have a type"_err_en_US);
       }
       if (arguments[2] && fptrRank == 0) {
         context.messages().Say(arguments[2]->sourceLocation(),

diff  --git a/flang/test/Semantics/c_f_pointer.f90 b/flang/test/Semantics/c_f_pointer.f90
index 0c1e8544b02b18a..c2529201ee26597 100644
--- a/flang/test/Semantics/c_f_pointer.f90
+++ b/flang/test/Semantics/c_f_pointer.f90
@@ -1,4 +1,4 @@
-! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
 ! Enforce 18.2.3.3
 
 program test
@@ -12,6 +12,12 @@ program test
   character(len=:), pointer :: charDeferredF
   integer :: j
   integer, dimension(2, 2) :: rankTwoArray
+  class(*), pointer :: unlimited
+  type :: notBindCType
+    integer :: n
+  end type
+  type(notBindCType), pointer :: notBindC
+  character(2), pointer :: c2ptr
   rankTwoArray = reshape([1, 2, 3, 4], shape(rankTwoArray))
   call c_f_pointer(scalarC, scalarIntF) ! ok
   call c_f_pointer(scalarC, arrayIntF, [1_8]) ! ok
@@ -38,4 +44,10 @@ program test
   call c_f_pointer(scalarC, multiDimIntF, shape=[1_8])
   !ERROR: SHAPE= argument to C_F_POINTER() must be a rank-one array.
   call c_f_pointer(scalarC, multiDimIntF, shape=rankTwoArray)
+  !WARNING: FPTR= argument to C_F_POINTER() should not be unlimited polymorphic
+  call c_f_pointer(scalarC, unlimited)
+  !WARNING: FPTR= argument to C_F_POINTER() should not have a derived type that is not BIND(C)
+  call c_f_pointer(scalarC, notBindC)
+  !WARNING: FPTR= argument to C_F_POINTER() should not have the non-interoperable intrinsic type CHARACTER(KIND=1,LEN=2_8)
+  call c_f_pointer(scalarC, c2ptr)
 end program