[flang-commits] [flang] 3809554 - [flang] Constraint checks C751 to C760
Pete Steinfeld via flang-commits
flang-commits at lists.llvm.org
Fri May 15 19:05:25 PDT 2020
Author: Pete Steinfeld
Date: 2020-05-15T18:50:14-07:00
New Revision: 38095549c6a12a75794595464fa9b95f5c6dcf35
URL: https://github.com/llvm/llvm-project/commit/38095549c6a12a75794595464fa9b95f5c6dcf35
DIFF: https://github.com/llvm/llvm-project/commit/38095549c6a12a75794595464fa9b95f5c6dcf35.diff
LOG: [flang] Constraint checks C751 to C760
Summary:
Many of these were already implemented, and I just annotated the tests and/or
the code.
C752 was a simple check to verify that CONTIGUOUS components are arrays with
C754 proved to be virtually identical to C750 that I implemented previously.
This caused me to remove the distinction between specification expressions for
type parameters and bounds expressions that I'd previously created.
the POINTER attribute.
I also changed the error messages to specify that errors in specification
expressions could arise from either bad derived type components or type
parameters.
In cases where we detect a type param that was not declared, I created a symbol
marked as erroneous. That avoids subsequent semantic process for expressions
containing the symbol. This change caused me to adjust tests resolve33.f90 and
resolve34.f90. Also, I avoided putting out error messages for erroneous type
param symbols in `OkToAddComponent()` in resolve-names.cpp and in
`EvaluateParameters()`, type.cpp.
C756 checks that procedure components have the POINTER attribute.
Reviewers: tskeith, klausler, DavidTruby
Subscribers: llvm-commits
Tags: #llvm, #flang
Differential Revision: https://reviews.llvm.org/D79798
Added:
flang/test/Semantics/resolve90.f90
Modified:
flang/include/flang/Evaluate/check-expression.h
flang/lib/Evaluate/check-expression.cpp
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/type.cpp
flang/test/Semantics/assign02.f90
flang/test/Semantics/resolve31.f90
flang/test/Semantics/resolve33.f90
flang/test/Semantics/resolve34.f90
flang/test/Semantics/resolve52.f90
flang/test/Semantics/resolve79.f90
flang/test/Semantics/resolve89.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/check-expression.h b/flang/include/flang/Evaluate/check-expression.h
index b14a47838e3a..16fe0bf11ae3 100644
--- a/flang/include/flang/Evaluate/check-expression.h
+++ b/flang/include/flang/Evaluate/check-expression.h
@@ -43,37 +43,28 @@ bool IsInitialDataTarget(
// (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
diff erentiate 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 <typename A>
void CheckSpecificationExpr(const A &, parser::ContextualMessages &,
- const semantics::Scope &, const IntrinsicProcTable &,
- SpecificationExprContext);
+ const semantics::Scope &, const IntrinsicProcTable &);
extern template void CheckSpecificationExpr(const Expr<SomeType> &x,
parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &, SpecificationExprContext);
+ const IntrinsicProcTable &);
extern template void CheckSpecificationExpr(const Expr<SomeInteger> &x,
parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &, SpecificationExprContext);
+ const IntrinsicProcTable &);
extern template void CheckSpecificationExpr(const Expr<SubscriptInteger> &x,
parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &, SpecificationExprContext);
+ const IntrinsicProcTable &);
extern template void CheckSpecificationExpr(
const std::optional<Expr<SomeType>> &x, parser::ContextualMessages &,
- const semantics::Scope &, const IntrinsicProcTable &,
- SpecificationExprContext);
+ const semantics::Scope &, const IntrinsicProcTable &);
extern template void CheckSpecificationExpr(
const std::optional<Expr<SomeInteger>> &x, parser::ContextualMessages &,
- const semantics::Scope &, const IntrinsicProcTable &,
- SpecificationExprContext);
+ const semantics::Scope &, const IntrinsicProcTable &);
extern template void CheckSpecificationExpr(
const std::optional<Expr<SubscriptInteger>> &x,
parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &, SpecificationExprContext);
+ const IntrinsicProcTable &);
// Simple contiguity (9.5.4)
template <typename A>
diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index 923e814fc59b..6c8db0fe2419 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -191,10 +191,9 @@ class CheckSpecificationExprHelper
public:
using Result = std::optional<std::string>;
using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;
- 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 @@ class CheckSpecificationExprHelper
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 @@ class CheckSpecificationExprHelper
template <int KIND>
Result operator()(const TypeParamInquiry<KIND> &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 @@ class CheckSpecificationExprHelper
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 @@ class CheckSpecificationExprHelper
private:
const semantics::Scope &scope_;
const IntrinsicProcTable &table_;
- const SpecificationExprContext specExprContext_;
const std::set<std::string> badIntrinsicsForComponents_{
"allocated", "associated", "extends_type_of", "present", "same_type_as"};
static bool IsProhibitedFunction(std::string name) { return false; }
@@ -319,33 +318,30 @@ class CheckSpecificationExprHelper
template <typename A>
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<SomeType> &,
parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &, SpecificationExprContext);
+ const IntrinsicProcTable &);
template void CheckSpecificationExpr(const Expr<SomeInteger> &,
parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &, SpecificationExprContext);
+ const IntrinsicProcTable &);
template void CheckSpecificationExpr(const Expr<SubscriptInteger> &,
parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &, SpecificationExprContext);
+ const IntrinsicProcTable &);
template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &, SpecificationExprContext);
+ const IntrinsicProcTable &);
template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
parser::ContextualMessages &, const semantics::Scope &,
- const IntrinsicProcTable &, SpecificationExprContext);
+ const IntrinsicProcTable &);
template void CheckSpecificationExpr(
const std::optional<Expr<SubscriptInteger>> &, 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
index edbd01d4eca0..e29cdcae0447 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -33,10 +33,7 @@ class CheckHelper {
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 @@ class CheckHelper {
void Check(const Scope &);
private:
- template <typename A>
- void CheckSpecExpr(
- const A &x, const evaluate::SpecificationExprContext specExprContext) {
+ template <typename A> void CheckSpecExpr(const A &x) {
if (symbolBeingChecked_ && IsSaved(*symbolBeingChecked_)) {
if (!evaluate::IsConstantExpr(x)) {
messages_.Say(
@@ -58,22 +53,18 @@ class CheckHelper {
}
} else {
evaluate::CheckSpecificationExpr(
- x, messages_, DEREF(scope_), context_.intrinsics(), specExprContext);
+ x, messages_, DEREF(scope_), context_.intrinsics());
}
}
- template <typename A>
- void CheckSpecExpr(const std::optional<A> &x,
- const evaluate::SpecificationExprContext specExprContext) {
+ template <typename A> void CheckSpecExpr(const std::optional<A> &x) {
if (x) {
- CheckSpecExpr(*x, specExprContext);
+ CheckSpecExpr(*x);
}
}
- template <typename A>
- void CheckSpecExpr(
- A &x, const evaluate::SpecificationExprContext specExprContext) {
+ template <typename A> 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 @@ void CheckHelper::Check(const ParamValue &value, bool canBeAssumed) {
" external function result"_err_en_US);
}
} else {
- CheckSpecExpr(
- value.GetExplicit(), evaluate::SpecificationExprContext::TYPE_PARAM);
+ CheckSpecExpr(value.GetExplicit());
}
}
@@ -294,6 +284,12 @@ void CheckHelper::Check(const Symbol &symbol) {
"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 @@ void CheckHelper::CheckProcEntity(
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::CheckVolatile(const Symbol &symbol, bool isAssociated,
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 @@ void CheckHelper::CheckPointer(const Symbol &symbol) { // C852
}
// 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 @@ void CheckHelper::CheckPassArg(
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
index f4768bc426c2..175d02597dfa 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -3671,6 +3671,13 @@ bool DeclarationVisitor::Pre(const parser::DerivedTypeDef &x) {
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<TypeParamDetails>()) {
Say2(paramName, "'%s' is not defined as a type parameter"_err_en_US,
*symbol, "Definition of '%s'"_en_US); // C741
@@ -3906,7 +3913,7 @@ bool DeclarationVisitor::Pre(const parser::ProcComponentDefStmt &) {
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 @@ void DeclarationVisitor::SetType(
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 @@ bool DeclarationVisitor::OkToAddComponent(
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
index c02ab6b6afd3..d8c817bd92cc 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -123,9 +123,12 @@ void DerivedTypeSpec::EvaluateParameters(
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 @@ void DerivedTypeSpec::EvaluateParameters(
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
index caf5b6ed9f1f..292a6d42ff98 100644
--- a/flang/test/Semantics/assign02.f90
+++ b/flang/test/Semantics/assign02.f90
@@ -11,7 +11,7 @@ module m1
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
index a668e6877a08..f22f7e5af29e 100644
--- a/flang/test/Semantics/resolve31.f90
+++ b/flang/test/Semantics/resolve31.f90
@@ -84,7 +84,7 @@ module m4
!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
index 6f4f7b066c3a..380a1ab2b8a7 100644
--- a/flang/test/Semantics/resolve33.f90
+++ b/flang/test/Semantics/resolve33.f90
@@ -39,7 +39,6 @@ module m
!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
index 783336614069..93dcd2a43420 100644
--- a/flang/test/Semantics/resolve34.f90
+++ b/flang/test/Semantics/resolve34.f90
@@ -27,9 +27,13 @@ module m3
!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
index 6f684e845918..0b3ebd0dc104 100644
--- 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
index a010324dc23d..1545aad97dbb 100644
--- a/flang/test/Semantics/resolve79.f90
+++ b/flang/test/Semantics/resolve79.f90
@@ -24,6 +24,8 @@ module m
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
index fd9488ff0b01..f3bf218fdce7 100644
--- 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 @@ module m
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 @@ subroutine s(iArg, allocArg, pointerArg, arrayArg, ioArg, optionalArg)
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 @@ subroutine s(iArg, allocArg, pointerArg, arrayArg, ioArg, optionalArg)
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 @@ subroutine inner (derivedArg)
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 @@ subroutine inner (derivedArg)
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
index 000000000000..3260ee983fb9
--- /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
More information about the flang-commits
mailing list