[flang] Check constraints on passed-object dummy argument

The passed-object dummy argument cannot be checked until the
interfaces of contained subprograms are known. To accomplish this,
add `FinishSpecificationPart` pass to run after all specification
parts have been analyzed but before any of the execution parts.
This visits all derived types defined in each scope and performs
the checks on each procedure component and procedure binding.

Add a flag to `ParamValue` to distinguish kind from len parameters.

Fix some tests that had errors we now detect.

Original-commit: flang-compiler/f18@4789643c5b
Reviewed-on: https://github.com/flang-compiler/f18/pull/521

flang/lib/semantics/resolve-names.cc

@@ -107,9 +107,10 @@ public:
   // Emit a message about a SourceName
   Message &Say(const SourceName &, MessageFixedText &&);
   // Emit a formatted message associated with a source location.
-  Message &Say(const SourceName &, MessageFixedText &&, const SourceName &);
-  Message &Say(const SourceName &, MessageFixedText &&, const SourceName &,
-      const SourceName &);
+  template<typename... A>
+  Message &Say(const SourceName &source, MessageFixedText &&msg, A &&... args) {
+    return context_->Say(source, std::move(msg), std::forward<A>(args)...);
+  }
 
 private:
   SemanticsContext *context_{nullptr};
@@ -1047,6 +1048,10 @@ private:
   void AddSubpNames(const ProgramTree &);
   bool BeginScope(const ProgramTree &);
   void ResolveSpecificationParts(ProgramTree &);
+  void FinishSpecificationParts(const ProgramTree &);
+  void FinishDerivedType(Scope &);
+  const Symbol *CheckPassArg(
+      const Symbol &, const Symbol *, const SourceName *);
 };
 
 // ImplicitRules implementation
