[flang] Correct interaction between generics and intrinsics

[klausler]

Summary

Fortran allows a generic interface to have he same name as an
intrinsic procedure. If the intrinsic is explicitly marked with
the INTRINSIC attribute, restrictions apply (C848) - the generic
must contain only functions or subroutines, depending on the
intrinsic. Explicit or not, the generic overrides the intrinsic,
but the intrinsic behavior must still be available for calls
whose actual arguments do not match any of the specific procedures.

Semantics was not checking constraint C848, and it didn't allow
an explicit INTRINSIC attribute on a name of a generic interface.

[jeanPerier]

LGTM

flang/lib/Semantics/check-declarations.cpp

void CheckDefinedIoProc(
       const Symbol &, const GenericDetails &, GenericKind::DefinedIo);
   bool CheckDioDummyIsData(const Symbol &, const Symbol *, std::size_t);
   void CheckDioDummyIsDerived(
       const Symbol &, const Symbol &, GenericKind::DefinedIo ioKind);
   void CheckDioDummyIsDefaultInteger(const Symbol &, const Symbol &);
   void CheckDioDummyIsScalar(const Symbol &, const Symbol &);
   void CheckDioDummyAttrs(const Symbol &, const Symbol &, Attr);
   void CheckDioDtvArg(const Symbol &, const Symbol *, GenericKind::DefinedIo);
