[flang] Fix non-portable TYPE(*) usage in generic (#176235)

Fortran allows a scalar actual argument of any type to correspond with a
TYPE(*) dummy argument that is an assumed-size array. This usage isn't
portable, and it didn't work with a generic procedure with this
compiler, only specific procedures. It affected at least one API in
OpenMPI.

Fix generic resolution to allow for this case, add a distinguishability
test to detect generic interfaces that have ambiguous specific
procedures due to it, and add an optional portability warning (off by
default).

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

@@ -80,7 +80,7 @@ ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
     NullActualForDefaultIntentAllocatable, UseAssociationIntoSameNameSubprogram,
     HostAssociatedIntentOutInSpecExpr, NonVolatilePointerToVolatile,
     RealConstantWidening, VolatileOrAsynchronousTemporary, UnusedVariable,
-    UsedUndefinedVariable, BadValueInDeadCode)
+    UsedUndefinedVariable, BadValueInDeadCode, AssumedTypeSizeDummy)
 
 using LanguageFeatures = EnumSet<LanguageFeature, LanguageFeature_enumSize>;
 using UsageWarnings = EnumSet<UsageWarning, UsageWarning_enumSize>;

flang/lib/Evaluate/characteristics.cpp

@@ -1887,6 +1887,12 @@ bool DistinguishUtils::Distinguishable(const TypeAndShape &x,
   if (ignoreTKR.test(common::IgnoreTKR::Rank)) {
   } else if (x.attrs().test(TypeAndShape::Attr::AssumedRank) ||
       y.attrs().test(TypeAndShape::Attr::AssumedRank)) {
+  } else if ((x.attrs().test(TypeAndShape::Attr::AssumedSize) &&
+                 x.type().IsAssumedType() && y.Rank() == 0) ||
+      (y.attrs().test(TypeAndShape::Attr::AssumedSize) &&
+          y.type().IsAssumedType() && x.Rank() == 0)) {
+    // F'2023 15.5.2.5 p14, third bullet: scalar actual can be passed
+    // to TYPE(*) assumed-size dummy argument
   } else if (x.Rank() != y.Rank()) {
     return true;
   }

flang/lib/Semantics/check-call.cpp

@@ -573,6 +573,12 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
           "Assumed-size array may not be associated with assumed-shape %s"_err_en_US,
           dummyName);
     }
