[flang] Warn about useless explicit typing of intrinsics

[klausler]

Summary

Fortran 2018 explicitly permits an ignored type declaration
for the result of a generic intrinsic function. See the comment
added to Semantics/expression.cpp for an explanation of why this
is somewhat dangerous and worthy of a warning.

Depended on https://reviews.llvm.org/D96878

[tskeith]

flang/lib/Semantics/resolve-names.cpp

5983

Where is AcquireIntrinsicProcedureFlags defined?

[klausler]

Rebase to latest llvm-project/main to resolve dependency on another patch.

flang/docs/Extensions.md

* Wrong argument types in calls to specific intrinsics that have different names than the
   PGI converts the arguments while Intel and XLF replace the specific by the related generic.
 
 ## Preprocessing behavior
 
 * The preprocessor is always run, whatever the filename extension may be.
 * We respect Fortran comments in macro actual arguments (like GNU, Intel, NAG;
   unlike PGI and XLF) on the principle that macro calls should be treated
   like function references.  Fortran's line continuation methods also work.
+
+## Standard features not silently accepted
+
+* Fortran explicitly ignores type declaration statements when they
+  attempt to type the name of a generic intrinsic function (8.2 p3).
+  One can declare `CHARACTER::COS` and still get a real result
+  from `COS(3.14159)`, for example.  f18 will complain when a
+  generic intrinsic function's inferred result type does not
+  match an explicit declaration.  This message is a warning.

flang/include/flang/Evaluate/characteristics.h

public:
   std::optional<Expr<SubscriptInteger>> MeasureElementSizeInBytes(
       FoldingContext &, bool align) const;
   std::optional<Expr<SubscriptInteger>> MeasureSizeInBytes(
       FoldingContext &) const;
 
   // called by Fold() to rewrite in place
   TypeAndShape &Rewrite(FoldingContext &);
 
+  std::string AsFortran() const;
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 
 private:
   static std::optional<TypeAndShape> Characterize(
       const semantics::AssocEntityDetails &, FoldingContext &);
   static std::optional<TypeAndShape> Characterize(
       const semantics::ProcEntityDetails &, FoldingContext &);
   void AcquireAttrs(const semantics::Symbol &);

flang/include/flang/Semantics/expression.h

private:
   const Symbol &AccessSpecific(
       const Symbol &originalGeneric, const Symbol &specific);
   std::optional<CalleeAndArguments> GetCalleeAndArguments(const parser::Name &,
       ActualArguments &&, bool isSubroutine = false,
       bool mightBeStructureConstructor = false);
   std::optional<CalleeAndArguments> GetCalleeAndArguments(
       const parser::ProcedureDesignator &, ActualArguments &&,
       bool isSubroutine, bool mightBeStructureConstructor = false);
-
+  void CheckBadExplicitType(const SpecificCall &, const Symbol &);
   void CheckForBadRecursion(parser::CharBlock, const semantics::Symbol &);
   bool EnforceTypeConstraint(parser::CharBlock, const MaybeExpr &, TypeCategory,
       bool defaultKind = false);
   MaybeExpr MakeFunctionRef(
       parser::CharBlock, ProcedureDesignator &&, ActualArguments &&);
   MaybeExpr MakeFunctionRef(parser::CharBlock intrinsic, ActualArguments &&);
   template <typename T> T Fold(T &&expr) {
     return evaluate::Fold(foldingContext_, std::move(expr));

flang/lib/Evaluate/characteristics.cpp

std::optional<TypeAndShape> TypeAndShape::Characterize(
   return Characterize(arg.UnwrapExpr(), context);
 }
 
 bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages,
     const TypeAndShape &that, const char *thisIs, const char *thatIs,
     bool isElemental, bool thisIsDeferredShape,
     bool thatIsDeferredShape) const {
   if (!type_.IsTkCompatibleWith(that.type_)) {
-    const auto &len{that.LEN()};
     messages.Say(
         "%1$s type '%2$s' is not compatible with %3$s type '%4$s'"_err_en_US,
-        thatIs, that.type_.AsFortran(len ? len->AsFortran() : ""), thisIs,
-        type_.AsFortran(LEN_ ? LEN_->AsFortran() : ""));
+        thatIs, that.AsFortran(), thisIs, AsFortran());
     return false;
   }
   return isElemental ||
       CheckConformance(messages, shape_, that.shape_, thisIs, thatIs, false,
           false /* no scalar expansion */, thisIsDeferredShape,
           thatIsDeferredShape);
 }
 

 void TypeAndShape::AcquireLEN(const semantics::Symbol &symbol) {
   if (type_.category() == TypeCategory::Character) {
     if (auto len{DataRef{symbol}.LEN()}) {
       LEN_ = std::move(*len);
     }
   }
 }
 
