[flang] Fix generic/specific procedure confusion

[klausler]

Summary

A recent change that extended semantic analysis for actual arguments
that associate with procedure dummy arguments exposed some bugs in
regression test suites due to points of confusion in symbol table
handling in situations where a generic interface contains a specific
procedure of the same name. When passing that name as an actual
argument, for example, it's necessary to take this possibility into
account because the symbol for the generic interface shadows the
symbol of the same name for the specific procedure, which is
what needs to be checked. So add a small utility that bypasses
the symbol for a generic interface in this case, and use it
where needed.

[PeteSteinfeld]

All builds, tests, and looks good.

It would be good to have a test that illustrates the situation that these changes fix.

flang/include/flang/Parser/parse-tree.h

struct Designator {
   CharBlock source;
   std::variant<DataRef, Substring> u;
 };
 
 // R902 variable -> designator | function-reference
 struct Variable {
   UNION_CLASS_BOILERPLATE(Variable);
   mutable TypedExpr typedExpr;
-  parser::CharBlock GetSource() const;
+  CharBlock GetSource() const;
   std::variant<common::Indirection<Designator>,
       common::Indirection<FunctionReference>>
       u;
 };
 
 // R904 logical-variable -> variable
 // Appears only as part of scalar-logical-variable.
 using ScalarLogicalVariable = Scalar<Logical<Variable>>;

flang/include/flang/Semantics/tools.h

 template <typename T>
 const Symbol *FindExternallyVisibleObject(
     const evaluate::Expr<T> &expr, const Scope &scope) {
   return std::visit(
       [&](const auto &x) { return FindExternallyVisibleObject(x, scope); },
       expr.u);
 }
 
