[flang-commits] [flang] 036701a - [flang] Correct procedure pointer (or dummy) compatibility check
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Fri Jan 27 14:53:20 PST 2023
Author: Peter Klausler
Date: 2023-01-27T14:53:09-08:00
New Revision: 036701a1773320e7a2ea4f9cdba1e90b1a4a17d7
URL: https://github.com/llvm/llvm-project/commit/036701a1773320e7a2ea4f9cdba1e90b1a4a17d7
DIFF: https://github.com/llvm/llvm-project/commit/036701a1773320e7a2ea4f9cdba1e90b1a4a17d7.diff
LOG: [flang] Correct procedure pointer (or dummy) compatibility check
Fix a subtle bug in procedure compatibility checking with base
derived types vs. their extensions to ensure that a procedure
expecting an extended type cannot be associated with a pointer
(or dummy procedure) to a procedure expecting a base type.
subroutine s1(base); ... subroutine s2(extended)
procedure(s1), pointer :: p
p => s2 ! <- must be caught as an error
Differential Revision: https://reviews.llvm.org/D142753
Added:
flang/test/Semantics/assign12.f90
Modified:
flang/lib/Evaluate/characteristics.cpp
flang/lib/Evaluate/formatting.cpp
flang/lib/Evaluate/type.cpp
flang/lib/Semantics/expression.cpp
flang/test/Semantics/assign09.f90
flang/test/Semantics/call05.f90
flang/test/Semantics/global01.f90
Removed:
################################################################################
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 9c5f243a590a..535f2f2158c1 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -1017,8 +1017,14 @@ bool Procedure::IsCompatibleWith(const Procedure &actual, std::string *whyNot,
}
} else {
for (std::size_t j{0}; j < dummyArguments.size(); ++j) {
- if (!dummyArguments[j].IsCompatibleWith(
- actual.dummyArguments[j], whyNot)) {
+ // Subtlety: the dummy/actual distinction must be reversed for this
+ // compatibility test in order to correctly check extended vs.
+ // base types. Example:
+ // subroutine s1(base); subroutine s2(extended)
+ // procedure(s1), pointer :: p
+ // p => s2 ! an error, s2 is more restricted, can't handle "base"
+ if (!actual.dummyArguments[j].IsCompatibleWith(
+ dummyArguments[j], whyNot)) {
if (whyNot) {
*whyNot = "incompatible dummy argument #"s + std::to_string(j + 1) +
": "s + *whyNot;
diff --git a/flang/lib/Evaluate/formatting.cpp b/flang/lib/Evaluate/formatting.cpp
index 9b649e7cee55..f9548e119f1a 100644
--- a/flang/lib/Evaluate/formatting.cpp
+++ b/flang/lib/Evaluate/formatting.cpp
@@ -479,7 +479,11 @@ llvm::raw_ostream &StructureConstructor::AsFortran(llvm::raw_ostream &o) const {
std::string DynamicType::AsFortran() const {
if (derived_) {
CHECK(category_ == TypeCategory::Derived);
- return DerivedTypeSpecAsFortran(*derived_);
+ std::string result{DerivedTypeSpecAsFortran(*derived_)};
+ if (IsPolymorphic()) {
+ result = "CLASS("s + result + ')';
+ }
+ return result;
} else if (charLengthParamValue_ || knownLength()) {
std::string result{"CHARACTER(KIND="s + std::to_string(kind_) + ",LEN="};
if (knownLength()) {
diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 81744cb752d6..fa5775588075 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -215,14 +215,7 @@ static const semantics::Symbol *FindParentComponent(
}
if (scope) {
const auto &dtDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
- if (auto extends{dtDetails.GetParentComponentName()}) {
- if (auto iter{scope->find(*extends)}; iter != scope->cend()) {
- if (const Symbol & symbol{*iter->second};
- symbol.test(Symbol::Flag::ParentComp)) {
- return &symbol;
- }
- }
- }
+ return dtDetails.GetParentComponent(*scope);
}
return nullptr;
}
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index a4c184360071..cd418606521a 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -4068,7 +4068,7 @@ std::string ArgumentAnalyzer::TypeAsFortran(std::size_t i) {
} else if (std::optional<DynamicType> type{GetType(i)}) {
return type->IsAssumedType() ? "TYPE(*)"s
: type->IsUnlimitedPolymorphic() ? "CLASS(*)"s
- : type->IsPolymorphic() ? "CLASS("s + type->AsFortran() + ')'
+ : type->IsPolymorphic() ? type->AsFortran()
: type->category() == TypeCategory::Derived
? "TYPE("s + type->AsFortran() + ')'
: type->category() == TypeCategory::Character
diff --git a/flang/test/Semantics/assign09.f90 b/flang/test/Semantics/assign09.f90
index ab581eee0451..d8104b1dd60b 100644
--- a/flang/test/Semantics/assign09.f90
+++ b/flang/test/Semantics/assign09.f90
@@ -34,11 +34,11 @@ elemental real function userElemental(a)
noInterfaceProcPtr => sqrt ! ok
realToRealProcPtr => sqrt ! ok
- !ERROR: Procedure pointer 'inttorealprocptr' associated with incompatible procedure designator 'sqrt': incompatible dummy argument #1: incompatible dummy data object types: INTEGER(4) vs REAL(4)
+ !ERROR: Procedure pointer 'inttorealprocptr' associated with incompatible procedure designator 'sqrt': incompatible dummy argument #1: incompatible dummy data object types: REAL(4) vs INTEGER(4)
intToRealProcPtr => sqrt
call sub1(sqrt) ! ok
call sub2(sqrt) ! ok
- !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': incompatible dummy argument #1: incompatible dummy data object types: INTEGER(4) vs REAL(4)
+ !ERROR: Actual procedure argument has interface incompatible with dummy argument 'p=': incompatible dummy argument #1: incompatible dummy data object types: REAL(4) vs INTEGER(4)
call sub3(sqrt)
noInterfaceProcPtr => noInterfaceExternal ! ok
diff --git a/flang/test/Semantics/assign12.f90 b/flang/test/Semantics/assign12.f90
new file mode 100644
index 000000000000..30feb6b5b5b6
--- /dev/null
+++ b/flang/test/Semantics/assign12.f90
@@ -0,0 +1,32 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+ type base
+ procedure(baseSub), pointer :: baseComponent
+ end type
+ type, extends(base) :: extended
+ end type
+ contains
+ subroutine baseSub(x)
+ class(base), intent(in) :: x
+ end
+ subroutine extendedSub(x)
+ class(extended), intent(in) :: x
+ end
+ subroutine test
+ procedure(baseSub), pointer :: basePtr
+ procedure(extendedSub), pointer :: extendedPtr
+ type(extended) :: extendedVar
+ extendedPtr => baseSub ! ok
+ extendedPtr => basePtr ! ok
+ extendedVar = extended(baseSub) ! ok
+ extendedVar = extended(basePtr) ! ok
+ !ERROR: Procedure pointer 'baseptr' associated with incompatible procedure designator 'extendedsub': incompatible dummy argument #1: incompatible dummy data object types: CLASS(extended) vs CLASS(base)
+ basePtr => extendedSub
+ !ERROR: Procedure pointer 'baseptr' associated with incompatible procedure designator 'extendedptr': incompatible dummy argument #1: incompatible dummy data object types: CLASS(extended) vs CLASS(base)
+ basePtr => extendedPtr
+ !ERROR: Procedure pointer 'basecomponent' associated with incompatible procedure designator 'extendedsub': incompatible dummy argument #1: incompatible dummy data object types: CLASS(extended) vs CLASS(base)
+ extendedVar = extended(extendedSub)
+ !ERROR: Procedure pointer 'basecomponent' associated with incompatible procedure designator 'extendedptr': incompatible dummy argument #1: incompatible dummy data object types: CLASS(extended) vs CLASS(base)
+ extendedVar = extended(extendedPtr)
+ end
+end
diff --git a/flang/test/Semantics/call05.f90 b/flang/test/Semantics/call05.f90
index ab7b974527a9..7cc635f15d9b 100644
--- a/flang/test/Semantics/call05.f90
+++ b/flang/test/Semantics/call05.f90
@@ -85,9 +85,9 @@ subroutine test
call sup(pp)
!ERROR: If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both must be so
call sua(pa)
- !ERROR: Actual argument type 'CLASS(*)' is not compatible with dummy argument type 't'
+ !ERROR: Actual argument type 'CLASS(*)' is not compatible with dummy argument type 'CLASS(t)'
call spp(up)
- !ERROR: Actual argument type 'CLASS(*)' is not compatible with dummy argument type 't'
+ !ERROR: Actual argument type 'CLASS(*)' is not compatible with dummy argument type 'CLASS(t)'
call spa(ua)
!ERROR: POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind
call spp(pp2)
diff --git a/flang/test/Semantics/global01.f90 b/flang/test/Semantics/global01.f90
index 5dfa6f6dea60..752c902c2c72 100644
--- a/flang/test/Semantics/global01.f90
+++ b/flang/test/Semantics/global01.f90
@@ -23,7 +23,7 @@ subroutine global5(x)
program test
interface
- !WARNING: The global subprogram 'global1' is not compatible with its local procedure declaration (incompatible dummy argument #1: incompatible dummy data object types: REAL(4) vs INTEGER(4))
+ !WARNING: The global subprogram 'global1' is not compatible with its local procedure declaration (incompatible dummy argument #1: incompatible dummy data object types: INTEGER(4) vs REAL(4))
subroutine global1(x)
real, intent(in) :: x
end subroutine
More information about the flang-commits
mailing list