diff --git a/flang/include/flang/Evaluate/check-expression.h b/flang/include/flang/Evaluate/check-expression.h --- a/flang/include/flang/Evaluate/check-expression.h +++ b/flang/include/flang/Evaluate/check-expression.h @@ -43,37 +43,28 @@ // (10.1.11(2), C1010). Constant expressions are always valid // specification expressions. -// There are two contexts where specification expressions appear -- array -// bounds and type param expressions. We need to differentiate them because -// additional checks are required for array bounds expressions in declarations -// of derived type components (see C750). -ENUM_CLASS(SpecificationExprContext, TYPE_PARAM, BOUND) - template void CheckSpecificationExpr(const A &, parser::ContextualMessages &, - const semantics::Scope &, const IntrinsicProcTable &, - SpecificationExprContext); + const semantics::Scope &, const IntrinsicProcTable &); extern template void CheckSpecificationExpr(const Expr &x, parser::ContextualMessages &, const semantics::Scope &, - const IntrinsicProcTable &, SpecificationExprContext); + const IntrinsicProcTable &); extern template void CheckSpecificationExpr(const Expr &x, parser::ContextualMessages &, const semantics::Scope &, - const IntrinsicProcTable &, SpecificationExprContext); + const IntrinsicProcTable &); extern template void CheckSpecificationExpr(const Expr &x, parser::ContextualMessages &, const semantics::Scope &, - const IntrinsicProcTable &, SpecificationExprContext); + const IntrinsicProcTable &); extern template void CheckSpecificationExpr( const std::optional> &x, parser::ContextualMessages &, - const semantics::Scope &, const IntrinsicProcTable &, - SpecificationExprContext); + const semantics::Scope &, const IntrinsicProcTable &); extern template void CheckSpecificationExpr( const std::optional> &x, parser::ContextualMessages &, - const semantics::Scope &, const IntrinsicProcTable &, - SpecificationExprContext); + const semantics::Scope &, const IntrinsicProcTable &); extern template void CheckSpecificationExpr( const std::optional> &x, parser::ContextualMessages &, const semantics::Scope &, - const IntrinsicProcTable &, SpecificationExprContext); + const IntrinsicProcTable &); // Simple contiguity (9.5.4) template diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp --- a/flang/lib/Evaluate/check-expression.cpp +++ b/flang/lib/Evaluate/check-expression.cpp @@ -191,10 +191,9 @@ public: using Result = std::optional; using Base = AnyTraverse; - explicit CheckSpecificationExprHelper(const semantics::Scope &s, - const IntrinsicProcTable &table, SpecificationExprContext specExprContext) - : Base{*this}, scope_{s}, table_{table}, specExprContext_{ - specExprContext} {} + explicit CheckSpecificationExprHelper( + const semantics::Scope &s, const IntrinsicProcTable &table) + : Base{*this}, scope_{s}, table_{table} {} using Base::operator(); Result operator()(const ProcedureDesignator &) const { @@ -205,8 +204,7 @@ Result operator()(const semantics::Symbol &symbol) const { if (semantics::IsNamedConstant(symbol)) { return std::nullopt; - } else if (scope_.IsDerivedType() && IsVariableName(symbol) && - specExprContext_ == SpecificationExprContext::BOUND) { // C750 + } else if (scope_.IsDerivedType() && IsVariableName(symbol)) { // C750, C754 return "derived type component not allowed to reference variable '"s + symbol.name().ToString() + "'"; } else if (symbol.IsDummy()) { @@ -256,8 +254,7 @@ template Result operator()(const TypeParamInquiry &inq) const { if (scope_.IsDerivedType() && !IsConstantExpr(inq) && - inq.parameter().owner() != scope_ && - specExprContext_ == SpecificationExprContext::BOUND) { // C750 + inq.parameter().owner() != scope_) { // C750, C754 return "non-constant reference to a type parameter inquiry " "not allowed for derived type components"; } @@ -274,16 +271,14 @@ return "reference to statement function '"s + symbol->name().ToString() + "'"; } - if (scope_.IsDerivedType() && - specExprContext_ == SpecificationExprContext::BOUND) { // C750 + if (scope_.IsDerivedType()) { // C750, C754 return "reference to function '"s + symbol->name().ToString() + "' not allowed for derived type components"; } // TODO: other checks for standard module procedures } else { const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())}; - if (scope_.IsDerivedType() && - specExprContext_ == SpecificationExprContext::BOUND) { // C750 + if (scope_.IsDerivedType()) { // C750, C754 if ((table_.IsIntrinsic(intrin.name) && badIntrinsicsForComponents_.find(intrin.name) != badIntrinsicsForComponents_.end()) || @@ -311,7 +306,6 @@ private: const semantics::Scope &scope_; const IntrinsicProcTable &table_; - const SpecificationExprContext specExprContext_; const std::set badIntrinsicsForComponents_{ "allocated", "associated", "extends_type_of", "present", "same_type_as"}; static bool IsProhibitedFunction(std::string name) { return false; } @@ -319,33 +313,30 @@ template void CheckSpecificationExpr(const A &x, parser::ContextualMessages &messages, - const semantics::Scope &scope, const IntrinsicProcTable &table, - SpecificationExprContext specExprContext) { - if (auto why{ - CheckSpecificationExprHelper{scope, table, specExprContext}(x)}) { + const semantics::Scope &scope, const IntrinsicProcTable &table) { + if (auto why{CheckSpecificationExprHelper{scope, table}(x)}) { messages.Say("Invalid specification expression: %s"_err_en_US, *why); } } template void CheckSpecificationExpr(const Expr &, parser::ContextualMessages &, const semantics::Scope &, - const IntrinsicProcTable &, SpecificationExprContext); + const IntrinsicProcTable &); template void CheckSpecificationExpr(const Expr &, parser::ContextualMessages &, const semantics::Scope &, - const IntrinsicProcTable &, SpecificationExprContext); + const IntrinsicProcTable &); template void CheckSpecificationExpr(const Expr &, parser::ContextualMessages &, const semantics::Scope &, - const IntrinsicProcTable &, SpecificationExprContext); + const IntrinsicProcTable &); template void CheckSpecificationExpr(const std::optional> &, parser::ContextualMessages &, const semantics::Scope &, - const IntrinsicProcTable &, SpecificationExprContext); + const IntrinsicProcTable &); template void CheckSpecificationExpr(const std::optional> &, parser::ContextualMessages &, const semantics::Scope &, - const IntrinsicProcTable &, SpecificationExprContext); + const IntrinsicProcTable &); template void CheckSpecificationExpr( const std::optional> &, parser::ContextualMessages &, - const semantics::Scope &, const IntrinsicProcTable &, - SpecificationExprContext); + const semantics::Scope &, const IntrinsicProcTable &); // IsSimplyContiguous() -- 9.5.4 class IsSimplyContiguousHelper diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -33,10 +33,7 @@ void Check() { Check(context_.globalScope()); } void Check(const ParamValue &, bool canBeAssumed); - void Check(const Bound &bound) { - CheckSpecExpr( - bound.GetExplicit(), evaluate::SpecificationExprContext::BOUND); - } + void Check(const Bound &bound) { CheckSpecExpr(bound.GetExplicit()); } void Check(const ShapeSpec &spec) { Check(spec.lbound()); Check(spec.ubound()); @@ -47,9 +44,7 @@ void Check(const Scope &); private: - template - void CheckSpecExpr( - const A &x, const evaluate::SpecificationExprContext specExprContext) { + template void CheckSpecExpr(const A &x) { if (symbolBeingChecked_ && IsSaved(*symbolBeingChecked_)) { if (!evaluate::IsConstantExpr(x)) { messages_.Say( @@ -58,22 +53,18 @@ } } else { evaluate::CheckSpecificationExpr( - x, messages_, DEREF(scope_), context_.intrinsics(), specExprContext); + x, messages_, DEREF(scope_), context_.intrinsics()); } } - template - void CheckSpecExpr(const std::optional &x, - const evaluate::SpecificationExprContext specExprContext) { + template void CheckSpecExpr(const std::optional &x) { if (x) { - CheckSpecExpr(*x, specExprContext); + CheckSpecExpr(*x); } } - template - void CheckSpecExpr( - A &x, const evaluate::SpecificationExprContext specExprContext) { + template void CheckSpecExpr(A &x) { x = Fold(foldingContext_, std::move(x)); const A &constx{x}; - CheckSpecExpr(constx, specExprContext); + CheckSpecExpr(constx); } void CheckValue(const Symbol &, const DerivedTypeSpec *); void CheckVolatile( @@ -141,8 +132,7 @@ " external function result"_err_en_US); } } else { - CheckSpecExpr( - value.GetExplicit(), evaluate::SpecificationExprContext::TYPE_PARAM); + CheckSpecExpr(value.GetExplicit()); } } @@ -164,6 +154,7 @@ } void CheckHelper::Check(const Symbol &symbol) { + // xmark if (context_.HasError(symbol)) { return; } @@ -294,6 +285,13 @@ "A dummy argument may not have the SAVE attribute"_err_en_US); } } + if (symbol.owner().IsDerivedType()) { + if (symbol.attrs().test(Attr::CONTIGUOUS) && + !(IsPointer(symbol) && symbol.Rank() > 0)) { // C752 + messages_.Say( + "A CONTIGUOUS component must be an array with the POINTER attribute"_err_en_US); + } + } } void CheckHelper::CheckValue( @@ -1066,7 +1064,7 @@ void CheckHelper::CheckPointer(const Symbol &symbol) { // C852 CheckConflicting(symbol, Attr::POINTER, Attr::TARGET); - CheckConflicting(symbol, Attr::POINTER, Attr::ALLOCATABLE); + CheckConflicting(symbol, Attr::POINTER, Attr::ALLOCATABLE); // C751 CheckConflicting(symbol, Attr::POINTER, Attr::INTRINSIC); if (symbol.Corank() > 0) { messages_.Say( @@ -1076,6 +1074,7 @@ } // C760 constraints on the passed-object dummy argument +// C757 constraints on procedure pointer components void CheckHelper::CheckPassArg( const Symbol &proc, const Symbol *interface, const WithPassArg &details) { if (proc.attrs().test(Attr::NOPASS)) { @@ -1117,7 +1116,7 @@ break; } } - if (!passArgIndex) { + if (!passArgIndex) { // C758 messages_.Say(*passName, "'%s' is not a dummy argument of procedure interface '%s'"_err_en_US, *passName, interface->name()); diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -3906,7 +3906,18 @@ CHECK(!interfaceName_); return true; } -void DeclarationVisitor::Post(const parser::ProcComponentDefStmt &) { +void DeclarationVisitor::Post(const parser::ProcComponentDefStmt &stmt) { + const auto &attrList{ + std::get>(stmt.t)}; + bool foundPointer{false}; + for (const auto &attr : attrList) { + if (std::get_if(&attr.u)) { + foundPointer = true; + } + } + if (!foundPointer) { // C756 + Say("A procedure component must have the POINTER attribute"_err_en_US); + } interfaceName_ = nullptr; } bool DeclarationVisitor::Pre(const parser::ProcPointerInit &x) { @@ -4682,7 +4693,7 @@ SetType(name, currScope().MakeCharacterType(std::move(length), std::move(kind))); return; - } else { + } else { // C753 Say(name, "A length specifier cannot be used to declare the non-character entity '%s'"_err_en_US); } diff --git a/flang/test/Semantics/assign02.f90 b/flang/test/Semantics/assign02.f90 --- a/flang/test/Semantics/assign02.f90 +++ b/flang/test/Semantics/assign02.f90 @@ -11,7 +11,7 @@ end type contains - ! C853 + ! C852 subroutine s0 !ERROR: 'p1' may not have both the POINTER and TARGET attributes real, pointer :: p1, p3 diff --git a/flang/test/Semantics/resolve31.f90 b/flang/test/Semantics/resolve31.f90 --- a/flang/test/Semantics/resolve31.f90 +++ b/flang/test/Semantics/resolve31.f90 @@ -84,7 +84,7 @@ !ERROR: A sequence type data component must either be of an intrinsic type or a derived sequence type type(plainType) :: testField1 type(sequenceType) :: testField2 - procedure(real), nopass :: procField + procedure(real), pointer, nopass :: procField end type testType !ERROR: A sequence type may not have type parameters type :: paramType(param) diff --git a/flang/test/Semantics/resolve33.f90 b/flang/test/Semantics/resolve33.f90 --- a/flang/test/Semantics/resolve33.f90 +++ b/flang/test/Semantics/resolve33.f90 @@ -40,6 +40,7 @@ !ERROR: No definition found for type parameter 'l' type :: t6(k, l) !ERROR: Must be a constant value + !ERROR: Invalid specification expression: derived type component not allowed to reference variable 'l' character(kind=k, len=l) :: d3 end type type(t6(2, 10)) :: x3 diff --git a/flang/test/Semantics/resolve52.f90 b/flang/test/Semantics/resolve52.f90 --- a/flang/test/Semantics/resolve52.f90 +++ b/flang/test/Semantics/resolve52.f90 @@ -5,6 +5,13 @@ ! 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. +! +! C757 If the procedure pointer component has an implicit interface or has no +! arguments, NOPASS shall be specified. +! +! C758 If PASS (arg-name) appears, the interface of the procedure pointer +! component shall have a dummy argument named arg-name. + module m1 type :: t diff --git a/flang/test/Semantics/resolve79.f90 b/flang/test/Semantics/resolve79.f90 --- a/flang/test/Semantics/resolve79.f90 +++ b/flang/test/Semantics/resolve79.f90 @@ -24,6 +24,8 @@ procedure(passNopassProc), pass, pointer, nopass :: passNopassField !WARNING: Attribute 'POINTER' cannot be used more than once procedure(pointerProc), pointer, public, pointer :: pointerField + !ERROR: A procedure component must have the POINTER attribute + procedure(publicProc), public :: nonpointerField contains procedure :: noPassProc procedure :: passProc diff --git a/flang/test/Semantics/resolve89.f90 b/flang/test/Semantics/resolve89.f90 --- a/flang/test/Semantics/resolve89.f90 +++ b/flang/test/Semantics/resolve89.f90 @@ -1,9 +1,15 @@ ! RUN: %S/test_errors.sh %s %t %f18 ! C750 Each bound in the explicit-shape-spec shall be a specification ! expression in which there are no references to specification functions or -! the intrinsic functions ALLOCATED, ASSOCIATED, EXTENDS_- TYPE_OF, PRESENT, +! the intrinsic functions ALLOCATED, ASSOCIATED, EXTENDS_TYPE_OF, PRESENT, ! or SAME_TYPE_AS, every specification inquiry reference is a constant ! expression, and the value does not depend on the value of a variable. +! +! C754 Each type-param-value within a component-def-stmt shall be a colon or +! a specification expression in which there are no references to specification +! functions or the intrinsic functions ALLOCATED, ASSOCIATED, EXTENDS_TYPE_OF, +! PRESENT, or SAME_TYPE_AS, every specification inquiry reference is a +! constant expression, and the value does not depend on the value of a variable. impure function impureFunc() integer :: impureFunc @@ -21,6 +27,7 @@ end module m subroutine s(iArg, allocArg, pointerArg, arrayArg, ioArg, optionalArg) +! C750 use m implicit logical(l) integer, intent(in) :: iArg @@ -108,3 +115,42 @@ integer, dimension(derivedArg%kindParam) :: localVar end subroutine inner end subroutine s1 + +subroutine s2(iArg, allocArg, pointerArg, arrayArg, optionalArg) + ! C754 + integer, intent(in) :: iArg + real, allocatable, intent(in) :: allocArg + real, pointer, intent(in) :: pointerArg + integer, dimension(:), intent(in) :: arrayArg + real, optional, intent(in) :: optionalArg + + type paramType(lenParam) + integer, len :: lenParam = 4 + end type paramType + + type charType + !ERROR: Invalid specification expression: derived type component not allowed to reference variable 'iarg' + character(iabs(iArg)) :: fieldWithIntrinsic + !ERROR: Invalid specification expression: reference to intrinsic 'allocated' not allowed for derived type components + character(merge(1, 2, allocated(allocArg))) :: allocField + !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components + character(merge(1, 2, associated(pointerArg))) :: assocField + !ERROR: Invalid specification expression: non-constant reference to inquiry intrinsic 'is_contiguous' not allowed for derived type components + character(merge(1, 2, is_contiguous(arrayArg))) :: contigField + !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components + character(merge(1, 2, present(optionalArg))) :: presentField + end type charType + + type derivedType + !ERROR: Invalid specification expression: derived type component not allowed to reference variable 'iarg' + type(paramType(iabs(iArg))) :: fieldWithIntrinsic + !ERROR: Invalid specification expression: reference to intrinsic 'allocated' not allowed for derived type components + type(paramType(merge(1, 2, allocated(allocArg)))) :: allocField + !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components + type(paramType(merge(1, 2, associated(pointerArg)))) :: assocField + !ERROR: Invalid specification expression: non-constant reference to inquiry intrinsic 'is_contiguous' not allowed for derived type components + type(paramType(merge(1, 2, is_contiguous(arrayArg)))) :: contigField + !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components + type(paramType(merge(1, 2, present(optionalArg)))) :: presentField + end type derivedType +end subroutine s2 diff --git a/flang/test/Semantics/resolve90.f90 b/flang/test/Semantics/resolve90.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/resolve90.f90 @@ -0,0 +1,18 @@ +! RUN: %S/test_errors.sh %s %t %f18 +! C751 A component shall not have both the ALLOCATABLE and POINTER attributes. +! C752 If the CONTIGUOUS attribute is specified, the component shall be an +! array with the POINTER attribute. +! C753 The * char-length option is permitted only if the component is of type +! character. +subroutine s() + type derivedType + !ERROR: 'pointerallocatablefield' may not have both the POINTER and ALLOCATABLE attributes + real, pointer, allocatable :: pointerAllocatableField + real, dimension(:), contiguous, pointer :: goodContigField + !ERROR: A CONTIGUOUS component must be an array with the POINTER attribute + real, dimension(:), contiguous, allocatable :: badContigField + character :: charField * 3 + !ERROR: A length specifier cannot be used to declare the non-character entity 'realfield' + real :: realField * 3 + end type derivedType +end subroutine s