[flang] Warn about undefined function results (#99533)

When the result of a function never appears in a variable definition
context, emit a warning.

If the function has multiple result variables due to alternate ENTRY
statements, any definition will suffice.

The implementation of this check is tied to the general variable
definability checking utility in semantics. Every variable definition
context uses it to ensure that no undefinable variable is being defined.
A set of defined variables is maintained in the SemanticsContext and,
when the warning is enabled and no fatal error has been reported, the
scope tree is traversed and all the function subprograms' results are
tested for membership in that set.

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

@@ -70,7 +70,7 @@ ENUM_CLASS(UsageWarning, Portability, PointerToUndefinable,
     IgnoredIntrinsicFunctionType, PreviousScalarUse,
     RedeclaredInaccessibleComponent, ImplicitShared, IndexVarRedefinition,
     IncompatibleImplicitInterfaces, BadTypeForTarget,
-    VectorSubscriptFinalization)
+    VectorSubscriptFinalization, UndefinedFunctionResult)
 
 using LanguageFeatures = EnumSet<LanguageFeature, LanguageFeature_enumSize>;
 using UsageWarnings = EnumSet<UsageWarning, UsageWarning_enumSize>;
@@ -144,6 +144,7 @@ public:
     warnUsage_.set(UsageWarning::IncompatibleImplicitInterfaces);
     warnUsage_.set(UsageWarning::BadTypeForTarget);
     warnUsage_.set(UsageWarning::VectorSubscriptFinalization);
+    warnUsage_.set(UsageWarning::UndefinedFunctionResult);
   }
   LanguageFeatureControl(const LanguageFeatureControl &) = default;
 

flang/include/flang/Semantics/semantics.h

@@ -254,6 +254,9 @@ public:
   // behavior.
   CommonBlockList GetCommonBlocks() const;
 
