[flang-commits] [flang] 5ea0ba2 - [flang] Enforce more restrictions on I/O data list items
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Fri Dec 2 16:11:00 PST 2022
Author: Peter Klausler
Date: 2022-12-02T16:10:52-08:00
New Revision: 5ea0ba2c13af3c6c8e68701b00695f0f0481bed0
URL: https://github.com/llvm/llvm-project/commit/5ea0ba2c13af3c6c8e68701b00695f0f0481bed0
DIFF: https://github.com/llvm/llvm-project/commit/5ea0ba2c13af3c6c8e68701b00695f0f0481bed0.diff
LOG: [flang] Enforce more restrictions on I/O data list items
12.6.3p5 requires an I/O data list item to have a defined I/O procedure
if it is polymorphic. (We could defer this checking to the runtime,
but no other Fortran compiler does so, and we would also have to be
able to catch the case of an allocatable or pointer direct component
in the absence of a defined I/O subroutine.)
Also includes a patch to name resolution that ensures that a
SELECT TYPE construct entity is polymorphic in the domain of a
CLASS IS guard.
Also ensures that non-defined I/O of types with PRIVATE components
is caught.
Differential Revision: https://reviews.llvm.org/D139050
Added:
flang/test/Semantics/io14.f90
flang/test/Semantics/io15.f90
Modified:
flang/include/flang/Semantics/semantics.h
flang/include/flang/Semantics/tools.h
flang/lib/Semantics/check-io.cpp
flang/lib/Semantics/check-io.h
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/tools.cpp
flang/test/Semantics/io12.f90
flang/test/Semantics/symbol11.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Semantics/semantics.h b/flang/include/flang/Semantics/semantics.h
index 2d08a9f03557..04a1d6bbd240 100644
--- a/flang/include/flang/Semantics/semantics.h
+++ b/flang/include/flang/Semantics/semantics.h
@@ -168,10 +168,12 @@ class SemanticsContext {
return messages_.Say(std::move(msg));
}
template <typename... A>
- void SayWithDecl(const Symbol &symbol, const parser::CharBlock &at,
- parser::MessageFixedText &&msg, A &&...args) {
+ parser::Message &SayWithDecl(const Symbol &symbol,
+ const parser::CharBlock &at, parser::MessageFixedText &&msg,
+ A &&...args) {
auto &message{Say(at, std::move(msg), args...)};
evaluate::AttachDeclaration(&message, symbol);
+ return message;
}
const Scope &FindScope(parser::CharBlock) const;
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index 7b2c4bf7aac5..88cb720c3d62 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -610,11 +610,6 @@ std::optional<ArraySpec> ToArraySpec(
// procedure.
bool HasDefinedIo(
GenericKind::DefinedIo, const DerivedTypeSpec &, const Scope * = nullptr);
-// Seeks out an allocatable or pointer ultimate component that is not
-// nested in a nonallocatable/nonpointer component with a specific
-// defined I/O procedure.
-const Symbol *FindUnsafeIoDirectComponent(
- GenericKind::DefinedIo, const DerivedTypeSpec &, const Scope * = nullptr);
// Some intrinsic operators have more than one name (e.g. `operator(.eq.)` and
// `operator(==)`). GetAllNames() returns them all, including symbolName.
diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp
index 5e25e51ec169..ee7eb02efefa 100644
--- a/flang/lib/Semantics/check-io.cpp
+++ b/flang/lib/Semantics/check-io.cpp
@@ -323,7 +323,7 @@ void IoChecker::Enter(const parser::InputItem &spec) {
}
CheckForDefinableVariable(*var, "Input");
if (auto expr{AnalyzeExpr(context_, *var)}) {
- CheckForBadIoComponent(*expr,
+ CheckForBadIoType(*expr,
flags_.test(Flag::FmtOrNml) ? GenericKind::DefinedIo::ReadFormatted
: GenericKind::DefinedIo::ReadUnformatted,
var->GetSource());
@@ -616,7 +616,7 @@ void IoChecker::Enter(const parser::OutputItem &item) {
context_.Say(parser::FindSourceLocation(*x),
"Output item must not be a procedure pointer"_err_en_US); // C1233
}
- CheckForBadIoComponent(*expr,
+ CheckForBadIoType(*expr,
flags_.test(Flag::FmtOrNml)
? GenericKind::DefinedIo::WriteFormatted
: GenericKind::DefinedIo::WriteUnformatted,
@@ -738,29 +738,21 @@ void IoChecker::Leave(const parser::PrintStmt &) {
Done();
}
-static void CheckForDoVariableInNamelist(const Symbol &namelist,
- SemanticsContext &context, parser::CharBlock namelistLocation) {
- const auto &details{namelist.GetUltimate().get<NamelistDetails>()};
- for (const Symbol &object : details.objects()) {
- context.CheckIndexVarRedefine(namelistLocation, object);
- }
-}
-
-static void CheckForDoVariableInNamelistSpec(
- const parser::ReadStmt &readStmt, SemanticsContext &context) {
- const std::list<parser::IoControlSpec> &controls{readStmt.controls};
+static const parser::Name *FindNamelist(
+ const std::list<parser::IoControlSpec> &controls) {
for (const auto &control : controls) {
- if (const auto *namelist{std::get_if<parser::Name>(&control.u)}) {
- if (const Symbol * symbol{namelist->symbol}) {
- CheckForDoVariableInNamelist(*symbol, context, namelist->source);
+ if (const parser::Name * namelist{std::get_if<parser::Name>(&control.u)}) {
+ if (namelist->symbol &&
+ namelist->symbol->GetUltimate().has<NamelistDetails>()) {
+ return namelist;
}
}
}
+ return nullptr;
}
static void CheckForDoVariable(
const parser::ReadStmt &readStmt, SemanticsContext &context) {
- CheckForDoVariableInNamelistSpec(readStmt, context);
const std::list<parser::InputItem> &items{readStmt.items};
for (const auto &item : items) {
if (const parser::Variable *
@@ -774,6 +766,12 @@ void IoChecker::Leave(const parser::ReadStmt &readStmt) {
if (!flags_.test(Flag::InternalUnit)) {
CheckForPureSubprogram();
}
+ if (const parser::Name * namelist{FindNamelist(readStmt.controls)}) {
+ if (namelist->symbol) {
+ CheckNamelist(*namelist->symbol, GenericKind::DefinedIo::ReadFormatted,
+ namelist->source);
+ }
+ }
CheckForDoVariable(readStmt, context_);
if (!flags_.test(Flag::IoControlList)) {
Done();
@@ -807,10 +805,16 @@ void IoChecker::Leave(const parser::WaitStmt &) {
Done();
}
-void IoChecker::Leave(const parser::WriteStmt &) {
+void IoChecker::Leave(const parser::WriteStmt &writeStmt) {
if (!flags_.test(Flag::InternalUnit)) {
CheckForPureSubprogram();
}
+ if (const parser::Name * namelist{FindNamelist(writeStmt.controls)}) {
+ if (namelist->symbol) {
+ CheckNamelist(*namelist->symbol, GenericKind::DefinedIo::WriteFormatted,
+ namelist->source);
+ }
+ }
LeaveReadWrite();
CheckForProhibitedSpecifier(IoSpecKind::Blank); // C1213
CheckForProhibitedSpecifier(IoSpecKind::End); // C1213
@@ -1030,20 +1034,139 @@ void IoChecker::CheckForPureSubprogram() const { // C1597
}
}
-// Fortran 2018, 12.6.3 paragraph 7
-void IoChecker::CheckForBadIoComponent(const SomeExpr &expr,
+// Seeks out an allocatable or pointer ultimate component that is not
+// nested in a nonallocatable/nonpointer component with a specific
+// defined I/O procedure.
+static const Symbol *FindUnsafeIoDirectComponent(GenericKind::DefinedIo which,
+ const DerivedTypeSpec &derived, const Scope &scope) {
+ if (HasDefinedIo(which, derived, &scope)) {
+ return nullptr;
+ }
+ if (const Scope * dtScope{derived.scope()}) {
+ for (const auto &pair : *dtScope) {
+ const Symbol &symbol{*pair.second};
+ if (IsAllocatableOrPointer(symbol)) {
+ return &symbol;
+ }
+ if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
+ if (const DeclTypeSpec * type{details->type()}) {
+ if (type->category() == DeclTypeSpec::Category::TypeDerived) {
+ const DerivedTypeSpec &componentDerived{type->derivedTypeSpec()};
+ if (const Symbol *
+ bad{FindUnsafeIoDirectComponent(
+ which, componentDerived, scope)}) {
+ return bad;
+ }
+ }
+ }
+ }
+ }
+ }
+ return nullptr;
+}
+
+// For a type that does not have a defined I/O subroutine, finds a direct
+// component that is a witness to an accessibility violation outside the module
+// in which the type was defined.
+static const Symbol *FindInaccessibleComponent(GenericKind::DefinedIo which,
+ const DerivedTypeSpec &derived, const Scope &scope) {
+ if (const Scope * dtScope{derived.scope()}) {
+ if (const Scope * module{FindModuleContaining(*dtScope)}) {
+ for (const auto &pair : *dtScope) {
+ const Symbol &symbol{*pair.second};
+ if (IsAllocatableOrPointer(symbol)) {
+ continue; // already an error
+ }
+ if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
+ const DerivedTypeSpec *componentDerived{nullptr};
+ if (const DeclTypeSpec * type{details->type()}) {
+ if (type->category() == DeclTypeSpec::Category::TypeDerived) {
+ componentDerived = &type->derivedTypeSpec();
+ }
+ }
+ if (componentDerived &&
+ HasDefinedIo(which, *componentDerived, &scope)) {
+ continue; // this component and its descendents are fine
+ }
+ if (symbol.attrs().test(Attr::PRIVATE) &&
+ !symbol.test(Symbol::Flag::ParentComp)) {
+ if (!DoesScopeContain(module, scope)) {
+ return &symbol;
+ }
+ }
+ if (componentDerived) {
+ if (const Symbol *
+ bad{FindInaccessibleComponent(
+ which, *componentDerived, scope)}) {
+ return bad;
+ }
+ }
+ }
+ }
+ }
+ }
+ return nullptr;
+}
+
+// Fortran 2018, 12.6.3 paragraphs 5 & 7
+parser::Message *IoChecker::CheckForBadIoType(const evaluate::DynamicType &type,
GenericKind::DefinedIo which, parser::CharBlock where) const {
- if (auto type{expr.GetType()}) {
- if (type->category() == TypeCategory::Derived &&
- !type->IsUnlimitedPolymorphic()) {
+ if (type.IsUnlimitedPolymorphic()) {
+ return &context_.Say(
+ where, "I/O list item may not be unlimited polymorphic"_err_en_US);
+ } else if (type.category() == TypeCategory::Derived) {
+ const auto &derived{type.GetDerivedTypeSpec()};
+ const Scope &scope{context_.FindScope(where)};
+ if (const Symbol *
+ bad{FindUnsafeIoDirectComponent(which, derived, scope)}) {
+ return &context_.SayWithDecl(*bad, where,
+ "Derived type '%s' in I/O cannot have an allocatable or pointer direct component '%s' unless using defined I/O"_err_en_US,
+ derived.name(), bad->name());
+ }
+ if (!HasDefinedIo(which, derived, &scope)) {
+ if (type.IsPolymorphic()) {
+ return &context_.Say(where,
+ "Derived type '%s' in I/O may not be polymorphic unless using defined I/O"_err_en_US,
+ derived.name());
+ }
if (const Symbol *
- bad{FindUnsafeIoDirectComponent(
- which, type->GetDerivedTypeSpec(), &context_.FindScope(where))}) {
- context_.SayWithDecl(*bad, where,
- "Derived type in I/O cannot have an allocatable or pointer direct component unless using defined I/O"_err_en_US);
+ bad{FindInaccessibleComponent(which, derived, scope)}) {
+ return &context_.Say(where,
+ "I/O of the derived type '%s' may not be performed without defined I/O in a scope in which a direct component like '%s' is inaccessible"_err_en_US,
+ derived.name(), bad->name());
}
}
}
+ return nullptr;
+}
+
+void IoChecker::CheckForBadIoType(const SomeExpr &expr,
+ GenericKind::DefinedIo which, parser::CharBlock where) const {
+ if (auto type{expr.GetType()}) {
+ CheckForBadIoType(*type, which, where);
+ }
+}
+
+parser::Message *IoChecker::CheckForBadIoType(const Symbol &symbol,
+ GenericKind::DefinedIo which, parser::CharBlock where) const {
+ if (auto type{evaluate::DynamicType::From(symbol)}) {
+ if (auto *msg{CheckForBadIoType(*type, which, where)}) {
+ evaluate::AttachDeclaration(*msg, symbol);
+ return msg;
+ }
+ }
+ return nullptr;
+}
+
+void IoChecker::CheckNamelist(const Symbol &namelist,
+ GenericKind::DefinedIo which, parser::CharBlock namelistLocation) const {
+ const auto &details{namelist.GetUltimate().get<NamelistDetails>()};
+ for (const Symbol &object : details.objects()) {
+ context_.CheckIndexVarRedefine(namelistLocation, object);
+ if (auto *msg{CheckForBadIoType(object, which, namelistLocation)}) {
+ evaluate::AttachDeclaration(*msg, namelist);
+ }
+ }
}
} // namespace Fortran::semantics
diff --git a/flang/lib/Semantics/check-io.h b/flang/lib/Semantics/check-io.h
index c23652a2a547..03738e883cc5 100644
--- a/flang/lib/Semantics/check-io.h
+++ b/flang/lib/Semantics/check-io.h
@@ -126,8 +126,15 @@ class IoChecker : public virtual BaseChecker {
void CheckForPureSubprogram() const;
- void CheckForBadIoComponent(
+ parser::Message *CheckForBadIoType(const evaluate::DynamicType &,
+ GenericKind::DefinedIo, parser::CharBlock) const;
+ void CheckForBadIoType(
const SomeExpr &, GenericKind::DefinedIo, parser::CharBlock) const;
+ parser::Message *CheckForBadIoType(
+ const Symbol &, GenericKind::DefinedIo, parser::CharBlock) const;
+
+ void CheckNamelist(
+ const Symbol &, GenericKind::DefinedIo, parser::CharBlock) const;
void Init(IoStmtKind s) {
stmt_ = s;
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index e53d3404c600..510f7cbc05a4 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -1194,6 +1194,7 @@ class ConstructVisitor : public virtual DeclarationVisitor {
// Creates Block scopes with neither symbol name nor symbol details.
bool Pre(const parser::SelectRankConstruct::RankCase &);
void Post(const parser::SelectRankConstruct::RankCase &);
+ bool Pre(const parser::TypeGuardStmt::Guard &);
void Post(const parser::TypeGuardStmt::Guard &);
void Post(const parser::SelectRankCaseStmt::Rank &);
bool Pre(const parser::ChangeTeamStmt &);
@@ -6407,6 +6408,14 @@ void ConstructVisitor::Post(const parser::SelectRankConstruct::RankCase &) {
PopScope();
}
+bool ConstructVisitor::Pre(const parser::TypeGuardStmt::Guard &x) {
+ if (std::holds_alternative<parser::DerivedTypeSpec>(x.u)) {
+ // CLASS IS (t)
+ SetDeclTypeSpecCategory(DeclTypeSpec::Category::ClassDerived);
+ }
+ return true;
+}
+
void ConstructVisitor::Post(const parser::TypeGuardStmt::Guard &x) {
if (auto *symbol{MakeAssocEntity()}) {
if (std::holds_alternative<parser::Default>(x.u)) {
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index dbe50dfd6f2c..5ac5f9de54bb 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -1514,31 +1514,4 @@ bool HasDefinedIo(GenericKind::DefinedIo which, const DerivedTypeSpec &derived,
return false;
}
-const Symbol *FindUnsafeIoDirectComponent(GenericKind::DefinedIo which,
- const DerivedTypeSpec &derived, const Scope *scope) {
- if (HasDefinedIo(which, derived, scope)) {
- return nullptr;
- }
- if (const Scope * dtScope{derived.scope()}) {
- for (const auto &pair : *dtScope) {
- const Symbol &symbol{*pair.second};
- if (IsAllocatableOrPointer(symbol)) {
- return &symbol;
- }
- if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
- if (const DeclTypeSpec * type{details->type()}) {
- if (type->category() == DeclTypeSpec::Category::TypeDerived) {
- if (const Symbol *
- bad{FindUnsafeIoDirectComponent(
- which, type->derivedTypeSpec(), scope)}) {
- return bad;
- }
- }
- }
- }
- }
- }
- return nullptr;
-}
-
} // namespace Fortran::semantics
diff --git a/flang/test/Semantics/io12.f90 b/flang/test/Semantics/io12.f90
index f0f2ae18e7aa..474b07c04451 100644
--- a/flang/test/Semantics/io12.f90
+++ b/flang/test/Semantics/io12.f90
@@ -52,9 +52,9 @@ subroutine test3(u)
type(maybeBad) :: y
type(poison) :: z
write(u) x ! always ok
- !ERROR: Derived type in I/O cannot have an allocatable or pointer direct component unless using defined I/O
+ !ERROR: Derived type 'maybebad' in I/O cannot have an allocatable or pointer direct component 'allocatablecomponent' unless using defined I/O
write(u) y ! bad here
- !ERROR: Derived type in I/O cannot have an allocatable or pointer direct component unless using defined I/O
+ !ERROR: Derived type 'poison' in I/O cannot have an allocatable or pointer direct component 'allocatablecomponent' unless using defined I/O
write(u) z ! bad
end subroutine
end module
@@ -69,7 +69,7 @@ subroutine test4(u)
type(poison) :: z
write(u) x ! always ok
write(u) y ! ok here
- !ERROR: Derived type in I/O cannot have an allocatable or pointer direct component unless using defined I/O
+ !ERROR: Derived type 'poison' in I/O cannot have an allocatable or pointer direct component 'allocatablecomponent' unless using defined I/O
write(u) z ! bad
end subroutine
end module
diff --git a/flang/test/Semantics/io14.f90 b/flang/test/Semantics/io14.f90
new file mode 100644
index 000000000000..6dd6763bc944
--- /dev/null
+++ b/flang/test/Semantics/io14.f90
@@ -0,0 +1,37 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Test polymorphic restrictions
+module m
+ type base
+ end type
+ type, extends(base) :: t
+ integer n
+ contains
+ procedure :: fwrite
+ generic :: write(formatted) => fwrite
+ end type
+ contains
+ subroutine fwrite(x, unit, iotype, vlist, iostat, iomsg)
+ class(t), intent(in) :: x
+ integer, intent(in) :: unit
+ character(*), intent(in) :: iotype
+ integer, intent(in) :: vlist(:)
+ integer, intent(out) :: iostat
+ character(*), intent(in out) :: iomsg
+ write(unit, *, iostat=iostat, iomsg=iomsg) '(', iotype, ':', vlist, ':', x%n, ')'
+ end subroutine
+ subroutine subr(x, y, z)
+ class(t), intent(in) :: x
+ class(base), intent(in) :: y
+ class(*), intent(in) :: z
+ print *, x ! ok
+ !ERROR: Derived type 'base' in I/O may not be polymorphic unless using defined I/O
+ print *, y
+ !ERROR: I/O list item may not be unlimited polymorphic
+ print *, z
+ end subroutine
+end
+
+program main
+ use m
+ call subr(t(123),t(234),t(345))
+end
diff --git a/flang/test/Semantics/io15.f90 b/flang/test/Semantics/io15.f90
new file mode 100644
index 000000000000..a00732a9e504
--- /dev/null
+++ b/flang/test/Semantics/io15.f90
@@ -0,0 +1,55 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Test visibility restrictions
+module m
+ type t1
+ integer, private :: ip1 = 123
+ contains
+ procedure :: fwrite1
+ generic :: write(formatted) => fwrite1
+ end type t1
+ type t2
+ integer, private :: ip2 = 234
+ type(t1) x1
+ end type t2
+ type t3
+ type(t1) x1
+ type(t2) x2
+ end type t3
+ type, extends(t2) :: t4
+ end type t4
+ contains
+ subroutine fwrite1(x, unit, iotype, vlist, iostat, iomsg)
+ class(t1), intent(in) :: x
+ integer, intent(in) :: unit
+ character(*), intent(in) :: iotype
+ integer, intent(in) :: vlist(:)
+ integer, intent(out) :: iostat
+ character(*), intent(in out) :: iomsg
+ write(unit, *, iostat=iostat, iomsg=iomsg) '(', iotype, ':', vlist, ':', x%ip1, ')'
+ end subroutine
+ subroutine local ! all OK since type is local
+ type(t1) :: x1
+ type(t2) :: x2
+ type(t3) :: x3
+ type(t4) :: x4
+ print *, x1
+ print *, x2
+ print *, x3
+ print *, x4
+ end subroutine
+end module
+
+program main
+ use m
+ type(t1) :: x1
+ type(t2) :: x2
+ type(t3) :: x3
+ type(t4) :: x4
+ print *, x1 ! ok
+ !ERROR: I/O of the derived type 't2' may not be performed without defined I/O in a scope in which a direct component like 'ip2' is inaccessible
+ print *, x2
+ !ERROR: I/O of the derived type 't3' may not be performed without defined I/O in a scope in which a direct component like 'ip2' is inaccessible
+ print *, x3
+ !ERROR: I/O of the derived type 't4' may not be performed without defined I/O in a scope in which a direct component like 'ip2' is inaccessible
+ print *, x4
+end
diff --git a/flang/test/Semantics/symbol11.f90 b/flang/test/Semantics/symbol11.f90
index 1fbe685863a6..37029369795f 100644
--- a/flang/test/Semantics/symbol11.f90
+++ b/flang/test/Semantics/symbol11.f90
@@ -68,7 +68,7 @@ subroutine s3
!REF: /s3/t2
class is (t2)
!REF: /s3/i
- !DEF: /s3/OtherConstruct1/y TARGET AssocEntity TYPE(t2)
+ !DEF: /s3/OtherConstruct1/y TARGET AssocEntity CLASS(t2)
!REF: /s3/t2/a2
i = y%a2
!REF: /s3/t1
@@ -79,7 +79,8 @@ subroutine s3
i = y%a1
class default
!DEF: /s3/OtherConstruct3/y TARGET AssocEntity CLASS(t1)
- print *, y
+ !REF:/s3/t1/a1
+ print *, y%a1
end select
end subroutine
More information about the flang-commits
mailing list