[flang] Extension to distinguish specific procedures

[klausler]

Summary

Allocatable dummy arguments can be used to distinguish
two specific procedures in a generic interface when
it is the case that exactly one of them is polymorphic
or exactly one of them is unlimited polymorphic. The
standard requires that an actual argument corresponding
to an (unlimited) polymorphic allocatable dummy argument
must also be an (unlimited) polymorphic allocatable, so an
actual argument that's acceptable to one procedure must
necessarily be a bad match for the other.

[PeteSteinfeld]

Looks great!

flang/docs/Extensions.md

* A forward reference to a default INTEGER scalar dummy argument is
   as default INTEGER if IMPLICIT NONE(TYPE) were absent.
 * OPEN(ACCESS='APPEND') is interpreted as OPEN(POSITION='APPEND')
   to ease porting from Sun Fortran.
 * Intrinsic subroutines EXIT([status]) and ABORT()
 * The definition of simple contiguity in 9.5.4 applies only to arrays;
   we also treat scalars as being trivially contiguous, so that they
   can be used in contexts like data targets in pointer assignments
   with bounds remapping.
+* We support some combinations of specific procedures in generic
+  interfaces that a strict reading of the standard would preclude
+  when their calls must nonetheless be distinguishable.
+  Specifically, `ALLOCATABLE` dummy arguments are distinguishing
+  if an actual argument acceptable to one could not be passed to
+  the other & vice versa because exactly one is polymorphic or
+  exactly one is unlimited polymorphic).
 
 ### Extensions supported when enabled by options
 
 * C-style backslash escape sequences in quoted CHARACTER literals
   (but not Hollerith) [-fbackslash]
 * Logical abbreviations `.T.`, `.F.`, `.N.`, `.A.`, `.O.`, and `.X.`
   [-flogical-abbreviations]
 * `.XOR.` as a synonym for `.NEQV.` [-fxor-operator]

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