+std::string TypeAndShape::AsFortran() const {
+  return type_.AsFortran(LEN_ ? LEN_->AsFortran() : "");
+}
+
 llvm::raw_ostream &TypeAndShape::Dump(llvm::raw_ostream &o) const {
   o << type_.AsFortran(LEN_ ? LEN_->AsFortran() : "");
   attrs_.Dump(o, EnumToString);
   if (!shape_.empty()) {
     o << " dimension";
     char sep{'('};
     for (const auto &expr : shape_) {
       o << sep;

flang/lib/Semantics/expression.cpp

auto ExpressionAnalyzer::GetCalleeAndArguments(const parser::Name &name,
   if (context_.HasError(symbol)) {
     return std::nullopt; // also handles null symbol
   }
   const Symbol &ultimate{DEREF(symbol).GetUltimate()};
   if (ultimate.attrs().test(semantics::Attr::INTRINSIC)) {
     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 {
     CheckForBadRecursion(name.source, ultimate);
     if (ultimate.has<semantics::GenericDetails>()) {
       ExpressionAnalyzer::AdjustActuals noAdjustment;
if (symbol) {
           std::move(specificCall->arguments)};
     } else {
       EmitGenericResolutionError(*name.symbol);
     }
   }
   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,
+// especially since implementations are free to extend their sets of
+// intrinsics, and in doing so might clash with a name in a program.
+// So we emit a warning in this situation, and perhaps it should be an
+// error -- any correctly working program can silence the message by
+// simply deleting the pointless type declaration.
+void ExpressionAnalyzer::CheckBadExplicitType(
+    const SpecificCall &call, const Symbol &intrinsic) {
+  if (intrinsic.GetUltimate().GetType()) {
+    const auto &procedure{call.specificIntrinsic.characteristics.value()};
+    if (const auto &result{procedure.functionResult}) {
+      if (const auto *typeAndShape{result->GetTypeAndShape()}) {
+        if (auto declared{
+                typeAndShape->Characterize(intrinsic, GetFoldingContext())}) {
+          if (!declared->type().IsTkCompatibleWith(typeAndShape->type())) {
+            if (auto *msg{Say(
+                    "The result type '%s' of the intrinsic function '%s' is not the explicit declared type '%s'"_en_US,
+                    typeAndShape->AsFortran(), intrinsic.name(),
+                    declared->AsFortran())}) {
+              msg->Attach(intrinsic.name(),
+                  "Ignored declaration of intrinsic function '%s'"_en_US,
+                  intrinsic.name());
+            }
+          }
+        }
+      }
+    }
+  }
+}
+
 void ExpressionAnalyzer::CheckForBadRecursion(
     parser::CharBlock callSite, const semantics::Symbol &proc) {
   if (const auto *scope{proc.scope()}) {
     if (scope->sourceRange().Contains(callSite)) {
       parser::Message *msg{nullptr};
       if (proc.attrs().test(semantics::Attr::NON_RECURSIVE)) { // 15.6.2.1(3)
         msg = Say("NON_RECURSIVE procedure '%s' cannot call itself"_err_en_US,
             callSite);

flang/lib/Semantics/resolve-names.cpp

for (const auto &name : x.v) {
     auto &symbol{DEREF(FindSymbol(name))};
     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
+      // order.
+      Say(symbol.name(),
+          "Explicit type declaration ignored for intrinsic function '%s'"_en_US,
+          symbol.name())
+          .Attach(name.source,
+              "INTRINSIC statement for explicitly-typed '%s'"_en_US,
+              name.source);
     }
   }
   return false;
 }
 bool DeclarationVisitor::Pre(const parser::OptionalStmt &x) {
   return CheckNotInBlock("OPTIONAL") && // C1107
       HandleAttributeStmt(Attr::OPTIONAL, x.v);
 }
void ResolveNamesVisitor::HandleProcedureName(
     Symbol::Flag flag, const parser::Name &name) {
   CHECK(flag == Symbol::Flag::Function || flag == Symbol::Flag::Subroutine);
   auto *symbol{FindSymbol(NonDerivedTypeScope(), name)};
   if (!symbol) {
     if (IsIntrinsic(name.source, flag)) {
       symbol =
           &MakeSymbol(InclusiveScope(), name.source, Attrs{Attr::INTRINSIC});
     } else {
       symbol = &MakeSymbol(context().globalScope(), name.source, Attrs{});
     }
     Resolve(name, *symbol);
     if (symbol->has<ModuleDetails>()) {
       SayWithDecl(name, *symbol,
           "Use of '%s' as a procedure conflicts with its declaration"_err_en_US);
       return;
     }
     if (!symbol->attrs().test(Attr::INTRINSIC)) {
       if (!CheckImplicitNoneExternal(name.source, *symbol)) {
         return;
       }
       MakeExternal(*symbol);
     }
     ConvertToProcEntity(*symbol);
     SetProcFlag(name, *symbol, flag);
   } else if (CheckUseError(name)) {
     // error was reported
   } else {
     symbol = &Resolve(name, symbol)->GetUltimate();
     bool convertedToProcEntity{ConvertToProcEntity(*symbol)};
     if (convertedToProcEntity && !symbol->attrs().test(Attr::EXTERNAL) &&
         IsIntrinsic(symbol->name(), flag) && !IsDummy(*symbol)) {
-      // 8.2(3): ignore type from intrinsic in type-declaration-stmt
-      symbol->get<ProcEntityDetails>().set_interface(ProcInterface{});
       AcquireIntrinsicProcedureFlags(*symbol);
     }
     if (!SetProcFlag(name, *symbol, flag)) {
       return; // reported error
     }
     CheckImplicitNoneExternal(name.source, *symbol);
     if (symbol->has<SubprogramDetails>() &&
         symbol->attrs().test(Attr::ABSTRACT)) {

flang/test/Semantics/badly-typed-intrinsic.f90

+! RUN: %f18 -fsyntax-only %s 2>&1 | FileCheck %s
+
+type :: t
+end type
+integer :: acos
+double precision :: cos
+!CHECK: Explicit type declaration ignored for intrinsic function 'int'
+complex :: int
+character :: sin
+logical :: asin
+type(t) :: atan
+!CHECK: INTRINSIC statement for explicitly-typed 'int'
+intrinsic int
+!CHECK: The result type 'REAL(4)' of the intrinsic function 'acos' is not the explicit declared type 'INTEGER(4)'
+!CHECK: Ignored declaration of intrinsic function 'acos'
+print *, acos(0.)
+!CHECK: The result type 'REAL(4)' of the intrinsic function 'cos' is not the explicit declared type 'REAL(8)'
+!CHECK: Ignored declaration of intrinsic function 'cos'
+print *, cos(0.)
+!CHECK: The result type 'REAL(4)' of the intrinsic function 'sin' is not the explicit declared type 'CHARACTER(KIND=1,LEN=1_8)'
+!CHECK: Ignored declaration of intrinsic function 'sin'
+print *, sin(0.)
+!CHECK: The result type 'REAL(4)' of the intrinsic function 'asin' is not the explicit declared type 'LOGICAL(4)'
+!CHECK: Ignored declaration of intrinsic function 'asin'
+print *, asin(0.)
+!CHECK: The result type 'REAL(4)' of the intrinsic function 'atan' is not the explicit declared type 't'
+!CHECK: Ignored declaration of intrinsic function 'atan'
+print *, atan(0.)
+end

flang/test/Semantics/symbol18.f90

 ! RUN: %S/test_symbols.sh %s %t %f18
 
 ! Intrinsic function in type declaration statement: type is ignored
 
 !DEF: /p1 MainProgram
 program p1
- !DEF: /p1/cos ELEMENTAL, INTRINSIC, PURE (Function) ProcEntity
+ !DEF: /p1/cos ELEMENTAL, INTRINSIC, PURE (Function) ProcEntity INTEGER(4)
  integer cos
  !DEF: /p1/y (Implicit) ObjectEntity REAL(4)
  !REF: /p1/cos
  !DEF: /p1/x (Implicit) ObjectEntity REAL(4)
  y = cos(x)
  !REF: /p1/y
  !DEF: /p1/sin ELEMENTAL, INTRINSIC, PURE (Function) ProcEntity
  !REF: /p1/x