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,9 +204,9 @@ Result operator()(const semantics::Symbol &symbol) const { if (semantics::IsNamedConstant(symbol)) { return std::nullopt; - } else if (scope_.IsDerivedType() && IsVariableName(symbol) && - specExprContext_ == SpecificationExprContext::BOUND) { // C750 - return "derived type component not allowed to reference variable '"s + + } else if (scope_.IsDerivedType() && IsVariableName(symbol)) { // C750, C754 + return "derived type component or type parameter value not allowed to " + "reference variable '"s + symbol.name().ToString() + "'"; } else if (symbol.IsDummy()) { if (symbol.attrs().test(semantics::Attr::OPTIONAL)) { @@ -256,10 +255,9 @@ template Result operator()(const TypeParamInquiry &inq) const { if (scope_.IsDerivedType() && !IsConstantExpr(inq) && - inq.parameter().owner() != scope_ && - specExprContext_ == SpecificationExprContext::BOUND) { // C750 - return "non-constant reference to a type parameter inquiry " - "not allowed for derived type components"; + inq.parameter().owner() != scope_) { // C750, C754 + return "non-constant reference to a type parameter inquiry not " + "allowed for derived type components or type parameter values"; } return std::nullopt; } @@ -274,28 +272,30 @@ 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"; + "' not allowed for derived type components or type parameter" + " values"; } // 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()) || IsProhibitedFunction(intrin.name)) { return "reference to intrinsic '"s + intrin.name + - "' not allowed for derived type components"; + "' not allowed for derived type components or type parameter" + " values"; } if (table_.GetIntrinsicClass(intrin.name) == IntrinsicClass::inquiryFunction && !IsConstantExpr(x)) { return "non-constant reference to inquiry intrinsic '"s + - intrin.name + "' not allowed for derived type components"; + intrin.name + + "' not allowed for derived type components or type" + " parameter values"; } } else if (intrin.name == "present") { return std::nullopt; // no need to check argument(s) @@ -311,7 +311,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 +318,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()); } } @@ -294,6 +284,12 @@ "A dummy argument may not have the SAVE attribute"_err_en_US); } } + if (symbol.owner().IsDerivedType() && + (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( @@ -584,6 +580,12 @@ messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US); } } else if (symbol.owner().IsDerivedType()) { + if (!symbol.attrs().test(Attr::POINTER)) { // C756 + const auto &name{symbol.name()}; + messages_.Say(name, + "Procedure component '%s' must have POINTER attribute"_err_en_US, + name); + } CheckPassArg(symbol, details.interface().symbol(), details); } if (symbol.attrs().test(Attr::POINTER)) { @@ -1066,7 +1068,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 +1078,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 +1120,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 @@ -3671,6 +3671,13 @@ if (!symbol) { Say(paramName, "No definition found for type parameter '%s'"_err_en_US); // C742 + // No symbol for a type param. Create one and mark it as containing an + // error to improve subsequent semantic processing + BeginAttrs(); + Symbol *typeParam{MakeTypeSymbol( + paramName, TypeParamDetails{common::TypeParamAttr::Len})}; + typeParam->set(Symbol::Flag::Error); + EndAttrs(); } else if (!symbol->has()) { Say2(paramName, "'%s' is not defined as a type parameter"_err_en_US, *symbol, "Definition of '%s'"_en_US); // C741 @@ -3906,7 +3913,7 @@ CHECK(!interfaceName_); return true; } -void DeclarationVisitor::Post(const parser::ProcComponentDefStmt &) { +void DeclarationVisitor::Post(const parser::ProcComponentDefStmt &stmt) { interfaceName_ = nullptr; } bool DeclarationVisitor::Pre(const parser::ProcPointerInit &x) { @@ -4682,7 +4689,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); } @@ -4810,21 +4817,23 @@ for (const Scope *scope{&currScope()}; scope;) { CHECK(scope->IsDerivedType()); if (auto *prev{FindInScope(*scope, name)}) { - auto msg{""_en_US}; - if (extends) { - msg = "Type cannot be extended as it has a component named" - " '%s'"_err_en_US; - } else if (prev->test(Symbol::Flag::ParentComp)) { - msg = "'%s' is a parent type of this type and so cannot be" - " a component"_err_en_US; - } else if (scope != &currScope()) { - msg = "Component '%s' is already declared in a parent of this" - " derived type"_err_en_US; - } else { - msg = "Component '%s' is already declared in this" - " derived type"_err_en_US; + if (!prev->test(Symbol::Flag::Error)) { + auto msg{""_en_US}; + if (extends) { + msg = "Type cannot be extended as it has a component named" + " '%s'"_err_en_US; + } else if (prev->test(Symbol::Flag::ParentComp)) { + msg = "'%s' is a parent type of this type and so cannot be" + " a component"_err_en_US; + } else if (scope != &currScope()) { + msg = "Component '%s' is already declared in a parent of this" + " derived type"_err_en_US; + } else { + msg = "Component '%s' is already declared in this" + " derived type"_err_en_US; + } + Say2(name, std::move(msg), *prev, "Previous declaration of '%s'"_en_US); } - Say2(name, std::move(msg), *prev, "Previous declaration of '%s'"_en_US); return false; } if (scope == &currScope() && extends) { diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp --- a/flang/lib/Semantics/type.cpp +++ b/flang/lib/Semantics/type.cpp @@ -123,9 +123,12 @@ continue; } } - evaluate::SayWithDeclaration(messages, symbol, - "Value of type parameter '%s' (%s) is not convertible to its type"_err_en_US, - name, expr->AsFortran()); + if (!symbol.test(Symbol::Flag::Error)) { + evaluate::SayWithDeclaration(messages, symbol, + "Value of type parameter '%s' (%s) is not convertible to its" + " type"_err_en_US, + name, expr->AsFortran()); + } } } } @@ -147,7 +150,7 @@ auto expr{ evaluate::Fold(foldingContext, common::Clone(details.init()))}; AddParamValue(name, ParamValue{std::move(*expr), details.attr()}); - } else { + } else if (!symbol.test(Symbol::Flag::Error)) { messages.Say(name_, "Type parameter '%s' lacks a value and has no default"_err_en_US, name); 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 @@ -39,7 +39,6 @@ !ERROR: No definition found for type parameter 'k' !ERROR: No definition found for type parameter 'l' type :: t6(k, l) - !ERROR: Must be a constant value character(kind=k, len=l) :: d3 end type type(t6(2, 10)) :: x3 diff --git a/flang/test/Semantics/resolve34.f90 b/flang/test/Semantics/resolve34.f90 --- a/flang/test/Semantics/resolve34.f90 +++ b/flang/test/Semantics/resolve34.f90 @@ -27,9 +27,13 @@ !ERROR: 't1' is a parent type of this type and so cannot be a component real :: t1 end type - type, extends(t2) :: t3 - !ERROR: 't1' is a parent type of this type and so cannot be a component - real :: t1 + type :: t3 + end type + type, extends(t3) :: t4 + end type + type, extends(t4) :: t5 + !ERROR: 't3' is a parent type of this type and so cannot be a component + real :: t3 end type end 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: Procedure component 'nonpointerfield' must have 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 @@ -58,7 +65,7 @@ real, dimension(iabs(iArg)) :: arrayVarWithIntrinsic type arrayType - !ERROR: Invalid specification expression: derived type component not allowed to reference variable 'var' + !ERROR: Invalid specification expression: derived type component or type parameter value not allowed to reference variable 'var' real, dimension(var) :: varField !ERROR: Invalid specification expression: reference to impure function 'ivolatilestmtfunc' real, dimension(iVolatileStmtFunc()) :: arrayFieldWithVolatile @@ -66,17 +73,17 @@ real, dimension(iImpureStmtFunc()) :: arrayFieldWithImpureFunction !ERROR: Invalid specification expression: reference to statement function 'ipurestmtfunc' real, dimension(iPureStmtFunc()) :: arrayFieldWithPureFunction - !ERROR: Invalid specification expression: derived type component not allowed to reference variable 'iarg' + !ERROR: Invalid specification expression: derived type component or type parameter value not allowed to reference variable 'iarg' real, dimension(iabs(iArg)) :: arrayFieldWithIntrinsic - !ERROR: Invalid specification expression: reference to intrinsic 'allocated' not allowed for derived type components + !ERROR: Invalid specification expression: reference to intrinsic 'allocated' not allowed for derived type components or type parameter values real, dimension(merge(1, 2, allocated(allocArg))) :: realField1 - !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components + !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components or type parameter values real, dimension(merge(1, 2, associated(pointerArg))) :: realField2 - !ERROR: Invalid specification expression: non-constant reference to inquiry intrinsic 'is_contiguous' not allowed for derived type components + !ERROR: Invalid specification expression: non-constant reference to inquiry intrinsic 'is_contiguous' not allowed for derived type components or type parameter values real, dimension(merge(1, 2, is_contiguous(arrayArg))) :: realField3 - !ERROR: Invalid specification expression: derived type component not allowed to reference variable 'ioarg' + !ERROR: Invalid specification expression: derived type component or type parameter value not allowed to reference variable 'ioarg' real, dimension(ioArg) :: realField4 - !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components + !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components or type parameter values real, dimension(merge(1, 2, present(optionalArg))) :: realField5 end type arrayType @@ -100,7 +107,7 @@ type localDerivedType ! OK because the specification inquiry is a constant integer, dimension(localDerived%kindParam) :: goodField - !ERROR: Invalid specification expression: non-constant reference to a type parameter inquiry not allowed for derived type components + !ERROR: Invalid specification expression: non-constant reference to a type parameter inquiry not allowed for derived type components or type parameter values integer, dimension(derivedArg%lenParam) :: badField end type localDerivedType @@ -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 or type parameter value not allowed to reference variable 'iarg' + character(iabs(iArg)) :: fieldWithIntrinsic + !ERROR: Invalid specification expression: reference to intrinsic 'allocated' not allowed for derived type components or type parameter values + character(merge(1, 2, allocated(allocArg))) :: allocField + !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components or type parameter values + 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 or type parameter values + character(merge(1, 2, is_contiguous(arrayArg))) :: contigField + !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components or type parameter values + character(merge(1, 2, present(optionalArg))) :: presentField + end type charType + + type derivedType + !ERROR: Invalid specification expression: derived type component or type parameter value 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 or type parameter values + type(paramType(merge(1, 2, allocated(allocArg)))) :: allocField + !ERROR: Invalid specification expression: reference to intrinsic 'associated' not allowed for derived type components or type parameter values + 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 or type parameter values + type(paramType(merge(1, 2, is_contiguous(arrayArg)))) :: contigField + !ERROR: Invalid specification expression: reference to intrinsic 'present' not allowed for derived type components or type parameter values + 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