ENUM_CLASS(LanguageFeature, BackslashEscapes, OldDebugLines,
     Carriagecontrol, Convert, Dispose, IOListLeadingComma,
     AbbreviatedEditDescriptor, ProgramParentheses, PercentRefAndVal,
     OmitFunctionDummies, CrayPointer, Hollerith, ArithmeticIF, Assign,
     AssignedGOTO, Pause, OpenACC, OpenMP, CruftAfterAmpersand, ClassicCComments,
     AdditionalFormats, BigIntLiterals, RealDoControls,
     EquivalenceNumericWithCharacter, AdditionalIntrinsics, AnonymousParents,
     OldLabelDoEndStatements, LogicalIntegerAssignment, EmptySourceFile,
     ProgramReturn, ImplicitNoneTypeNever, ImplicitNoneTypeAlways,
-    ForwardRefDummyImplicitNone, OpenAccessAppend, BOZAsDefaultInteger)
+    ForwardRefDummyImplicitNone, OpenAccessAppend, BOZAsDefaultInteger,
+    DistinguishableSpecifics)
 
 using LanguageFeatures = EnumSet<LanguageFeature, LanguageFeature_enumSize>;
 
 class LanguageFeatureControl {
 public:
   LanguageFeatureControl() {
     // These features must be explicitly enabled by command line options.
     disable_.set(LanguageFeature::OldDebugLines);

flang/include/flang/Evaluate/characteristics.h

 
 #ifndef FORTRAN_EVALUATE_CHARACTERISTICS_H_
 #define FORTRAN_EVALUATE_CHARACTERISTICS_H_
 
 #include "common.h"
 #include "expression.h"
 #include "shape.h"
 #include "type.h"
+#include "flang/Common/Fortran-features.h"
 #include "flang/Common/Fortran.h"
 #include "flang/Common/enum-set.h"
 #include "flang/Common/idioms.h"
 #include "flang/Common/indirection.h"
 #include "flang/Parser/char-block.h"
 #include "flang/Semantics/symbol.h"
 #include <optional>
 #include <string>

 extern template class Fortran::common::Indirection<
     Fortran::evaluate::characteristics::Procedure, true>;
 
 namespace Fortran::evaluate::characteristics {
 
 using common::CopyableIndirection;
 
 // Are these procedures distinguishable for a generic name or FINAL?
-bool Distinguishable(const Procedure &, const Procedure &);
+bool Distinguishable(const common::LanguageFeatureControl &, const Procedure &,
+    const Procedure &);
 // Are these procedures distinguishable for a generic operator or assignment?
-bool DistinguishableOpOrAssign(const Procedure &, const Procedure &);
+bool DistinguishableOpOrAssign(const common::LanguageFeatureControl &,
+    const Procedure &, const Procedure &);
 
 // Shapes of function results and dummy arguments have to have
 // the same rank, the same deferred dimensions, and the same
 // values for explicit dimensions when constant.
 bool ShapesAreCompatible(const Shape &, const Shape &);
 
 class TypeAndShape {
 public:

flang/lib/Evaluate/characteristics.cpp

for (const auto &dummy : dummyArguments) {
     sep = ',';
   }
   return o << (sep == '(' ? "()" : ")");
 }
 
 // Utility class to determine if Procedures, etc. are distinguishable
 class DistinguishUtils {
 public:
+  explicit DistinguishUtils(const common::LanguageFeatureControl &features)
+      : features_{features} {}
+
   // Are these procedures distinguishable for a generic name?
-  static bool Distinguishable(const Procedure &, const Procedure &);
+  bool Distinguishable(const Procedure &, const Procedure &) const;
   // Are these procedures distinguishable for a generic operator or assignment?
-  static bool DistinguishableOpOrAssign(const Procedure &, const Procedure &);
+  bool DistinguishableOpOrAssign(const Procedure &, const Procedure &) const;
 
 private:
   struct CountDummyProcedures {
     CountDummyProcedures(const DummyArguments &args) {
       for (const DummyArgument &arg : args) {
         if (std::holds_alternative<DummyProcedure>(arg.u)) {
           total += 1;
           notOptional += !arg.IsOptional();
         }
       }
     }
     int total{0};
     int notOptional{0};
   };
 
-  static bool Rule3Distinguishable(const Procedure &, const Procedure &);
-  static const DummyArgument *Rule1DistinguishingArg(
-      const DummyArguments &, const DummyArguments &);
-  static int FindFirstToDistinguishByPosition(
-      const DummyArguments &, const DummyArguments &);
-  static int FindLastToDistinguishByName(
-      const DummyArguments &, const DummyArguments &);
-  static int CountCompatibleWith(const DummyArgument &, const DummyArguments &);
-  static int CountNotDistinguishableFrom(
-      const DummyArgument &, const DummyArguments &);
-  static bool Distinguishable(const DummyArgument &, const DummyArgument &);
-  static bool Distinguishable(const DummyDataObject &, const DummyDataObject &);
-  static bool Distinguishable(const DummyProcedure &, const DummyProcedure &);
-  static bool Distinguishable(const FunctionResult &, const FunctionResult &);
-  static bool Distinguishable(const TypeAndShape &, const TypeAndShape &);
-  static bool IsTkrCompatible(const DummyArgument &, const DummyArgument &);
-  static bool IsTkrCompatible(const TypeAndShape &, const TypeAndShape &);
-  static const DummyArgument *GetAtEffectivePosition(
-      const DummyArguments &, int);
-  static const DummyArgument *GetPassArg(const Procedure &);
+  bool Rule3Distinguishable(const Procedure &, const Procedure &) const;
+  const DummyArgument *Rule1DistinguishingArg(
+      const DummyArguments &, const DummyArguments &) const;
+  int FindFirstToDistinguishByPosition(
+      const DummyArguments &, const DummyArguments &) const;
+  int FindLastToDistinguishByName(
+      const DummyArguments &, const DummyArguments &) const;
+  int CountCompatibleWith(const DummyArgument &, const DummyArguments &) const;
+  int CountNotDistinguishableFrom(
+      const DummyArgument &, const DummyArguments &) const;
+  bool Distinguishable(const DummyArgument &, const DummyArgument &) const;
+  bool Distinguishable(const DummyDataObject &, const DummyDataObject &) const;
+  bool Distinguishable(const DummyProcedure &, const DummyProcedure &) const;
+  bool Distinguishable(const FunctionResult &, const FunctionResult &) const;
+  bool Distinguishable(const TypeAndShape &, const TypeAndShape &) const;
+  bool IsTkrCompatible(const DummyArgument &, const DummyArgument &) const;
+  bool IsTkrCompatible(const TypeAndShape &, const TypeAndShape &) const;
+  const DummyArgument *GetAtEffectivePosition(
+      const DummyArguments &, int) const;
+  const DummyArgument *GetPassArg(const Procedure &) const;
+
+  const common::LanguageFeatureControl &features_;
 };
 
 // Simpler distinguishability rules for operators and assignment
 bool DistinguishUtils::DistinguishableOpOrAssign(
-    const Procedure &proc1, const Procedure &proc2) {
+    const Procedure &proc1, const Procedure &proc2) const {
   auto &args1{proc1.dummyArguments};
   auto &args2{proc2.dummyArguments};
   if (args1.size() != args2.size()) {
     return true; // C1511: distinguishable based on number of arguments
   }
   for (std::size_t i{0}; i < args1.size(); ++i) {
     if (Distinguishable(args1[i], args2[i])) {
       return true; // C1511, C1512: distinguishable based on this arg
     }
   }
   return false;
 }
 
 bool DistinguishUtils::Distinguishable(
-    const Procedure &proc1, const Procedure &proc2) {
+    const Procedure &proc1, const Procedure &proc2) const {
   auto &args1{proc1.dummyArguments};
   auto &args2{proc2.dummyArguments};
   auto count1{CountDummyProcedures(args1)};
   auto count2{CountDummyProcedures(args2)};
   if (count1.notOptional > count2.total || count2.notOptional > count1.total) {
     return true; // distinguishable based on C1514 rule 2
   }
   if (Rule3Distinguishable(proc1, proc2)) {
if (pos2 >= 0 && pos2 <= name2) {
     return true; // distinguishable based on C1514 rule 4
   }
   return false;
 }
 
 // C1514 rule 3: Procedures are distinguishable if both have a passed-object
 // dummy argument and those are distinguishable.
 bool DistinguishUtils::Rule3Distinguishable(
-    const Procedure &proc1, const Procedure &proc2) {
+    const Procedure &proc1, const Procedure &proc2) const {
   const DummyArgument *pass1{GetPassArg(proc1)};
   const DummyArgument *pass2{GetPassArg(proc2)};
   return pass1 && pass2 && Distinguishable(*pass1, *pass2);
 }
 
 // Find a non-passed-object dummy data object in one of the argument lists
 // that satisfies C1514 rule 1. I.e. x such that:
 // - m is the number of dummy data objects in one that are nonoptional,
 //   are not passed-object, that x is TKR compatible with
 // - n is the number of non-passed-object dummy data objects, in the other
 //   that are not distinguishable from x
 // - m is greater than n
 const DummyArgument *DistinguishUtils::Rule1DistinguishingArg(
-    const DummyArguments &args1, const DummyArguments &args2) {
+    const DummyArguments &args1, const DummyArguments &args2) const {
   auto size1{args1.size()};
   auto size2{args2.size()};
   for (std::size_t i{0}; i < size1 + size2; ++i) {
     const DummyArgument &x{i < size1 ? args1[i] : args2[i - size1]};
     if (!x.pass && std::holds_alternative<DummyDataObject>(x.u)) {
       if (CountCompatibleWith(x, args1) >
               CountNotDistinguishableFrom(x, args2) ||
           CountCompatibleWith(x, args2) >
               CountNotDistinguishableFrom(x, args1)) {
         return &x;
       }
     }
   }
   return nullptr;
 }
 
 // Find the index of the first nonoptional non-passed-object dummy argument
 // in args1 at an effective position such that either:
 // - args2 has no dummy argument at that effective position
 // - the dummy argument at that position is distinguishable from it
 int DistinguishUtils::FindFirstToDistinguishByPosition(
-    const DummyArguments &args1, const DummyArguments &args2) {
+    const DummyArguments &args1, const DummyArguments &args2) const {
   int effective{0}; // position of arg1 in list, ignoring passed arg
   for (std::size_t i{0}; i < args1.size(); ++i) {
     const DummyArgument &arg1{args1.at(i)};
     if (!arg1.pass && !arg1.IsOptional()) {
       const DummyArgument *arg2{GetAtEffectivePosition(args2, effective)};
       if (!arg2 || Distinguishable(arg1, *arg2)) {
         return i;
       }
     }
     effective += !arg1.pass;
   }
   return -1;
 }
 
 // Find the index of the last nonoptional non-passed-object dummy argument
 // in args1 whose name is such that either:
 // - args2 has no dummy argument with that name
 // - the dummy argument with that name is distinguishable from it
 int DistinguishUtils::FindLastToDistinguishByName(
-    const DummyArguments &args1, const DummyArguments &args2) {
+    const DummyArguments &args1, const DummyArguments &args2) const {
   std::map<std::string, const DummyArgument *> nameToArg;
   for (const auto &arg2 : args2) {
     nameToArg.emplace(arg2.name, &arg2);
   }
   for (int i = args1.size() - 1; i >= 0; --i) {
     const DummyArgument &arg1{args1.at(i)};
     if (!arg1.pass && !arg1.IsOptional()) {
       auto it{nameToArg.find(arg1.name)};
       if (it == nameToArg.end() || Distinguishable(arg1, *it->second)) {
         return i;
       }
     }
   }
   return -1;
 }
 
 // Count the dummy data objects in args that are nonoptional, are not
 // passed-object, and that x is TKR compatible with
 int DistinguishUtils::CountCompatibleWith(
-    const DummyArgument &x, const DummyArguments &args) {
+    const DummyArgument &x, const DummyArguments &args) const {
   return std::count_if(args.begin(), args.end(), [&](const DummyArgument &y) {
     return !y.pass && !y.IsOptional() && IsTkrCompatible(x, y);
   });
 }
 
 // Return the number of dummy data objects in args that are not
 // distinguishable from x and not passed-object.
 int DistinguishUtils::CountNotDistinguishableFrom(
-    const DummyArgument &x, const DummyArguments &args) {
+    const DummyArgument &x, const DummyArguments &args) const {
   return std::count_if(args.begin(), args.end(), [&](const DummyArgument &y) {
     return !y.pass && std::holds_alternative<DummyDataObject>(y.u) &&
         !Distinguishable(y, x);
   });
 }
 
 bool DistinguishUtils::Distinguishable(
-    const DummyArgument &x, const DummyArgument &y) {
+    const DummyArgument &x, const DummyArgument &y) const {
   if (x.u.index() != y.u.index()) {
     return true; // different kind: data/proc/alt-return
   }
   return std::visit(
       common::visitors{
           [&](const DummyDataObject &z) {
             return Distinguishable(z, std::get<DummyDataObject>(y.u));
           },
           [&](const DummyProcedure &z) {
             return Distinguishable(z, std::get<DummyProcedure>(y.u));
           },
           [&](const AlternateReturn &) { return false; },
       },
       x.u);
 }
 
 bool DistinguishUtils::Distinguishable(
-    const DummyDataObject &x, const DummyDataObject &y) {
+    const DummyDataObject &x, const DummyDataObject &y) const {
   using Attr = DummyDataObject::Attr;
   if (Distinguishable(x.type, y.type)) {
     return true;
   } else if (x.attrs.test(Attr::Allocatable) && y.attrs.test(Attr::Pointer) &&
       y.intent != common::Intent::In) {
     return true;
   } else if (y.attrs.test(Attr::Allocatable) && x.attrs.test(Attr::Pointer) &&
       x.intent != common::Intent::In) {
     return true;
+  } else if (features_.IsEnabled(
+                 common::LanguageFeature::DistinguishableSpecifics) &&
+      (x.attrs.test(Attr::Allocatable) || x.attrs.test(Attr::Pointer)) &&
+      (y.attrs.test(Attr::Allocatable) || y.attrs.test(Attr::Pointer)) &&
+      (x.type.type().IsUnlimitedPolymorphic() !=
+              y.type.type().IsUnlimitedPolymorphic() ||
+          x.type.type().IsPolymorphic() != y.type.type().IsPolymorphic())) {
+    // Extension: Per 15.5.2.5(2), an allocatable/pointer dummy and its
+    // corresponding actual argument must both or neither be polymorphic,
+    // and must both or neither be unlimited polymorphic.  So when exactly
+    // one of two dummy arguments is polymorphic or unlimited polymorphic,
+    // any actual argument that is admissible to one of them cannot also match
+    // the other one.
+    return true;
   } else {
     return false;
   }
 }
 
 bool DistinguishUtils::Distinguishable(
-    const DummyProcedure &x, const DummyProcedure &y) {
+    const DummyProcedure &x, const DummyProcedure &y) const {
   const Procedure &xProc{x.procedure.value()};
   const Procedure &yProc{y.procedure.value()};
   if (Distinguishable(xProc, yProc)) {
     return true;
   } else {
     const std::optional<FunctionResult> &xResult{xProc.functionResult};
     const std::optional<FunctionResult> &yResult{yProc.functionResult};
     return xResult ? !yResult || Distinguishable(*xResult, *yResult)
                    : yResult.has_value();
   }
 }
 
 bool DistinguishUtils::Distinguishable(
-    const FunctionResult &x, const FunctionResult &y) {
+    const FunctionResult &x, const FunctionResult &y) const {
   if (x.u.index() != y.u.index()) {
     return true; // one is data object, one is procedure
   }
   return std::visit(
       common::visitors{
           [&](const TypeAndShape &z) {
             return Distinguishable(z, std::get<TypeAndShape>(y.u));
           },
           [&](const CopyableIndirection<Procedure> &z) {
             return Distinguishable(z.value(),
                 std::get<CopyableIndirection<Procedure>>(y.u).value());
           },
       },
       x.u);
 }
 
 bool DistinguishUtils::Distinguishable(
-    const TypeAndShape &x, const TypeAndShape &y) {
+    const TypeAndShape &x, const TypeAndShape &y) const {
   return !IsTkrCompatible(x, y) && !IsTkrCompatible(y, x);
 }
 
 // Compatibility based on type, kind, and rank
 bool DistinguishUtils::IsTkrCompatible(
-    const DummyArgument &x, const DummyArgument &y) {
+    const DummyArgument &x, const DummyArgument &y) const {
   const auto *obj1{std::get_if<DummyDataObject>(&x.u)};
   const auto *obj2{std::get_if<DummyDataObject>(&y.u)};
   return obj1 && obj2 && IsTkrCompatible(obj1->type, obj2->type);
 }
 bool DistinguishUtils::IsTkrCompatible(
-    const TypeAndShape &x, const TypeAndShape &y) {
+    const TypeAndShape &x, const TypeAndShape &y) const {
   return x.type().IsTkCompatibleWith(y.type()) &&
       (x.attrs().test(TypeAndShape::Attr::AssumedRank) ||
           y.attrs().test(TypeAndShape::Attr::AssumedRank) ||
           x.Rank() == y.Rank());
 }
 
 // Return the argument at the given index, ignoring the passed arg
 const DummyArgument *DistinguishUtils::GetAtEffectivePosition(
-    const DummyArguments &args, int index) {
+    const DummyArguments &args, int index) const {
   for (const DummyArgument &arg : args) {
     if (!arg.pass) {
       if (index == 0) {
         return &arg;
       }
       --index;
     }
   }
   return nullptr;
 }
 
 // Return the passed-object dummy argument of this procedure, if any
-const DummyArgument *DistinguishUtils::GetPassArg(const Procedure &proc) {
+const DummyArgument *DistinguishUtils::GetPassArg(const Procedure &proc) const {
   for (const auto &arg : proc.dummyArguments) {
     if (arg.pass) {
       return &arg;
     }
   }
   return nullptr;
 }
 
-bool Distinguishable(const Procedure &x, const Procedure &y) {
-  return DistinguishUtils::Distinguishable(x, y);
+bool Distinguishable(const common::LanguageFeatureControl &features,
+    const Procedure &x, const Procedure &y) {
+  return DistinguishUtils{features}.Distinguishable(x, y);
 }
 
-bool DistinguishableOpOrAssign(const Procedure &x, const Procedure &y) {
-  return DistinguishUtils::DistinguishableOpOrAssign(x, y);
+bool DistinguishableOpOrAssign(const common::LanguageFeatureControl &features,
+    const Procedure &x, const Procedure &y) {
+  return DistinguishUtils{features}.DistinguishableOpOrAssign(x, y);
 }
 
 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyArgument)
 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyProcedure)
 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(FunctionResult)
 DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(Procedure)
 } // namespace Fortran::evaluate::characteristics
 
 template class Fortran::common::Indirection<
     Fortran::evaluate::characteristics::Procedure, true>;

flang/lib/Semantics/check-declarations.cpp

 }
 
 bool CheckHelper::CheckDistinguishableFinals(const Symbol &f1,
     SourceName f1Name, const Symbol &f2, SourceName f2Name,
     const Symbol &derivedType) {
   const Procedure *p1{Characterize(f1)};
   const Procedure *p2{Characterize(f2)};
   if (p1 && p2) {
-    if (characteristics::Distinguishable(*p1, *p2)) {
+    if (characteristics::Distinguishable(
+            context_.languageFeatures(), *p1, *p2)) {
       return true;
     }
     if (auto *msg{messages_.Say(f1Name,
             "FINAL subroutines '%s' and '%s' of derived type '%s' cannot be distinguished by rank or KIND type parameter value"_err_en_US,
             f1Name, f2Name, derivedType.name())}) {
       msg->Attach(f2Name, "FINAL declaration of '%s'"_en_US, f2.name())
           .Attach(f1.name(), "Definition of '%s'"_en_US, f1Name)
           .Attach(f2.name(), "Definition of '%s'"_en_US, f2Name);
void DistinguishabilityHelper::Check(const Scope &scope) {
   for (const auto &[name, info] : nameToInfo_) {
     auto count{info.size()};
     for (std::size_t i1{0}; i1 < count - 1; ++i1) {
       const auto &[kind, symbol, proc]{info[i1]};
       for (std::size_t i2{i1 + 1}; i2 < count; ++i2) {
         auto distinguishable{kind.IsName()
                 ? evaluate::characteristics::Distinguishable
                 : evaluate::characteristics::DistinguishableOpOrAssign};
-        if (!distinguishable(proc, info[i2].procedure)) {
+        if (!distinguishable(
+                context_.languageFeatures(), proc, info[i2].procedure)) {
           SayNotDistinguishable(GetTopLevelUnitContaining(scope), name, kind,
               symbol, info[i2].symbol);
         }
       }
     }
   }
 }
 

flang/test/Semantics/resolve53.f90

interface operator(.not.)
     !ERROR: Procedure 'f' from module 'm20' is already specified in generic 'OPERATOR(.NOT.)'
     procedure f
   end interface
   interface operator(+)
     !ERROR: Procedure 'f' from module 'm20' is already specified in generic 'OPERATOR(+)'
     procedure f
   end interface
 end subroutine s1
+
+! Extensions for distinguishable allocatable arguments; these should not
+! elicit errors from f18
+module m21
+  type :: t
+  end type
+  interface int1
+    procedure s1a, s1b ! only one is polymorphic
+  end interface
+  interface int2
+    procedure s2a, s2b ! only one is unlimited polymorphic
+  end interface
+ contains
+  subroutine s1a(x)
+    type(t), allocatable :: x
+  end subroutine
+  subroutine s1b(x)
+    class(t), allocatable :: x
+  end subroutine
+  subroutine s2a(x)
+    class(t), allocatable :: x
+  end subroutine
+  subroutine s2b(x)
+    class(*), allocatable :: x
+  end subroutine
+end module