diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index da6d597008988..7d2e45dcbe96d 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 0c1e8544b02b1..c2529201ee265 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