+// Apply GetUltimate(), then if the symbol is a generic procedure shadowing a
+// specific procedure of the same name, return it instead.
+const Symbol &BypassGeneric(const Symbol &);
+
 using SomeExpr = evaluate::Expr<evaluate::SomeType>;
 
 bool ExprHasTypeCategory(
     const SomeExpr &expr, const common::TypeCategory &type);
 bool ExprTypeKindIsDefault(
     const SomeExpr &expr, const SemanticsContext &context);
 
 struct GetExprHelper {

flang/lib/Evaluate/fold-reduction.h

 
 // MAXVAL & MINVAL
 template <typename T>
 static Expr<T> FoldMaxvalMinval(FoldingContext &context, FunctionRef<T> &&ref,
     RelationalOperator opr, const Scalar<T> &identity) {
   static_assert(T::category == TypeCategory::Integer ||
       T::category == TypeCategory::Real ||
       T::category == TypeCategory::Character);
-  using Element = Scalar<T>; // pmk: was typename Constant<T>::Element;
+  using Element = Scalar<T>;
   std::optional<ConstantSubscript> dim;
   if (std::optional<Constant<T>> array{
           ProcessReductionArgs<T>(context, ref.arguments(), dim, identity,
               /*ARRAY=*/0, /*DIM=*/1, /*MASK=*/2)}) {
     auto accumulator{[&](Element &element, const ConstantSubscripts &at) {
       Expr<LogicalResult> test{PackageRelation(opr,
           Expr<T>{Constant<T>{array->At(at)}}, Expr<T>{Constant<T>{element}})};
       auto folded{GetScalarConstantValue<LogicalResult>(

flang/lib/Semantics/expression.cpp

private:
   const bool isProcedureCall_; // false for user-defined op or assignment
   const Symbol *sawDefinedOp_{nullptr};
 };
 
 // Wraps a data reference in a typed Designator<>, and a procedure
 // or procedure pointer reference in a ProcedureDesignator.
 MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) {
   const Symbol &last{ref.GetLastSymbol()};
-  const Symbol &symbol{last.GetUltimate()};
+  const Symbol &symbol{BypassGeneric(last).GetUltimate()};
   if (semantics::IsProcedure(symbol)) {
     if (auto *component{std::get_if<Component>(&ref.u)}) {
       return Expr<SomeType>{ProcedureDesignator{std::move(*component)}};
     } else if (!std::holds_alternative<SymbolRef>(ref.u)) {
       DIE("unexpected alternative in DataRef");
     } else if (!symbol.attrs().test(semantics::Attr::INTRINSIC)) {
+      if (symbol.has<semantics::GenericDetails>()) {
+        Say("'%s' is not a specific procedure"_err_en_US, symbol.name());
+      } else {
         return Expr<SomeType>{ProcedureDesignator{symbol}};
+      }
     } else if (auto interface{context_.intrinsics().IsSpecificIntrinsicFunction(
                    symbol.name().ToString())}) {
       SpecificIntrinsic intrinsic{
           symbol.name().ToString(), std::move(*interface)};
       intrinsic.isRestrictedSpecific = interface->isRestrictedSpecific;
       return Expr<SomeType>{ProcedureDesignator{std::move(intrinsic)}};
     } else {
       Say("'%s' is not a specific intrinsic procedure"_err_en_US,

 void ArgumentAnalyzer::Analyze(
     const parser::ActualArgSpec &arg, bool isSubroutine) {
   // TODO: Actual arguments that are procedures and procedure pointers need to
   // be detected and represented (they're not expressions).
   // TODO: C1534: Don't allow a "restricted" specific intrinsic to be passed.
   std::optional<ActualArgument> actual;
   std::visit(common::visitors{
                  [&](const common::Indirection<parser::Expr> &x) {
-                   // TODO: Distinguish & handle procedure name and
-                   // proc-component-ref
                    actual = AnalyzeExpr(x.value());
                  },
                  [&](const parser::AltReturnSpec &label) {
                    if (!isSubroutine) {
                      context_.Say(
                          "alternate return specification may not appear on"
                          " function reference"_err_en_US);
                    }

flang/lib/Semantics/resolve-names.cpp

 }
 
 // By now we should have seen all specific procedures referenced by name in
 // this generic interface. Resolve those names to symbols.
 void InterfaceVisitor::ResolveSpecificsInGeneric(Symbol &generic) {
   auto &details{generic.get<GenericDetails>()};
   UnorderedSymbolSet symbolsSeen;
   for (const Symbol &symbol : details.specificProcs()) {
-    symbolsSeen.insert(symbol);
+    symbolsSeen.insert(symbol.GetUltimate());
   }
   auto range{specificProcs_.equal_range(&generic)};
   for (auto it{range.first}; it != range.second; ++it) {
     auto *name{it->second.first};
     auto kind{it->second.second};
     const auto *symbol{FindSymbol(*name)};
     if (!symbol) {
       Say(*name, "Procedure '%s' not found"_err_en_US);
       continue;
     }
-    if (symbol == &generic) {
-      if (auto *specific{generic.get<GenericDetails>().specific()}) {
-        symbol = specific;
-      }
-    }
-    const Symbol &ultimate{symbol->GetUltimate()};
+    const Symbol &specific{BypassGeneric(*symbol)};
+    const Symbol &ultimate{specific.GetUltimate()};
     if (!ultimate.has<SubprogramDetails>() &&
         !ultimate.has<SubprogramNameDetails>()) {
       Say(*name, "'%s' is not a subprogram"_err_en_US);
       continue;
     }
     if (kind == ProcedureKind::ModuleProcedure) {
       if (const auto *nd{ultimate.detailsIf<SubprogramNameDetails>()}) {
         if (nd->kind() != SubprogramKind::Module) {
           Say(*name, "'%s' is not a module procedure"_err_en_US);
         }
       } else {
         // USE-associated procedure
         const auto *sd{ultimate.detailsIf<SubprogramDetails>()};
         CHECK(sd);
         if (ultimate.owner().kind() != Scope::Kind::Module ||
             sd->isInterface()) {
           Say(*name, "'%s' is not a module procedure"_err_en_US);
         }
       }
     }
-    if (!symbolsSeen.insert(ultimate).second) {
-      if (symbol == &ultimate) {
-        Say(name->source,
-            "Procedure '%s' is already specified in generic '%s'"_err_en_US,
-            name->source, MakeOpName(generic.name()));
-      } else {
-        Say(name->source,
-            "Procedure '%s' from module '%s' is already specified in generic '%s'"_err_en_US,
-            ultimate.name(), ultimate.owner().GetName().value(),
-            MakeOpName(generic.name()));
-      }
-      continue;
-    }
-    details.AddSpecificProc(*symbol, name->source);
+    if (symbolsSeen.insert(ultimate).second /*true if added*/) {
+      // When a specific procedure is a USE association, that association
+      // is saved in the generic's specifics, not its ultimate symbol,
+      // so that module file output of interfaces can distinguish them.
+      details.AddSpecificProc(specific, name->source);
+    } else if (&specific == &ultimate) {
   }
   specificProcs_.erase(range.first, range.second);
 }
 
 // Check that the specific procedures are all functions or all subroutines.
 // If there is a derived type with the same name they must be functions.
 // Set the corresponding flag on generic.
 void InterfaceVisitor::CheckGenericProcedures(Symbol &generic) {

flang/lib/Semantics/tools.cpp

if (IsPointer(ultimate) && IsPureProcedure(ultimate.owner()) &&
       &GetProgramUnitContaining(scope)) {
     return &object;
   } else if (const Symbol * block{FindCommonBlockContaining(ultimate)}) {
     return block;
   }
   return nullptr;
 }
 
+const Symbol &BypassGeneric(const Symbol &symbol) {
+  const Symbol &ultimate{symbol.GetUltimate()};
+  if (const auto *generic{ultimate.detailsIf<GenericDetails>()}) {
+    if (const Symbol * specific{generic->specific()}) {
+      return *specific;
+    }
+  }
+  return symbol;
+}
+
 bool ExprHasTypeCategory(
     const SomeExpr &expr, const common::TypeCategory &type) {
   auto dynamicType{expr.GetType()};
   return dynamicType && dynamicType->category() == type;
 }
 
 bool ExprTypeKindIsDefault(
     const SomeExpr &expr, const SemanticsContext &context) {

flang/runtime/type-info.h

private:
   std::uint64_t typeHash_{0};
 
   // These pointer targets include all of the items from the parent, if any.
   StaticDescriptor<1> kindParameter_; // pointer to rank-1 array of INTEGER(8)
   StaticDescriptor<1>
       lenParameterKind_; // pointer to rank-1 array of INTEGER(1)
 
   // This array of local data components includes the parent component.
-  // Components are in alphabetic order.
-  // TODO pmk: fix to be "component order"
+  // Components are in component order, not collation order of their names.
   // It does not include procedure pointer components.
   StaticDescriptor<1, true>
       component_; // TYPE(COMPONENT), POINTER, DIMENSION(:), CONTIGUOUS
 
   // Procedure pointer components
   StaticDescriptor<1, true>
       procPtr_; // TYPE(PROCPTR), POINTER, DIMENSION(:), CONTIGUOUS