[flang] Ensure that portability warnings are conditional (#71857)

Before emitting a warning message, code should check that the usage in
question should be diagnosed by calling ShouldWarn(). A fair number of
sites in the code do not, and can emit portability warnings
unconditionally, which can confuse a user that hasn't asked for them
(-pedantic) and isn't terribly concerned about portability *to* other
compilers.

Add calls to ShouldWarn() or IsEnabled() around messages that need them,
and add -pedantic to tests that now require it to test their portability
messages, and add more expected message lines to those tests when
-pedantic causes other diagnostics to fire.

Author: klausler

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

@@ -37,14 +37,23 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines,
     DistinguishableSpecifics, DefaultSave, PointerInSeqType, NonCharacterFormat,
     SaveMainProgram, SaveBigMainProgramVariables,
     DistinctArrayConstructorLengths, PPCVector, RelaxedIntentInChecking,
-    ForwardRefImplicitNoneData, NullActualForAllocatable)
+    ForwardRefImplicitNoneData, NullActualForAllocatable,
+    ActualIntegerConvertedToSmallerKind, HollerithOrCharacterAsBOZ,
+    BindingAsProcedure, StatementFunctionExtensions,
+    UseGenericIntrinsicWhenSpecificDoesntMatch, DataStmtExtensions,
+    RedundantContiguous, InitBlankCommon, EmptyBindCDerivedType,
+    MiscSourceExtensions, AllocateToOtherLength, LongNames, IntrinsicAsSpecific,
+    BenignNameClash, BenignRedundancy, NullMoldAllocatableComponentValue,
+    NopassScalarBase, MiscUseExtensions, ImpliedDoIndexScope,
+    DistinctCommonSizes)
 
 // Portability and suspicious usage warnings for conforming code
 ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
     NonTargetPassedToTarget, PointerToPossibleNoncontiguous,
     ShortCharacterActual, ExprPassedToVolatile, ImplicitInterfaceActual,
     PolymorphicTransferArg, PointerComponentTransferArg, TransferSizePresence,
-    F202XAllocatableBreakingChange)
+    F202XAllocatableBreakingChange, DimMustBePresent, CommonBlockPadding,
+    LogicalVsCBool, BindCCharLength)
 
 using LanguageFeatures = EnumSet<LanguageFeature, LanguageFeature_enumSize>;
 using UsageWarnings = EnumSet<UsageWarning, UsageWarning_enumSize>;

flang/include/flang/Evaluate/common.h

@@ -9,6 +9,7 @@
 #ifndef FORTRAN_EVALUATE_COMMON_H_
 #define FORTRAN_EVALUATE_COMMON_H_
 
+#include "flang/Common/Fortran-features.h"
 #include "flang/Common/Fortran.h"
 #include "flang/Common/default-kinds.h"
 #include "flang/Common/enum-set.h"
@@ -215,22 +216,27 @@ template <typename A> class Expr;
 class FoldingContext {
 public:
   FoldingContext(const common::IntrinsicTypeDefaultKinds &d,
-      const IntrinsicProcTable &t, const TargetCharacteristics &c)
-      : defaults_{d}, intrinsics_{t}, targetCharacteristics_{c} {}
+      const IntrinsicProcTable &t, const TargetCharacteristics &c,
+      const common::LanguageFeatureControl &lfc)
+      : defaults_{d}, intrinsics_{t}, targetCharacteristics_{c},
+        languageFeatures_{lfc} {}
   FoldingContext(const parser::ContextualMessages &m,
       const common::IntrinsicTypeDefaultKinds &d, const IntrinsicProcTable &t,
-      const TargetCharacteristics &c)
-      : messages_{m}, defaults_{d}, intrinsics_{t}, targetCharacteristics_{c} {}
+      const TargetCharacteristics &c, const common::LanguageFeatureControl &lfc)
+      : messages_{m}, defaults_{d}, intrinsics_{t}, targetCharacteristics_{c},
+        languageFeatures_{lfc} {}
   FoldingContext(const FoldingContext &that)
       : messages_{that.messages_}, defaults_{that.defaults_},
         intrinsics_{that.intrinsics_},
         targetCharacteristics_{that.targetCharacteristics_},
