[flang] Legacy extension: non-character formats

[klausler]

Summary

Very old (pre-'77 standard) codes would use arrays initialized
with Hollerith literals, typically in DATA, as modifiable
formats.

flang/docs/Extensions.md

 * Objects in blank COMMON may be initialized.
 * Multiple specifications of the SAVE attribute on the same object
   are allowed, with a warning.
 * Specific intrinsic functions BABS, IIABS, JIABS, KIABS, ZABS, and CDABS.
 * A `POINTER` component's type need not be a sequence type when
   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
 
 * C-style backslash escape sequences in quoted CHARACTER literals
   (but not Hollerith) [-fbackslash]
 * Logical abbreviations `.T.`, `.F.`, `.N.`, `.A.`, `.O.`, and `.X.`
   [-flogical-abbreviations]
 * `.XOR.` as a synonym for `.NEQV.` [-fxor-operator]

flang/include/flang/Common/Fortran-features.h

ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines,
     AbbreviatedEditDescriptor, ProgramParentheses, PercentRefAndVal,
     OmitFunctionDummies, CrayPointer, Hollerith, ArithmeticIF, Assign,
     AssignedGOTO, Pause, OpenACC, OpenMP, CruftAfterAmpersand, ClassicCComments,
     AdditionalFormats, BigIntLiterals, RealDoControls,
     EquivalenceNumericWithCharacter, AdditionalIntrinsics, AnonymousParents,
     OldLabelDoEndStatements, LogicalIntegerAssignment, EmptySourceFile,
     ProgramReturn, ImplicitNoneTypeNever, ImplicitNoneTypeAlways,
     ForwardRefDummyImplicitNone, OpenAccessAppend, BOZAsDefaultInteger,
-    DistinguishableSpecifics, DefaultSave, PointerInSeqType)
+    DistinguishableSpecifics, DefaultSave, PointerInSeqType, NonCharacterFormat)
 
 using LanguageFeatures = EnumSet<LanguageFeature, LanguageFeature_enumSize>;
 
 class LanguageFeatureControl {
 public:
   LanguageFeatureControl() {
     // These features must be explicitly enabled by command line options.
     disable_.set(LanguageFeature::OldDebugLines);

flang/lib/Semantics/check-io.cpp

std::visit(
           [&](const parser::Label &) { flags_.set(Flag::LabelFmt); },
           [&](const parser::Star &) { flags_.set(Flag::StarFmt); },
           [&](const parser::Expr &format) {
             const SomeExpr *expr{GetExpr(format)};
             if (!expr) {
               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.
+                  "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)};
             if (!constantFormat) {
               return;
             }

flang/test/Semantics/assign06.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! Test ASSIGN statement, assigned GOTO, and assigned format labels
 ! (see subclause 8.2.4 in Fortran 90 (*not* 2018!)
 
 program main
   call test(0)
  contains
   subroutine test(n)
     integer, intent(in) :: n
     integer :: lab
     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
     assign 1 to badlab1
     !ERROR: 'badlab2' must be a default integer scalar variable
     assign 1 to badlab2
     !ERROR: 'badlab3' must be a default integer scalar variable
     assign 1 to badlab3
     !ERROR: 'test' must be a default integer scalar variable
     assign 1 to test
     if (n==1) goto lab ! ok
     if (n==1) goto implicitlab2 ! ok
     !ERROR: 'badlab1' must be a default integer scalar variable
     if (n==1) goto badlab1
     !ERROR: 'badlab2' must be a default integer scalar variable
     if (n==1) goto badlab2
     !ERROR: 'badlab3' must be a default integer scalar variable
     if (n==1) goto badlab3
     if (n==1) goto lab(1) ! ok
     if (n==1) goto lab,(1) ! ok
     if (n==1) goto lab(1,1) ! ok
     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
 end program