Commit b0f02cee authored by Peter Klausler's avatar Peter Klausler
Browse files

[flang] Catch impure defined assignments in DO CONCURRENT 

The semantic checking of DO CONCURRENT bodies looks only at the
parse tree, not the typed expressions produced from it, so it
misses calls to defined assignment subroutines that arise from
assignment statements that resolve via generic interfaces into
subroutine calls.  Extend the checking to peek into the typed
assignment operations left on the parse tree by semantics.

Differential Revision: https://reviews.llvm.org/D146585
parent 30ce6fbf

flang/lib/Semantics/check-do-forall.cpp

+14 −4
Original line number Diff line number Diff line
@@ -219,6 +219,16 @@ public: 
        SayDeallocateWithImpureFinal(*entity, reason);

      }

    }

    if (const auto *assignment{GetAssignment(stmt)}) {

      if (const auto *call{

              std::get_if<evaluate::ProcedureRef>(&assignment->u)}) {

        if (auto bad{FindImpureCall(context_.foldingContext(), *call)}) {

          context_.Say(currentStatementSourcePosition_,

              "The defined assignment subroutine '%s' is not pure"_err_en_US,

              *bad);

        }

      }

    }

  }



  // Deallocation from a DEALLOCATE statement
@@ -431,10 +441,10 @@ public: 
  }



  void Check(const parser::ForallAssignmentStmt &stmt) {

    const evaluate::Assignment *assignment{common::visit(

    if (const evaluate::Assignment *

        assignment{common::visit(

            common::visitors{[&](const auto &x) { return GetAssignment(x); }},

        stmt.u)};

    if (assignment) {

            stmt.u)}) {

      CheckForallIndexesUsed(*assignment);

      CheckForImpureCall(assignment->lhs);

      CheckForImpureCall(assignment->rhs);

flang/test/Semantics/doconcurrent01.f90

+31 −0
Original line number Diff line number Diff line
@@ -237,3 +237,34 @@ subroutine s7() 
    end function pureFunc



end subroutine s7



module m8

  type t

   contains

    procedure tbpAssign

    generic :: assignment(=) => tbpAssign

  end type

  interface assignment(=)

    module procedure nonTbpAssign

  end interface

 contains

  impure elemental subroutine tbpAssign(to, from)

    class(t), intent(out) :: to

    class(t), intent(in) :: from

    print *, 'impure due to I/O'

  end

  impure elemental subroutine nonTbpAssign(to, from)

    type(t), intent(out) :: to

    integer, intent(in) :: from

    print *, 'impure due to I/O'

  end

  subroutine test

    type(t) x, y

    do concurrent (j=1:1)

      !ERROR: The defined assignment subroutine 'tbpassign' is not pure

      x = y

      !ERROR: The defined assignment subroutine 'nontbpassign' is not pure

      x = 666

    end do

  end

end