-        pdtInstance_{that.pdtInstance_}, impliedDos_{that.impliedDos_} {}
+        pdtInstance_{that.pdtInstance_}, impliedDos_{that.impliedDos_},
+        languageFeatures_{that.languageFeatures_} {}
   FoldingContext(
       const FoldingContext &that, const parser::ContextualMessages &m)
       : messages_{m}, defaults_{that.defaults_}, intrinsics_{that.intrinsics_},
         targetCharacteristics_{that.targetCharacteristics_},
-        pdtInstance_{that.pdtInstance_}, impliedDos_{that.impliedDos_} {}
+        pdtInstance_{that.pdtInstance_}, impliedDos_{that.impliedDos_},
+        languageFeatures_{that.languageFeatures_} {}
 
   parser::ContextualMessages &messages() { return messages_; }
   const parser::ContextualMessages &messages() const { return messages_; }
@@ -242,6 +248,9 @@ class FoldingContext {
   const TargetCharacteristics &targetCharacteristics() const {
     return targetCharacteristics_;
   }
+  const common::LanguageFeatureControl &languageFeatures() const {
+    return languageFeatures_;
+  }
   bool inModuleFile() const { return inModuleFile_; }
   FoldingContext &set_inModuleFile(bool yes = true) {
     inModuleFile_ = yes;
@@ -272,6 +281,7 @@ class FoldingContext {
   const semantics::DerivedTypeSpec *pdtInstance_{nullptr};
   bool inModuleFile_{false};
   std::map<parser::CharBlock, ConstantSubscript> impliedDos_;
+  const common::LanguageFeatureControl &languageFeatures_;
 };
 
 void RealFlagWarnings(FoldingContext &, const RealFlags &, const char *op);

flang/include/flang/Lower/Bridge.h

@@ -58,10 +58,11 @@ class LoweringBridge {
          const Fortran::parser::AllCookedSources &allCooked,
          llvm::StringRef triple, fir::KindMapping &kindMap,
          const Fortran::lower::LoweringOptions &loweringOptions,
-         const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults) {
+         const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults,
+         const Fortran::common::LanguageFeatureControl &languageFeatures) {
     return LoweringBridge(ctx, semanticsContext, defaultKinds, intrinsics,
                           targetCharacteristics, allCooked, triple, kindMap,
-                          loweringOptions, envDefaults);
+                          loweringOptions, envDefaults, languageFeatures);
   }
 
   //===--------------------------------------------------------------------===//
@@ -99,6 +100,10 @@ class LoweringBridge {
     return envDefaults;
   }
 
+  const Fortran::common::LanguageFeatureControl &getLanguageFeatures() const {
+    return languageFeatures;
+  }
+
   /// Create a folding context. Careful: this is very expensive.
   Fortran::evaluate::FoldingContext createFoldingContext() const;
 
@@ -132,7 +137,8 @@ class LoweringBridge {
       const Fortran::parser::AllCookedSources &cooked, llvm::StringRef triple,
       fir::KindMapping &kindMap,
       const Fortran::lower::LoweringOptions &loweringOptions,
-      const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults);
+      const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults,
+      const Fortran::common::LanguageFeatureControl &languageFeatures);
   LoweringBridge() = delete;
   LoweringBridge(const LoweringBridge &) = delete;
 
@@ -147,6 +153,7 @@ class LoweringBridge {
   fir::KindMapping &kindMap;
   const Fortran::lower::LoweringOptions &loweringOptions;
   const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults;
+  const Fortran::common::LanguageFeatureControl &languageFeatures;
 };
 
 } // namespace lower

flang/lib/Evaluate/check-expression.cpp

@@ -12,6 +12,7 @@
 #include "flang/Evaluate/tools.h"
 #include "flang/Evaluate/traverse.h"
 #include "flang/Evaluate/type.h"
