[flang] Legacy extension: non-character formats
Very old (pre-'77 standard) codes would use arrays initialized with Hollerith literals, typically in DATA, as modifiable formats. Differential Revision: https://reviews.llvm.org/D117344
This commit is contained in:
parent
fb3b86fedc
commit
cadc07f01f
|
@ -204,6 +204,11 @@ end
|
|||
the component appears in a derived type with `SEQUENCE`.
|
||||
(This case should probably be an exception to constraint C740 in
|
||||
the standard.)
|
||||
* Format expressions that have type but are not character and not
|
||||
integer scalars are accepted so long as they are simply contiguous.
|
||||
This legacy extension supports pre-Fortran'77 usage in which
|
||||
variables initialized in DATA statements with Hollerith literals
|
||||
as modifiable formats.
|
||||
|
||||
### Extensions supported when enabled by options
|
||||
|
||||
|
|
|
@ -31,7 +31,7 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines,
|
|||
OldLabelDoEndStatements, LogicalIntegerAssignment, EmptySourceFile,
|
||||
ProgramReturn, ImplicitNoneTypeNever, ImplicitNoneTypeAlways,
|
||||
ForwardRefDummyImplicitNone, OpenAccessAppend, BOZAsDefaultInteger,
|
||||
DistinguishableSpecifics, DefaultSave, PointerInSeqType)
|
||||
DistinguishableSpecifics, DefaultSave, PointerInSeqType, NonCharacterFormat)
|
||||
|
||||
using LanguageFeatures = EnumSet<LanguageFeature, LanguageFeature_enumSize>;
|
||||
|
||||
|
|
|
@ -213,23 +213,43 @@ void IoChecker::Enter(const parser::Format &spec) {
|
|||
return;
|
||||
}
|
||||
auto type{expr->GetType()};
|
||||
if (!type ||
|
||||
(type->category() != TypeCategory::Integer &&
|
||||
type->category() != TypeCategory::Character) ||
|
||||
type->kind() !=
|
||||
context_.defaultKinds().GetDefaultKind(type->category())) {
|
||||
context_.Say(format.source,
|
||||
"Format expression must be default character or integer"_err_en_US);
|
||||
return;
|
||||
}
|
||||
if (type->category() == TypeCategory::Integer) {
|
||||
if (type && type->category() == TypeCategory::Integer &&
|
||||
type->kind() ==
|
||||
context_.defaultKinds().GetDefaultKind(type->category()) &&
|
||||
expr->Rank() == 0) {
|
||||
flags_.set(Flag::AssignFmt);
|
||||
if (expr->Rank() != 0 || !IsVariable(*expr)) {
|
||||
if (!IsVariable(*expr)) {
|
||||
context_.Say(format.source,
|
||||
"Assigned format label must be a scalar variable"_err_en_US);
|
||||
}
|
||||
return;
|
||||
}
|
||||
if (type && type->category() != TypeCategory::Character &&
|
||||
(type->category() != TypeCategory::Integer ||
|
||||
expr->Rank() > 0) &&
|
||||
context_.IsEnabled(
|
||||
common::LanguageFeature::NonCharacterFormat)) {
|
||||
// Legacy extension: using non-character variables, typically
|
||||
// DATA-initialized with Hollerith, as format expressions.
|
||||
if (context_.ShouldWarn(
|
||||
common::LanguageFeature::NonCharacterFormat)) {
|
||||
context_.Say(format.source,
|
||||
"Non-character format expression is not standard"_en_US);
|
||||
}
|
||||
} else if (!type ||
|
||||
type->kind() !=
|
||||
context_.defaultKinds().GetDefaultKind(type->category())) {
|
||||
context_.Say(format.source,
|
||||
"Format expression must be default character or default scalar integer"_err_en_US);
|
||||
return;
|
||||
}
|
||||
if (expr->Rank() > 0 &&
|
||||
!IsSimplyContiguous(*expr, context_.foldingContext())) {
|
||||
// The runtime APIs don't allow arbitrary descriptors for formats.
|
||||
context_.Say(format.source,
|
||||
"Format expression must be a simply contiguous array if not scalar"_err_en_US);
|
||||
return;
|
||||
}
|
||||
flags_.set(Flag::CharFmt);
|
||||
const std::optional<std::string> constantFormat{
|
||||
GetConstExpr<std::string>(format)};
|
||||
|
|
|
@ -11,6 +11,8 @@ program main
|
|||
integer(kind=1) :: badlab1
|
||||
real :: badlab2
|
||||
integer :: badlab3(1)
|
||||
real, pointer :: badlab4(:) ! not contiguous
|
||||
real, pointer, contiguous :: oklab4(:)
|
||||
assign 1 to lab ! ok
|
||||
assign 1 to implicitlab1 ! ok
|
||||
!ERROR: 'badlab1' must be a default integer scalar variable
|
||||
|
@ -35,12 +37,16 @@ program main
|
|||
assign 3 to lab ! ok
|
||||
write(*,fmt=lab) ! ok
|
||||
write(*,fmt=implicitlab3) ! ok
|
||||
!ERROR: Format expression must be default character or integer
|
||||
!ERROR: Format expression must be default character or default scalar integer
|
||||
write(*,fmt=badlab1)
|
||||
!ERROR: Format expression must be default character or integer
|
||||
write(*,fmt=badlab2)
|
||||
!ERROR: Format expression must be default character or integer
|
||||
!ERROR: Format expression must be default character or default scalar integer
|
||||
write(*,fmt=z'feedface')
|
||||
!Legacy extension cases
|
||||
write(*,fmt=badlab2)
|
||||
write(*,fmt=badlab3)
|
||||
!ERROR: Format expression must be a simply contiguous array if not scalar
|
||||
write(*,fmt=badlab4)
|
||||
write(*,fmt=badlab5) ! ok legacy extension
|
||||
1 continue
|
||||
3 format('yes')
|
||||
end subroutine test
|
||||
|
|
Loading…
Reference in a new issue