Merge branch 'main' into users/meinersbur/flang_runtime_split-headersusers/meinersbur/flang_runtime_split-headers

1 files changed, 107 insertions, 48 deletions

diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index b9be586f4d77..c2eb17c1ac8e 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -651,40 +651,52 @@ int ExpressionAnalyzer::AnalyzeKindParam(
   return static_cast<int>(kind);
 }
 
-// Common handling of parser::IntLiteralConstant and SignedIntLiteralConstant
-struct IntTypeVisitor {
+// Common handling of parser::IntLiteralConstant, SignedIntLiteralConstant,
+// and UnsignedLiteralConstant
+template <typename TYPES, TypeCategory CAT> struct IntTypeVisitor {
   using Result = MaybeExpr;
-  using Types = IntegerTypes;
+  using Types = TYPES;
   template <typename T> Result Test() {
     if (T::kind >= kind) {
       const char *p{digits.begin()};
       using Int = typename T::Scalar;
       typename Int::ValueWithOverflow num{0, false};
+      const char *typeName{
+          CAT == TypeCategory::Integer ? "INTEGER" : "UNSIGNED"};
       if (isNegated) {
         auto unsignedNum{Int::Read(p, 10, false /*unsigned*/)};
         num.value = unsignedNum.value.Negate().value;
-        num.overflow = unsignedNum.overflow || num.value > Int{0};
+        num.overflow = unsignedNum.overflow ||
+            (CAT == TypeCategory::Integer && num.value > Int{0});
         if (!num.overflow && num.value.Negate().overflow) {
           analyzer.Warn(LanguageFeature::BigIntLiterals, digits,
               "negated maximum INTEGER(KIND=%d) literal"_port_en_US, T::kind);
         }
       } else {
-        num = Int::Read(p, 10, true /*signed*/);
+        num = Int::Read(p, 10, /*isSigned=*/CAT == TypeCategory::Integer);
       }
-      if (!num.overflow) {
+      if (num.overflow) {
+        if constexpr (CAT == TypeCategory::Unsigned) {
+          analyzer.Warn(common::UsageWarning::UnsignedLiteralTruncation,
+              "Unsigned literal too large for UNSIGNED(KIND=%d); truncated"_warn_en_US,
+              kind);
+          return Expr<SomeType>{
+              Expr<SomeKind<CAT>>{Expr<T>{Constant<T>{std::move(num.value)}}}};
+        }
+      } else {
         if (T::kind > kind) {
           if (!isDefaultKind ||
               !analyzer.context().IsEnabled(LanguageFeature::BigIntLiterals)) {
             return std::nullopt;
           } else {
             analyzer.Warn(LanguageFeature::BigIntLiterals, digits,
-                "Integer literal is too large for default INTEGER(KIND=%d); "
-                "assuming INTEGER(KIND=%d)"_port_en_US,
-                kind, T::kind);
+                "Integer literal is too large for default %s(KIND=%d); "
+                "assuming %s(KIND=%d)"_port_en_US,
+                typeName, kind, typeName, T::kind);
           }
         }
         return Expr<SomeType>{
-            Expr<SomeInteger>{Expr<T>{Constant<T>{std::move(num.value)}}}};
+            Expr<SomeKind<CAT>>{Expr<T>{Constant<T>{std::move(num.value)}}}};
       }
     }
     return std::nullopt;
@@ -696,24 +708,25 @@ struct IntTypeVisitor {
   bool isNegated;
 };
 
-template <typename PARSED>
+template <typename TYPES, TypeCategory CAT, typename PARSED>
 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)) {
+  int kind{AnalyzeKindParam(kindParam, GetDefaultKind(CAT))};
+  const char *typeName{CAT == TypeCategory::Integer ? "INTEGER" : "UNSIGNED"};
+  if (CheckIntrinsicKind(CAT, kind)) {
     auto digits{std::get<parser::CharBlock>(x.t)};
-    if (MaybeExpr result{common::SearchTypes(
-            IntTypeVisitor{*this, digits, kind, isDefaultKind, isNegated})}) {
+    if (MaybeExpr result{common::SearchTypes(IntTypeVisitor<TYPES, CAT>{
+            *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);
+          "Integer literal is too large for any allowable kind of %s"_err_en_US,
+          typeName);
     } else {
-      Say(digits, "Integer literal is too large for INTEGER(KIND=%d)"_err_en_US,
-          kind);
+      Say(digits, "Integer literal is too large for %s(KIND=%d)"_err_en_US,
+          typeName, kind);
     }
   }
   return std::nullopt;
@@ -723,13 +736,25 @@ MaybeExpr ExpressionAnalyzer::Analyze(
     const parser::IntLiteralConstant &x, bool isNegated) {
   auto restorer{
       GetContextualMessages().SetLocation(std::get<parser::CharBlock>(x.t))};
-  return IntLiteralConstant(x, isNegated);
+  return IntLiteralConstant<IntegerTypes, TypeCategory::Integer>(x, isNegated);
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(
     const parser::SignedIntLiteralConstant &x) {
   auto restorer{GetContextualMessages().SetLocation(x.source)};
-  return IntLiteralConstant(x);
+  return IntLiteralConstant<IntegerTypes, TypeCategory::Integer>(x);
+}
+
+MaybeExpr ExpressionAnalyzer::Analyze(
+    const parser::UnsignedLiteralConstant &x) {
+  parser::CharBlock at{std::get<parser::CharBlock>(x.t)};
+  auto restorer{GetContextualMessages().SetLocation(at)};
+  if (!context().IsEnabled(common::LanguageFeature::Unsigned) &&
+      !context().AnyFatalError()) {
+    context().Say(
+        at, "-funsigned is required to enable UNSIGNED constants"_err_en_US);
+  }
+  return IntLiteralConstant<UnsignedTypes, TypeCategory::Unsigned>(x);
 }
 
 template <typename TYPE>
@@ -2489,7 +2514,8 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
 
 // Can actual be argument associated with dummy?
 static bool CheckCompatibleArgument(bool isElemental,
-    const ActualArgument &actual, const characteristics::DummyArgument &dummy) {
+    const ActualArgument &actual, const characteristics::DummyArgument &dummy,
+    FoldingContext &foldingContext) {
   const auto *expr{actual.UnwrapExpr()};
   return common::visit(
       common::visitors{
@@ -2509,8 +2535,26 @@ static bool CheckCompatibleArgument(bool isElemental,
             }
             return false;
           },
-          [&](const characteristics::DummyProcedure &) {
-            return expr && IsProcedurePointerTarget(*expr);
+          [&](const characteristics::DummyProcedure &dummy) {
+            if (!expr || !IsProcedurePointerTarget(*expr)) {
+              return false;
+            }
+            if (auto actualProc{characteristics::Procedure::Characterize(
+                    *expr, foldingContext)}) {
+              const auto &dummyResult{dummy.procedure.value().functionResult};
+              const auto *dummyTypeAndShape{
+                  dummyResult ? dummyResult->GetTypeAndShape() : nullptr};
+              const auto &actualResult{actualProc->functionResult};
+              const auto *actualTypeAndShape{
+                  actualResult ? actualResult->GetTypeAndShape() : nullptr};
+              if (dummyTypeAndShape && actualTypeAndShape) {
+                // Return false when the function results' types are both
+                // known and not compatible.
+                return actualTypeAndShape->type().IsTkCompatibleWith(
+                    dummyTypeAndShape->type());
+              }
+            }
+            return true;
           },
           [&](const characteristics::AlternateReturn &) {
             return actual.isAlternateReturn();
@@ -2521,15 +2565,16 @@ static bool CheckCompatibleArgument(bool isElemental,
 
 // Are the actual arguments compatible with the dummy arguments of procedure?
 static bool CheckCompatibleArguments(
-    const characteristics::Procedure &procedure,
-    const ActualArguments &actuals) {
+    const characteristics::Procedure &procedure, const ActualArguments &actuals,
+    FoldingContext &foldingContext) {
   bool isElemental{procedure.IsElemental()};
   const auto &dummies{procedure.dummyArguments};
   CHECK(dummies.size() == actuals.size());
   for (std::size_t i{0}; i < dummies.size(); ++i) {
     const characteristics::DummyArgument &dummy{dummies[i]};
     const std::optional<ActualArgument> &actual{actuals[i]};
-    if (actual && !CheckCompatibleArgument(isElemental, *actual, dummy)) {
+    if (actual &&
+        !CheckCompatibleArgument(isElemental, *actual, dummy, foldingContext)) {
       return false;
     }
   }
@@ -2726,7 +2771,8 @@ std::pair<const Symbol *, bool> ExpressionAnalyzer::ResolveGeneric(
         }
         if (semantics::CheckInterfaceForGeneric(*procedure, localActuals,
                 context_, false /* no integer conversions */) &&
-            CheckCompatibleArguments(*procedure, localActuals)) {
+            CheckCompatibleArguments(
+                *procedure, localActuals, foldingContext_)) {
           if ((procedure->IsElemental() && elemental) ||
               (!procedure->IsElemental() && nonElemental)) {
             int d{ComputeCudaMatchingDistance(
@@ -3499,9 +3545,9 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedUnary &x) {
 
 // Binary (dyadic) operations
 
-template <template <typename> class OPR>
-MaybeExpr NumericBinaryHelper(ExpressionAnalyzer &context, NumericOperator opr,
-    const parser::Expr::IntrinsicBinary &x) {
+template <template <typename> class OPR, NumericOperator opr>
+MaybeExpr NumericBinaryHelper(
+    ExpressionAnalyzer &context, const parser::Expr::IntrinsicBinary &x) {
   ArgumentAnalyzer analyzer{context};
   analyzer.Analyze(std::get<0>(x.t));
   analyzer.Analyze(std::get<1>(x.t));
@@ -3510,9 +3556,10 @@ MaybeExpr NumericBinaryHelper(ExpressionAnalyzer &context, NumericOperator opr,
       analyzer.CheckForNullPointer();
       analyzer.CheckForAssumedRank();
       analyzer.CheckConformance();
-      return NumericOperation<OPR>(context.GetContextualMessages(),
-          analyzer.MoveExpr(0), analyzer.MoveExpr(1),
-          context.GetDefaultKind(TypeCategory::Real));
+      constexpr bool canBeUnsigned{opr != NumericOperator::Power};
+      return NumericOperation<OPR, canBeUnsigned>(
+          context.GetContextualMessages(), analyzer.MoveExpr(0),
+          analyzer.MoveExpr(1), context.GetDefaultKind(TypeCategory::Real));
     } else {
       return analyzer.TryDefinedOp(AsFortran(opr),
           "Operands of %s must be numeric; have %s and %s"_err_en_US);
@@ -3522,23 +3569,23 @@ MaybeExpr NumericBinaryHelper(ExpressionAnalyzer &context, NumericOperator opr,
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Power &x) {
-  return NumericBinaryHelper<Power>(*this, NumericOperator::Power, x);
+  return NumericBinaryHelper<Power, NumericOperator::Power>(*this, x);
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Multiply &x) {
-  return NumericBinaryHelper<Multiply>(*this, NumericOperator::Multiply, x);
+  return NumericBinaryHelper<Multiply, NumericOperator::Multiply>(*this, x);
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Divide &x) {
-  return NumericBinaryHelper<Divide>(*this, NumericOperator::Divide, x);
+  return NumericBinaryHelper<Divide, NumericOperator::Divide>(*this, x);
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Add &x) {
-  return NumericBinaryHelper<Add>(*this, NumericOperator::Add, x);
+  return NumericBinaryHelper<Add, NumericOperator::Add>(*this, x);
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::Subtract &x) {
-  return NumericBinaryHelper<Subtract>(*this, NumericOperator::Subtract, x);
+  return NumericBinaryHelper<Subtract, NumericOperator::Subtract>(*this, x);
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(
@@ -4269,12 +4316,14 @@ bool ArgumentAnalyzer::IsIntrinsicNumeric(NumericOperator opr) const {
     }
   } else {
     std::optional<DynamicType> rightType{GetType(1)};
-    if (IsBOZLiteral(0) && rightType) { // BOZ opr Integer/Real
+    if (IsBOZLiteral(0) && rightType) { // BOZ opr Integer/Unsigned/Real
       auto cat1{rightType->category()};
-      return cat1 == TypeCategory::Integer || cat1 == TypeCategory::Real;
-    } else if (IsBOZLiteral(1) && leftType) { // Integer/Real opr BOZ
+      return cat1 == TypeCategory::Integer || cat1 == TypeCategory::Unsigned ||
+          cat1 == TypeCategory::Real;
+    } else if (IsBOZLiteral(1) && leftType) { // Integer/Unsigned/Real opr BOZ
       auto cat0{leftType->category()};
-      return cat0 == TypeCategory::Integer || cat0 == TypeCategory::Real;
+      return cat0 == TypeCategory::Integer || cat0 == TypeCategory::Unsigned ||
+          cat0 == TypeCategory::Real;
     } else {
       return leftType && rightType &&
           semantics::IsIntrinsicNumeric(
@@ -4328,9 +4377,9 @@ bool ArgumentAnalyzer::CheckConformance() {
 }
 
 bool ArgumentAnalyzer::CheckAssignmentConformance() {
-  if (actuals_.size() == 2) {
-    const auto *lhs{actuals_.at(0).value().UnwrapExpr()};
-    const auto *rhs{actuals_.at(1).value().UnwrapExpr()};
+  if (actuals_.size() == 2 && actuals_[0] && actuals_[1]) {
+    const auto *lhs{actuals_[0]->UnwrapExpr()};
+    const auto *rhs{actuals_[1]->UnwrapExpr()};
     if (lhs && rhs) {
       auto &foldingContext{context_.GetFoldingContext()};
       auto lhShape{GetShape(foldingContext, *lhs)};
@@ -4522,6 +4571,7 @@ std::optional<ProcedureRef> ArgumentAnalyzer::TryDefinedAssignment() {
         }
       } else {
         if (lhsType->category() == TypeCategory::Integer ||
+            lhsType->category() == TypeCategory::Unsigned ||
             lhsType->category() == TypeCategory::Real) {
           ConvertBOZ(nullptr, 1, lhsType);
         }
@@ -4756,7 +4806,8 @@ int ArgumentAnalyzer::GetRank(std::size_t i) const {
 }
 
 // If the argument at index i is a BOZ literal, convert its type to match the
-// otherType.  If it's REAL convert to REAL, otherwise convert to INTEGER.
+// otherType.  If it's REAL, convert to REAL; if it's UNSIGNED, convert to
+// UNSIGNED; otherwise, convert to INTEGER.
 // Note that IBM supports comparing BOZ literals to CHARACTER operands.  That
 // is not currently supported.
 void ArgumentAnalyzer::ConvertBOZ(std::optional<DynamicType> *thisType,
@@ -4768,10 +4819,18 @@ void ArgumentAnalyzer::ConvertBOZ(std::optional<DynamicType> *thisType,
       int kind{context_.context().GetDefaultKind(TypeCategory::Real)};
       MaybeExpr realExpr{
           ConvertToKind<TypeCategory::Real>(kind, std::move(*boz))};
-      actuals_[i] = std::move(*realExpr);
+      actuals_[i] = std::move(realExpr.value());
       if (thisType) {
         thisType->emplace(TypeCategory::Real, kind);
       }
+    } else if (otherType && otherType->category() == TypeCategory::Unsigned) {
+      int kind{context_.context().GetDefaultKind(TypeCategory::Unsigned)};
+      MaybeExpr unsignedExpr{
+          ConvertToKind<TypeCategory::Unsigned>(kind, std::move(*boz))};
+      actuals_[i] = std::move(unsignedExpr.value());
+      if (thisType) {
+        thisType->emplace(TypeCategory::Unsigned, kind);
+      }
     } else {
       int kind{context_.context().GetDefaultKind(TypeCategory::Integer)};
       MaybeExpr intExpr{