+#include "flang/Semantics/semantics.h"
 #include "flang/Semantics/symbol.h"
 #include "flang/Semantics/tools.h"
 #include <set>
@@ -1030,23 +1031,46 @@ class StmtFunctionChecker
   using Result = std::optional<parser::Message>;
   using Base = AnyTraverse<StmtFunctionChecker, Result>;
   StmtFunctionChecker(const Symbol &sf, FoldingContext &context)
-      : Base{*this}, sf_{sf}, context_{context} {}
+      : Base{*this}, sf_{sf}, context_{context} {
+    if (!context_.languageFeatures().IsEnabled(
+            common::LanguageFeature::StatementFunctionExtensions)) {
+      severity_ = parser::Severity::Error;
+    } else if (context_.languageFeatures().ShouldWarn(
+                   common::LanguageFeature::StatementFunctionExtensions)) {
+      severity_ = parser::Severity::Portability;
+    }
+  }
   using Base::operator();
 
   template <typename T> Result operator()(const ArrayConstructor<T> &) const {
-    return parser::Message{sf_.name(),
-        "Statement function '%s' should not contain an array constructor"_port_en_US,
-        sf_.name()};
+    if (severity_) {
+      auto msg{
+          "Statement function '%s' should not contain an array constructor"_port_en_US};
+      msg.set_severity(*severity_);
+      return parser::Message{sf_.name(), std::move(msg), sf_.name()};
+    } else {
+      return std::nullopt;
+    }
   }
   Result operator()(const StructureConstructor &) const {
-    return parser::Message{sf_.name(),
-        "Statement function '%s' should not contain a structure constructor"_port_en_US,
-        sf_.name()};
+    if (severity_) {
+      auto msg{
+          "Statement function '%s' should not contain a structure constructor"_port_en_US};
+      msg.set_severity(*severity_);
+      return parser::Message{sf_.name(), std::move(msg), sf_.name()};
+    } else {
+      return std::nullopt;
+    }
   }
   Result operator()(const TypeParamInquiry &) const {
-    return parser::Message{sf_.name(),
-        "Statement function '%s' should not contain a type parameter inquiry"_port_en_US,
-        sf_.name()};
+    if (severity_) {
+      auto msg{
+          "Statement function '%s' should not contain a type parameter inquiry"_port_en_US};
+      msg.set_severity(*severity_);
+      return parser::Message{sf_.name(), std::move(msg), sf_.name()};
+    } else {
+      return std::nullopt;
+    }
   }
   Result operator()(const ProcedureDesignator &proc) const {
     if (const Symbol * symbol{proc.GetSymbol()}) {
@@ -1064,16 +1088,23 @@ class StmtFunctionChecker
       if (auto chars{
               characteristics::Procedure::Characterize(proc, context_)}) {
         if (!chars->CanBeCalledViaImplicitInterface()) {
-          return parser::Message(sf_.name(),
-              "Statement function '%s' should not reference function '%s' that requires an explicit interface"_port_en_US,
-              sf_.name(), symbol->name());
+          if (severity_) {
+            auto msg{
+                "Statement function '%s' should not reference function '%s' that requires an explicit interface"_port_en_US};
+            msg.set_severity(*severity_);
+            return parser::Message{
+                sf_.name(), std::move(msg), sf_.name(), symbol->name()};
+          }
         }
       }
     }
     if (proc.Rank() > 0) {
-      return parser::Message(sf_.name(),
-          "Statement function '%s' should not reference a function that returns an array"_port_en_US,
-          sf_.name());
+      if (severity_) {
+        auto msg{
+            "Statement function '%s' should not reference a function that returns an array"_port_en_US};
+        msg.set_severity(*severity_);
+        return parser::Message{sf_.name(), std::move(msg), sf_.name()};
+      }
     }
     return std::nullopt;
   }
