Merge branch 'main' into yonah/julia-fix

Author: YonahGoldberg

clang-tools-extra/docs/clang-tidy/checks/bugprone/macro-parentheses.rst

@@ -19,5 +19,5 @@ with parentheses. This ensures that the argument value is calculated
 properly.
 
 This check corresponds to the CERT C Coding Standard rule
-`PRE20-C. Macro replacement lists should be parenthesized.
+`PRE02-C. Macro replacement lists should be parenthesized.
 <https://wiki.sei.cmu.edu/confluence/display/c/PRE02-C.+Macro+replacement+lists+should+be+parenthesized>`_

flang/docs/Extensions.md

@@ -474,6 +474,10 @@ end
   with an optional compilation-time warning.  When executed, it
   is treated as an 'nX' positioning control descriptor that skips
   over the same number of characters, without comparison.
+* A passed-object dummy argument for a procedure binding is allowed
+  to be a pointer so long as it is `INTENT(IN)`.
+  (This extension is not yet supported for procedure pointer component
+  interfaces.)
 
 ### Extensions supported when enabled by options
 

flang/include/flang/Lower/CallInterface.h

@@ -401,11 +401,17 @@ class CallerInterface : public CallInterface<CallerInterface> {
     llvm_unreachable("getting host associated type in CallerInterface");
   }
 
+  std::optional<mlir::Value> getOriginalPassArg() const {
+    return originalPassArg;
+  }
+  void setOriginalPassArg(mlir::Value x) { originalPassArg = x; }
+
 private:
   /// Check that the input vector is complete.
   bool verifyActualInputs() const;
   const Fortran::evaluate::ProcedureRef &procRef;
   llvm::SmallVector<mlir::Value> actualInputs;
+  std::optional<mlir::Value> originalPassArg;
 };
 
 //===----------------------------------------------------------------------===//

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

@@ -56,7 +56,7 @@ ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines,
     IgnoreIrrelevantAttributes, Unsigned, AmbiguousStructureConstructor,
     ContiguousOkForSeqAssociation, ForwardRefExplicitTypeDummy,
     InaccessibleDeferredOverride, CudaWarpMatchFunction, DoConcurrentOffload,
-    TransferBOZ, Coarray)
+    TransferBOZ, Coarray, PointerPassObject)
 
 // Portability and suspicious usage warnings
 ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,

flang/lib/Lower/CallInterface.cpp

@@ -103,7 +103,7 @@ bool Fortran::lower::CallerInterface::requireDispatchCall() const {
       return true;
   }
   // calls with PASS attribute have the passed-object already set in its
-  // arguments. Just check if their is one.
+  // arguments. Just check if there is one.
   std::optional<unsigned> passArg = getPassArgIndex();
   if (passArg)
     return true;

flang/lib/Lower/ConvertCall.cpp

