[flang-commits] [flang] dc65c3f - [flang] Allow pointers to non-sequence types in sequence types

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-01-14T10:49:49-08:00
New Revision: dc65c3f2ffee2e745a9a6120dbbbec07b7d7f12a

URL: https://github.com/llvm/llvm-project/commit/dc65c3f2ffee2e745a9a6120dbbbec07b7d7f12a
DIFF: https://github.com/llvm/llvm-project/commit/dc65c3f2ffee2e745a9a6120dbbbec07b7d7f12a.diff

LOG: [flang] Allow pointers to non-sequence types in sequence types

Derived types with SEQUENCE must have data components of sequence
types; but this rule is relaxed as common an extension in the case of
pointer components, whose targets' types are not really relevant
to the implementation requirements of sequence types.

Differential Revision: https://reviews.llvm.org/D117158

Added: 
    

Modified: 
    flang/docs/Extensions.md
    flang/include/flang/Common/Fortran-features.h
    flang/lib/Semantics/resolve-names.cpp
    flang/test/Semantics/resolve31.f90

Removed: 
    


################################################################################
diff  --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index c5d1e7c060d54..6b639fa489b90 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -200,6 +200,10 @@ end
 * 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.)
 
 ### Extensions supported when enabled by options
 

diff  --git a/flang/include/flang/Common/Fortran-features.h b/flang/include/flang/Common/Fortran-features.h
index f5fe2b5de475e..c033de623fc01 100644
--- a/flang/include/flang/Common/Fortran-features.h
+++ b/flang/include/flang/Common/Fortran-features.h
@@ -31,7 +31,7 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines,
     OldLabelDoEndStatements, LogicalIntegerAssignment, EmptySourceFile,
     ProgramReturn, ImplicitNoneTypeNever, ImplicitNoneTypeAlways,
     ForwardRefDummyImplicitNone, OpenAccessAppend, BOZAsDefaultInteger,
-    DistinguishableSpecifics, DefaultSave)
+    DistinguishableSpecifics, DefaultSave, PointerInSeqType)
 
 using LanguageFeatures = EnumSet<LanguageFeature, LanguageFeature_enumSize>;
 

diff  --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 70cd23e557c5f..b401ef2bf276f 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -4296,8 +4296,14 @@ bool DeclarationVisitor::Pre(const parser::DataComponentDefStmt &x) {
   if (derivedTypeInfo_.sequence) { // C740
     if (const auto *declType{GetDeclTypeSpec()}) {
       if (!declType->AsIntrinsic() && !declType->IsSequenceType()) {
-        Say("A sequence type data component must either be of an"
-            " intrinsic type or a derived sequence type"_err_en_US);
+        if (GetAttrs().test(Attr::POINTER) &&
+            context().IsEnabled(common::LanguageFeature::PointerInSeqType)) {
+          if (context().ShouldWarn(common::LanguageFeature::PointerInSeqType)) {
+            Say("A sequence type data component that is a pointer to a non-sequence type is not standard"_en_US);
+          }
+        } else {
+          Say("A sequence type data component must either be of an intrinsic type or a derived sequence type"_err_en_US);
+        }
       }
     }
   }

diff  --git a/flang/test/Semantics/resolve31.f90 b/flang/test/Semantics/resolve31.f90
index 57fa5e028b325..8535ebbfa4e37 100644
--- a/flang/test/Semantics/resolve31.f90
+++ b/flang/test/Semantics/resolve31.f90
@@ -83,6 +83,8 @@ module m4
     class(*), allocatable :: typeStarField
     !ERROR: A sequence type data component must either be of an intrinsic type or a derived sequence type
     type(plainType) :: testField1
+    !Pointers are ok as an extension
+    type(plainType), pointer :: testField1p
     type(sequenceType) :: testField2
     procedure(real), pointer, nopass :: procField
   end type testType