@@ -1083,9 +1114,12 @@ class StmtFunctionChecker
         return result;
       }
       if (expr->Rank() > 0 && !UnwrapWholeSymbolOrComponentDataRef(*expr)) {
-        return parser::Message(sf_.name(),
-            "Statement function '%s' should not pass an array argument that is not a whole array"_port_en_US,
-            sf_.name());
+        if (severity_) {
+          auto msg{
+              "Statement function '%s' should not pass an array argument that is not a whole array"_port_en_US};
+          msg.set_severity(*severity_);
+          return parser::Message{sf_.name(), std::move(msg), sf_.name()};
+        }
       }
     }
     return std::nullopt;
@@ -1094,6 +1128,7 @@ class StmtFunctionChecker
 private:
   const Symbol &sf_;
   FoldingContext &context_;
+  std::optional<parser::Severity> severity_;
 };
 
 std::optional<parser::Message> CheckStatementFunction(

flang/lib/Evaluate/intrinsics.cpp

@@ -2225,12 +2225,15 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
         if (const Symbol *whole{
                 UnwrapWholeSymbolOrComponentDataRef(actualForDummy[*dimArg])}) {
           if (IsOptional(*whole) || IsAllocatableOrObjectPointer(whole)) {
-            if (rank == Rank::scalarIfDim || arrayRank.value_or(-1) == 1) {
-              messages.Say(
-                  "The actual argument for DIM= is optional, pointer, or allocatable, and it is assumed to be present and equal to 1 at execution time"_port_en_US);
-            } else {
-              messages.Say(
-                  "The actual argument for DIM= is optional, pointer, or allocatable, and may not be absent during execution; parenthesize to silence this warning"_warn_en_US);
+            if (context.languageFeatures().ShouldWarn(
+                    common::UsageWarning::DimMustBePresent)) {
+              if (rank == Rank::scalarIfDim || arrayRank.value_or(-1) == 1) {
+                messages.Say(
+                    "The actual argument for DIM= is optional, pointer, or allocatable, and it is assumed to be present and equal to 1 at execution time"_warn_en_US);
+              } else {
+                messages.Say(
+                    "The actual argument for DIM= is optional, pointer, or allocatable, and may not be absent during execution; parenthesize to silence this warning"_warn_en_US);
+              }
             }
           }
         }
@@ -3181,28 +3184,37 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
 
   // If there was no exact match with a specific, try to match the related
   // generic and convert the result to the specific required type.
-  for (auto specIter{specificRange.first}; specIter != specificRange.second;
-       ++specIter) {
-    // We only need to check the cases with distinct generic names.
-    if (const char *genericName{specIter->second->generic}) {
-      if (specIter->second->useGenericAndForceResultType) {
-        auto genericRange{genericFuncs_.equal_range(genericName)};
-        for (auto genIter{genericRange.first}; genIter != genericRange.second;
-             ++genIter) {
-          if (auto specificCall{
-                  matchOrBufferMessages(*genIter->second, specificBuffer)}) {
-            // Force the call result type to the specific intrinsic result type
-            DynamicType newType{GetReturnType(*specIter->second, defaults_)};
-            context.messages().Say(
-                "argument types do not match specific intrinsic '%s' "
-                "requirements; using '%s' generic instead and converting the "
-                "result to %s if needed"_port_en_US,
-                call.name, genericName, newType.AsFortran());
-            specificCall->specificIntrinsic.name = call.name;
-            specificCall->specificIntrinsic.characteristics.value()
-                .functionResult.value()
-                .SetType(newType);
-            return specificCall;
+  if (context.languageFeatures().IsEnabled(common::LanguageFeature::
+              UseGenericIntrinsicWhenSpecificDoesntMatch)) {
+    for (auto specIter{specificRange.first}; specIter != specificRange.second;
+         ++specIter) {
+      // We only need to check the cases with distinct generic names.
+      if (const char *genericName{specIter->second->generic}) {
+        if (specIter->second->useGenericAndForceResultType) {
+          auto genericRange{genericFuncs_.equal_range(genericName)};
+          for (auto genIter{genericRange.first}; genIter != genericRange.second;
+               ++genIter) {
+            if (auto specificCall{
+                    matchOrBufferMessages(*genIter->second, specificBuffer)}) {
+              // Force the call result type to the specific intrinsic result
+              // type
+              DynamicType newType{GetReturnType(*specIter->second, defaults_)};
+              if (context.languageFeatures().ShouldWarn(
+                      common::LanguageFeature::
+                          UseGenericIntrinsicWhenSpecificDoesntMatch)) {
+                context.messages().Say(
+                    "Argument types do not match specific intrinsic '%s' "
+                    "requirements; using '%s' generic instead and converting "
+                    "the "
+                    "result to %s if needed"_port_en_US,
+                    call.name, genericName, newType.AsFortran());
+              }
+              specificCall->specificIntrinsic.name = call.name;
+              specificCall->specificIntrinsic.characteristics.value()
+                  .functionResult.value()
+                  .SetType(newType);
+              return specificCall;
+            }
           }
         }
       }

flang/lib/Frontend/FrontendActions.cpp

@@ -278,7 +278,8 @@ bool CodeGenAction::beginSourceFileAction() {
       ci.getInvocation().getSemanticsContext().targetCharacteristics(),
       ci.getParsing().allCooked(), ci.getInvocation().getTargetOpts().triple,
       kindMap, ci.getInvocation().getLoweringOpts(),
-      ci.getInvocation().getFrontendOpts().envDefaults);
+      ci.getInvocation().getFrontendOpts().envDefaults,
+      ci.getInvocation().getFrontendOpts().features);
 
   // Fetch module from lb, so we can set
   mlirModule = std::make_unique<mlir::ModuleOp>(lb.getModule());

flang/lib/Lower/Bridge.cpp

@@ -4914,7 +4914,8 @@ class FirConverter : public Fortran::lower::AbstractConverter {
 
 Fortran::evaluate::FoldingContext
 Fortran::lower::LoweringBridge::createFoldingContext() const {
-  return {getDefaultKinds(), getIntrinsicTable(), getTargetCharacteristics()};
+  return {getDefaultKinds(), getIntrinsicTable(), getTargetCharacteristics(),
+          getLanguageFeatures()};
 }
 
 void Fortran::lower::LoweringBridge::lower(
@@ -4944,11 +4945,13 @@ Fortran::lower::LoweringBridge::LoweringBridge(
     const Fortran::parser::AllCookedSources &cooked, llvm::StringRef triple,
     fir::KindMapping &kindMap,
     const Fortran::lower::LoweringOptions &loweringOptions,
-    const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults)
+    const std::vector<Fortran::lower::EnvironmentDefault> &envDefaults,
+    const Fortran::common::LanguageFeatureControl &languageFeatures)
     : semanticsContext{semanticsContext}, defaultKinds{defaultKinds},
       intrinsics{intrinsics}, targetCharacteristics{targetCharacteristics},
       cooked{&cooked}, context{context}, kindMap{kindMap},
-      loweringOptions{loweringOptions}, envDefaults{envDefaults} {
+      loweringOptions{loweringOptions}, envDefaults{envDefaults},
+      languageFeatures{languageFeatures} {
   // Register the diagnostic handler.
   context.getDiagEngine().registerHandler([](mlir::Diagnostic &diag) {
     llvm::raw_ostream &os = llvm::errs();

flang/lib/Parser/expr-parsers.cpp

@@ -77,10 +77,8 @@ constexpr auto primary{instrumented("primary"_en_US,
         construct<Expr>(Parser<StructureConstructor>{}),
         construct<Expr>(Parser<ArrayConstructor>{}),
         // PGI/XLF extension: COMPLEX constructor (x,y)
-        extension<LanguageFeature::ComplexConstructor>(
-            "nonstandard usage: generalized COMPLEX constructor"_port_en_US,
-            construct<Expr>(parenthesized(
-                construct<Expr::ComplexConstructor>(expr, "," >> expr)))),
+        construct<Expr>(parenthesized(
+            construct<Expr::ComplexConstructor>(expr, "," >> expr))),
         extension<LanguageFeature::PercentLOC>(
             "nonstandard usage: %LOC"_port_en_US,
             construct<Expr>("%LOC" >> parenthesized(construct<Expr::PercentLoc>(