@@ -673,10 +673,13 @@ Fortran::lower::genCallOpAndResult(
       // passed object because interface mismatch issues may have inserted a
       // cast to the operand with a different declared type, which would break
       // later type bound call resolution in the FIR to FIR pass.
+      mlir::Value passActual = caller.getInputs()[*passArg];
+      if (std::optional<mlir::Value> original = caller.getOriginalPassArg())
+        passActual = *original;
       dispatch = fir::DispatchOp::create(
           builder, loc, funcType.getResults(), builder.getStringAttr(procName),
-          caller.getInputs()[*passArg], operands,
-          builder.getI32IntegerAttr(*passArg), /*arg_attrs=*/nullptr,
+          passActual, operands, builder.getI32IntegerAttr(*passArg),
+          /*arg_attrs=*/nullptr,
           /*res_attrs=*/nullptr, procAttrs);
     } else {
       // NOPASS
@@ -1636,8 +1639,12 @@ void prepareUserCallArguments(
   mlir::Location loc = callContext.loc;
   bool mustRemapActualToDummyDescriptors = false;
   fir::FirOpBuilder &builder = callContext.getBuilder();
+  std::optional<unsigned> passArg = caller.getPassArgIndex();
+  int argIndex = -1;
   for (auto [preparedActual, arg] :
        llvm::zip(loweredActuals, caller.getPassedArguments())) {
+    ++argIndex;
+    bool thisIsPassArg = passArg && argIndex == static_cast<int>(*passArg);
     mlir::Type argTy = callSiteType.getInput(arg.firArgument);
     if (!preparedActual) {
       // Optional dummy argument for which there is no actual argument.
@@ -1750,14 +1757,16 @@ void prepareUserCallArguments(
         continue;
       }
       if (fir::isPointerType(argTy) &&
-          !Fortran::evaluate::IsObjectPointer(*expr)) {
+          (!Fortran::evaluate::IsObjectPointer(*expr) || thisIsPassArg)) {
         // Passing a non POINTER actual argument to a POINTER dummy argument.
         // Create a pointer of the dummy argument type and assign the actual
         // argument to it.
         auto dataTy = llvm::cast<fir::BaseBoxType>(fir::unwrapRefType(argTy));
         fir::ExtendedValue actualExv = Fortran::lower::convertToAddress(
             loc, callContext.converter, actual, callContext.stmtCtx,
             hlfir::getFortranElementType(dataTy));
+        if (thisIsPassArg)
+          caller.setOriginalPassArg(fir::getBase(actualExv));
         // If the dummy is an assumed-rank pointer, allocate a pointer
         // descriptor with the actual argument rank (if it is not assumed-rank
         // itself).

flang/lib/Optimizer/HLFIR/Transforms/ConvertToFIR.cpp

@@ -473,7 +473,7 @@ class DesignateOpConversion
     if (designate.getComponent()) {
       mlir::Type baseRecordType = baseEntity.getFortranElementType();
       if (fir::isRecordWithTypeParameters(baseRecordType))
-        TODO(loc, "hlfir.designate with a parametrized derived type base");
+        TODO(loc, "hlfir.designate with a parameterized derived type base");
       fieldIndex = fir::FieldIndexOp::create(
           builder, loc, fir::FieldType::get(builder.getContext()),
           designate.getComponent().value(), baseRecordType,
@@ -499,7 +499,7 @@ class DesignateOpConversion
             return mlir::success();
           }
           TODO(loc,
-               "addressing parametrized derived type automatic components");
+               "addressing parameterized derived type automatic components");
         }
         baseEleTy = hlfir::getFortranElementType(componentType);
         shape = designate.getComponentShape();

flang/lib/Semantics/check-call.cpp

@@ -610,9 +610,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
             !dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {
           if (IsPointer(*actualLastSymbol)) {
             if (isOkBecauseContiguous) {
-              context.Warn(
+              foldingContext.Warn(
                   common::LanguageFeature::ContiguousOkForSeqAssociation,
-                  messages.at(),
                   "Element of contiguous pointer array is accepted for storage sequence association"_port_en_US);
             } else {
               basicError = true;
@@ -623,9 +622,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
           } else if (IsAssumedShape(*actualLastSymbol) &&
               !dummy.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {
             if (isOkBecauseContiguous) {
-              context.Warn(
+              foldingContext.Warn(
                   common::LanguageFeature::ContiguousOkForSeqAssociation,
-                  messages.at(),
                   "Element of contiguous assumed-shape array is accepted for storage sequence association"_port_en_US);
             } else {
               basicError = true;
@@ -653,9 +651,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
             messages.Say(
                 "Assumed-rank array may not be associated with a dummy argument that is not assumed-rank"_err_en_US);
           } else {
-            context.Warn(
+            foldingContext.Warn(
                 common::LanguageFeature::AssumedRankPassedToNonAssumedRank,
-                messages.at(),
                 "Assumed-rank array should not be associated with a dummy argument that is not assumed-rank"_port_en_US);
           }
         } else if (actualRank == 0) {
@@ -693,7 +690,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
                       static_cast<std::intmax_t>(*actualElements), dummyName,
                       static_cast<std::intmax_t>(*dummySize));
                 } else {
-                  context.Warn(common::UsageWarning::ShortArrayActual,
+                  foldingContext.Warn(common::UsageWarning::ShortArrayActual,
                       "Actual argument has fewer elements remaining in storage sequence (%jd) than %s array (%jd)"_warn_en_US,
                       static_cast<std::intmax_t>(*actualElements), dummyName,
                       static_cast<std::intmax_t>(*dummySize));
@@ -711,7 +708,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
                   static_cast<std::intmax_t>(*actualSize), dummyName,
                   static_cast<std::intmax_t>(*dummySize));
             } else {
-              context.Warn(common::UsageWarning::ShortArrayActual,
+              foldingContext.Warn(common::UsageWarning::ShortArrayActual,
                   "Actual argument array has fewer elements (%jd) than %s array (%jd)"_warn_en_US,
                   static_cast<std::intmax_t>(*actualSize), dummyName,
                   static_cast<std::intmax_t>(*dummySize));
@@ -826,8 +823,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
                    (actualIsPointer && dummyIsPointer)) &&
         evaluate::IsArraySection(actual) && !actualIsContiguous &&
         !evaluate::HasVectorSubscript(actual)) {
-      context.Warn(common::UsageWarning::VolatileOrAsynchronousTemporary,
-          messages.at(),
+      foldingContext.Warn(common::UsageWarning::VolatileOrAsynchronousTemporary,
           "The array section '%s' should not be associated with %s with %s attribute, unless the dummy is assumed-shape or assumed-rank"_warn_en_US,
           actual.AsFortran(), dummyName,
           dummyIsAsynchronous ? "ASYNCHRONOUS" : "VOLATILE");
@@ -844,8 +840,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
   if (copyOutNeeded && !volatileOrAsyncNeedsTempDiagnosticIssued) {
     if ((actualIsVolatile || actualIsAsynchronous) &&
         (dummyIsVolatile || dummyIsAsynchronous)) {
-      context.Warn(common::UsageWarning::VolatileOrAsynchronousTemporary,
-          messages.at(),
+      foldingContext.Warn(common::UsageWarning::VolatileOrAsynchronousTemporary,
           "The actual argument '%s' with %s attribute should not be associated with %s with %s attribute, because a temporary copy is required during the call"_warn_en_US,
           actual.AsFortran(), actualIsVolatile ? "VOLATILE" : "ASYNCHRONOUS",
           dummyName, dummyIsVolatile ? "VOLATILE" : "ASYNCHRONOUS");
@@ -863,7 +858,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
             (actualIsPointer && dummyIsPointer)) &&
         evaluate::IsArraySection(actual) &&
         !evaluate::HasVectorSubscript(actual)) {
-      context.Warn(common::UsageWarning::Portability, messages.at(),
+      foldingContext.Warn(common::UsageWarning::Portability,
           "The array section '%s' should not be associated with %s with %s attribute, unless the dummy is assumed-shape or assumed-rank"_port_en_US,
           actual.AsFortran(), dummyName,
           dummyIsAsynchronous ? "ASYNCHRONOUS" : "VOLATILE");
@@ -872,7 +867,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
     if (copyOutNeeded && !volatileOrAsyncNeedsTempDiagnosticIssued) {
       if ((dummyIsVolatile && !actualIsVolatile && !actualIsAsynchronous) ||
           (dummyIsAsynchronous && !actualIsVolatile && !actualIsAsynchronous)) {
-        context.Warn(common::UsageWarning::Portability, messages.at(),
+        foldingContext.Warn(common::UsageWarning::Portability,
             "The actual argument '%s' should not be associated with %s with %s attribute, because a temporary copy is required during the call"_port_en_US,
             actual.AsFortran(), dummyName,
             dummyIsVolatile ? "VOLATILE" : "ASYNCHRONOUS");
@@ -2437,7 +2432,7 @@ bool CheckArguments(const characteristics::Procedure &proc,
         intrinsic, allowArgumentConversions,
         /*extentErrors=*/true, ignoreImplicitVsExplicit)};
     if (!explicitBuffer.empty()) {
-      if (treatingExternalAsImplicit) {
+      if (treatingExternalAsImplicit && explicitBuffer.AnyFatalError()) {
         // Combine all messages into one warning
         if (auto *warning{messages.Warn(/*inModuleFile=*/false,
                 context.languageFeatures(),

flang/lib/Semantics/check-declarations.cpp

@@ -2608,9 +2608,6 @@ void CheckHelper::CheckPassArg(
   if (!passArg.has<ObjectEntityDetails>()) {
     msg = "Passed-object dummy argument '%s' of procedure '%s'"
           " must be a data object"_err_en_US;
-  } else if (passArg.attrs().test(Attr::POINTER)) {
-    msg = "Passed-object dummy argument '%s' of procedure '%s'"
-          " may not have the POINTER attribute"_err_en_US;
   } else if (passArg.attrs().test(Attr::ALLOCATABLE)) {
     msg = "Passed-object dummy argument '%s' of procedure '%s'"
           " may not have the ALLOCATABLE attribute"_err_en_US;
@@ -2620,6 +2617,23 @@ void CheckHelper::CheckPassArg(
   } else if (passArg.Rank() > 0) {
     msg = "Passed-object dummy argument '%s' of procedure '%s'"
           " must be scalar"_err_en_US;
+  } else if (passArg.attrs().test(Attr::POINTER)) {
+    if (context_.IsEnabled(common::LanguageFeature::PointerPassObject) &&
+        IsIntentIn(passArg)) {
+      if (proc.has<ProcBindingDetails>()) {
+        // Extension: allow a passed object to be an INTENT(IN) POINTER.
+        // Only works for TBPs, needs lowering work for proc ptr components.
+        Warn(common::LanguageFeature::PointerPassObject, name,
+            "Passed-object dummy argument '%s' of procedure '%s' that is an INTENT(IN) POINTER is not standard"_port_en_US,
+            *passName, name);
+      } else {
+        msg =
+            "Passed-object dummy argument '%s' of procedure '%s' used as procedure pointer component interface may not have the POINTER attribute"_err_en_US;
+      }
+    } else {
+      msg =
+          "Passed-object dummy argument '%s' of procedure '%s' may not have the POINTER attribute unless INTENT(IN)"_err_en_US;
+    }
   }
   if (msg) {
     messages_.Say(name, std::move(*msg), passName.value(), name);

flang/lib/Semantics/resolve-names.cpp

@@ -7565,12 +7565,14 @@ void DeclarationVisitor::SetType(
   } else if (HadForwardRef(symbol)) {
     // error recovery after use of host-associated name
   } else if (!symbol.test(Symbol::Flag::Implicit)) {
-    SayWithDecl(
-        name, symbol, "The type of '%s' has already been declared"_err_en_US);
+    SayWithDecl(name, symbol,
+        "The type of '%s' has already been declared as %s"_err_en_US,
+        prevType->AsFortran());
     context().SetError(symbol);
   } else if (type != *prevType) {
     SayWithDecl(name, symbol,
-        "The type of '%s' has already been implicitly declared"_err_en_US);
+        "The type of '%s' has already been implicitly declared as %s"_err_en_US,
+        prevType->AsFortran());
     context().SetError(symbol);
   } else {
     symbol.set(Symbol::Flag::Implicit, false);
@@ -9710,12 +9712,20 @@ void ResolveNamesVisitor::EarlyDummyTypeDeclaration(
     const parser::Statement<common::Indirection<parser::TypeDeclarationStmt>>
         &stmt) {
   context().set_location(stmt.source);
-  const auto &[declTypeSpec, attrs, entities] = stmt.statement.value().t;
+  const auto &[declTypeSpec, attrs, entities]{stmt.statement.value().t};
   if (const auto *intrin{
           std::get_if<parser::IntrinsicTypeSpec>(&declTypeSpec.u)}) {
     if (const auto *intType{std::get_if<parser::IntegerTypeSpec>(&intrin->u)}) {
       if (const auto &kind{intType->v}) {
-        if (!parser::Unwrap<parser::KindSelector::StarSize>(*kind) &&
+        if (const auto *call{parser::Unwrap<parser::Call>(*kind)}) {
+          if (!std::get<std::list<parser::ActualArgSpec>>(call->t).empty()) {
+            // Accept INTEGER(int_ptr_kind()), at least.  Don't allow a
+            // nonempty argument list, to prevent implicitly typing names
+            // that might appear.  (TODO: But maybe INTEGER(KIND(n)) after
+            // an explicit declaration of 'n' would be useful.)
+            return;
+          }
+        } else if (!parser::Unwrap<parser::KindSelector::StarSize>(*kind) &&
             !parser::Unwrap<parser::IntLiteralConstant>(*kind)) {
           return;
         }