diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h index c2fa9a2228180..dafe46f65ed75 100644 --- a/flang/include/flang/Parser/parse-tree.h +++ b/flang/include/flang/Parser/parse-tree.h @@ -2642,7 +2642,7 @@ WRAPPER_CLASS(FileUnitNumber, ScalarIntExpr); // symbols are known. struct IoUnit { UNION_CLASS_BOILERPLATE(IoUnit); - std::variant u; + std::variant, Star> u; }; // R1206 file-name-expr -> scalar-default-char-expr diff --git a/flang/lib/Lower/IO.cpp b/flang/lib/Lower/IO.cpp index 75453721d91a2..515ceb8e89c86 100644 --- a/flang/lib/Lower/IO.cpp +++ b/flang/lib/Lower/IO.cpp @@ -1841,7 +1841,9 @@ static mlir::Value genIOUnit(Fortran::lower::AbstractConverter &converter, int defaultUnitNumber) { auto &builder = converter.getFirOpBuilder(); if (iounit) - if (auto *e = std::get_if(&iounit->u)) + if (auto *e = + std::get_if>( + &iounit->u)) return genIOUnitNumber(converter, loc, Fortran::semantics::GetExpr(*e), ty, csi, stmtCtx); return builder.create( diff --git a/flang/lib/Parser/io-parsers.cpp b/flang/lib/Parser/io-parsers.cpp index 25b09efd40c52..c69ea58738b90 100644 --- a/flang/lib/Parser/io-parsers.cpp +++ b/flang/lib/Parser/io-parsers.cpp @@ -23,8 +23,12 @@ namespace Fortran::parser { // R905 char-variable -> variable // "char-variable" is attempted first since it's not type constrained but // syntactically ambiguous with "file-unit-number", which is constrained. +// Note, "file-unit-number" is replaced by "expr" to allow for better +// error messages. TYPE_PARSER(construct(variable / lookAhead(space / ",);\n"_ch)) || - construct(fileUnitNumber) || construct(star)) + construct( + indirect(expr) / (lookAhead(space >> ",)"_ch) || atEndOfStmt)) || + construct(star)) // R1202 file-unit-number -> scalar-int-expr TYPE_PARSER(construct( diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp index 42c3b9e11efc1..10b32d9af0f88 100644 --- a/flang/lib/Semantics/check-io.cpp +++ b/flang/lib/Semantics/check-io.cpp @@ -9,7 +9,9 @@ #include "check-io.h" #include "definable.h" #include "flang/Common/format.h" +#include "flang/Common/indirection.h" #include "flang/Evaluate/tools.h" +#include "flang/Parser/characters.h" #include "flang/Parser/tools.h" #include "flang/Semantics/expression.h" #include "flang/Semantics/tools.h" @@ -576,8 +578,9 @@ void IoChecker::Enter(const parser::IoUnit &spec) { std::move(mutableVar.u))}; newExpr.source = source; newExpr.typedExpr = std::move(typedExpr); - mutableSpec.u = parser::FileUnitNumber{ - parser::ScalarIntExpr{parser::IntExpr{std::move(newExpr)}}}; + mutableSpec.u = common::Indirection{std::move(newExpr)}; + SetSpecifier(IoSpecKind::Unit); + flags_.set(Flag::NumberUnit); } else if (!dyType || dyType->category() != TypeCategory::Character) { SetSpecifier(IoSpecKind::Unit); context_.Say(parser::FindSourceLocation(*var), @@ -598,6 +601,26 @@ void IoChecker::Enter(const parser::IoUnit &spec) { } else if (std::get_if(&spec.u)) { SetSpecifier(IoSpecKind::Unit); flags_.set(Flag::StarUnit); + } else if (const common::Indirection *pexpr{ + std::get_if>(&spec.u)}) { + const auto *expr{GetExpr(context_, *pexpr)}; + std::optional dyType; + if (expr) { + dyType = expr->GetType(); + } + if (!expr || !dyType) { + context_.Say(parser::FindSourceLocation(*pexpr), + "I/O unit must be a character variable or scalar integer expression"_err_en_US); + } else if (dyType->category() != TypeCategory::Integer) { + context_.Say(parser::FindSourceLocation(*pexpr), + "I/O unit must be a character variable or a scalar integer expression, but is an expression of type %s"_err_en_US, + parser::ToUpperCaseLetters(dyType->AsFortran())); + } else if (expr->Rank() != 0) { + context_.Say(parser::FindSourceLocation(*pexpr), + "I/O unit number must be scalar"_err_en_US); + } + SetSpecifier(IoSpecKind::Unit); + flags_.set(Flag::NumberUnit); } } diff --git a/flang/test/Semantics/io03.f90 b/flang/test/Semantics/io03.f90 index 6c05924f09dce..3841735ebff95 100644 --- a/flang/test/Semantics/io03.f90 +++ b/flang/test/Semantics/io03.f90 @@ -171,6 +171,22 @@ !ERROR: ID kind (2) is smaller than default INTEGER kind (4) read(10, id=id2, asynchronous='yes') jj + !ERROR: I/O unit must be a character variable or a scalar integer expression, but is an expression of type CHARACTER(1) + read((msg), *) + !ERROR: I/O unit must be a character variable or a scalar integer expression, but is an expression of type CHARACTER(KIND=1,LEN=8_8) + read("a string", *) + !ERROR: I/O unit must be a character variable or a scalar integer expression, but is an expression of type CHARACTER(1) + read(msg//msg, *) + !ERROR: I/O unit must be a character variable or a scalar integer expression, but is an expression of type LOGICAL(4) + read(.true., *) + !ERROR: I/O unit must be a character variable or a scalar integer expression, but is an expression of type REAL(4) + read(1.0, *) + read(internal_fileA, *) + !ERROR: I/O unit must be a character variable or a scalar integer expression, but is an expression of type CHARACTER(1) + read((internal_fileA), *) + !ERROR: I/O unit number must be scalar + read([1,2,3], *) + 9 continue end diff --git a/flang/test/Semantics/io04.f90 b/flang/test/Semantics/io04.f90 index 7114f14a9488a..1ad2c71a9f948 100644 --- a/flang/test/Semantics/io04.f90 +++ b/flang/test/Semantics/io04.f90 @@ -3,6 +3,7 @@ character(kind=1,len=100) msg character(20) sign character, parameter :: const_internal_file*(*) = "(I6)" + character(kind=1,len=50) internal_fileA(20) integer*1 stat1, id1 integer*2 stat2 integer*4 stat4 @@ -138,6 +139,23 @@ write(*, '(X)') + !ERROR: I/O unit must be a character variable or a scalar integer expression, but is an expression of type CHARACTER(1) + write((msg), *) + !ERROR: I/O unit must be a character variable or a scalar integer expression, but is an expression of type CHARACTER(KIND=1,LEN=8_8) + write("a string", *) + !ERROR: I/O unit must be a character variable or a scalar integer expression, but is an expression of type CHARACTER(1) + write(msg//msg, *) + !ERROR: I/O unit must be a character variable or a scalar integer expression, but is an expression of type LOGICAL(4) + write(.true., *) + !ERROR: I/O unit must be a character variable or a scalar integer expression, but is an expression of type REAL(4) + write(1.0, *) + write(internal_fileA, *) + !ERROR: I/O unit must be a character variable or a scalar integer expression, but is an expression of type CHARACTER(1) + write((internal_fileA), *) + !ERROR: I/O unit number must be scalar + write([1,2,3], *) + + !ERROR: Output item must not be a procedure print*, procptr !ERROR: Output item must not be a procedure diff --git a/flang/test/Semantics/unsigned-errors.f90 b/flang/test/Semantics/unsigned-errors.f90 index 24d6460bc2fe3..2e2539b40e5ee 100644 --- a/flang/test/Semantics/unsigned-errors.f90 +++ b/flang/test/Semantics/unsigned-errors.f90 @@ -64,7 +64,7 @@ !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types INTEGER(4) and UNSIGNED(4) j = 1u -!ERROR: Must have INTEGER type, but is UNSIGNED(4) +!ERROR: I/O unit must be a character variable or a scalar integer expression, but is an expression of type UNSIGNED(4) write(6u,*) 'hi' !ERROR: ARITHMETIC IF expression must not be an UNSIGNED expression