[flang-commits] [flang] 199402c - [flang] Check dummy arguments of BIND(C) procedures
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Fri Mar 10 09:40:06 PST 2023
Author: Peter Klausler
Date: 2023-03-10T09:36:05-08:00
New Revision: 199402c378630be3449d2a006812b9e9f0caa7ce
URL: https://github.com/llvm/llvm-project/commit/199402c378630be3449d2a006812b9e9f0caa7ce
DIFF: https://github.com/llvm/llvm-project/commit/199402c378630be3449d2a006812b9e9f0caa7ce.diff
LOG: [flang] Check dummy arguments of BIND(C) procedures
Declaration checking in semantics was only examining symbols with
explicit BIND(C) attributes; extend it to also check dummy arguments
to such procedures.
Differential Revision: https://reviews.llvm.org/D145746
Added:
flang/test/Semantics/bind-c11.f90
Modified:
flang/docs/Extensions.md
flang/lib/Semantics/check-declarations.cpp
flang/module/iso_c_binding.f90
flang/module/omp_lib.h
flang/test/Lower/call-by-value.f90
flang/test/Semantics/modfile04.f90
Removed:
################################################################################
diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index a71363cb3b6ea..31fc3a7bc801c 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -557,6 +557,9 @@ end module
obsolete module file from a previous compilation and then overwriting
that file later.
+* F18 allows `OPTIONAL` dummy arguments to interoperable procedures
+ unless they are `VALUE` (C865).
+
## De Facto Standard Features
* `EXTENDS_TYPE_OF()` returns `.TRUE.` if both of its arguments have the
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 540f004863f48..702d4fbf6b248 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -254,7 +254,9 @@ void CheckHelper::Check(const Symbol &symbol) {
if (symbol.attrs().test(Attr::VOLATILE)) {
CheckVolatile(symbol, derived);
}
- CheckBindC(symbol);
+ if (symbol.attrs().test(Attr::BIND_C)) {
+ CheckBindC(symbol);
+ }
CheckGlobalName(symbol);
if (isDone) {
return; // following checks do not apply
@@ -430,7 +432,9 @@ void CheckHelper::Check(const Symbol &symbol) {
void CheckHelper::CheckCommonBlock(const Symbol &symbol) {
CheckGlobalName(symbol);
- CheckBindC(symbol);
+ if (symbol.attrs().test(Attr::BIND_C)) {
+ CheckBindC(symbol);
+ }
}
void CheckHelper::CheckBindCFunctionResult(const Symbol &symbol) { // C1553
@@ -2218,13 +2222,16 @@ void CheckHelper::CheckGlobalName(const Symbol &symbol) {
}
void CheckHelper::CheckBindC(const Symbol &symbol) {
- if (!symbol.attrs().test(Attr::BIND_C)) {
- return;
+ bool isExplicitBindC{symbol.attrs().test(Attr::BIND_C)};
+ if (isExplicitBindC) {
+ CheckConflicting(symbol, Attr::BIND_C, Attr::PARAMETER);
+ CheckConflicting(symbol, Attr::BIND_C, Attr::ELEMENTAL);
+ } else {
+ // symbol must be interoperable (e.g., dummy argument of interoperable
+ // procedure interface) but is not itself BIND(C).
}
- CheckConflicting(symbol, Attr::BIND_C, Attr::PARAMETER);
- CheckConflicting(symbol, Attr::BIND_C, Attr::ELEMENTAL);
if (const std::string * bindName{symbol.GetBindName()};
- bindName) { // BIND(C,NAME=...)
+ bindName) { // has a binding name
if (!bindName->empty()) {
bool ok{bindName->front() == '_' || parser::IsLetter(bindName->front())};
for (char ch : *bindName) {
@@ -2237,7 +2244,7 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
}
}
}
- if (symbol.GetIsExplicitBindName()) { // C1552, C1529
+ if (symbol.GetIsExplicitBindName()) { // BIND(C,NAME=...); C1552, C1529
auto defClass{ClassifyProcedure(symbol)};
if (IsProcedurePointer(symbol)) {
messages_.Say(symbol.name(),
@@ -2256,33 +2263,67 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
context_.SetError(symbol);
}
}
- if (symbol.detailsIf<ObjectEntityDetails>()) {
- if (!symbol.owner().IsModule()) {
+ if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+ if (isExplicitBindC && !symbol.owner().IsModule()) {
messages_.Say(symbol.name(),
"A variable with BIND(C) attribute may only appear in the specification part of a module"_err_en_US);
context_.SetError(symbol);
}
- if (auto extents{evaluate::GetConstantExtents(foldingContext_, symbol)};
- extents && evaluate::GetSize(*extents) == 0) {
- SayWithDeclaration(symbol, symbol.name(),
- "Interoperable array must have at least one element"_err_en_US);
- }
- if (const auto *type{symbol.GetType()}) {
- if (const auto *derived{type->AsDerived()}) {
- if (!derived->typeSymbol().attrs().test(Attr::BIND_C)) {
- if (auto *msg{messages_.Say(symbol.name(),
- "The derived type of a BIND(C) object must also be BIND(C)"_err_en_US)}) {
- msg->Attach(
- derived->typeSymbol().name(), "Non-interoperable type"_en_US);
+ if (auto shape{evaluate::GetShape(foldingContext_, symbol)}) {
+ if (evaluate::GetRank(*shape) == 0) { // 18.3.4
+ if (isExplicitBindC && IsAllocatableOrPointer(symbol)) {
+ messages_.Say(symbol.name(),
+ "A scalar interoperable variable may not be ALLOCATABLE or POINTER"_err_en_US);
+ context_.SetError(symbol);
+ }
+ } else { // 18.3.5
+ if (auto extents{
+ evaluate::AsConstantExtents(foldingContext_, *shape)}) {
+ if (evaluate::GetSize(*extents) == 0) {
+ SayWithDeclaration(symbol, symbol.name(),
+ "Interoperable array must have at least one element"_err_en_US);
+ context_.SetError(symbol);
}
+ } else if ((isExplicitBindC || symbol.attrs().test(Attr::VALUE)) &&
+ !evaluate::IsExplicitShape(symbol) && !object->IsAssumedSize()) {
+ SayWithDeclaration(symbol, symbol.name(),
+ "BIND(C) array must have explicit shape or be assumed-size unless a dummy argument without the VALUE attribute"_err_en_US);
context_.SetError(symbol);
}
- } else if (!IsInteroperableIntrinsicType(*type)) {
+ }
+ }
+ if (const auto *type{symbol.GetType()}) {
+ const auto *derived{type->AsDerived()};
+ if (derived && !derived->typeSymbol().attrs().test(Attr::BIND_C)) {
+ if (auto *msg{messages_.Say(symbol.name(),
+ "The derived type of a BIND(C) object must also be BIND(C)"_err_en_US)}) {
+ msg->Attach(
+ derived->typeSymbol().name(), "Non-interoperable type"_en_US);
+ }
+ context_.SetError(symbol);
+ }
+ if (type->IsAssumedType() || IsAssumedLengthCharacter(symbol)) {
+ // ok
+ } else if (IsAllocatableOrPointer(symbol) &&
+ type->category() == DeclTypeSpec::Character &&
+ type->characterTypeSpec().length().isDeferred()) {
+ // ok; F'2018 18.3.6 p2(6)
+ } else if (derived || IsInteroperableIntrinsicType(*type)) {
+ // F'2018 18.3.6 p2(4,5)
+ } else if (symbol.attrs().test(Attr::VALUE)) {
+ messages_.Say(symbol.name(),
+ "A BIND(C) VALUE dummy argument must have an interoperable type"_err_en_US);
+ context_.SetError(symbol);
+ } else {
messages_.Say(symbol.name(),
"A BIND(C) object must have an interoperable type"_err_en_US);
context_.SetError(symbol);
}
}
+ if (IsOptional(symbol) && !symbol.attrs().test(Attr::VALUE)) {
+ messages_.Say(symbol.name(),
+ "An interoperable procedure with an OPTIONAL dummy argument might not be portable"_port_en_US);
+ }
} else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
if (!proc->procInterface() ||
!proc->procInterface()->attrs().test(Attr::BIND_C)) {
@@ -2290,6 +2331,16 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
"An interface name with BIND attribute must be specified if the BIND attribute is specified in a procedure declaration statement"_err_en_US);
context_.SetError(symbol);
}
+ } else if (const auto *subp{symbol.detailsIf<SubprogramDetails>()}) {
+ for (const Symbol *dummy : subp->dummyArgs()) {
+ if (dummy) {
+ CheckBindC(*dummy);
+ } else {
+ messages_.Say(symbol.name(),
+ "A subprogram interface with the BIND attribute may not have an alternate return argument"_err_en_US);
+ context_.SetError(symbol);
+ }
+ }
} else if (const auto *derived{symbol.detailsIf<DerivedTypeDetails>()}) {
if (derived->sequence()) { // C1801
messages_.Say(symbol.name(),
diff --git a/flang/module/iso_c_binding.f90 b/flang/module/iso_c_binding.f90
index 0fcebc7bd7514..68035579ec620 100644
--- a/flang/module/iso_c_binding.f90
+++ b/flang/module/iso_c_binding.f90
@@ -64,7 +64,7 @@ module iso_c_binding
c_double_complex = c_double, &
c_long_double_complex = c_long_double
- integer, parameter :: c_bool = 1 ! TODO: or default LOGICAL?
+ integer, parameter :: c_bool = 1
integer, parameter :: c_char = 1
! C characters with special semantics
diff --git a/flang/module/omp_lib.h b/flang/module/omp_lib.h
index 993b00409af72..d8a9aeb152df5 100644
--- a/flang/module/omp_lib.h
+++ b/flang/module/omp_lib.h
@@ -9,7 +9,7 @@
!dir$ free
integer, parameter :: omp_integer_kind = selected_int_kind(9) ! 32-bit int
- integer, parameter :: omp_logical_kind = kind(.true.)
+ integer, parameter :: omp_logical_kind = 1 ! C_BOOL
integer, parameter :: omp_sched_kind = omp_integer_kind
integer, parameter :: omp_proc_bind_kind = omp_integer_kind
diff --git a/flang/test/Lower/call-by-value.f90 b/flang/test/Lower/call-by-value.f90
index 909d1cc03a1db..8fa8def0f3d99 100644
--- a/flang/test/Lower/call-by-value.f90
+++ b/flang/test/Lower/call-by-value.f90
@@ -2,21 +2,23 @@
! RUN: bbc -emit-fir %s -o - | FileCheck %s
!CHECK-LABEL: func @_QQmain()
-!CHECK: %[[LOGICAL:.*]] = fir.alloca !fir.logical<4>
+!CHECK: %[[LOGICAL:.*]] = fir.alloca !fir.logical<1>
!CHECK: %false = arith.constant false
-!CHECK: %[[VALUE:.*]] = fir.convert %false : (i1) -> !fir.logical<4>
+!CHECK: %[[VALUE:.*]] = fir.convert %false : (i1) -> !fir.logical<1>
!CHECK: fir.store %[[VALUE]] to %[[LOGICAL]]
!CHECK: %[[LOAD:.*]] = fir.load %[[LOGICAL]]
!CHECK: fir.call @omp_set_nested(%[[LOAD]]) {{.*}}: {{.*}}
program call_by_value
+ use iso_c_binding, only: c_bool
interface
subroutine omp_set_nested(enable) bind(c)
- logical, value :: enable
+ import c_bool
+ logical(c_bool), value :: enable
end subroutine omp_set_nested
end interface
- logical do_nested
+ logical(c_bool) do_nested
do_nested = .FALSE.
call omp_set_nested(do_nested)
end program call_by_value
diff --git a/flang/test/Semantics/bind-c11.f90 b/flang/test/Semantics/bind-c11.f90
new file mode 100644
index 0000000000000..06f5c05c511d1
--- /dev/null
+++ b/flang/test/Semantics/bind-c11.f90
@@ -0,0 +1,21 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+ !ERROR: A scalar interoperable variable may not be ALLOCATABLE or POINTER
+ real, allocatable, bind(c) :: x1
+ !ERROR: A scalar interoperable variable may not be ALLOCATABLE or POINTER
+ real, pointer, bind(c) :: x2
+ !ERROR: BIND(C) array must have explicit shape or be assumed-size unless a dummy argument without the VALUE attribute
+ real, allocatable, bind(c) :: x3(:)
+ contains
+ subroutine s1(x) bind(c)
+ !ERROR: A BIND(C) VALUE dummy argument must have an interoperable type
+ logical(2), intent(in), value :: x
+ end
+ subroutine s2(x) bind(c)
+ !PORTABILITY: An interoperable procedure with an OPTIONAL dummy argument might not be portable
+ integer, intent(in), optional :: x
+ end
+ !ERROR: A subprogram interface with the BIND attribute may not have an alternate return argument
+ subroutine s3(*) bind(c)
+ end
+end
diff --git a/flang/test/Semantics/modfile04.f90 b/flang/test/Semantics/modfile04.f90
index c0829c4417984..2779dd4bdf57d 100644
--- a/flang/test/Semantics/modfile04.f90
+++ b/flang/test/Semantics/modfile04.f90
@@ -7,7 +7,7 @@ module m1
contains
pure subroutine Ss(x, y) bind(c)
- logical x
+ logical(1) x
intent(inout) y
intent(in) x
end subroutine
@@ -54,7 +54,7 @@ end module m3
!end type
!contains
!pure subroutine ss(x,y) bind(c)
-!logical(4),intent(in)::x
+!logical(1),intent(in)::x
!real(4),intent(inout)::y
!end
!function f1() result(x)
More information about the flang-commits
mailing list