[flang-commits] [flang] 7ff9064 - [flang] Delay parse tree rewriting for I/O UNIT=func()
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Thu Oct 6 11:30:10 PDT 2022
Author: Peter Klausler
Date: 2022-10-06T11:29:41-07:00
New Revision: 7ff9064b2609f2bcc8ca277f8cbb7f2f17d8e369
URL: https://github.com/llvm/llvm-project/commit/7ff9064b2609f2bcc8ca277f8cbb7f2f17d8e369
DIFF: https://github.com/llvm/llvm-project/commit/7ff9064b2609f2bcc8ca277f8cbb7f2f17d8e369.diff
LOG: [flang] Delay parse tree rewriting for I/O UNIT=func()
When an I/O statement's UNIT= specifier is a variable that is a
function reference, parse tree rewriting may determine the wrong type
of the result because generic resolution has not yet been performed.
So move this bit of parse tree rewriting into I/O semantic
checking so that the right handling (integer -> external file unit
number, character pointer -> internal I/O) applies.
Differential Revision: https://reviews.llvm.org/D135210
Added:
flang/test/Semantics/io13.f90
Modified:
flang/lib/Semantics/check-io.cpp
flang/lib/Semantics/rewrite-parse-tree.cpp
flang/test/Semantics/io04.f90
Removed:
################################################################################
diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp
index 60980405fdc0..6322a6570b05 100644
--- a/flang/lib/Semantics/check-io.cpp
+++ b/flang/lib/Semantics/check-io.cpp
@@ -542,17 +542,50 @@ void IoChecker::Enter(const parser::IoControlSpec::Size &var) {
void IoChecker::Enter(const parser::IoUnit &spec) {
if (const parser::Variable * var{std::get_if<parser::Variable>(&spec.u)}) {
- if (stmt_ == IoStmtKind::Write) {
- CheckForDefinableVariable(*var, "Internal file");
+ // Only now after generic resolution can it be known whether a function
+ // call appearing as UNIT=f() is an integer scalar external unit number
+ // or a character pointer for internal I/O.
+ const auto *expr{GetExpr(context_, *var)};
+ std::optional<evaluate::DynamicType> dyType;
+ if (expr) {
+ dyType = expr->GetType();
}
- if (const auto *expr{GetExpr(context_, *var)}) {
+ if (dyType && dyType->category() == TypeCategory::Integer) {
+ if (expr->Rank() != 0) {
+ context_.Say(parser::FindSourceLocation(*var),
+ "I/O unit number must be scalar"_err_en_US);
+ }
+ // In the case of an integer unit number variable, rewrite the parse
+ // tree as if the unit had been parsed as a FileUnitNumber in order
+ // to ease lowering.
+ auto &mutableSpec{const_cast<parser::IoUnit &>(spec)};
+ auto &mutableVar{std::get<parser::Variable>(mutableSpec.u)};
+ auto source{mutableVar.GetSource()};
+ auto typedExpr{std::move(mutableVar.typedExpr)};
+ auto newExpr{common::visit(
+ [](auto &&indirection) {
+ return parser::Expr{std::move(indirection)};
+ },
+ std::move(mutableVar.u))};
+ newExpr.source = source;
+ newExpr.typedExpr = std::move(typedExpr);
+ mutableSpec.u = parser::FileUnitNumber{
+ parser::ScalarIntExpr{parser::IntExpr{std::move(newExpr)}}};
+ } else if (!dyType || dyType->category() != TypeCategory::Character) {
+ SetSpecifier(IoSpecKind::Unit);
+ context_.Say(parser::FindSourceLocation(*var),
+ "I/O unit must be a character variable or a scalar integer expression"_err_en_US);
+ } else { // CHARACTER variable (internal I/O)
+ if (stmt_ == IoStmtKind::Write) {
+ CheckForDefinableVariable(*var, "Internal file");
+ }
if (HasVectorSubscript(*expr)) {
context_.Say(parser::FindSourceLocation(*var), // C1201
"Internal file must not have a vector subscript"_err_en_US);
}
+ SetSpecifier(IoSpecKind::Unit);
+ flags_.set(Flag::InternalUnit);
}
- SetSpecifier(IoSpecKind::Unit);
- flags_.set(Flag::InternalUnit);
} else if (std::get_if<parser::Star>(&spec.u)) {
SetSpecifier(IoSpecKind::Unit);
flags_.set(Flag::StarUnit);
diff --git a/flang/lib/Semantics/rewrite-parse-tree.cpp b/flang/lib/Semantics/rewrite-parse-tree.cpp
index 8fb7673bbfac..05df1f408082 100644
--- a/flang/lib/Semantics/rewrite-parse-tree.cpp
+++ b/flang/lib/Semantics/rewrite-parse-tree.cpp
@@ -41,7 +41,6 @@ class RewriteMutator {
void Post(parser::Name &);
void Post(parser::SpecificationPart &);
bool Pre(parser::ExecutionPart &);
- void Post(parser::IoUnit &);
void Post(parser::ReadStmt &);
void Post(parser::WriteStmt &);
@@ -130,29 +129,6 @@ bool RewriteMutator::Pre(parser::ExecutionPart &x) {
return true;
}
-// Convert a syntactically ambiguous io-unit internal-file-variable to a
-// file-unit-number.
-void RewriteMutator::Post(parser::IoUnit &x) {
- if (auto *var{std::get_if<parser::Variable>(&x.u)}) {
- const parser::Name &last{parser::GetLastName(*var)};
- DeclTypeSpec *type{last.symbol ? last.symbol->GetType() : nullptr};
- if (!type || type->category() != DeclTypeSpec::Character) {
- // If the Variable is not known to be character (any kind), transform
- // the I/O unit in situ to a FileUnitNumber so that automatic expression
- // constraint checking will be applied.
- auto source{var->GetSource()};
- auto expr{common::visit(
- [](auto &&indirection) {
- return parser::Expr{std::move(indirection)};
- },
- std::move(var->u))};
- expr.source = source;
- x.u = parser::FileUnitNumber{
- parser::ScalarIntExpr{parser::IntExpr{std::move(expr)}}};
- }
- }
-}
-
// When a namelist group name appears (without NML=) in a READ or WRITE
// statement in such a way that it can be misparsed as a format expression,
// rewrite the I/O statement's parse tree node as if the namelist group
diff --git a/flang/test/Semantics/io04.f90 b/flang/test/Semantics/io04.f90
index e53b1ebf43b3..77e1bb6286f5 100644
--- a/flang/test/Semantics/io04.f90
+++ b/flang/test/Semantics/io04.f90
@@ -87,7 +87,7 @@
!ERROR: If UNIT=* appears, REC must not appear
write(*, rec=13) 'Ok'
- !ERROR: Must have INTEGER type, but is REAL(4)
+ !ERROR: I/O unit must be a character variable or a scalar integer expression
write(unit, *) 'Ok'
!ERROR: If ADVANCE appears, UNIT=internal-file must not appear
diff --git a/flang/test/Semantics/io13.f90 b/flang/test/Semantics/io13.f90
new file mode 100644
index 000000000000..f50f59ffc186
--- /dev/null
+++ b/flang/test/Semantics/io13.f90
@@ -0,0 +1,53 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Tests for UNIT=function()
+module m1
+ integer, target :: itarget
+ character(20), target :: ctarget
+ logical, target :: ltarget
+ interface gf
+ module procedure :: intf, pintf, pchf, logf, plogf
+ end interface
+ contains
+ integer function intf(n)
+ integer(1), intent(in) :: n
+ intf = n
+ end function
+ function pintf(n)
+ integer(2), intent(in) :: n
+ integer, pointer :: pintf
+ pintf => itarget
+ pintf = n
+ end function
+ function pchf(n)
+ integer(4), intent(in) :: n
+ character(:), pointer :: pchf
+ pchf => ctarget
+ end function
+ logical function logf(n)
+ integer(8), intent(in) :: n
+ logf = .true.
+ end function
+ function plogf(n)
+ integer(16), intent(in) :: n
+ logical, pointer :: plf
+ plf => ltarget
+ end function
+ subroutine test
+ write(intf(6_1),"('hi')")
+ write(pintf(6_2),"('hi')")
+ write(pchf(123_4),"('hi')")
+ write(gf(6_1),"('hi')")
+ write(gf(6_2),"('hi')")
+ write(gf(666_4),"('hi')")
+ !ERROR: I/O unit must be a character variable or a scalar integer expression
+ write(logf(666_8),"('hi')")
+ !ERROR: I/O unit must be a character variable or a scalar integer expression
+ write(plogf(666_16),"('hi')")
+ !ERROR: I/O unit must be a character variable or a scalar integer expression
+ write(gf(666_8),"('hi')")
+ !ERROR: I/O unit must be a character variable or a scalar integer expression
+ write(gf(666_16),"('hi')")
+ !ERROR: I/O unit must be a character variable or a scalar integer expression
+ write(null(),"('hi')")
+ end subroutine
+end module
More information about the flang-commits
mailing list