[flang] Add checks for valid defined assignment procedures

Perform the checks from 15.4.3.4.3 to determine what procedures are
valid to implement defined assignment. This requires characterizing
procedures, so share the result of that with
`CheckSpecificsAreDistinguishable`.

Original-commit: flang-compiler/f18@9e0d79f
Reviewed-on: flang-compiler/f18#841
Tree-same-pre-rewrite: false

flang/lib/semantics/check-declarations.cc

@@ -26,6 +26,10 @@
 
 namespace Fortran::semantics {
 
+using evaluate::characteristics::DummyArgument;
+using evaluate::characteristics::DummyDataObject;
+using evaluate::characteristics::Procedure;
+
 class CheckHelper {
 public:
   explicit CheckHelper(SemanticsContext &c) : context_{c} {}
@@ -58,7 +62,11 @@ class CheckHelper {
   void CheckProcEntity(const Symbol &, const ProcEntityDetails &);
   void CheckDerivedType(const Symbol &, const DerivedTypeDetails &);
   void CheckGeneric(const Symbol &, const GenericDetails &);
-  void CheckSpecificsAreDistinguishable(const Symbol &, const GenericDetails &);
+  std::optional<std::vector<Procedure>> Characterize(const SymbolVector &);
+  bool CheckDefinedAssignment(const Symbol &, const Procedure &);
+  bool CheckDefinedAssignmentArg(const Symbol &, const DummyArgument &, int);
+  void CheckSpecificsAreDistinguishable(
+      const Symbol &, const GenericDetails &, const std::vector<Procedure> &);
   void SayNotDistinguishable(
       const SourceName &, GenericKind, const Symbol &, const Symbol &);
   bool InPure() const {
@@ -119,7 +127,7 @@ void CheckHelper::Check(const Symbol &symbol) {
   }
   const DeclTypeSpec *type{symbol.GetType()};
   const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
-  auto save{messages_.SetLocation(symbol.name())};
+  auto restorer{messages_.SetLocation(symbol.name())};
   context_.set_location(symbol.name());
   bool isAssociated{symbol.has<UseDetails>() || symbol.has<HostAssocDetails>()};
   if (symbol.attrs().test(Attr::VOLATILE)) {
@@ -386,12 +394,28 @@ void CheckHelper::CheckDerivedType(
 
 void CheckHelper::CheckGeneric(
     const Symbol &symbol, const GenericDetails &details) {
-  CheckSpecificsAreDistinguishable(symbol, details);
+  const SymbolVector &specifics{details.specificProcs()};
+  const auto &bindingNames{details.bindingNames()};
+  std::optional<std::vector<Procedure>> procs{Characterize(specifics)};
+  if (!procs) {
+    return;
+  }
+  bool ok{true};
+  if (details.kind().IsAssignment()) {
+    for (std::size_t i{0}; i < specifics.size(); ++i) {
+      auto restorer{messages_.SetLocation(bindingNames[i])};
+      ok &= CheckDefinedAssignment(specifics[i], (*procs)[i]);
+    }
+  }
+  // TODO: check defined operators too
+  if (ok) {
+    CheckSpecificsAreDistinguishable(symbol, details, *procs);
+  }
 }
 
 // Check that the specifics of this generic are distinguishable from each other
-void CheckHelper::CheckSpecificsAreDistinguishable(
-    const Symbol &generic, const GenericDetails &details) {
+void CheckHelper::CheckSpecificsAreDistinguishable(const Symbol &generic,
+    const GenericDetails &details, const std::vector<Procedure> &procs) {
   const SymbolVector &specifics{details.specificProcs()};
   std::size_t count{specifics.size()};
   if (count < 2) {
@@ -401,18 +425,6 @@ void CheckHelper::CheckSpecificsAreDistinguishable(
   auto distinguishable{kind.IsAssignment() || kind.IsOperator()
           ? evaluate::characteristics::DistinguishableOpOrAssign
           : evaluate::characteristics::Distinguishable};
-  using evaluate::characteristics::Procedure;
-  std::vector<Procedure> procs;
-  for (const Symbol &symbol : specifics) {
-    if (context_.HasError(symbol)) {
-      return;
-    }
-    auto proc{Procedure::Characterize(symbol, context_.intrinsics())};
-    if (!proc) {
-      return;
-    }
-    procs.emplace_back(*proc);
-  }
   for (std::size_t i1{0}; i1 < count - 1; ++i1) {
     auto &proc1{procs[i1]};
     for (std::size_t i2{i1 + 1}; i2 < count; ++i2) {
@@ -438,6 +450,91 @@ void CheckHelper::SayNotDistinguishable(const SourceName &name,
   evaluate::AttachDeclaration(msg, proc2);
 }
 
+static bool ConflictsWithIntrinsicAssignment(
+    const DummyDataObject &arg0, const DummyDataObject &arg1) {
+  auto cat0{arg0.type.type().category()};
+  auto cat1{arg1.type.type().category()};
+  int rank0{arg0.type.Rank()};
+  int rank1{arg1.type.Rank()};
+  if (cat0 == TypeCategory::Derived || (rank1 > 0 && rank0 != rank1)) {
+    return false;
+  } else {
+    return cat0 == cat1 ||
+        (IsNumericTypeCategory(cat0) && IsNumericTypeCategory(cat1));
+  }
+}
+
+// Check if this procedure can be used for defined assignment (see 15.4.3.4.3).
+bool CheckHelper::CheckDefinedAssignment(
+    const Symbol &specific, const Procedure &proc) {
+  std::optional<parser::MessageFixedText> msg;
+  if (!proc.IsSubroutine()) {
+    msg = "Defined assignment procedure '%s' must be a subroutine"_err_en_US;
+  } else if (proc.dummyArguments.size() != 2) {
+    msg = "Defined assignment subroutine '%s' must have"
+          " two dummy arguments"_err_en_US;
+  } else if (!CheckDefinedAssignmentArg(specific, proc.dummyArguments[0], 0) |
+      !CheckDefinedAssignmentArg(specific, proc.dummyArguments[1], 1)) {
+    return false;  // error was reported
+  } else if (ConflictsWithIntrinsicAssignment(
+                 std::get<DummyDataObject>(proc.dummyArguments[0].u),
+                 std::get<DummyDataObject>(proc.dummyArguments[1].u))) {
+    msg = "Defined assignment subroutine '%s' conflicts with"
+          " intrinsic assignment"_err_en_US;
+  } else {
+    return true;  // OK
+  }
+  SayWithDeclaration(specific, std::move(msg.value()), specific.name());
+  return false;
+}
+
+bool CheckHelper::CheckDefinedAssignmentArg(
+    const Symbol &symbol, const DummyArgument &arg, int pos) {
+  std::optional<parser::MessageFixedText> msg;
+  if (arg.IsOptional()) {
+    msg = "In defined assignment subroutine '%s', dummy argument '%s'"
+          " may not be OPTIONAL"_err_en_US;
+  } else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)}) {
+    if (pos == 0) {
+      if (dataObject->intent != common::Intent::Out &&
+          dataObject->intent != common::Intent::InOut) {
+        msg = "In defined assignment subroutine '%s', first dummy argument '%s'"
+              " must have INTENT(OUT) or INTENT(INOUT)"_err_en_US;
+      }
+    } else if (pos == 1) {
+      if (dataObject->intent != common::Intent::In &&
+          !dataObject->attrs.test(DummyDataObject::Attr::Value)) {
+        msg =
+            "In defined assignment subroutine '%s', second dummy"
+            " argument '%s' must have INTENT(IN) or VALUE attribute"_err_en_US;
+      }
+    } else {
+      DIE("pos must be 0 or 1");
+    }
+  } else {
+    msg = "In defined assignment subroutine '%s', dummy argument '%s'"
+          " must be a data object"_err_en_US;
+  }
+  if (msg) {
+    SayWithDeclaration(symbol, std::move(*msg), symbol.name(), arg.name);
+    return false;
+  }
+  return true;
+}
+
+std::optional<std::vector<Procedure>> CheckHelper::Characterize(
+    const SymbolVector &specifics) {
+  std::vector<Procedure> result;
+  for (const Symbol &specific : specifics) {
+    auto proc{Procedure::Characterize(specific, context_.intrinsics())};
+    if (!proc || context_.HasError(specific)) {
+      return std::nullopt;
+    }
+    result.emplace_back(*proc);
+  }
+  return result;
+}
+
 void CheckHelper::CheckVolatile(const Symbol &symbol, bool isAssociated,
     const DerivedTypeSpec *derived) {  // C866 - C868
   if (IsIntentIn(symbol)) {

flang/test/semantics/CMakeLists.txt

@@ -101,6 +101,7 @@ set(ERROR_TESTS
   resolve62.f90
   resolve63.f90
   resolve64.f90
+  resolve65.f90
   stop01.f90
   structconst01.f90
   structconst02.f90

flang/test/semantics/resolve15.f90

@@ -1,4 +1,4 @@
-! Copyright (c) 2018, NVIDIA CORPORATION.  All rights reserved.
+! Copyright (c) 2018-2019, NVIDIA CORPORATION.  All rights reserved.
 !
 ! Licensed under the Apache License, Version 2.0 (the "License");
 ! you may not use this file except in compliance with the License.
@@ -41,6 +41,8 @@ subroutine s
     module procedure :: sub
   end interface
 contains
-  subroutine sub
+  subroutine sub(x, y)
+    real, intent(out) :: x
+    logical, intent(in) :: y
   end
 end

flang/test/semantics/resolve53.f90

@@ -445,32 +445,8 @@ subroutine s(x, y)
   end
 end
 
-! C1512 - rules for assignment
-! s1 and s2 are not distinguishable for a generic name but they are
-! for assignment
-module m19
-  interface assignment(=)
-    module procedure s1
-    module procedure s2
-  end interface
-  !ERROR: Generic 'g' may not have specific procedures 's1' and 's2' as their interfaces are not distinguishable
-  interface g
-    module procedure s1
-    module procedure s2
-  end interface
-contains
-  subroutine s1(d, p)
-    real, intent(out) :: d
-    integer, intent(in) :: p
-  end subroutine
-  subroutine s2(p, d)
-    integer, intent(out) :: p
-    real, intent(in) :: d
-  end subroutine
-end module
-
 ! C1511 - rules for operators
-module m20
+module m19
   interface operator(.foo.)
     module procedure f1
     module procedure f2

flang/test/semantics/resolve65.f90

@@ -0,0 +1,120 @@
+! Copyright (c) 2019, NVIDIA CORPORATION.  All rights reserved.
+!
+! Licensed under the Apache License, Version 2.0 (the "License");
+! you may not use this file except in compliance with the License.
+! You may obtain a copy of the License at
+!
+!     http://www.apache.org/licenses/LICENSE-2.0
+!
+! Unless required by applicable law or agreed to in writing, software
+! distributed under the License is distributed on an "AS IS" BASIS,
+! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+! See the License for the specific language governing permissions and
+! limitations under the License.
+
+! Test restrictions on what subprograms can be used for defined assignment.
+
+module m1
+  implicit none
+  type :: t
+  contains
+    !ERROR: Defined assignment procedure 'binding' must be a subroutine
+    generic :: assignment(=) => binding
+    procedure :: binding => assign_t1
+    procedure :: assign_t
+    procedure :: assign_t2
+    procedure :: assign_t3
+    !ERROR: Defined assignment subroutine 'assign_t2' must have two dummy arguments
+    !ERROR: In defined assignment subroutine 'assign_t3', second dummy argument 'y' must have INTENT(IN) or VALUE attribute
+    !ERROR: In defined assignment subroutine 'assign_t4', first dummy argument 'x' must have INTENT(OUT) or INTENT(INOUT)
+    generic :: assignment(=) => assign_t, assign_t2, assign_t3, assign_t4
+    procedure :: assign_t4
+  end type
+contains
+  subroutine assign_t(x, y)
+    class(t), intent(out) :: x
+    type(t), intent(in) :: y
+  end
+  logical function assign_t1(x, y)
+    class(t), intent(out) :: x
+    type(t), intent(in) :: y
+  end
+  subroutine assign_t2(x)
+    class(t), intent(out) :: x
+  end
+  subroutine assign_t3(x, y)
+    class(t), intent(out) :: x
+    real :: y
+  end
+  subroutine assign_t4(x, y)
+    class(t) :: x
+      integer, intent(in) :: y
+  end
+end
+
+module m2
+  type :: t
+  end type
+  interface assignment(=)
+    !ERROR: In defined assignment subroutine 's1', dummy argument 'y' may not be OPTIONAL
+    subroutine s1(x, y)
+      import t
+      type(t), intent(out) :: x
+      real, optional, intent(in) :: y
+    end
+    !ERROR: In defined assignment subroutine 's2', dummy argument 'y' must be a data object
+    subroutine s2(x, y)
+      import t
+      type(t), intent(out) :: x
+      intent(in) :: y
+      interface
+        subroutine y()
+        end
+      end interface
+    end
+  end interface
+end
+
+! Detect defined assignment that conflicts with intrinsic assignment
+module m5
+  type :: t
+  end type
+  interface assignment(=)
+    ! OK - lhs is derived type
+    subroutine assign_tt(x, y)
+      import t
+      type(t), intent(out) :: x
+      type(t), intent(in) :: y
+    end
+    !OK - incompatible types
+    subroutine assign_il(x, y)
+      integer, intent(out) :: x
+      logical, intent(in) :: y
+    end
+    !OK - different ranks
+    subroutine assign_23(x, y)
+      integer, intent(out) :: x(:,:)
+      integer, intent(in) :: y(:,:,:)
+    end
+    !OK - scalar = array
+    subroutine assign_01(x, y)
+      integer, intent(out) :: x
+      integer, intent(in) :: y(:)
+    end
+    !ERROR: Defined assignment subroutine 'assign_10' conflicts with intrinsic assignment
+    subroutine assign_10(x, y)
+      integer, intent(out) :: x(:)
+      integer, intent(in) :: y
+    end
+    !ERROR: Defined assignment subroutine 'assign_ir' conflicts with intrinsic assignment
+    subroutine assign_ir(x, y)
+      integer, intent(out) :: x
+      real, intent(in) :: y
+    end
+    !ERROR: Defined assignment subroutine 'assign_ii' conflicts with intrinsic assignment
+    subroutine assign_ii(x, y)
+      integer(2), intent(out) :: x
+      integer(1), intent(in) :: y
+    end
+  end interface
+end