[flang] Avoid spurious warnings from reading module files

[klausler]

Summary

When processing the literal constants of the various kinds of
INTEGER that are too large by 1 (e.g., 2147483648_4) in expression
analysis, emit a portability warning rather than a fatal error if
the literal constant appears as the operand to a unary minus, since
the folded result will be in range. And don't emit any warning if
the negated literal is coming from a module file -- f18 wrote the
module file and the warning would simply be confusing, especially to
the programmer that wrote (-2147483647_4-1) in the first place.

Further, emit portability warnings for the canonical expressions for
infinities and NaN (-1./0., 0./0., & 1./0.), but not when they appear
in a module file, for the same reason. The Fortran language has no
syntax for these special values so we have to emit expressions that
fold to them.

Fixes LLVM bugs https://github.com/llvm/llvm-project/issues/55086 and
https://github.com/llvm/llvm-project/issues/55081.

flang/docs/Extensions.md

* If both the `COUNT=` and the `COUNT_MAX=` optional arguments are
   we require that their types have the same integer kind, since the
   kind of these arguments is used to select the clock rate.  In common
   with some other compilers, the clock rate varies from tenths of a
   second to nanoseconds depending on argument kind and platform support.
 * If a dimension of a descriptor has zero extent in a call to
   `CFI_section`, `CFI_setpointer` or `CFI_allocate`, the lower
   bound on that dimension will be set to 1 for consistency with
   the `LBOUND()` intrinsic function.
+* `-2147483648_4` is, strictly speaking, a non-conforming literal
+  constant on a machine with 32-bit two's-complement integers as
+  kind 4, because the grammar of Fortran expressions parses it as a
+  negation of a literal constant, not a negative literal constant.
+  This compiler accepts it with a portability warning.
 
 ## Extensions, deletions, and legacy features supported by default
 
 * Tabs in source
 * `<>` as synonym for `.NE.` and `/=`
 * `$` and `@` as legal characters in names
 * Initialization in type declaration statements using `/values/`
 * Kind specification with `*`, e.g. `REAL*4`

flang/include/flang/Evaluate/common.h

const common::IntrinsicTypeDefaultKinds &defaults() const {
     return defaults_;
   }
   Rounding rounding() const { return rounding_; }
   bool flushSubnormalsToZero() const { return flushSubnormalsToZero_; }
   bool bigEndian() const { return bigEndian_; }
   std::size_t maxAlignment() const { return maxAlignment_; }
   const semantics::DerivedTypeSpec *pdtInstance() const { return pdtInstance_; }
   const IntrinsicProcTable &intrinsics() const { return intrinsics_; }
+  bool inModuleFile() const { return inModuleFile_; }
+  FoldingContext &set_inModuleFile(bool yes = true) {
+    inModuleFile_ = yes;
+    return *this;
+  }
 
   ConstantSubscript &StartImpliedDo(parser::CharBlock, ConstantSubscript = 1);
   std::optional<ConstantSubscript> GetImpliedDo(parser::CharBlock) const;
   void EndImpliedDo(parser::CharBlock);
 
   std::map<parser::CharBlock, ConstantSubscript> &impliedDos() {
     return impliedDos_;
   }
 
   common::Restorer<const semantics::DerivedTypeSpec *> WithPDTInstance(
       const semantics::DerivedTypeSpec &spec) {
     return common::ScopedSet(pdtInstance_, &spec);
   }
 
 private:
   parser::ContextualMessages messages_;
   const common::IntrinsicTypeDefaultKinds &defaults_;
   const IntrinsicProcTable &intrinsics_;
   Rounding rounding_{defaultRounding};
   bool flushSubnormalsToZero_{false};
   static constexpr bool bigEndian_{false}; // TODO: configure for target
   static constexpr std::size_t maxAlignment_{8}; // TODO: configure for target
   const semantics::DerivedTypeSpec *pdtInstance_{nullptr};
+  bool inModuleFile_{false};
   std::map<parser::CharBlock, ConstantSubscript> impliedDos_;
 };
 
 void RealFlagWarnings(FoldingContext &, const RealFlags &, const char *op);
 } // namespace Fortran::evaluate
 #endif // FORTRAN_EVALUATE_COMMON_H_

flang/include/flang/Semantics/expression.h

public:
 
   // Builds a typed Designator from an untyped DataRef
   MaybeExpr Designate(DataRef &&);
 
 protected:
   int IntegerTypeSpecKind(const parser::IntegerTypeSpec &);
 
 private:
-  MaybeExpr Analyze(const parser::IntLiteralConstant &);
+  MaybeExpr Analyze(const parser::IntLiteralConstant &, bool negated = false);
   MaybeExpr Analyze(const parser::RealLiteralConstant &);
   MaybeExpr Analyze(const parser::ComplexPart &);
   MaybeExpr Analyze(const parser::ComplexLiteralConstant &);
   MaybeExpr Analyze(const parser::LogicalLiteralConstant &);
   MaybeExpr Analyze(const parser::CharLiteralConstant &);
   MaybeExpr Analyze(const parser::HollerithLiteralConstant &);
   MaybeExpr Analyze(const parser::BOZLiteralConstant &);
   MaybeExpr Analyze(const parser::NamedConstant &);
template <typename... As> MaybeExpr Analyze(const std::variant<As...> &u) {
     return common::visit([&](const auto &x) { return Analyze(x); }, u);
   }
 
   // Analysis subroutines
   int AnalyzeKindParam(
       const std::optional<parser::KindParam> &, int defaultKind);
   template <typename PARSED>
   MaybeExpr ExprOrVariable(const PARSED &, parser::CharBlock source);
-  template <typename PARSED> MaybeExpr IntLiteralConstant(const PARSED &);
+  template <typename PARSED>
+  MaybeExpr IntLiteralConstant(const PARSED &, bool negated = false);
   MaybeExpr AnalyzeString(std::string &&, int kind);
   std::optional<Expr<SubscriptInteger>> AsSubscript(MaybeExpr &&);
   std::optional<Expr<SubscriptInteger>> TripletPart(
       const std::optional<parser::Subscript> &);
   std::optional<Subscript> AnalyzeSectionSubscript(
       const parser::SectionSubscript &);
   std::vector<Subscript> AnalyzeSectionSubscripts(
       const std::list<parser::SectionSubscript> &);

flang/include/flang/Semantics/semantics.h

void SayWithDecl(const Symbol &symbol, const parser::CharBlock &at,
       parser::MessageFixedText &&msg, A &&...args) {
     auto &message{Say(at, std::move(msg), args...)};
     evaluate::AttachDeclaration(&message, symbol);
   }
 
   const Scope &FindScope(parser::CharBlock) const;
   Scope &FindScope(parser::CharBlock);
 
+  bool IsInModuleFile(parser::CharBlock) const;
+
   const ConstructStack &constructStack() const { return constructStack_; }
   template <typename N> void PushConstruct(const N &node) {
     constructStack_.emplace_back(&node);
   }
   void PopConstruct();
 
   ENUM_CLASS(IndexVarKind, DO, FORALL)
   // Check to see if a variable being redefined is a DO or FORALL index.

flang/lib/Evaluate/fold-implementation.h

if constexpr (T::category == TypeCategory::Integer) {
       }
       if (quotAndRem.overflow) {
         context.messages().Say(
             "INTEGER(%d) division overflowed"_warn_en_US, T::kind);
       }
       return Expr<T>{Constant<T>{quotAndRem.quotient}};
     } else {
       auto quotient{folded->first.Divide(folded->second, context.rounding())};
+      // Don't warn about -1./0., 0./0., or 1./0. from a module file
+      // they are interpreted as canonical Fortran representations of -Inf,
+      // NaN, and Inf respectively.
+      bool isCanonicalNaNOrInf{false};
+      if constexpr (T::category == TypeCategory::Real) {
+        if (folded->second.IsZero() && context.inModuleFile()) {
+          using IntType = typename T::Scalar::Word;
+          auto intNumerator{folded->first.template ToInteger<IntType>()};
+          isCanonicalNaNOrInf = intNumerator.flags == RealFlags{} &&
+              intNumerator.value >= IntType{-1} &&
+              intNumerator.value <= IntType{1};
+        }
+      }
+      if (!isCanonicalNaNOrInf) {
         RealFlagWarnings(context, quotient.flags, "division");
+      }
       if (context.flushSubnormalsToZero()) {
         quotient.value = quotient.value.FlushSubnormalToZero();
       }
       return Expr<T>{Constant<T>{quotient.value}};
     }
   }
   return Expr<T>{std::move(x)};
 }

