Index: flang/docs/Extensions.md =================================================================== --- flang/docs/Extensions.md +++ flang/docs/Extensions.md @@ -204,6 +204,11 @@ 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 Index: flang/include/flang/Common/Fortran-features.h =================================================================== --- flang/include/flang/Common/Fortran-features.h +++ flang/include/flang/Common/Fortran-features.h @@ -31,7 +31,7 @@ OldLabelDoEndStatements, LogicalIntegerAssignment, EmptySourceFile, ProgramReturn, ImplicitNoneTypeNever, ImplicitNoneTypeAlways, ForwardRefDummyImplicitNone, OpenAccessAppend, BOZAsDefaultInteger, - DistinguishableSpecifics, DefaultSave, PointerInSeqType) + DistinguishableSpecifics, DefaultSave, PointerInSeqType, NonCharacterFormat) using LanguageFeatures = EnumSet; Index: flang/lib/Semantics/check-io.cpp =================================================================== --- flang/lib/Semantics/check-io.cpp +++ flang/lib/Semantics/check-io.cpp @@ -213,21 +213,41 @@ return; } auto type{expr->GetType()}; - if (!type || - (type->category() != TypeCategory::Integer && - type->category() != TypeCategory::Character) || + if (type && type->category() == TypeCategory::Integer && + type->kind() == + context_.defaultKinds().GetDefaultKind(type->category()) && + expr->Rank() == 0) { + flags_.set(Flag::AssignFmt); + 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 integer"_err_en_US); + "Format expression must be default character or default scalar integer"_err_en_US); return; } - if (type->category() == TypeCategory::Integer) { - flags_.set(Flag::AssignFmt); - if (expr->Rank() != 0 || !IsVariable(*expr)) { - context_.Say(format.source, - "Assigned format label must be a scalar variable"_err_en_US); - } + 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); Index: flang/test/Semantics/assign06.f90 =================================================================== --- flang/test/Semantics/assign06.f90 +++ flang/test/Semantics/assign06.f90 @@ -11,6 +11,8 @@ 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 @@ 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