+  void NoteDefinedSymbol(const Symbol &);
+  bool IsSymbolDefined(const Symbol &) const;
+
 private:
   struct ScopeIndexComparator {
     bool operator()(parser::CharBlock, parser::CharBlock) const;
@@ -303,6 +306,7 @@ private:
   std::unique_ptr<CommonBlockMap> commonBlockMap_;
   ModuleDependences moduleDependences_;
   std::map<const Symbol *, SourceName> moduleFileOutputRenamings_;
+  UnorderedSymbolSet isDefined_;
 };
 
 class Semantics {

flang/include/flang/Semantics/tools.h

@@ -52,7 +52,6 @@ const Symbol *FindPointerComponent(const DeclTypeSpec &);
 const Symbol *FindPointerComponent(const Symbol &);
 const Symbol *FindInterface(const Symbol &);
 const Symbol *FindSubprogram(const Symbol &);
-const Symbol *FindFunctionResult(const Symbol &);
 const Symbol *FindOverriddenBinding(
     const Symbol &, bool &isInaccessibleDeferred);
 const Symbol *FindGlobal(const Symbol &);

flang/lib/Semantics/check-allocate.cpp

@@ -600,10 +600,13 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
   const Scope &subpScope{
       GetProgramUnitContaining(context.FindScope(name_.source))};
   if (allocateObject_.typedExpr && allocateObject_.typedExpr->v) {
-    if (auto whyNot{WhyNotDefinable(name_.source, subpScope,
-            {DefinabilityFlag::PointerDefinition,
-                DefinabilityFlag::AcceptAllocatable},
-            *allocateObject_.typedExpr->v)}) {
+    DefinabilityFlags flags{DefinabilityFlag::PointerDefinition,
+        DefinabilityFlag::AcceptAllocatable};
+    if (allocateInfo_.gotSource) {
+      flags.set(DefinabilityFlag::SourcedAllocation);
+    }
+    if (auto whyNot{WhyNotDefinable(
+            name_.source, subpScope, flags, *allocateObject_.typedExpr->v)}) {
       context
           .Say(name_.source,
               "Name in ALLOCATE statement is not definable"_err_en_US)

flang/lib/Semantics/check-call.cpp

@@ -27,7 +27,7 @@ namespace characteristics = Fortran::evaluate::characteristics;
 namespace Fortran::semantics {
 
 static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
-    parser::ContextualMessages &messages, evaluate::FoldingContext &context) {
+    parser::ContextualMessages &messages, SemanticsContext &context) {
   auto restorer{
       messages.SetLocation(arg.sourceLocation().value_or(messages.at()))};
   if (auto kw{arg.keyword()}) {
@@ -79,8 +79,12 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
         messages.Say(
             "VOLATILE argument requires an explicit interface"_err_en_US);
       }
+      if (const Symbol & base{named->GetFirstSymbol()};
+          IsFunctionResult(base)) {
+        context.NoteDefinedSymbol(base);
+      }
     } else if (auto argChars{characteristics::DummyArgument::FromActual(
-                   "actual argument", *expr, context,
+                   "actual argument", *expr, context.foldingContext(),
                    /*forImplicitInterface=*/true)}) {
       const auto *argProcDesignator{
           std::get_if<evaluate::ProcedureDesignator>(&expr->u)};
@@ -647,8 +651,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
         actualLastSymbol->name(), dummyName);
   }
 
-  // Definability
-  bool actualIsVariable{evaluate::IsVariable(actual)};
+  // Definability checking
+  // Problems with polymorphism are caught in the callee's definition.
   if (scope) {
     std::optional<parser::MessageFixedText> undefinableMessage;
     if (dummy.intent == common::Intent::Out) {
@@ -670,7 +674,6 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
       }
     }
     if (undefinableMessage) {
-      // Problems with polymorphism are caught in the callee's definition.
       DefinabilityFlags flags{DefinabilityFlag::PolymorphicOkInPure};
       if (isElemental) { // 15.5.2.4(21)
         flags.set(DefinabilityFlag::VectorSubscriptIsOk);
@@ -689,6 +692,14 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
           messages.Say(std::move(*whyNot));
         }
       }
+    } else if (dummy.intent != common::Intent::In ||
+        (dummyIsPointer && !actualIsPointer)) {
+      if (auto named{evaluate::ExtractNamedEntity(actual)}) {
+        if (const Symbol & base{named->GetFirstSymbol()};
+            IsFunctionResult(base)) {
+          context.NoteDefinedSymbol(base);
+        }
+      }
     }
   }
 
@@ -893,6 +904,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
   // argument
   if (dummy.attrs.test(characteristics::DummyDataObject::Attr::Target) &&
       context.ShouldWarn(common::UsageWarning::NonTargetPassedToTarget)) {
+    bool actualIsVariable{evaluate::IsVariable(actual)};
     bool actualIsTemp{!actualIsVariable || HasVectorSubscript(actual) ||
         evaluate::ExtractCoarrayRef(actual)};
     if (actualIsTemp) {
@@ -1416,7 +1428,8 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
             if (auto whyNot{WhyNotDefinable(
                     pointerArg->sourceLocation().value_or(messages.at()),
                     *scope,
-                    DefinabilityFlags{DefinabilityFlag::PointerDefinition},
+                    DefinabilityFlags{DefinabilityFlag::PointerDefinition,
+                        DefinabilityFlag::DoNotNoteDefinition},
                     *pointerExpr)}) {
               if (whyNot->IsFatal()) {
                 if (auto *msg{messages.Say(pointerArg->sourceLocation(),
@@ -2021,7 +2034,7 @@ bool CheckArguments(const characteristics::Procedure &proc,
       auto restorer{messages.SetMessages(buffer)};
       for (auto &actual : actuals) {
         if (actual) {
-          CheckImplicitInterfaceArg(*actual, messages, foldingContext);
+          CheckImplicitInterfaceArg(*actual, messages, context);
         }
       }
     }

flang/lib/Semantics/check-purity.cpp

@@ -31,7 +31,7 @@ void PurityChecker::Enter(const parser::FunctionSubprogram &func) {
       stmt.source, std::get<std::list<parser::PrefixSpec>>(stmt.statement.t));
 }
 
-void PurityChecker::Leave(const parser::FunctionSubprogram &) { Left(); }
+void PurityChecker::Leave(const parser::FunctionSubprogram &func) { Left(); }
 
 bool PurityChecker::InPureSubprogram() const {
   return pureDepth_ >= 0 && depth_ >= pureDepth_;

flang/lib/Semantics/definable.cpp

@@ -127,6 +127,12 @@ static std::optional<parser::Message> WhyNotDefinableBase(parser::CharBlock at,
       (!IsPointer(ultimate) || (isWholeSymbol && isPointerDefinition))) {
     return BlameSymbol(
         at, "'%s' is an INTENT(IN) dummy argument"_en_US, original);
+  } else if (acceptAllocatable &&
+      !flags.test(DefinabilityFlag::SourcedAllocation)) {
+    // allocating a function result doesn't count as a def'n
+    // unless there's SOURCE=
+  } else if (!flags.test(DefinabilityFlag::DoNotNoteDefinition)) {
+    scope.context().NoteDefinedSymbol(ultimate);
   }
   if (const Scope * pure{FindPureProcedureContaining(scope)}) {
     // Additional checking for pure subprograms.

flang/lib/Semantics/definable.h

@@ -30,7 +30,9 @@ ENUM_CLASS(DefinabilityFlag,
     DuplicatesAreOk, // vector subscript may have duplicates
     PointerDefinition, // a pointer is being defined, not its target
     AcceptAllocatable, // treat allocatable as if it were a pointer
-    PolymorphicOkInPure) // don't check for polymorphic type in pure subprogram
+    SourcedAllocation, // ALLOCATE(a,SOURCE=)
+    PolymorphicOkInPure, // don't check for polymorphic type in pure subprogram
+    DoNotNoteDefinition) // context does not imply definition
 
 using DefinabilityFlags =
     common::EnumSet<DefinabilityFlag, DefinabilityFlag_enumSize>;

flang/lib/Semantics/pointer-assignment.cpp

@@ -358,8 +358,10 @@ bool PointerAssignmentChecker::Check(const evaluate::Designator<T> &d) {
       Say(std::get<MessageFormattedText>(*msg));
     }
     return false;
+  } else {
+    context_.NoteDefinedSymbol(*base);
+    return true;
   }
-  return true;
 }
 
 // Common handling for procedure pointer right-hand sides

flang/lib/Semantics/semantics.cpp

@@ -160,6 +160,41 @@ private:
   SemanticsContext &context_;
 };
 
+static void WarnUndefinedFunctionResult(
+    SemanticsContext &context, const Scope &scope) {
+  auto WasDefined{[&context](const Symbol &symbol) {
+    return context.IsSymbolDefined(symbol) ||
+        IsInitialized(symbol, /*ignoreDataStatements=*/true,
+            /*ignoreAllocatable=*/true, /*ignorePointer=*/true);
+  }};
+  if (const Symbol * symbol{scope.symbol()}) {
+    if (const auto *subp{symbol->detailsIf<SubprogramDetails>()}) {
+      if (subp->isFunction() && !subp->isInterface() && !subp->stmtFunction()) {
+        bool wasDefined{WasDefined(subp->result())};
+        if (!wasDefined) {
+          // Definitions of ENTRY result variables also count.
+          for (const auto &pair : scope) {
+            const Symbol &local{*pair.second};
+            if (IsFunctionResult(local) && WasDefined(local)) {
+              wasDefined = true;
+              break;
+            }
+          }
+          if (!wasDefined) {
+            context.Say(
+                symbol->name(), "Function result is never defined"_warn_en_US);
+          }
+        }
+      }
+    }
+  }
+  if (!scope.IsModuleFile()) {
+    for (const Scope &child : scope.children()) {
+      WarnUndefinedFunctionResult(context, child);
+    }
+  }
+}
+
 using StatementSemanticsPass1 = ExprChecker;
 using StatementSemanticsPass2 = SemanticsVisitor<AllocateChecker,
     ArithmeticIfStmtChecker, AssignmentChecker, CaseChecker, CoarrayChecker,
@@ -187,6 +222,9 @@ static bool PerformStatementSemantics(
     SemanticsVisitor<CUDAChecker>{context}.Walk(program);
   }
   if (!context.AnyFatalError()) {
+    if (context.ShouldWarn(common::UsageWarning::UndefinedFunctionResult)) {
+      WarnUndefinedFunctionResult(context, context.globalScope());
+    }
     pass2.CompileDataInitializationsIntoInitializers();
   }
   return !context.AnyFatalError();
@@ -712,4 +750,12 @@ CommonBlockList SemanticsContext::GetCommonBlocks() const {
   return {};
 }
 
+void SemanticsContext::NoteDefinedSymbol(const Symbol &symbol) {
+  isDefined_.insert(symbol);
+}
+
+bool SemanticsContext::IsSymbolDefined(const Symbol &symbol) const {
+  return isDefined_.find(symbol) != isDefined_.end();
+}
+
 } // namespace Fortran::semantics

flang/lib/Semantics/tools.cpp

@@ -685,7 +685,7 @@ bool IsInitialized(const Symbol &symbol, bool ignoreDataStatements,
     return true;
   } else if (IsPointer(symbol)) {
     return !ignorePointer;
-  } else if (IsNamedConstant(symbol) || IsFunctionResult(symbol)) {
+  } else if (IsNamedConstant(symbol)) {
     return false;
   } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
     if (!object->isDummy() && object->type()) {

flang/test/Evaluate/folding08.f90

@@ -11,6 +11,11 @@ module m
   end type
   type(t) :: ta(0:2)
   character(len=2) :: ca(-1:1)
+  interface
+    function foo()
+      real :: foo(2:3,4:6)
+    end function
+  end interface
   integer, parameter :: lbtadim = lbound(ta,1)
   logical, parameter :: test_lbtadim = lbtadim == 0
   integer, parameter :: ubtadim = ubound(ta,1)
@@ -47,9 +52,6 @@ module m
   logical, parameter :: test_lb_empty_dim = lbound(empty, 1) == 1
   logical, parameter :: test_ub_empty_dim = ubound(empty, 1) == 0
  contains
-  function foo()
-    real :: foo(2:3,4:6)
-  end function
   subroutine test(n1,a1,a2)
     integer, intent(in) :: n1
     real, intent(in) :: a1(1:n1), a2(0:*)

flang/test/Semantics/call02.f90

@@ -72,6 +72,7 @@ module m01
  contains
   elemental real function elem03(x)
     real, value :: x
+    elem03 = 0.
   end function
   subroutine test
     intrinsic :: cos
@@ -87,6 +88,7 @@ module m01
    contains
     elemental real function elem04(x)
       real, value :: x
+      elem04 = 0.
     end function
   end subroutine
 end module

flang/test/Semantics/call05.f90

@@ -155,11 +155,13 @@ module m2
 
   function return_deferred_length_ptr()
     character(len=:), pointer :: return_deferred_length_ptr
+    return_deferred_length_ptr => p2
   end function
 
   function return_explicit_length_ptr(n)
     integer :: n
     character(len=n), pointer :: return_explicit_length_ptr
+    return_explicit_length_ptr => p2(1:n)
   end function
 
   subroutine test()

flang/test/Semantics/contiguous01.f90

@@ -30,8 +30,10 @@ module m
     contiguous r2
     !PORTABILITY: CONTIGUOUS entity 'e' should be an array pointer, assumed-shape, or assumed-rank
     entry e() result(r2)
+    r2 = 0
   end
   function fp()
     real, pointer, contiguous :: fp(:) ! ok
+    nullify(fp)
   end
 end

flang/test/Semantics/resolve53.f90

@@ -227,14 +227,17 @@ contains
   real function f1(x, y)
     real, intent(in) :: x
     logical, intent(in) :: y
+    f1 = 0.
   end
   integer function f2(x, y)
     integer, intent(in) :: x
     logical, intent(in) :: y
+    f2 = 0.
   end
   real function f3(x, y)
     real, value :: x
     logical, value :: y
+    f3 = 0.
   end
 end module
 
@@ -447,12 +450,15 @@ module m19
 contains
   integer function f1(i)
     integer, intent(in) :: i
+    f1 = 0
   end
   integer function f2(i, j)
     integer, value :: i, j
+    f2 = 0
   end
   integer function f3(i, j)
     integer, intent(in) :: i, j
+    f3 = 0
   end
 end
 

flang/test/Semantics/undef-result01.f90

@@ -0,0 +1,144 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -Werror
+
+!WARNING: Function result is never defined
+function basic()
+end
+
+function defdByIntentOut()
+  call intentout(defdByIntentOut)
+ contains
+  subroutine intentout(x)
+    real, intent(out) :: x
+  end
+end
+
+function defdByIntentInOut()
+  call intentinout(defdByIntentInOut)
+ contains
+  subroutine intentInout(x)
+    real, intent(out) :: x
+  end
+end
+
+function defdByIntentInPtr()
+  real, target :: defdByIntentInPtr
+  call intentInPtr(defdByIntentInPtr)
+ contains
+  subroutine intentInPtr(p)
+    real, intent(in), pointer :: p
+  end
+end
+
+!WARNING: Function result is never defined
+function notDefdByCall()
+  call intentin(notDefdByCall)
+ contains
+  subroutine intentin(n)
+    integer, intent(in) :: n
+  end
+end
+
+!WARNING: Function result is never defined
+function basicAlloc()
+  real, allocatable :: basicAlloc
+  allocate(basicAlloc)
+end
+
+function sourcedAlloc()
+  real, allocatable :: sourcedAlloc
+  allocate(sourcedAlloc, source=0.)
+end
+
+function defdByEntry()
+  entry entry1
+  entry1 = 0.
+end
+
+function defdByEntry2()
+  entry entry2() result(entryResult)
+  entryResult = 0.
+end
+
+function usedAsTarget()
+  real, target :: usedAsTarget
+  real, pointer :: p
+  p => usedAsTarget
+end
+
+function entryUsedAsTarget()
+  real, target :: entryResult
+  real, pointer :: p
+  entry entry5() result(entryResult)
+  p => entryResult
+end
+
+function defdByCall()
+  call implicitInterface(defdByCall)
+end
+
+function defdInInternal()
+ contains
+  subroutine internal
+    defdInInternal = 0.
+  end
+end
+
+function defdByEntryInInternal()
+  entry entry3() result(entryResult)
+ contains
+  subroutine internal
+    entryResult = 0.
+  end
+end
+
+type(defaultInitialized) function defdByDefault()
+  type defaultInitialized
+    integer :: n = 123
+  end type
+end
+
+integer function defdByDo()
+  do defdByDo = 1, 10
+  end do
+end
+
+function defdByRead()
+  read(*,*) defdByRead
+end function
+
+function defdByNamelist()
+  namelist /nml/ defdByNamelist
+  read(*,nml=nml)
+end
+
+character(4) function defdByWrite()
+  write(defdByWrite) 'abcd'
+end
+
+integer function defdBySize()
+  real arr(10)
+  read(*,size=defdBySize) arr
+end
+
+character(40) function defdByIomsg()
+  write(123,*,iomsg=defdByIomsg)
+end
+
+character(20) function defdByInquire()
+  inquire(6,status=defdByInquire)
+end
+
+!WARNING: Function result is never defined
+character(20) function notDefdByInquire()
+  inquire(file=notDefdByInquire)
+end
+
+integer function defdByNewunit()
+  open(newunit=defdByNewunit, file="foo.txt")
+end
+
+function defdByAssociate()
+  associate(s => defdByAssociate)
+    s = 1.
+  end associate
+end