flang/lib/Semantics/expression.cpp

 
 // Common handling of parser::IntLiteralConstant and SignedIntLiteralConstant
 struct IntTypeVisitor {
   using Result = MaybeExpr;
   using Types = IntegerTypes;
   template <typename T> Result Test() {
     if (T::kind >= kind) {
       const char *p{digits.begin()};
-      auto value{T::Scalar::Read(p, 10, true /*signed*/)};
-      if (!value.overflow) {
+      using Int = typename T::Scalar;
+      typename Int::ValueWithOverflow num{0, false};
+      if (isNegated) {
+        auto unsignedNum{Int::Read(p, 10, false /*unsigned*/)};
+        num.value = unsignedNum.value.Negate().value;
+        num.overflow = unsignedNum.overflow || num.value > Int{0};
+        if (!num.overflow && num.value.Negate().overflow &&
+            !analyzer.context().IsInModuleFile(digits)) {
+          analyzer.Say(digits,
+              "negated maximum INTEGER(KIND=%d) literal"_port_en_US, T::kind);
+        }
+      } else {
+        num = Int::Read(p, 10, true /*signed*/);
+      }
+      if (!num.overflow) {
         if (T::kind > kind) {
           if (!isDefaultKind ||
               !analyzer.context().IsEnabled(LanguageFeature::BigIntLiterals)) {
             return std::nullopt;
           } else if (analyzer.context().ShouldWarn(
                          LanguageFeature::BigIntLiterals)) {
             analyzer.Say(digits,
                 "Integer literal is too large for default INTEGER(KIND=%d); "
                 "assuming INTEGER(KIND=%d)"_port_en_US,
                 kind, T::kind);
           }
         }
         return Expr<SomeType>{
-            Expr<SomeInteger>{Expr<T>{Constant<T>{std::move(value.value)}}}};
+            Expr<SomeInteger>{Expr<T>{Constant<T>{std::move(num.value)}}}};
       }
     }
     return std::nullopt;
   }
   ExpressionAnalyzer &analyzer;
   parser::CharBlock digits;
   int kind;
   bool isDefaultKind;
+  bool isNegated;
 };
 
 template <typename PARSED>
-MaybeExpr ExpressionAnalyzer::IntLiteralConstant(const PARSED &x) {
+MaybeExpr ExpressionAnalyzer::IntLiteralConstant(
+    const PARSED &x, bool isNegated) {
   const auto &kindParam{std::get<std::optional<parser::KindParam>>(x.t)};
   bool isDefaultKind{!kindParam};
   int kind{AnalyzeKindParam(kindParam, GetDefaultKind(TypeCategory::Integer))};
   if (CheckIntrinsicKind(TypeCategory::Integer, kind)) {
     auto digits{std::get<parser::CharBlock>(x.t)};
     if (MaybeExpr result{common::SearchTypes(
-            IntTypeVisitor{*this, digits, kind, isDefaultKind})}) {
+            IntTypeVisitor{*this, digits, kind, isDefaultKind, isNegated})}) {
       return result;
     } else if (isDefaultKind) {
       Say(digits,
           "Integer literal is too large for any allowable "
           "kind of INTEGER"_err_en_US);
     } else {
       Say(digits, "Integer literal is too large for INTEGER(KIND=%d)"_err_en_US,
           kind);
     }
   }
   return std::nullopt;
 }
 
