intel/llvm
1
0
Fork 0
mirror of https://github.com/intel/llvm.git synced 2026-01-25 10:55:58 +08:00
Code Issues Packages Projects Releases Wiki Activity

[flang] Foil attempts to require interoperable pointers be CONTIGUOUS

Browse Source 
BIND(C) interoperable pointer descriptors may not be required to be
CONTIGUOUS in procedure interfaces.

(Also fixed erroneous true result from IsDescriptor() predicate for
assumed-size arrays that was exposed by testing.)

Fixes llvm-test-suite/Fortran/gfortran/regression/bind_c_contiguous.f90.

Differential Revision: https://reviews.llvm.org/D157342
This commit is contained in:
Peter Klausler
2023-08-03 13:06:20 -07:00
parent 458d9fbdc7
commit 6bc14f238e
3 changed files with 31 additions and 4 deletions
Download Patch File Download Diff File Expand all files Collapse all files

18
flang/lib/Evaluate/type.cpp
View File

@@ -34,13 +34,23 @@ static bool IsDescriptor(const DeclTypeSpec *type) {
}
static bool IsDescriptor(const ObjectEntityDetails &details) {
if (IsDescriptor(details.type())) {
if (IsDescriptor(details.type()) || details.IsAssumedRank()) {
return true;
}
std::size_t j{0};
for (const ShapeSpec &shapeSpec : details.shape()) {
const auto &lb{shapeSpec.lbound().GetExplicit()};
const auto &ub{shapeSpec.ubound().GetExplicit()};
if (!lb || !ub || !IsConstantExpr(*lb) || !IsConstantExpr(*ub)) {
++j;
if (const auto &lb{shapeSpec.lbound().GetExplicit()};
!lb || !IsConstantExpr(*lb)) {
return true;
}
if (const auto &ub{shapeSpec.ubound().GetExplicit()}) {
if (!IsConstantExpr(*ub)) {
return true;
}
} else if (j == details.shape().size() && details.isDummy()) {
// assumed size array
} else {
return true;
}
}

5
flang/lib/Semantics/check-declarations.cpp
View File

@@ -2720,6 +2720,11 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
WarnIfNotInModuleFile(symbol.name(),
"An interoperable procedure with an OPTIONAL dummy argument might not be portable"_port_en_US);
}
if (IsDescriptor(symbol) && IsPointer(symbol) &&
symbol.attrs().test(Attr::CONTIGUOUS)) {
messages_.Say(symbol.name(),
"An interoperable pointer must not be CONTIGUOUS"_err_en_US);
}
} else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
if (!proc->procInterface() ||
!proc->procInterface()->attrs().test(Attr::BIND_C)) {

12
flang/test/Semantics/bind-c13.f90 Normal file
View File

@@ -0,0 +1,12 @@
! RUN: %python %S/test_errors.py %s %flang_fc1
! Interoperable objects that require descriptors cannot be CONTIGUOUS
subroutine interop(ptr,ashape,arank,eshape,asize) bind(c)
!ERROR: An interoperable pointer must not be CONTIGUOUS
real, pointer, contiguous :: ptr(:)
real, contiguous :: ashape(:) ! ok
real, contiguous :: arank(..) ! ok
!ERROR: CONTIGUOUS entity 'eshape' must be an array pointer, assumed-shape, or assumed-rank
real, contiguous :: eshape(10)
!ERROR: CONTIGUOUS entity 'asize' must be an array pointer, assumed-shape, or assumed-rank
real, contiguous :: asize(*)
end