@@ -1319,14 +1324,6 @@ Message &MessageHandler::Say(MessageFormattedText &&msg) {
 Message &MessageHandler::Say(const SourceName &name, MessageFixedText &&msg) {
   return Say(name, std::move(msg), name);
 }
-Message &MessageHandler::Say(const SourceName &location, MessageFixedText &&msg,
-    const SourceName &arg1) {
-  return context_->Say(location, std::move(msg), arg1);
-}
-Message &MessageHandler::Say(const SourceName &location, MessageFixedText &&msg,
-    const SourceName &arg1, const SourceName &arg2) {
-  return context_->Say(location, std::move(msg), arg1, arg2);
-}
 
 // ImplicitRulesVisitor implementation
 
@@ -4765,6 +4762,7 @@ bool ResolveNamesVisitor::Pre(const parser::ProgramUnit &x) {
   auto root{ProgramTree::Build(x)};
   SetScope(context().globalScope());
   ResolveSpecificationParts(root);
+  FinishSpecificationParts(root);
   SetScope(context().globalScope());
   ResolveExecutionParts(root);
   return false;
@@ -4869,6 +4867,146 @@ bool ResolveNamesVisitor::BeginScope(const ProgramTree &node) {
   }
 }
 
+// Perform checks that need to happen after all of the specification parts
+// but before any of the execution parts.
+void ResolveNamesVisitor::FinishSpecificationParts(const ProgramTree &node) {
+  if (!node.scope()) {
+    return;  // error occurred creating scope
+  }
+  SetScope(*node.scope());
+  for (Scope &childScope : currScope().children()) {
+    if (childScope.kind() == Scope::Kind::DerivedType && childScope.symbol()) {
+      FinishDerivedType(childScope);
+    }
+  }
+  for (const auto &child : node.children()) {
+    FinishSpecificationParts(child);
+  }
+}
+
+static int FindIndexOfName(
+    const SourceName &name, std::vector<Symbol *> symbols) {
+  for (std::size_t i{0}; i < symbols.size(); ++i) {
+    if (symbols[i] && symbols[i]->name() == name) {
+      return i;
+    }
+  }
+  return -1;
+}
+
+// Perform checks on procedure bindings of this type
+void ResolveNamesVisitor::FinishDerivedType(Scope &scope) {
+  CHECK(scope.kind() == Scope::Kind::DerivedType);
+  for (auto &pair : scope) {
+    Symbol &comp{*pair.second};
+    std::visit(
+        common::visitors{
+            [&](ProcEntityDetails &x) {
+              x.set_passArg(
+                  CheckPassArg(comp, x.interface().symbol(), x.passName()));
+            },
+            [&](ProcBindingDetails &x) {
+              x.set_passArg(CheckPassArg(comp, &x.symbol(), x.passName()));
+            },
+            [](auto &x) {},
+        },
+        comp.details());
+  }
+}
+
+// Check C760, constraints on the passed-object dummy argument
+// If they all pass, return the Symbol for that argument.
+const Symbol *ResolveNamesVisitor::CheckPassArg(
+    const Symbol &proc, const Symbol *interface, const SourceName *passName) {
+  if (proc.attrs().test(Attr::NOPASS)) {
+    return nullptr;
+  }
+  const auto &name{proc.name()};
+  if (!interface) {
+    Say(name,
+        "Procedure component '%s' must have NOPASS attribute or explicit interface"_err_en_US,
+        name);
+    return nullptr;
+  }
+  const auto &dummyArgs{interface->get<SubprogramDetails>().dummyArgs()};
+  if (!passName && dummyArgs.empty()) {
+    Say(name,
+        proc.has<ProcEntityDetails>()
+            ? "Procedure component '%s' with no dummy arguments"
+              " must have NOPASS attribute"_err_en_US
+            : "Procedure binding '%s' with no dummy arguments"
+              " must have NOPASS attribute"_err_en_US,
+        name);
+    return nullptr;
+  }
+  int passArgIndex{0};
+  if (!passName) {
+    passName = &dummyArgs[0]->name();
+  } else {
+    passArgIndex = FindIndexOfName(*passName, dummyArgs);
+    if (passArgIndex < 0) {
+      Say(*passName,
+          "'%s' is not a dummy argument of procedure interface '%s'"_err_en_US,
+          *passName, interface->name());
+      return nullptr;
+    }
+  }
+  const Symbol &passArg{*dummyArgs[passArgIndex]};
+  std::optional<MessageFixedText> msg;
+  if (!passArg.has<ObjectEntityDetails>()) {
+    msg = "Passed-object dummy argument '%s' of procedure '%s'"
+          " must be a data object"_err_en_US;
+  } else if (passArg.attrs().test(Attr::POINTER)) {
+    msg = "Passed-object dummy argument '%s' of procedure '%s'"
+          " may not have the POINTER attribute"_err_en_US;
+  } else if (passArg.attrs().test(Attr::ALLOCATABLE)) {
+    msg = "Passed-object dummy argument '%s' of procedure '%s'"
+          " may not have the ALLOCATABLE attribute"_err_en_US;
+  } else if (passArg.attrs().test(Attr::VALUE)) {
+    msg = "Passed-object dummy argument '%s' of procedure '%s'"
+          " may not have the VALUE attribute"_err_en_US;
+  } else if (passArg.Rank() > 0) {
+    msg = "Passed-object dummy argument '%s' of procedure '%s'"
+          " must be scalar"_err_en_US;
+  }
+  if (msg) {
+    Say(name, std::move(*msg), *passName, name);
+    return nullptr;
+  }
+  const DeclTypeSpec *type{passArg.GetType()};
+  if (!type) {
+    return nullptr;  // an error already occurred
+  }
+  const Symbol &typeSymbol{*proc.owner().GetSymbol()};
+  const DerivedTypeSpec *derived{type->AsDerived()};
+  if (!derived || derived->typeSymbol() != typeSymbol) {
+    Say(name,
+        "Passed-object dummy argument '%s' of procedure '%s'"
+        " must be of type '%s' but is '%s'"_err_en_US,
+        *passName, name, typeSymbol.name(), type->AsFortran());
+    return nullptr;
+  }
+  if (IsExtensibleType(derived) != type->IsPolymorphic()) {
+    Say(name,
+        type->IsPolymorphic()
+            ? "Passed-object dummy argument '%s' of procedure '%s'"
+              " must not be polymorphic because '%s' is not extensible"_err_en_US
+            : "Passed-object dummy argument '%s' of procedure '%s'"
+              " must polymorphic because '%s' is extensible"_err_en_US,
+        *passName, name, typeSymbol.name());
+    return nullptr;
+  }
+  for (const auto &[paramName, paramValue] : derived->parameters()) {
+    if (paramValue.isLen() && !paramValue.isAssumed()) {
+      Say(name,
+          "Passed-object dummy argument '%s' of procedure '%s'"
+          " has non-assumed length parameter '%s'"_err_en_US,
+          *passName, name, paramName);
+    }
+  }
+  return &passArg;
+}
+
 // Resolve names in the execution part of this node and its children
 void ResolveNamesVisitor::ResolveExecutionParts(const ProgramTree &node) {
   if (!node.scope()) {

flang/lib/semantics/symbol.h

@@ -21,6 +21,7 @@
 #include <functional>
 #include <list>
 #include <optional>
+#include <vector>
 
 namespace Fortran::semantics {
 
@@ -73,14 +74,14 @@ public:
     CHECK(result_ == nullptr);
     result_ = &result;
   }
-  const std::list<Symbol *> &dummyArgs() const { return dummyArgs_; }
+  const std::vector<Symbol *> &dummyArgs() const { return dummyArgs_; }
   void add_dummyArg(Symbol &symbol) { dummyArgs_.push_back(&symbol); }
   void add_alternateReturn() { dummyArgs_.push_back(nullptr); }
 
 private:
   bool isInterface_{false};  // true if this represents an interface-body
   MaybeExpr bindName_;
-  std::list<Symbol *> dummyArgs_;  // nullptr -> alternate return indicator
+  std::vector<Symbol *> dummyArgs_;  // nullptr -> alternate return indicator
   Symbol *result_{nullptr};
   friend std::ostream &operator<<(std::ostream &, const SubprogramDetails &);
 };

flang/lib/semantics/tools.cc

@@ -293,6 +293,12 @@ const Symbol *FindFunctionResult(const Symbol &symbol) {
   return nullptr;
 }
 
+bool IsExtensibleType(const DerivedTypeSpec *derived) {
+  return derived && !IsIsoCType(derived) &&
+      !derived->typeSymbol().attrs().test(Attr::BIND_C) &&
+      !derived->typeSymbol().get<DerivedTypeDetails>().sequence();
+}
+
 bool IsDerivedTypeFromModule(
     const DerivedTypeSpec *derived, const char *module, const char *name) {
   if (!derived) {

flang/lib/semantics/tools.h

@@ -57,6 +57,7 @@ bool IsProcedure(const Symbol &);
 bool IsProcName(const Symbol &symbol);  // proc-name
 bool IsVariableName(const Symbol &symbol);  // variable-name
 bool IsProcedurePointer(const Symbol &);
+bool IsExtensibleType(const DerivedTypeSpec *);
 // Is this a derived type from module with this name?
 bool IsDerivedTypeFromModule(
     const DerivedTypeSpec *derived, const char *module, const char *name);

flang/lib/semantics/type.cc

@@ -130,8 +130,9 @@ Scope &DerivedTypeSpec::Instantiate(
       // one of its parents.  Put the type parameter expression value
       // into the new scope as the initialization value for the parameter.
       if (ParamValue * paramValue{FindParameter(name)}) {
+        const TypeParamDetails &details{symbol->get<TypeParamDetails>()};
+        paramValue->set_attr(details.attr());
         if (MaybeIntExpr expr{paramValue->GetExplicit()}) {
-          const TypeParamDetails &details{symbol->get<TypeParamDetails>()};
           // Ensure that any kind type parameters with values are
           // constant by now.
           if (details.attr() == common::TypeParamAttr::Kind) {

flang/lib/semantics/type.h

@@ -101,6 +101,9 @@ public:
   bool isDeferred() const { return category_ == Category::Deferred; }
   const MaybeIntExpr &GetExplicit() const { return expr_; }
   void SetExplicit(SomeIntExpr &&);
+  bool isKind() const { return attr_ == common::TypeParamAttr::Kind; }
+  bool isLen() const { return attr_ == common::TypeParamAttr::Len; }
+  void set_attr(common::TypeParamAttr attr) { attr_ = attr; }
   bool operator==(const ParamValue &that) const {
     return category_ == that.category_ && expr_ == that.expr_;
   }
@@ -110,6 +113,7 @@ private:
   enum class Category { Explicit, Deferred, Assumed };
   ParamValue(Category category) : category_{category} {}
   Category category_{Category::Explicit};
+  common::TypeParamAttr attr_{common::TypeParamAttr::Kind};
   MaybeIntExpr expr_;
   friend std::ostream &operator<<(std::ostream &, const ParamValue &);
 };
@@ -285,6 +289,12 @@ public:
 
   Category category() const { return category_; }
   void set_category(Category category) { category_ = category; }
+  bool IsPolymorphic() const {
+    return category_ == ClassDerived || IsUnlimitedPolymorphic();
+  }
+  bool IsUnlimitedPolymorphic() const {
+    return category_ == TypeStar || category_ == ClassStar;
+  }
   bool IsNumeric(TypeCategory) const;
   const NumericTypeSpec &numericTypeSpec() const;
   const LogicalTypeSpec &logicalTypeSpec() const;

flang/test/semantics/CMakeLists.txt

@@ -84,6 +84,7 @@ set(ERROR_TESTS
   resolve49.f90
   resolve50.f90
   resolve51.f90
+  resolve52.f90
   stop01.f90
   structconst01.f90
   structconst02.f90

flang/test/semantics/allocate01.f90

@@ -31,12 +31,10 @@ module m
 contains
   function mfoo(x)
     class(a_type) :: foo, x
-    allocatable :: x
     foo = x
   end function
   subroutine mbar(x)
-    class(a_type), allocatable :: x
-    allocate(x)
+    class(a_type) :: x
   end subroutine
 end module
 

flang/test/semantics/expr-errors01.f90

@@ -15,7 +15,7 @@
 ! C1003 - can't parenthesize function call returning procedure pointer
 module m1
   type :: dt
-    procedure(frpp), pointer :: pp
+    procedure(frpp), pointer, nopass :: pp
   end type dt
  contains
   subroutine boring

flang/test/semantics/null01.f90

@@ -45,10 +45,10 @@ subroutine test
     integer, pointer :: ip1(:)
   end type dt1
   type :: dt2
-    procedure(s0), pointer :: pps0
+    procedure(s0), pointer, nopass :: pps0
   end type dt2
   type :: dt3
-    procedure(s1), pointer :: pps1
+    procedure(s1), pointer, nopass :: pps1
   end type dt3
   integer :: j
   type(dt0) :: dt0x

flang/test/semantics/resolve52.f90

@@ -0,0 +1,145 @@
+! 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.
+
+! Tests for C760:
+! The passed-object dummy argument shall be a scalar, nonpointer, nonallocatable
+! dummy data object with the same declared type as the type being defined;
+! all of its length type parameters shall be assumed; it shall be polymorphic
+! (7.3.2.3) if and only if the type being defined is extensible (7.5.7).
+! It shall not have the VALUE attribute.
+
+module m1
+  type :: t
+    procedure(real), pointer, nopass :: a
+    !ERROR: Procedure component 'b' must have NOPASS attribute or explicit interface
+    procedure(real), pointer :: b
+  end type
+end
+
+module m2
+  type :: t
+    !ERROR: Procedure component 'a' with no dummy arguments must have NOPASS attribute
+    procedure(s1), pointer :: a
+    !ERROR: Procedure component 'b' with no dummy arguments must have NOPASS attribute
+    procedure(s1), pointer, pass :: b
+  contains
+    !ERROR: Procedure binding 'p1' with no dummy arguments must have NOPASS attribute
+    procedure :: p1 => s1
+    !ERROR: Procedure binding 'p2' with no dummy arguments must have NOPASS attribute
+    procedure, pass :: p2 => s1
+  end type
+contains
+  subroutine s1()
+  end
+end
+
+module m3
+  type :: t
+    !ERROR: 'y' is not a dummy argument of procedure interface 's'
+    procedure(s), pointer, pass(y) :: a
+  contains
+    !ERROR: 'z' is not a dummy argument of procedure interface 's'
+    procedure, pass(z) :: p => s
+  end type
+contains
+  subroutine s(x)
+    class(t) :: x
+  end
+end
+
+module m4
+  type :: t
+    !ERROR: Passed-object dummy argument 'x' of procedure 'a' may not have the POINTER attribute
+    procedure(s1), pointer :: a
+    !ERROR: Passed-object dummy argument 'x' of procedure 'b' may not have the ALLOCATABLE attribute
+    procedure(s2), pointer, pass(x) :: b
+    !ERROR: Passed-object dummy argument 'f' of procedure 'c' must be a data object
+    procedure(s3), pointer, pass :: c
+    !ERROR: Passed-object dummy argument 'x' of procedure 'd' must be scalar
+    procedure(s4), pointer, pass :: d
+  end type
+contains
+  subroutine s1(x)
+    class(t), pointer :: x
+  end
+  subroutine s2(w, x)
+    real :: x
+    !ERROR: The type of 'x' has already been declared
+    class(t), allocatable :: x
+  end
+  subroutine s3(f)
+    interface
+      real function f()
+      end function
+    end interface
+  end
+  subroutine s4(x)
+    class(t) :: x(10)
+  end
+end
+
+module m5
+  type :: t1
+    sequence
+    !ERROR: Passed-object dummy argument 'x' of procedure 'a' must be of type 't1' but is 'REAL(4)'
+    procedure(s), pointer :: a
+  end type
+  type :: t2
+  contains
+    !ERROR: Passed-object dummy argument 'y' of procedure 's' must be of type 't2' but is 'TYPE(t1)'
+    procedure, pass(y) :: s
+  end type
+contains
+  subroutine s(x, y)
+    real :: x
+    type(t1) :: y
+  end
+end
+
+module m6
+  type :: t(k, l)
+    integer, kind :: k
+    integer, len :: l
+    !ERROR: Passed-object dummy argument 'x' of procedure 'a' has non-assumed length parameter 'l'
+    procedure(s1), pointer :: a
+  end type
+contains
+  subroutine s1(x)
+    class(t(1, 2)) :: x
+  end
+end
+
+module m7
+  type :: t
+    sequence  ! t is not extensible
+    !ERROR: Passed-object dummy argument 'x' of procedure 'a' must not be polymorphic because 't' is not extensible
+    procedure(s), pointer :: a
+  end type
+contains
+  subroutine s(x)
+    class(t) :: x
+  end
+end
+
+module m8
+  type :: t
+  contains
+    !ERROR: Passed-object dummy argument 'x' of procedure 's' must polymorphic because 't' is extensible
+    procedure :: s
+  end type
+contains
+  subroutine s(x)
+    type(t) :: x  ! x is not polymorphic
+  end
+end

flang/test/semantics/structconst02.f90

@@ -30,8 +30,8 @@ module module1
     character(kind=ck,len=len) :: cx = ' '
     logical(kind=lk) :: lx = .false.
     real(kind=rk), pointer :: rp = NULL()
-    procedure(realfunc), pointer :: rfp1 => NULL()
-    procedure(real), pointer :: rfp2 => NULL()
+    procedure(realfunc), pointer, nopass :: rfp1 => NULL()
+    procedure(real), pointer, nopass :: rfp2 => NULL()
   end type scalar
  contains
   subroutine scalararg(x)