[flang] Implement checks for test/semantics/call02.f90

Original-commit: flang-compiler/f18@38eaaa72ff
Reviewed-on: https://github.com/flang-compiler/f18/pull/745
Tree-same-pre-rewrite: false

flang/lib/evaluate/call.cc

@@ -103,20 +103,32 @@ int ProcedureDesignator::Rank() const {
       }
     }
   }
-  common::die("ProcedureDesignator::Rank(): no case");
+  DIE("ProcedureDesignator::Rank(): no case");
   return 0;
 }
 
-bool ProcedureDesignator::IsElemental() const {
+const semantics::Symbol *ProcedureDesignator::GetInterfaceSymbol() const {
   if (const Symbol * symbol{GetSymbol()}) {
-    return symbol->attrs().test(semantics::Attr::ELEMENTAL);
+    if (const auto *details{
+            symbol->detailsIf<semantics::ProcEntityDetails>()}) {
+      return details->interface().symbol();
+    }
   }
-  if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) {
+  return nullptr;
+}
+
+bool ProcedureDesignator::IsElemental() const {
+  if (const Symbol * interface{GetInterfaceSymbol()}) {
+    return interface->attrs().test(semantics::Attr::ELEMENTAL);
+  } else if (const Symbol * symbol{GetSymbol()}) {
+    return symbol->attrs().test(semantics::Attr::ELEMENTAL);
+  } else if (const auto *intrinsic{std::get_if<SpecificIntrinsic>(&u)}) {
     return intrinsic->characteristics.value().attrs.test(
         characteristics::Procedure::Attr::Elemental);
+  } else {
+    DIE("ProcedureDesignator::IsElemental(): no case");
   }
-  common::die("ProcedureDesignator::IsElemental(): no case");
-  return 0;
+  return false;
 }
 
 const SpecificIntrinsic *ProcedureDesignator::GetSpecificIntrinsic() const {

flang/lib/evaluate/call.h

@@ -151,6 +151,8 @@ struct ProcedureDesignator {
   // Always null if the procedure is intrinsic.
   const Component *GetComponent() const;
 
+  const semantics::Symbol *GetInterfaceSymbol() const;
+
   std::string GetName() const;
   std::optional<DynamicType> GetType() const;
   int Rank() const;

flang/lib/evaluate/tools.h

@@ -245,6 +245,9 @@ template<typename A> std::optional<NamedEntity> ExtractNamedEntity(const A &x) {
             [](Component &&component) -> std::optional<NamedEntity> {
               return NamedEntity{std::move(component)};
             },
+            [](CoarrayRef &&co) -> std::optional<NamedEntity> {
+              return co.GetBase();
+            },
             [](auto &&) { return std::optional<NamedEntity>{}; },
         },
         std::move(dataRef->u));
@@ -253,6 +256,37 @@ template<typename A> std::optional<NamedEntity> ExtractNamedEntity(const A &x) {
   }
 }
 
+struct ExtractCoindexedObjectHelper {
+  template<typename A> std::optional<CoarrayRef> operator()(const A &) const {
+    return std::nullopt;
+  }
+  std::optional<CoarrayRef> operator()(const CoarrayRef &x) const { return x; }
+  std::optional<CoarrayRef> operator()(const DataRef &dataRef) const {
+    return std::visit(*this, dataRef.u);
+  }
+  std::optional<CoarrayRef> operator()(const NamedEntity &named) const {
+    if (const Component * component{named.UnwrapComponent()}) {
+      return (*this)(*component);
+    } else {
+      return std::nullopt;
+    }
+  }
+  std::optional<CoarrayRef> operator()(const Component &component) const {
+    return (*this)(component.base());
+  }
+  std::optional<CoarrayRef> operator()(const ArrayRef &arrayRef) const {
+    return (*this)(arrayRef.base());
+  }
+};
+
+template<typename A> std::optional<CoarrayRef> ExtractCoarrayRef(const A &x) {
+  if (auto dataRef{ExtractDataRef(x)}) {
+    return ExtractCoindexedObjectHelper{}(*dataRef);
+  } else {
+    return std::nullopt;
+  }
+}
+
 // If an expression is simply a whole symbol data designator,
 // extract and return that symbol, else null.
 template<typename A> const Symbol *UnwrapWholeSymbolDataRef(const A &x) {

flang/lib/semantics/expression.cc

@@ -909,8 +909,57 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::StructureComponent &sc) {
   return std::nullopt;
 }
 
-MaybeExpr ExpressionAnalyzer::Analyze(const parser::CoindexedNamedObject &) {
-  Say("TODO: CoindexedNamedObject unimplemented"_err_en_US);
+MaybeExpr ExpressionAnalyzer::Analyze(const parser::CoindexedNamedObject &x) {
+  if (auto dataRef{ExtractDataRef(Analyze(x.base))}) {
+    std::vector<Subscript> subscripts;
+    std::vector<const Symbol *> reversed;
+    if (auto *aRef{std::get_if<ArrayRef>(&dataRef->u)}) {
+      subscripts = std::move(aRef->subscript());
+      reversed.push_back(&aRef->GetLastSymbol());
+      if (Component * component{aRef->base().UnwrapComponent()}) {
+        *dataRef = std::move(component->base());
+      } else {
+        dataRef.reset();
+      }
+    }
+    if (dataRef.has_value()) {
+      while (auto *component{std::get_if<Component>(&dataRef->u)}) {
+        reversed.push_back(&component->GetLastSymbol());
+        *dataRef = std::move(component->base());
+      }
+      if (auto *baseSym{std::get_if<const Symbol *>(&dataRef->u)}) {
+        reversed.push_back(*baseSym);
+      } else {
+        Say("Base of coindexed named object has subscripts or cosubscripts"_err_en_US);
+      }
+    }
+    std::vector<Expr<SubscriptInteger>> cosubscripts;
+    bool cosubsOk{true};
+    for (const auto &cosub :
+        std::get<std::list<parser::Cosubscript>>(x.imageSelector.t)) {
+      MaybeExpr coex{Analyze(cosub)};
+      if (auto *intExpr{UnwrapExpr<Expr<SomeInteger>>(coex)}) {
+        cosubscripts.push_back(
+            ConvertToType<SubscriptInteger>(std::move(*intExpr)));
+      } else {
+        cosubsOk = false;
+      }
+    }
+    if (cosubsOk && !reversed.empty()) {
+      int numCosubscripts{static_cast<int>(cosubscripts.size())};
+      const Symbol &symbol{*reversed.front()};
+      if (numCosubscripts != symbol.Corank()) {
+        Say("'%s' has corank %d, but coindexed reference has %d cosubscripts"_err_en_US,
+            symbol.name(), symbol.Corank(), numCosubscripts);
+      }
+    }
+    // TODO: stat=/team=/team_number=
+    // Reverse the chain of symbols so that the base is first and coarray
+    // ultimate component is last.
+    return Designate(DataRef{CoarrayRef{
+        std::vector<const Symbol *>{reversed.crbegin(), reversed.crend()},
+        std::move(subscripts), std::move(cosubscripts)}});
+  }
   return std::nullopt;
 }
 
@@ -1515,18 +1564,31 @@ std::optional<ActualArgument> ExpressionAnalyzer::AnalyzeActualArgument(
   if (const Symbol * assumedTypeDummy{AssumedTypeDummy(expr)}) {
     return ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
   } else if (MaybeExpr argExpr{Analyze(expr)}) {
-    return ActualArgument{Fold(GetFoldingContext(), std::move(*argExpr))};
-  } else {
-    return std::nullopt;
-  }
-}
-
-std::optional<ActualArgument> ExpressionAnalyzer::AnalyzeActualArgument(
-    const parser::Variable &var) {
-  if (const Symbol * assumedTypeDummy{AssumedTypeDummy(var)}) {
-    return ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
-  } else if (MaybeExpr argExpr{Analyze(var)}) {
-    return ActualArgument{std::move(*argExpr)};
+    Expr<SomeType> x{Fold(GetFoldingContext(), std::move(*argExpr))};
+    if (const auto *proc{std::get_if<ProcedureDesignator>(&x.u)}) {
+      if (!std::holds_alternative<SpecificIntrinsic>(proc->u) &&
+          proc->IsElemental()) {  // C1533
+        Say(expr.source,
+            "Non-intrinsic ELEMENTAL procedure cannot be passed as argument."_err_en_US);
+      }
+    }
+    if (auto coarrayRef{ExtractCoarrayRef(x)}) {
+      const Symbol &coarray{coarrayRef->GetLastSymbol()};
+      if (const semantics::DeclTypeSpec * type{coarray.GetType()}) {
+        if (const semantics::DerivedTypeSpec * derived{type->AsDerived()}) {
+          if (auto ptr{semantics::FindPointerUltimateComponent(*derived)}) {
+            if (auto *msg{Say(expr.source,
+                    "Coindexed object '%s' with POINTER ultimate component '%s' cannot be passed as argument."_err_en_US,
+                    coarray.name(), (*ptr)->name())}) {
+              msg->Attach((*ptr)->name(),
+                  "Declaration of POINTER '%s' component of %s"_en_US,
+                  (*ptr)->name(), type->AsFortran());
+            }
+          }
+        }
+      }
+    }
+    return ActualArgument{std::move(x)};
   } else {
     return std::nullopt;
   }
@@ -1686,15 +1748,19 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::PercentLoc &x) {
   // Represent %LOC() exactly as if it had been a call to the LOC() extension
   // intrinsic function.
   // Use the actual source for the name of the call for error reporting.
-  if (std::optional<ActualArgument> arg{AnalyzeActualArgument(x.v.value())}) {
-    parser::CharBlock at{GetContextualMessages().at()};
-    CHECK(at.size() >= 4);
-    parser::CharBlock loc{at.begin() + 1, 3};
-    CHECK(loc == "loc");
-    return MakeFunctionRef(loc, ActualArguments{std::move(*arg)});
+  std::optional<ActualArgument> arg;
+  if (const Symbol * assumedTypeDummy{AssumedTypeDummy(x.v.value())}) {
+    arg = ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
+  } else if (MaybeExpr argExpr{Analyze(x.v.value())}) {
+    arg = ActualArgument{std::move(*argExpr)};
   } else {
     return std::nullopt;
   }
+  parser::CharBlock at{GetContextualMessages().at()};
+  CHECK(at.size() >= 4);
+  parser::CharBlock loc{at.begin() + 1, 3};
+  CHECK(loc == "loc");
+  return MakeFunctionRef(loc, ActualArguments{std::move(*arg)});
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::DefinedUnary &) {
@@ -2192,18 +2258,14 @@ evaluate::Expr<evaluate::SubscriptInteger> AnalyzeKindSelector(
   return analyzer.AnalyzeKindSelector(category, selector);
 }
 
+void AnalyzeCallStmt(SemanticsContext &context, const parser::CallStmt &call) {
+  evaluate::ExpressionAnalyzer{context}.Analyze(call);
+}
+
 ExprChecker::ExprChecker(SemanticsContext &context) : context_{context} {}
 
 bool ExprChecker::Walk(const parser::Program &program) {
   parser::Walk(program, *this);
   return !context_.AnyFatalError();
 }
-
-CallChecker::CallChecker(SemanticsContext &context) : analyzer_{context} {}
-
-void CallChecker::Enter(const parser::CallStmt &call) {
-  analyzer_.Analyze(call);
-}
-
-void CallChecker::Leave(const parser::CallStmt &) {}
 }

flang/lib/semantics/expression.h

@@ -313,7 +313,6 @@ private:
   std::optional<ProcedureDesignator> AnalyzeProcedureComponentRef(
       const parser::ProcComponentRef &);
   std::optional<ActualArgument> AnalyzeActualArgument(const parser::Expr &);
-  std::optional<ActualArgument> AnalyzeActualArgument(const parser::Variable &);
 
   struct CalleeAndArguments {
     ProcedureDesignator procedureDesignator;
@@ -375,6 +374,8 @@ evaluate::Expr<evaluate::SubscriptInteger> AnalyzeKindSelector(
     SemanticsContext &, common::TypeCategory,
     const std::optional<parser::KindSelector> &);
 
+void AnalyzeCallStmt(SemanticsContext &, const parser::CallStmt &);
+
 // Semantic analysis of all expressions in a parse tree, which becomes
 // decorated with typed representations for top-level expressions.
 class ExprChecker {
@@ -393,6 +394,10 @@ public:
     AnalyzeExpr(context_, x);
     return false;
   }
+  bool Pre(const parser::CallStmt &x) {
+    AnalyzeCallStmt(context_, x);
+    return false;
+  }
 
   template<typename A> bool Pre(const parser::Scalar<A> &x) {
     AnalyzeExpr(context_, x);
@@ -418,18 +423,5 @@ public:
 private:
   SemanticsContext &context_;
 };
-
-// Semantic analysis of all CALL statements in a parse tree.
-// (Function references are processed as primary expressions.)
-class CallChecker {
-public:
-  explicit CallChecker(SemanticsContext &);
-  void Enter(const parser::CallStmt &);
-  void Leave(const parser::CallStmt &);
-
-private:
-  evaluate::ExpressionAnalyzer analyzer_;
-};
-
 }  // namespace Fortran::semantics
 #endif  // FORTRAN_SEMANTICS_EXPRESSION_H_

flang/lib/semantics/resolve-names.cc

@@ -4058,8 +4058,8 @@ bool DeclarationVisitor::HandleUnrestrictedSpecificIntrinsicFunction(
           .has_value()) {
     // Unrestricted specific intrinsic function names (e.g., "cos")
     // are acceptable as procedure interfaces.
-    Symbol &symbol{
-        MakeSymbol(InclusiveScope(), name.source, Attrs{Attr::INTRINSIC})};
+    Symbol &symbol{MakeSymbol(InclusiveScope(), name.source,
+        Attrs{Attr::INTRINSIC, Attr::ELEMENTAL})};
     symbol.set_details(ProcEntityDetails{});
     Resolve(name, symbol);
     return true;

flang/lib/semantics/semantics.cc

@@ -115,7 +115,7 @@ private:
 
 using StatementSemanticsPass1 = ExprChecker;
 using StatementSemanticsPass2 = SemanticsVisitor<AllocateChecker,
-    ArithmeticIfStmtChecker, AssignmentChecker, CallChecker, CoarrayChecker,
+    ArithmeticIfStmtChecker, AssignmentChecker, CoarrayChecker,
     DeallocateChecker, DoChecker, IfStmtChecker, IoChecker, NullifyChecker,
     OmpStructureChecker, ReturnStmtChecker, StopChecker>;
 

flang/lib/semantics/tools.cc

@@ -962,6 +962,13 @@ UltimateComponentIterator::const_iterator FindCoarrayUltimateComponent(
       [](const Symbol *component) { return DEREF(component).Corank() > 0; });
 }
 
+UltimateComponentIterator::const_iterator FindPointerUltimateComponent(
+    const DerivedTypeSpec &derived) {
+  UltimateComponentIterator ultimates{derived};
+  return std::find_if(ultimates.begin(), ultimates.end(),
+      [](const Symbol *component) { return IsPointer(DEREF(component)); });
+}
+
 PotentialComponentIterator::const_iterator FindEventOrLockPotentialComponent(
     const DerivedTypeSpec &derived) {
   PotentialComponentIterator potentials{derived};

flang/lib/semantics/tools.h

@@ -73,14 +73,6 @@ bool IsTeamType(const DerivedTypeSpec *);
 // Is this derived type either C_PTR or C_FUNPTR from module ISO_C_BINDING
 bool IsIsoCType(const DerivedTypeSpec *);
 bool IsEventTypeOrLockType(const DerivedTypeSpec *);
-// Returns an ultimate component symbol that is a
-// coarray or nullptr if there are no such component.
-// There is no guarantee regarding which ultimate coarray
-// component is returned in case there are several because this
-// does not really matter for the checks where it is needed.
-const Symbol *HasCoarrayUltimateComponent(const DerivedTypeSpec &);
-// Same logic as HasCoarrayUltimateComponent, but looking for
-const Symbol *HasEventOrLockPotentialComponent(const DerivedTypeSpec &);
 bool IsOrContainsEventOrLockComponent(const Symbol &);
 // Has an explicit or implied SAVE attribute
 bool IsSaved(const Symbol &);
@@ -369,5 +361,7 @@ PotentialComponentIterator::const_iterator FindEventOrLockPotentialComponent(
     const DerivedTypeSpec &);
 UltimateComponentIterator::const_iterator FindCoarrayUltimateComponent(
     const DerivedTypeSpec &);
+UltimateComponentIterator::const_iterator FindPointerUltimateComponent(
+    const DerivedTypeSpec &);
 }
 #endif  // FORTRAN_SEMANTICS_TOOLS_H_

flang/test/semantics/CMakeLists.txt

@@ -163,6 +163,7 @@ set(ERROR_TESTS
   blockconstruct02.f90
   blockconstruct03.f90
   call01.f90
+  call02.f90
 )
 
 # These test files have expected symbols in the source

flang/test/semantics/call02.f90

@@ -27,8 +27,8 @@ subroutine s01(elem, subr)
     end subroutine
   end interface
   call subr(cos) ! not an error
-  !ERROR: cannot pass non-intrinsic ELEMENTAL procedure as argument
-  call subr(elem)
+  !ERROR: Non-intrinsic ELEMENTAL procedure cannot be passed as argument.
+  call subr(elem) ! C1533
 end subroutine
 
 module m01
@@ -47,14 +47,14 @@ module m01
   end function
   subroutine test
     call callme(cos) ! not an error
-    !ERROR: cannot pass non-intrinsic ELEMENTAL procedure as argument
-    call callme(elem01)
-    !ERROR: cannot pass non-intrinsic ELEMENTAL procedure as argument
-    call callme(elem02)
-    !ERROR: cannot pass non-intrinsic ELEMENTAL procedure as argument
-    call callme(elem03)
-    !ERROR: cannot pass non-intrinsic ELEMENTAL procedure as argument
-    call callme(elem04)
+    !ERROR: Non-intrinsic ELEMENTAL procedure cannot be passed as argument.
+    call callme(elem01) ! C1533
+    !ERROR: Non-intrinsic ELEMENTAL procedure cannot be passed as argument.
+    call callme(elem02) ! C1533
+    !ERROR: Non-intrinsic ELEMENTAL procedure cannot be passed as argument.
+    call callme(elem03) ! C1533
+    !ERROR: Non-intrinsic ELEMENTAL procedure cannot be passed as argument.
+    call callme(elem04) ! C1533
    contains
     elemental real function elem04(x)
       real, value :: x
@@ -63,22 +63,6 @@ module m01
 end module
 
 module m02
-  interface
-    subroutine altreturn(*)
-    end subroutine
-  end interface
- contains
-  subroutine test
-1   continue
-   contains
-    subroutine internal
-      !ERROR: alternate return label must be in the inclusive scope
-      call altreturn(*1)
-    end subroutine
-  end subroutine
-end module
-
-module m03
   type :: t
     integer, pointer :: ptr
   end type
@@ -88,7 +72,7 @@ module m03
     type(t), intent(in) :: x
   end subroutine
   subroutine test
-    !ERROR: coindexed argument cannot have a POINTER ultimate component
-    call callee(coarray[1])
+    !ERROR: Coindexed object 'coarray' with POINTER ultimate component 'ptr' cannot be passed as argument.
+    call callee(coarray[1]) ! C1537
   end subroutine
 end module

flang/test/semantics/procinterface01.f90

@@ -66,13 +66,13 @@ module module1
   !DEF: /module1/derived1/p5 NOPASS, POINTER (Function) ProcEntity COMPLEX(4)
   !DEF: /module1/nested4 PUBLIC (Function) Subprogram COMPLEX(4)
   procedure(complex), pointer, nopass :: p5 => nested4
-  !DEF: /module1/sin INTRINSIC, PUBLIC ProcEntity
+  !DEF: /module1/sin ELEMENTAL, INTRINSIC, PUBLIC ProcEntity
   !DEF: /module1/derived1/p6 NOPASS, POINTER ProcEntity
   !REF: /module1/nested1
   procedure(sin), pointer, nopass :: p6 => nested1
   !REF: /module1/sin
   !DEF: /module1/derived1/p7 NOPASS, POINTER ProcEntity
-  !DEF: /module1/cos INTRINSIC, PUBLIC ProcEntity
+  !DEF: /module1/cos ELEMENTAL, INTRINSIC, PUBLIC ProcEntity
   procedure(sin), pointer, nopass :: p7 => cos
   !REF: /module1/tan
   !DEF: /module1/derived1/p8 NOPASS, POINTER (Function) ProcEntity CHARACTER(1_4,1)

flang/test/semantics/resolve59.f90

@@ -59,9 +59,14 @@ contains
   end function
   function f5(x)
     real :: x
-    procedure(acos), pointer :: f5
-    f5 => acos
-    ! OK call to f5 pointer (acos)
+    interface
+      real function rfunc(x)
+        real, intent(in) :: x
+      end function
+    end interface
+    procedure(rfunc), pointer :: f5
+    f5 => rfunc
+    ! OK call to f5 pointer
     x = acos(f5(x+1))
     !ERROR: Typeless item not allowed for 'x=' argument
     x = acos(f5)