+  void CheckGenericVsIntrinsic(const Symbol &, const GenericDetails &);
   void CheckDefaultIntegerArg(const Symbol &, const Symbol *, Attr);
   void CheckDioAssumedLenCharacterArg(
       const Symbol &, const Symbol *, std::size_t, Attr);
   void CheckDioVlistArg(const Symbol &, const Symbol *, std::size_t);
   void CheckDioArgCount(
       const Symbol &, GenericKind::DefinedIo ioKind, std::size_t);
   struct TypeWithDefinedIo {
     const DerivedTypeSpec *type;

 
 void CheckHelper::CheckGeneric(
     const Symbol &symbol, const GenericDetails &details) {
   CheckSpecificsAreDistinguishable(symbol, details);
   std::visit(common::visitors{
                  [&](const GenericKind::DefinedIo &io) {
                    CheckDefinedIoProc(symbol, details, io);
                  },
+                 [&](const GenericKind::OtherKind &other) {
+                   if (other == GenericKind::OtherKind::Name) {
+                     CheckGenericVsIntrinsic(symbol, details);
+                   }
+                 },
                  [](const auto &) {},
              },
       details.kind().u);
 }
 
 // Check that the specifics of this generic are distinguishable from each other
 void CheckHelper::CheckSpecificsAreDistinguishable(
     const Symbol &generic, const GenericDetails &details) {
if (CheckDioDummyIsData(subp, arg, 0)) {
     CheckDioDummyAttrs(subp, *arg,
         ioKind == GenericKind::DefinedIo::ReadFormatted ||
                 ioKind == GenericKind::DefinedIo::ReadUnformatted
             ? Attr::INTENT_INOUT
             : Attr::INTENT_IN);
   }
 }
 
+// If an explicit INTRINSIC name is a function, so must all the specifics be,
+// and similarly for subroutines
+void CheckHelper::CheckGenericVsIntrinsic(
+    const Symbol &symbol, const GenericDetails &generic) {
+  if (symbol.attrs().test(Attr::INTRINSIC)) {
+    const evaluate::IntrinsicProcTable &table{
+        context_.foldingContext().intrinsics()};
+    bool isSubroutine{table.IsIntrinsicSubroutine(symbol.name().ToString())};
+    if (isSubroutine || table.IsIntrinsicFunction(symbol.name().ToString())) {
+      for (const SymbolRef &ref : generic.specificProcs()) {
+        const Symbol &ultimate{ref->GetUltimate()};
+        bool specificFunc{ultimate.test(Symbol::Flag::Function)};
+        bool specificSubr{ultimate.test(Symbol::Flag::Subroutine)};
+        if (!specificFunc && !specificSubr) {
+          if (const auto *proc{ultimate.detailsIf<SubprogramDetails>()}) {
+            if (proc->isFunction()) {
+              specificFunc = true;
+            } else {
+              specificSubr = true;
+            }
+          }
+        }
+        if ((specificFunc || specificSubr) &&
+            isSubroutine != specificSubr) { // C848
+          messages_.Say(symbol.name(),
+              "Generic interface '%s' with explicit intrinsic %s of the same name may not have specific procedure '%s' that is a %s"_err_en_US,
+              symbol.name(), isSubroutine ? "subroutine" : "function",
+              ref->name(), isSubroutine ? "function" : "subroutine");
+        }
+      }
+    }
+  }
+}
+
 void CheckHelper::CheckDefaultIntegerArg(
     const Symbol &subp, const Symbol *arg, Attr intent) {
   // Argument looks like: INTEGER, INTENT(intent) :: arg
   if (CheckDioDummyIsData(subp, arg, 1)) {
     CheckDioDummyIsDefaultInteger(subp, *arg);
     CheckDioDummyIsScalar(subp, *arg);
     CheckDioDummyAttrs(subp, *arg, intent);
   }

flang/lib/Semantics/expression.cpp

 auto ExpressionAnalyzer::GetCalleeAndArguments(const parser::Name &name,
     ActualArguments &&arguments, bool isSubroutine,
     bool mightBeStructureConstructor) -> std::optional<CalleeAndArguments> {
   const Symbol *symbol{name.symbol};
   if (context_.HasError(symbol)) {
     return std::nullopt; // also handles null symbol
   }
   const Symbol &ultimate{DEREF(symbol).GetUltimate()};
-  if (ultimate.attrs().test(semantics::Attr::INTRINSIC)) {
+  CheckForBadRecursion(name.source, ultimate);
+  bool dueToNullActual{false};
+  bool isGenericInterface{ultimate.has<semantics::GenericDetails>()};
+  const Symbol *resolution{nullptr};
+  if (isGenericInterface) {
+    ExpressionAnalyzer::AdjustActuals noAdjustment;
+    auto pair{ResolveGeneric(
+        *symbol, arguments, noAdjustment, mightBeStructureConstructor)};
+    resolution = pair.first;
+    dueToNullActual = pair.second;
+  }
+  if (!resolution) {
+    // Not generic, or no resolution; may be intrinsic
+    if (!symbol->attrs().test(semantics::Attr::EXTERNAL)) {
       if (std::optional<SpecificCall> specificCall{context_.intrinsics().Probe(
               CallCharacteristics{ultimate.name().ToString(), isSubroutine},
               arguments, GetFoldingContext())}) {
         CheckBadExplicitType(*specificCall, *symbol);
         return CalleeAndArguments{
             ProcedureDesignator{std::move(specificCall->specificIntrinsic)},
             std::move(specificCall->arguments)};
+      } else if (symbol->attrs().test(semantics::Attr::INTRINSIC)) {
+        return std::nullopt;
+      }
     }
+    if (isGenericInterface) {
+      EmitGenericResolutionError(*symbol, dueToNullActual);
+      return std::nullopt;
     } else {
-    CheckForBadRecursion(name.source, ultimate);
-    bool dueToNullActual{false};
-    if (ultimate.has<semantics::GenericDetails>()) {
-      ExpressionAnalyzer::AdjustActuals noAdjustment;
-      auto pair{ResolveGeneric(
-          *symbol, arguments, noAdjustment, mightBeStructureConstructor)};
-      symbol = pair.first;
-      dueToNullActual = pair.second;
+      // Neither a generic interface nor an intrinsic
+      resolution = symbol;
     }
-    if (symbol) {
-      if (symbol->GetUltimate().has<semantics::DerivedTypeDetails>()) {
-        if (mightBeStructureConstructor) {
-          return CalleeAndArguments{
-              semantics::SymbolRef{*symbol}, std::move(arguments)};
-        }
-      } else if (IsProcedure(*symbol)) {
-        return CalleeAndArguments{
-            ProcedureDesignator{*symbol}, std::move(arguments)};
-      }
-      if (!context_.HasError(*symbol)) {
-        AttachDeclaration(
-            Say(name.source, "'%s' is not a callable procedure"_err_en_US,
-                name.source),
-            *symbol);
-      }
-    } else if (std::optional<SpecificCall> specificCall{
-                   context_.intrinsics().Probe(
-                       CallCharacteristics{
-                           ultimate.name().ToString(), isSubroutine},
-                       arguments, GetFoldingContext())}) {
-      // Generics can extend intrinsics
-      return CalleeAndArguments{
-          ProcedureDesignator{std::move(specificCall->specificIntrinsic)},
-          std::move(specificCall->arguments)};
-    } else {
-      EmitGenericResolutionError(*name.symbol, dueToNullActual);
-    }
+  }
+  if (resolution->GetUltimate().has<semantics::DerivedTypeDetails>()) {
+          semantics::SymbolRef{*resolution}, std::move(arguments)};
+  } else if (IsProcedure(*resolution)) {
+        ProcedureDesignator{*resolution}, std::move(arguments)};
+  if (!context_.HasError(*resolution)) {
+        *resolution);
   }
   return std::nullopt;
 }
 
 // Fortran 2018 expressly states (8.2 p3) that any declared type for a
 // generic intrinsic function "has no effect" on the result type of a
 // call to that intrinsic.  So one can declare "character*8 cos" and
 // still get a real result from "cos(1.)".  This is a dangerous feature,

flang/lib/Semantics/resolve-names.cpp

bool DeclarationVisitor::Pre(const parser::IntentStmt &x) {
   auto &names{std::get<std::list<parser::Name>>(x.t)};
   return CheckNotInBlock("INTENT") && // C1107
       HandleAttributeStmt(IntentSpecToAttr(intentSpec), names);
 }
 bool DeclarationVisitor::Pre(const parser::IntrinsicStmt &x) {
   HandleAttributeStmt(Attr::INTRINSIC, x.v);
   for (const auto &name : x.v) {
     auto &symbol{DEREF(FindSymbol(name))};
-    if (!ConvertToProcEntity(symbol)) {
+    if (symbol.has<GenericDetails>()) {
+      // Generic interface is extending intrinsic; ok
+    } else if (!ConvertToProcEntity(symbol)) {
       SayWithDecl(
           name, symbol, "INTRINSIC attribute not allowed on '%s'"_err_en_US);
     } else if (symbol.attrs().test(Attr::EXTERNAL)) { // C840
       Say(symbol.name(),
           "Symbol '%s' cannot have both EXTERNAL and INTRINSIC attributes"_err_en_US,
           symbol.name());
     } else if (symbol.GetType()) {
       // These warnings are worded so that they should make sense in either

flang/test/Semantics/resolve109.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Interfaces are allowed to extend intrinsic procedures, with limitations
+module m1
+  intrinsic sin
+  interface sin
+    module procedure :: charcpy
+  end interface
+  interface cos ! no INTRINSIC statement
+    module procedure :: charcpy
+  end interface
+  intrinsic mvbits
+  interface mvbits
+    module procedure :: negate
+  end interface
+  interface move_alloc ! no INTRINSIC statement
+    module procedure :: negate
+  end interface
+  interface tan ! not explicitly INTRINSIC
+    module procedure :: negate ! a subroutine
+  end interface
+  interface acos
+    module procedure :: minus ! override
+  end interface
+  intrinsic atan
+  !ERROR: Generic interface 'atan' with explicit intrinsic function of the same name may not have specific procedure 'negate' that is a subroutine
+  interface atan
+    module procedure :: negate ! a subroutine
+  end interface
+ contains
+  character function charcpy(x)
+    character, intent(in) :: x
+    charcpy = x
+  end function
+  subroutine negate(x)
+    real, intent(in out) :: x
+    x = -x
+  end subroutine
+  real elemental function minus(x)
+    real, intent(in) :: x
+    minus = -x
+  end function
+  subroutine test
+    integer, allocatable :: j, k
+    real :: x
+    character :: str
+    x = sin(x)
+    str = sin(str) ! charcpy
+    x = cos(x)
+    str = cos(str) ! charcpy
+    call mvbits(j,0,1,k,0)
+    call mvbits(x) ! negate
+    call move_alloc(j, k)
+    call move_alloc(x) ! negate
+    !ERROR: Cannot call subroutine 'tan' like a function
+    x = tan(x)
+    x = acos(x) ! user's interface overrides intrinsic
+  end subroutine
+end module