+  } else if (dummyIsAssumedSize && dummy.type.type().IsAssumedType() &&
+      actualRank == 0 && !actualIsAssumedRank) {
+    // F'2023 15.5.2.5 p14 third bullet allows a scalar actual
+    // argument to associate with a TYPE(*) assumed-size dummy
+    foldingContext.Warn(common::UsageWarning::AssumedTypeSizeDummy,
+        "A scalar actual argument for an assumed-size TYPE(*) dummy is not portable"_port_en_US);
   } else if (dummyRank > 0) {
     bool basicError{false};
     if (actualRank == 0 && !actualIsAssumedRank &&
@@ -589,9 +595,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
           actualType.type().category() == TypeCategory::Character &&
           actualType.type().kind() == 1};
       if (!actualIsCKindCharacter) {
-        if (!actualIsArrayElement &&
-            !(dummy.type.type().IsAssumedType() && dummyIsAssumedSize) &&
-            !dummyIsAssumedRank &&
+        if (!actualIsArrayElement && !dummyIsAssumedRank &&
             !dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) {
           basicError = true;
           messages.Say(

flang/lib/Semantics/expression.cpp

@@ -2712,7 +2712,10 @@ static bool CheckCompatibleArgument(bool isElemental,
             } else if (!isElemental && actual.Rank() != x.type.Rank() &&
                 !x.type.attrs().test(
                     characteristics::TypeAndShape::Attr::AssumedRank) &&
-                !x.ignoreTKR.test(common::IgnoreTKR::Rank)) {
+                !x.ignoreTKR.test(common::IgnoreTKR::Rank) &&
+                !(x.type.type().IsAssumedType() &&
+                    x.type.attrs().test(
+                        characteristics::TypeAndShape::Attr::AssumedSize))) {
               return false;
             } else if (auto actualType{actual.GetType()}) {
               return x.type.type().IsTkCompatibleWith(*actualType, x.ignoreTKR);
@@ -2964,6 +2967,7 @@ auto ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol,
             continue;
           }
         }
+        tried.push_back(*specific);
         if (semantics::CheckInterfaceForGeneric(*procedure, localActuals,
                 context_, false /* no integer conversions */) &&
             CheckCompatibleArguments(
@@ -2996,7 +3000,6 @@ auto ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol,
           crtMatchingDistance = ComputeCudaMatchingDistance(
               context_.languageFeatures(), *procedure, localActuals);
         } else {
-          tried.push_back(*specific);
         }
       }
     }
@@ -3155,17 +3158,23 @@ void ExpressionAnalyzer::EmitGenericResolutionError(const Symbol &symbol,
       if (auto procChars{characteristics::Procedure::Characterize(
               specific, GetFoldingContext())}) {
         if (procChars->HasExplicitInterface()) {
-          if (auto reasons{semantics::CheckExplicitInterface(*procChars,
-                  arguments, context_, &scope, /*intrinsic=*/nullptr,
-                  /*allocActualArgumentConversions=*/false,
-                  /*extentErrors=*/false,
-                  /*ignoreImplicitVsExplicit=*/false)};
-              !reasons.empty()) {
-            reasons.AttachTo(
-                msg->Attach(specific.name(),
-                    "Specific procedure '%s' does not match the actual arguments because"_en_US,
-                    specific.name()),
-                parser::Severity::None);
+          auto reasons{semantics::CheckExplicitInterface(*procChars, arguments,
+              context_, &scope, /*intrinsic=*/nullptr,
+              /*allocActualArgumentConversions=*/false,
+              /*extentErrors=*/false,
+              /*ignoreImplicitVsExplicit=*/false)};
+          if (reasons.AnyFatalError() != dueToAmbiguity) {
+            if (dueToAmbiguity) {
+              msg->Attach(specific.name(),
+                  "Specific procedure '%s' matched the actual arguments"_en_US,
+                  specific.name());
+            } else {
+              reasons.AttachTo(
+                  msg->Attach(specific.name(),
+                      "Specific procedure '%s' does not match the actual arguments because"_en_US,
+                      specific.name()),
+                  parser::Severity::None);
+            }
           }
         }
       }

flang/test/Semantics/call03.f90

@@ -237,6 +237,7 @@ module m01
     call charray(assumed_shape_char(1))  ! not an error if character
     call assumedsize(arr(1))  ! not an error if element in sequence
     call assumedrank(x)  ! not an error
+    !PORTABILITY: A scalar actual argument for an assumed-size TYPE(*) dummy is not portable [-Wassumed-type-size-dummy]
     call assumedtypeandsize(x)  ! not an error
   end subroutine
 

flang/test/Semantics/call46.f90

@@ -0,0 +1,32 @@
+!RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+module m
+  interface generic1 ! ok
+    module procedure :: sub1
+  end interface
+  !ERROR: Generic 'generic2' may not have specific procedures 'sub1' and 'sub2' as their interfaces are not distinguishable
+  interface generic2
+    module procedure :: sub1, sub2
+  end interface
+ contains
+  subroutine sub1(a,len)
+    type(*), intent(in) :: a(*)
+    integer len
+    print *, 'in sub'
+  end
+  subroutine sub2(a,len)
+    character(*), intent(in) :: a
+    integer len
+    print *, 'in sub2'
+  end
+end
+
+program test
+  use m
+  character(3) :: foo = "abc"
+  !PORTABILITY: A scalar actual argument for an assumed-size TYPE(*) dummy is not portable [-Wassumed-type-size-dummy]
+  call sub1(foo, 3) ! ok
+  !PORTABILITY: A scalar actual argument for an assumed-size TYPE(*) dummy is not portable [-Wassumed-type-size-dummy]
+  call generic1(foo, 3) ! ok
+  !ERROR: The actual arguments to the generic procedure 'generic2' matched multiple specific procedures, perhaps due to use of NULL() without MOLD= or an actual procedure with an implicit interface
+  call generic2(foo, 3)
+end