[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

   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
 

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

     OldLabelDoEndStatements, LogicalIntegerAssignment, EmptySourceFile,
     ProgramReturn, ImplicitNoneTypeNever, ImplicitNoneTypeAlways,
     ForwardRefDummyImplicitNone, OpenAccessAppend, BOZAsDefaultInteger,
-    DistinguishableSpecifics, DefaultSave, PointerInSeqType)
+    DistinguishableSpecifics, DefaultSave, PointerInSeqType, NonCharacterFormat)
 
 using LanguageFeatures = EnumSet<LanguageFeature, LanguageFeature_enumSize>;
 

flang/lib/Semantics/check-io.cpp

               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);

flang/test/Semantics/assign06.f90

     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 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