-MaybeExpr ExpressionAnalyzer::Analyze(const parser::IntLiteralConstant &x) {
+MaybeExpr ExpressionAnalyzer::Analyze(
+    const parser::IntLiteralConstant &x, bool isNegated) {
   auto restorer{
       GetContextualMessages().SetLocation(std::get<parser::CharBlock>(x.t))};
-  return IntLiteralConstant(x);
+  return IntLiteralConstant(x, isNegated);
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(
     const parser::SignedIntLiteralConstant &x) {
   auto restorer{GetContextualMessages().SetLocation(x.source)};
   return IntLiteralConstant(x);
 }
 
static MaybeExpr NumericUnaryHelper(ExpressionAnalyzer &context,
   return std::nullopt;
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::UnaryPlus &x) {
   return NumericUnaryHelper(*this, NumericOperator::Add, x);
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Negate &x) {
+  if (const auto *litConst{
+          std::get_if<parser::LiteralConstant>(&x.v.value().u)}) {
+    if (const auto *intConst{
+            std::get_if<parser::IntLiteralConstant>(&litConst->u)}) {
+      return Analyze(*intConst, true);
+    }
+  }
   return NumericUnaryHelper(*this, NumericOperator::Subtract, x);
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NOT &x) {
   ArgumentAnalyzer analyzer{*this};
   analyzer.Analyze(x.v);
   if (!analyzer.fatalErrors()) {
     if (analyzer.IsIntrinsicLogical()) {
bool ArgumentAnalyzer::OkLogicalIntegerAssignment(
     TypeCategory lhs, TypeCategory rhs) {
   if (!context_.context().languageFeatures().IsEnabled(
           common::LanguageFeature::LogicalIntegerAssignment)) {
     return false;
   }
   std::optional<parser::MessageFixedText> msg;
   if (lhs == TypeCategory::Integer && rhs == TypeCategory::Logical) {
     // allow assignment to LOGICAL from INTEGER as a legacy extension
-    msg = "nonstandard usage: assignment of LOGICAL to INTEGER"_port_en_US;
+    msg = "assignment of LOGICAL to INTEGER"_port_en_US;
   } else if (lhs == TypeCategory::Logical && rhs == TypeCategory::Integer) {
     // ... and assignment to LOGICAL from INTEGER
-    msg = "nonstandard usage: assignment of INTEGER to LOGICAL"_port_en_US;
+    msg = "assignment of INTEGER to LOGICAL"_port_en_US;
   } else {
     return false;
   }
   if (context_.context().languageFeatures().ShouldWarn(
           common::LanguageFeature::LogicalIntegerAssignment)) {
     context_.Say(std::move(*msg));
   }
   return true;

flang/lib/Semantics/mod-file.cpp

if (!ancestor) {
     parentScope = Read(*parent, false /*not intrinsic*/, ancestor, silent);
   } else {
     parentScope = ancestor;
   }
   auto pair{parentScope->try_emplace(name, UnknownDetails{})};
   if (!pair.second) {
     return nullptr;
   }
+  // Process declarations from the module file
   Symbol &modSymbol{*pair.first->second};
   modSymbol.set(Symbol::Flag::ModFile);
+  bool wasInModuleFile{context_.foldingContext().inModuleFile()};
+  context_.foldingContext().set_inModuleFile(true);
   ResolveNames(context_, parseTree, topScope);
+  context_.foldingContext().set_inModuleFile(wasInModuleFile);
   CHECK(modSymbol.has<ModuleDetails>());
   CHECK(modSymbol.test(Symbol::Flag::ModFile));
   if (isIntrinsic.value_or(false)) {
     modSymbol.attrs().set(Attr::INTRINSIC);
   }
   return modSymbol.scope();
 }
 

flang/lib/Semantics/semantics.cpp

if (auto *scope{globalScope_.FindScope(source)}) {
     return *scope;
   } else {
     common::die(
         "SemanticsContext::FindScope(): invalid source location for '%s'",
         source.ToString().c_str());
   }
 }
 
+bool SemanticsContext::IsInModuleFile(parser::CharBlock source) const {
+  for (const Scope *scope{&FindScope(source)}; !scope->IsGlobal();
+       scope = &scope->parent()) {
+    if (scope->IsModuleFile()) {
+      return true;
+    }
+  }
+  return false;
+}
+
 void SemanticsContext::PopConstruct() {
   CHECK(!constructStack_.empty());
   constructStack_.pop_back();
 }
 
 void SemanticsContext::CheckIndexVarRedefine(const parser::CharBlock &location,
     const Symbol &variable, parser::MessageFixedText &&message) {
   const Symbol &symbol{ResolveAssociations(variable)};

flang/test/Semantics/dosemantics03.f90

 ! Pointer to LOGICAL initial expression
 !ERROR: DO controls should be INTEGER
   DO ivar = plvar, 10, 3
     PRINT *, "ivar is: ", ivar
   END DO
 
 ! Invalid initial expression
 !ERROR: Integer literal is too large for INTEGER(KIND=4)
-  DO ivar = -2147483648_4, 10, 3
+  DO ivar = -2147483649_4, 10, 3
     PRINT *, "ivar is: ", ivar
   END DO
 
 ! Final expression
 ! REAL final expression
 !WARNING: DO controls should be INTEGER
   DO ivar = 1, rvar, 3
     PRINT *, "ivar is: ", ivar

 ! COMPLEX final expression
 !ERROR: DO controls should be INTEGER
   DO ivar = 1, cvar, 3
     PRINT *, "ivar is: ", ivar
   END DO
 
 ! Invalid final expression
 !ERROR: Integer literal is too large for INTEGER(KIND=4)
-  DO ivar = 1, -2147483648_4, 3
+  DO ivar = 1, -2147483649_4, 3
     PRINT *, "ivar is: ", ivar
   END DO
 
 ! Step expression
 ! REAL step expression
 !WARNING: DO controls should be INTEGER
   DO ivar = 1, 10, rvar
     PRINT *, "ivar is: ", ivar

 ! COMPLEX Step expression
 !ERROR: DO controls should be INTEGER
   DO ivar = 1, 10, cvar
     PRINT *, "ivar is: ", ivar
   END DO
 
 ! Invalid step expression
 !ERROR: Integer literal is too large for INTEGER(KIND=4)
-  DO ivar = 1, 10, -2147483648_4
+  DO ivar = 1, 10, -2147483649_4
     PRINT *, "ivar is: ", ivar
   END DO
 
 END PROGRAM do_issue_458