[flang] Check for passing DO variables to OUT arguments in a CALL statement

I added code to save the INTENT of a dummy argument in the checked expression
of the actual argument.  When processing a CallStmt, I then retrieve the
ProcedureRef, which contains a list of the checked ActualArguments.  I then
traverse this list looking for actual arguments that are active DO variable
that are being passed to dummy arguments whose INTENT is either OUT or INOUT.
For OUT dummies, I put out an error message and warn for INOUT dummies.

Original-commit: flang-compiler/f18@0ff1d26428
Reviewed-on: https://github.com/flang-compiler/f18/pull/902

flang/lib/evaluate/call.h

@@ -111,6 +111,11 @@ public:
   void set_isPassedObject(bool yes = true) { isPassedObject_ = yes; }
 
   bool Matches(const characteristics::DummyArgument &) const;
+  common::Intent dummyIntent() const { return dummyIntent_; }
+  ActualArgument &set_dummyIntent(common::Intent intent) {
+    dummyIntent_ = intent;
+    return *this;
+  }
 
   // Wrap this argument in parentheses
   void Parenthesize();
@@ -127,6 +132,7 @@ private:
   std::optional<parser::CharBlock> keyword_;
   bool isAlternateReturn_{false};  // whether expr is a "*label" number
   bool isPassedObject_{false};
+  common::Intent dummyIntent_{common::Intent::Default};
 };
 
 using ActualArguments = std::vector<std::optional<ActualArgument>>;

flang/lib/semantics/check-call.cc

