diff --git a/flang/lib/semantics/resolve-names.cc b/flang/lib/semantics/resolve-names.cc index 612ca5ef6aa7..1613856797a3 100644 --- a/flang/lib/semantics/resolve-names.cc +++ b/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 + Message &Say(const SourceName &source, MessageFixedText &&msg, A &&... args) { + return context_->Say(source, std::move(msg), std::forward(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 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().dummyArgs()}; + if (!passName && dummyArgs.empty()) { + Say(name, + proc.has() + ? "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 msg; + if (!passArg.has()) { + 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()) { diff --git a/flang/lib/semantics/symbol.h b/flang/lib/semantics/symbol.h index efc9f85a0b0a..c4276cf55662 100644 --- a/flang/lib/semantics/symbol.h +++ b/flang/lib/semantics/symbol.h @@ -21,6 +21,7 @@ #include #include #include +#include namespace Fortran::semantics { @@ -73,14 +74,14 @@ public: CHECK(result_ == nullptr); result_ = &result; } - const std::list &dummyArgs() const { return dummyArgs_; } + const std::vector &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 dummyArgs_; // nullptr -> alternate return indicator + std::vector dummyArgs_; // nullptr -> alternate return indicator Symbol *result_{nullptr}; friend std::ostream &operator<<(std::ostream &, const SubprogramDetails &); }; diff --git a/flang/lib/semantics/tools.cc b/flang/lib/semantics/tools.cc index ecdccfb175b6..b2b86b4b9943 100644 --- a/flang/lib/semantics/tools.cc +++ b/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().sequence(); +} + bool IsDerivedTypeFromModule( const DerivedTypeSpec *derived, const char *module, const char *name) { if (!derived) { diff --git a/flang/lib/semantics/tools.h b/flang/lib/semantics/tools.h index 280f4e4a4797..8e2eb9581b80 100644 --- a/flang/lib/semantics/tools.h +++ b/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); diff --git a/flang/lib/semantics/type.cc b/flang/lib/semantics/type.cc index 1dd5de6daa7f..815e0f3fac94 100644 --- a/flang/lib/semantics/type.cc +++ b/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()}; + paramValue->set_attr(details.attr()); if (MaybeIntExpr expr{paramValue->GetExplicit()}) { - const TypeParamDetails &details{symbol->get()}; // Ensure that any kind type parameters with values are // constant by now. if (details.attr() == common::TypeParamAttr::Kind) { diff --git a/flang/lib/semantics/type.h b/flang/lib/semantics/type.h index 698f43c5fe86..224140565c26 100644 --- a/flang/lib/semantics/type.h +++ b/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; diff --git a/flang/test/semantics/CMakeLists.txt b/flang/test/semantics/CMakeLists.txt index 78fbab448935..be8da26a5b42 100644 --- a/flang/test/semantics/CMakeLists.txt +++ b/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 diff --git a/flang/test/semantics/allocate01.f90 b/flang/test/semantics/allocate01.f90 index f452652a7e52..b6423d56ced1 100644 --- a/flang/test/semantics/allocate01.f90 +++ b/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 diff --git a/flang/test/semantics/expr-errors01.f90 b/flang/test/semantics/expr-errors01.f90 index d0fdd823d047..c4f3a1d63e11 100644 --- a/flang/test/semantics/expr-errors01.f90 +++ b/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 diff --git a/flang/test/semantics/null01.f90 b/flang/test/semantics/null01.f90 index 4793589999f8..32a6a1fbc05e 100644 --- a/flang/test/semantics/null01.f90 +++ b/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 diff --git a/flang/test/semantics/resolve52.f90 b/flang/test/semantics/resolve52.f90 new file mode 100644 index 000000000000..e4f2699724a4 --- /dev/null +++ b/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 diff --git a/flang/test/semantics/structconst02.f90 b/flang/test/semantics/structconst02.f90 index 0ab012adf617..49043300df8a 100644 --- a/flang/test/semantics/structconst02.f90 +++ b/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)