[flang] Better messages for function vs. array errors

When a scalar-valued function with no distinct RESULT
is being called recursively in its own executable part,
emit a better message about the error.  Clean up the
code that resolves function vs. array ambiguities in
expression semantics.

Update to address review comment

Differential Revision: https://reviews.llvm.org/D117577

flang/include/flang/Semantics/tools.h

@@ -96,7 +96,8 @@ bool IsPointerDummy(const Symbol &);
 bool IsBindCProcedure(const Symbol &);
 bool IsBindCProcedure(const Scope &);
 bool IsProcName(const Symbol &); // proc-name
-bool IsFunctionResultWithSameNameAsFunction(const Symbol &);
+// Returns a pointer to the function's symbol when true, else null
+const Symbol *IsFunctionResultWithSameNameAsFunction(const Symbol &);
 bool IsOrContainsEventOrLockComponent(const Symbol &);
 bool CanBeTypeBoundProc(const Symbol *);
 // Does a non-PARAMETER symbol have explicit initialization with =value or

flang/lib/Semantics/expression.cpp

@@ -2781,33 +2781,43 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedBinary &x) {
       "No operator %s defined for %s and %s"_err_en_US, nullptr, true);
 }
 
-static void CheckFuncRefToArrayElementRefHasSubscripts(
-    semantics::SemanticsContext &context,
+// Returns true if a parsed function reference should be converted
+// into an array element reference.
+static bool CheckFuncRefToArrayElement(semantics::SemanticsContext &context,
     const parser::FunctionReference &funcRef) {
   // Emit message if the function reference fix will end up an array element
-  // reference with no subscripts because it will not be possible to later tell
-  // the difference in expressions between empty subscript list due to bad
-  // subscripts error recovery or because the user did not put any.
-  if (std::get<std::list<parser::ActualArgSpec>>(funcRef.v.t).empty()) {
-    auto &proc{std::get<parser::ProcedureDesignator>(funcRef.v.t)};
-    const auto *name{std::get_if<parser::Name>(&proc.u)};
-    if (!name) {
-      name = &std::get<parser::ProcComponentRef>(proc.u).v.thing.component;
+  // reference with no subscripts, or subscripts on a scalar, because it will
+  // not be possible to later distinguish in expressions between an empty
+  // subscript list due to bad subscripts error recovery or because the
+  // user did not put any.
+  auto &proc{std::get<parser::ProcedureDesignator>(funcRef.v.t)};
+  const auto *name{std::get_if<parser::Name>(&proc.u)};
+  if (!name) {
+    name = &std::get<parser::ProcComponentRef>(proc.u).v.thing.component;
+  }
+  if (!name->symbol) {
+    return false;
+  } else if (name->symbol->Rank() == 0) {
+    if (const Symbol *
+        function{
+            semantics::IsFunctionResultWithSameNameAsFunction(*name->symbol)}) {
+      auto &msg{context.Say(funcRef.v.source,
+          "Recursive call to '%s' requires a distinct RESULT in its declaration"_err_en_US,
+          name->source)};
+      AttachDeclaration(&msg, *function);
+      name->symbol = const_cast<Symbol *>(function);
     }
-    auto &msg{context.Say(funcRef.v.source,
-        name->symbol && name->symbol->Rank() == 0
-            ? "'%s' is not a function"_err_en_US
-            : "Reference to array '%s' with empty subscript list"_err_en_US,
-        name->source)};
-    if (name->symbol) {
-      if (semantics::IsFunctionResultWithSameNameAsFunction(*name->symbol)) {
-        msg.Attach(name->source,
-            "A result variable must be declared with RESULT to allow recursive "
-            "function calls"_en_US);
-      } else {
+    return false;
+  } else {
+    if (std::get<std::list<parser::ActualArgSpec>>(funcRef.v.t).empty()) {
+      auto &msg{context.Say(funcRef.v.source,
+          "Reference to array '%s' with empty subscript list"_err_en_US,
+          name->source)};
+      if (name->symbol) {
         AttachDeclaration(&msg, *name->symbol);
       }
     }
+    return true;
   }
 }
 
@@ -2841,8 +2851,9 @@ static void FixMisparsedFunctionReference(
         // pointer as per C1105 so this cannot be a function reference.
         if constexpr (common::HasMember<common::Indirection<parser::Designator>,
                           uType>) {
-          CheckFuncRefToArrayElementRefHasSubscripts(context, funcRef);
-          u = common::Indirection{funcRef.ConvertToArrayElementRef()};
+          if (CheckFuncRefToArrayElement(context, funcRef)) {
+            u = common::Indirection{funcRef.ConvertToArrayElementRef()};
+          }
         } else {
           DIE("can't fix misparsed function as array reference");
         }

flang/lib/Semantics/tools.cpp

@@ -1345,13 +1345,15 @@ const Symbol *FindImmediateComponent(const DerivedTypeSpec &type,
   return nullptr;
 }
 
-bool IsFunctionResultWithSameNameAsFunction(const Symbol &symbol) {
+const Symbol *IsFunctionResultWithSameNameAsFunction(const Symbol &symbol) {
   if (IsFunctionResult(symbol)) {
     if (const Symbol * function{symbol.owner().symbol()}) {
-      return symbol.name() == function->name();
+      if (symbol.name() == function->name()) {
+        return function;
+      }
     }
   }
-  return false;
+  return nullptr;
 }
 
 void LabelEnforce::Post(const parser::GotoStmt &gotoStmt) {

flang/test/Semantics/resolve59.f90

@@ -10,7 +10,7 @@ contains
   ! testing with data object results
   function f1()
     real :: x, f1
-    !ERROR: 'f1' is not a function
+    !ERROR: Recursive call to 'f1' requires a distinct RESULT in its declaration
     x = acos(f1())
     f1 = x
     x = acos(f1) !OK
@@ -18,7 +18,7 @@ contains
   function f2(i)
     integer i
     real :: x, f2
-    !ERROR: 'f2' is not an array
+    !ERROR: Recursive call to 'f2' requires a distinct RESULT in its declaration
     x = acos(f2(i+1))
     f2 = x
     x = acos(f2) !OK
@@ -63,7 +63,7 @@ contains
   end function
   function f7() result(f7) !OKI (warning)
     real :: x, f7
-    !ERROR: 'f7' is not a function
+    !ERROR: Recursive call to 'f7' requires a distinct RESULT in its declaration
     x = acos(f7())
     f7 = x
     x = acos(f7) !OK
@@ -124,7 +124,7 @@ contains
   ! testing that calling the result is also caught
   function f6() result(r)
     real :: x, r
-    !ERROR: 'r' is not a function
+    !ERROR: 'r' is not a callable procedure
     x = r()
   end function
 end module

flang/test/Semantics/resolve93.f90

@@ -9,8 +9,9 @@ subroutine s1()
     character(10) str3
     !ERROR: Cannot reference function 'str1' as data
     print *, str1(1:9), str1(7)
-    !ERROR: 'str2' is not an array
-    print *, str2(1:9), str2(7)
+    print *, str2(1:9) ! substring is ok
+    !ERROR: 'str2' is not a callable procedure
+    print *, str2(7)
     !ERROR: Cannot reference function 'str3' as data
     print *, str3(7), str3(1:9)
   end block