@@ -601,6 +601,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
             if (auto *expr{arg.UnwrapExpr()}) {
               if (auto type{characteristics::TypeAndShape::Characterize(
                       *expr, context)}) {
+                arg.set_dummyIntent(object.intent);
                 bool isElemental{object.type.Rank() == 0 && proc.IsElemental()};
                 CheckExplicitDataArg(object, dummyName, *expr, *type,
                     isElemental, IsArrayElement(*expr), context, scope);

flang/lib/semantics/check-do.cc

@@ -902,6 +902,52 @@ void DoChecker::Leave(const parser::AssignmentStmt &stmt) {
   context_.CheckDoVarRedefine(variable);
 }
 
+// Check to see if a DO variable is being passed as an actual argument to a
+// dummy argument whose intent is OUT or INOUT.  To do this, we need to find
+// the expressions for actual arguments which contain DO variables.  We get the
+// intents of the dummy arguments from the ProcedureRef in the "typedCall"
+// field of the CallStmt which was filled in during expression checking.  At
+// the same time, we need to iterate over the parser::Expr versions of the
+// actual arguments to get their source locations of the arguments for the
+// messages.
+void DoChecker::Leave(const parser::CallStmt &callStmt) {
+  if (const auto &typedCall{callStmt.typedCall}) {
+    const auto &parsedArgs{
+        std::get<std::list<parser::ActualArgSpec>>(callStmt.v.t)};
+    auto parsedArgIter{parsedArgs.begin()};
+    const evaluate::ActualArguments &checkedArgs{typedCall->arguments()};
+    for (const auto &checkedOptionalArg : checkedArgs) {
+      if (parsedArgIter == parsedArgs.end()) {
+        break;  // No more parsed arguments, we're done.
+      }
+      const auto &parsedArg{std::get<parser::ActualArg>(parsedArgIter->t)};
+      ++parsedArgIter;
+      if (checkedOptionalArg) {
+        const evaluate::ActualArgument &checkedArg{*checkedOptionalArg};
+        if (const SomeExpr * checkedExpr{checkedArg.UnwrapExpr()}) {
+          if (const Symbol *
+              variable{evaluate::UnwrapWholeSymbolDataRef(*checkedExpr)}) {
+            if (const auto *parsedExpr{
+                    std::get_if<common::Indirection<parser::Expr>>(
+                        &parsedArg.u)}) {
+              const parser::CharBlock location{parsedExpr->value().source};
+              switch (checkedArg.dummyIntent()) {
+              case common::Intent::Out:
+                context_.CheckDoVarRedefine(location, *variable);
+                break;
+              case common::Intent::InOut:
+                context_.WarnDoVarRedefine(location, *variable);
+                break;
+              default:;  // INTENT(IN) or default intent
+              }
+            }
+          }
+        }
+      }
+    }
+  }
+}
+
 void DoChecker::Leave(const parser::ConnectSpec &connectSpec) {
   const auto *newunit{
       std::get_if<parser::ConnectSpec::Newunit>(&connectSpec.u)};
@@ -928,7 +974,7 @@ void DoChecker::Leave(const parser::IoControlSpec &ioControlSpec) {
 void DoChecker::Leave(const parser::OutputImpliedDo &outputImpliedDo) {
   const auto &control{std::get<parser::IoImpliedDoControl>(outputImpliedDo.t)};
   const parser::Name &name{control.name.thing.thing};
-  context_.CheckDoVarRedefine(*name.symbol, name.source);
+  context_.CheckDoVarRedefine(name.source, *name.symbol);
 }
 
 void DoChecker::Leave(const parser::StatVariable &statVariable) {

flang/lib/semantics/check-do.h

@@ -14,6 +14,7 @@
 
 namespace Fortran::parser {
 struct AssignmentStmt;
+struct CallStmt;
 struct ConnectSpec;
 struct CycleStmt;
 struct DoConstruct;
@@ -33,6 +34,7 @@ class DoChecker : public virtual BaseChecker {
 public:
   explicit DoChecker(SemanticsContext &context) : context_{context} {}
   void Leave(const parser::AssignmentStmt &);
+  void Leave(const parser::CallStmt &);
   void Leave(const parser::ConnectSpec &);
   void Enter(const parser::CycleStmt &);
   void Enter(const parser::DoConstruct &);

flang/lib/semantics/check-io.cc

@@ -509,7 +509,7 @@ static void CheckForDoVariableInNamelist(const Symbol &namelist,
     SemanticsContext &context, parser::CharBlock namelistLocation) {
   const auto &details{namelist.GetUltimate().get<NamelistDetails>()};
   for (const Symbol &object : details.objects()) {
-    context.CheckDoVarRedefine(object, namelistLocation);
+    context.CheckDoVarRedefine(namelistLocation, object);
   }
 }
 

flang/lib/semantics/semantics.cc

@@ -203,34 +203,41 @@ void SemanticsContext::PopConstruct() {
   constructStack_.pop_back();
 }
 
-void SemanticsContext::SayDoVarRedefine(
+void SemanticsContext::CheckDoVarRedefine(const parser::CharBlock &location,
+    const Symbol &variable, parser::MessageFixedText &&message) {
+  if (const Symbol * root{GetAssociationRoot(variable)}) {
+    if (IsActiveDoVariable(*root)) {
+      parser::CharBlock doLoc{GetDoVariableLocation(*root)};
+      CHECK(doLoc != parser::CharBlock{});
+      Say(location, message, root->name())
+          .Attach(doLoc, "Enclosing DO construct"_en_US);
+    }
+  }
+}
+
+void SemanticsContext::WarnDoVarRedefine(
     const parser::CharBlock &location, const Symbol &variable) {
-  const parser::CharBlock doLoc{GetDoVariableLocation(variable)};
-  CHECK(doLoc != parser::CharBlock{});
-  Say(location, "Cannot redefine DO variable '%s'"_err_en_US, variable.name())
-      .Attach(doLoc, "Enclosing DO construct"_en_US);
+  CheckDoVarRedefine(location, variable,
+      std::move("Possible redefinition of DO variable '%s'"_en_US));
 }
 
 void SemanticsContext::CheckDoVarRedefine(
-    const Symbol &variable, const parser::CharBlock &location) {
-  if (const Symbol * root{GetAssociationRoot(variable)}) {
-    if (IsActiveDoVariable(*root)) {
-      SayDoVarRedefine(location, *root);
-    }
-  }
+    const parser::CharBlock &location, const Symbol &variable) {
+  CheckDoVarRedefine(location, variable,
+      std::move("Cannot redefine DO variable '%s'"_err_en_US));
 }
 
 void SemanticsContext::CheckDoVarRedefine(const parser::Variable &variable) {
   if (const Symbol * entity{GetLastName(variable).symbol}) {
     const parser::CharBlock &sourceLocation{variable.GetSource()};
-    CheckDoVarRedefine(*entity, sourceLocation);
+    CheckDoVarRedefine(sourceLocation, *entity);
   }
 }
 
 void SemanticsContext::CheckDoVarRedefine(const parser::Name &name) {
   const parser::CharBlock &sourceLocation{name.source};
   if (const Symbol * entity{name.symbol}) {
-    CheckDoVarRedefine(*entity, sourceLocation);
+    CheckDoVarRedefine(sourceLocation, *entity);
   }
 }
 

flang/lib/semantics/semantics.h

@@ -152,7 +152,8 @@ public:
 
   // Check to see if a variable being redefined is a DO variable.  If so, emit
   // a message
-  void CheckDoVarRedefine(const Symbol &, const parser::CharBlock &);
+  void WarnDoVarRedefine(const parser::CharBlock &, const Symbol &);
+  void CheckDoVarRedefine(const parser::CharBlock &, const Symbol &);
   void CheckDoVarRedefine(const parser::Variable &);
   void CheckDoVarRedefine(const parser::Name &);
   void ActivateDoVariable(const parser::Name &);
@@ -161,7 +162,8 @@ public:
 
 private:
   parser::CharBlock GetDoVariableLocation(const Symbol &);
-  void SayDoVarRedefine(const parser::CharBlock &, const Symbol &);
+  void CheckDoVarRedefine(
+      const parser::CharBlock &, const Symbol &, parser::MessageFixedText &&);
   const common::IntrinsicTypeDefaultKinds &defaultKinds_;
   const common::LanguageFeatureControl languageFeatures_;
   parser::AllSources &allSources_;

flang/test/semantics/dosemantics12.f90

@@ -373,3 +373,41 @@ subroutine s11()
   end do
 
 end subroutine s11
+
+subroutine s12()
+
+  Integer :: ivar, jvar
+
+  call intentInSub(jvar, ivar)
+  do ivar = 1,10
+    call intentInSub(jvar, ivar)
+  end do
+
+  call intentOutSub(jvar, ivar)
+  do ivar = 1,10
+!ERROR: Cannot redefine DO variable 'ivar'
+    call intentOutSub(jvar, ivar)
+  end do
+
+  call intentInOutSub(jvar, ivar)
+  do ivar = 1,10
+    call intentInOutSub(jvar, ivar)
+  end do
+
+contains
+  subroutine intentInSub(arg1, arg2)
+    integer, intent(in) :: arg1
+    integer, intent(in) :: arg2
+  end subroutine intentInSub
+
+  subroutine intentOutSub(arg1, arg2)
+    integer, intent(in) :: arg1
+    integer, intent(out) :: arg2
+  end subroutine intentOutSub
+
+  subroutine intentInOutSub(arg1, arg2)
+    integer, intent(in) :: arg1
+    integer, intent(inout) :: arg2
+  end subroutine intentInOutSub
+
+end subroutine s12