replica
/
hanchenye-llvm-project
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[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
This commit is contained in:
Pete Steinfeld 2020-05-12 09:53:58 -07:00
parent 7af0c8559b
commit 38095549c6
13 changed files with 179 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
flang/include/flang/Evaluate/check-expression.h
View File

@ -43,37 +43,28 @@ bool IsInitialDataTarget(
// (10.1.11(2), C1010). Constant expressions are always valid // (10.1.11(2), C1010). Constant expressions are always valid
// specification expressions. // 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 <typename A> template <typename A>
void CheckSpecificationExpr(const A &, parser::ContextualMessages &, void CheckSpecificationExpr(const A &, parser::ContextualMessages &,
const semantics::Scope &, const IntrinsicProcTable &, const semantics::Scope &, const IntrinsicProcTable &);
SpecificationExprContext);
extern template void CheckSpecificationExpr(const Expr<SomeType> &x, extern template void CheckSpecificationExpr(const Expr<SomeType> &x,
parser::ContextualMessages &, const semantics::Scope &, parser::ContextualMessages &, const semantics::Scope &,
const IntrinsicProcTable &, SpecificationExprContext); const IntrinsicProcTable &);
extern template void CheckSpecificationExpr(const Expr<SomeInteger> &x, extern template void CheckSpecificationExpr(const Expr<SomeInteger> &x,
parser::ContextualMessages &, const semantics::Scope &, parser::ContextualMessages &, const semantics::Scope &,
const IntrinsicProcTable &, SpecificationExprContext); const IntrinsicProcTable &);
extern template void CheckSpecificationExpr(const Expr<SubscriptInteger> &x, extern template void CheckSpecificationExpr(const Expr<SubscriptInteger> &x,
parser::ContextualMessages &, const semantics::Scope &, parser::ContextualMessages &, const semantics::Scope &,
const IntrinsicProcTable &, SpecificationExprContext); const IntrinsicProcTable &);
extern template void CheckSpecificationExpr( extern template void CheckSpecificationExpr(
const std::optional<Expr<SomeType>> &x, parser::ContextualMessages &, const std::optional<Expr<SomeType>> &x, parser::ContextualMessages &,
const semantics::Scope &, const IntrinsicProcTable &, const semantics::Scope &, const IntrinsicProcTable &);
SpecificationExprContext);
extern template void CheckSpecificationExpr( extern template void CheckSpecificationExpr(
const std::optional<Expr<SomeInteger>> &x, parser::ContextualMessages &, const std::optional<Expr<SomeInteger>> &x, parser::ContextualMessages &,
const semantics::Scope &, const IntrinsicProcTable &, const semantics::Scope &, const IntrinsicProcTable &);
SpecificationExprContext);
extern template void CheckSpecificationExpr( extern template void CheckSpecificationExpr(
const std::optional<Expr<SubscriptInteger>> &x, const std::optional<Expr<SubscriptInteger>> &x,
parser::ContextualMessages &, const semantics::Scope &, parser::ContextualMessages &, const semantics::Scope &,
const IntrinsicProcTable &, SpecificationExprContext); const IntrinsicProcTable &);
// Simple contiguity (9.5.4) // Simple contiguity (9.5.4)
template <typename A> template <typename A>

56
flang/lib/Evaluate/check-expression.cpp
View File

@ -191,10 +191,9 @@ class CheckSpecificationExprHelper
public: public:
using Result = std::optional<std::string>; using Result = std::optional<std::string>;
using Base = AnyTraverse<CheckSpecificationExprHelper, Result>; using Base = AnyTraverse<CheckSpecificationExprHelper, Result>;
explicit CheckSpecificationExprHelper(const semantics::Scope &s, explicit CheckSpecificationExprHelper(
const IntrinsicProcTable &table, SpecificationExprContext specExprContext) const semantics::Scope &s, const IntrinsicProcTable &table)
: Base{*this}, scope_{s}, table_{table}, specExprContext_{ : Base{*this}, scope_{s}, table_{table} {}
specExprContext} {}
using Base::operator(); using Base::operator();
Result operator()(const ProcedureDesignator &) const { Result operator()(const ProcedureDesignator &) const {
@ -205,9 +204,9 @@ public:
Result operator()(const semantics::Symbol &symbol) const { Result operator()(const semantics::Symbol &symbol) const {
if (semantics::IsNamedConstant(symbol)) { if (semantics::IsNamedConstant(symbol)) {
return std::nullopt; return std::nullopt;
} else if (scope_.IsDerivedType() && IsVariableName(symbol) && } else if (scope_.IsDerivedType() && IsVariableName(symbol)) { // C750, C754
specExprContext_ == SpecificationExprContext::BOUND) { // C750 return "derived type component or type parameter value not allowed to "
return "derived type component not allowed to reference variable '"s + "reference variable '"s +
symbol.name().ToString() + "'"; symbol.name().ToString() + "'";
} else if (symbol.IsDummy()) { } else if (symbol.IsDummy()) {
if (symbol.attrs().test(semantics::Attr::OPTIONAL)) { if (symbol.attrs().test(semantics::Attr::OPTIONAL)) {
@ -256,10 +255,9 @@ public:
template <int KIND> template <int KIND>
Result operator()(const TypeParamInquiry<KIND> &inq) const { Result operator()(const TypeParamInquiry<KIND> &inq) const {
if (scope_.IsDerivedType() && !IsConstantExpr(inq) && if (scope_.IsDerivedType() && !IsConstantExpr(inq) &&
inq.parameter().owner() != scope_ && inq.parameter().owner() != scope_) { // C750, C754
specExprContext_ == SpecificationExprContext::BOUND) { // C750 return "non-constant reference to a type parameter inquiry not "
return "non-constant reference to a type parameter inquiry " "allowed for derived type components or type parameter values";
"not allowed for derived type components";
} }
return std::nullopt; return std::nullopt;
} }
@ -274,28 +272,30 @@ public:
return "reference to statement function '"s + return "reference to statement function '"s +
symbol->name().ToString() + "'"; symbol->name().ToString() + "'";
} }
if (scope_.IsDerivedType() && if (scope_.IsDerivedType()) { // C750, C754
specExprContext_ == SpecificationExprContext::BOUND) { // C750
return "reference to function '"s + symbol->name().ToString() + 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 // TODO: other checks for standard module procedures
} else { } else {
const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())}; const SpecificIntrinsic &intrin{DEREF(x.proc().GetSpecificIntrinsic())};
if (scope_.IsDerivedType() && if (scope_.IsDerivedType()) { // C750, C754
specExprContext_ == SpecificationExprContext::BOUND) { // C750
if ((table_.IsIntrinsic(intrin.name) && if ((table_.IsIntrinsic(intrin.name) &&
badIntrinsicsForComponents_.find(intrin.name) != badIntrinsicsForComponents_.find(intrin.name) !=
badIntrinsicsForComponents_.end()) || badIntrinsicsForComponents_.end()) ||
IsProhibitedFunction(intrin.name)) { IsProhibitedFunction(intrin.name)) {
return "reference to intrinsic '"s + 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) == if (table_.GetIntrinsicClass(intrin.name) ==
IntrinsicClass::inquiryFunction && IntrinsicClass::inquiryFunction &&
!IsConstantExpr(x)) { !IsConstantExpr(x)) {
return "non-constant reference to inquiry intrinsic '"s + 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") { } else if (intrin.name == "present") {
return std::nullopt; // no need to check argument(s) return std::nullopt; // no need to check argument(s)
@ -311,7 +311,6 @@ public:
private: private:
const semantics::Scope &scope_; const semantics::Scope &scope_;
const IntrinsicProcTable &table_; const IntrinsicProcTable &table_;
const SpecificationExprContext specExprContext_;
const std::set<std::string> badIntrinsicsForComponents_{ const std::set<std::string> badIntrinsicsForComponents_{
"allocated", "associated", "extends_type_of", "present", "same_type_as"}; "allocated", "associated", "extends_type_of", "present", "same_type_as"};
static bool IsProhibitedFunction(std::string name) { return false; } static bool IsProhibitedFunction(std::string name) { return false; }
@ -319,33 +318,30 @@ private:
template <typename A> template <typename A>
void CheckSpecificationExpr(const A &x, parser::ContextualMessages &messages, void CheckSpecificationExpr(const A &x, parser::ContextualMessages &messages,
const semantics::Scope &scope, const IntrinsicProcTable &table, const semantics::Scope &scope, const IntrinsicProcTable &table) {
SpecificationExprContext specExprContext) { if (auto why{CheckSpecificationExprHelper{scope, table}(x)}) {
if (auto why{
CheckSpecificationExprHelper{scope, table, specExprContext}(x)}) {
messages.Say("Invalid specification expression: %s"_err_en_US, *why); messages.Say("Invalid specification expression: %s"_err_en_US, *why);
} }
} }
template void CheckSpecificationExpr(const Expr<SomeType> &, template void CheckSpecificationExpr(const Expr<SomeType> &,
parser::ContextualMessages &, const semantics::Scope &, parser::ContextualMessages &, const semantics::Scope &,
const IntrinsicProcTable &, SpecificationExprContext); const IntrinsicProcTable &);
template void CheckSpecificationExpr(const Expr<SomeInteger> &, template void CheckSpecificationExpr(const Expr<SomeInteger> &,
parser::ContextualMessages &, const semantics::Scope &, parser::ContextualMessages &, const semantics::Scope &,
const IntrinsicProcTable &, SpecificationExprContext); const IntrinsicProcTable &);
template void CheckSpecificationExpr(const Expr<SubscriptInteger> &, template void CheckSpecificationExpr(const Expr<SubscriptInteger> &,
parser::ContextualMessages &, const semantics::Scope &, parser::ContextualMessages &, const semantics::Scope &,
const IntrinsicProcTable &, SpecificationExprContext); const IntrinsicProcTable &);
template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &, template void CheckSpecificationExpr(const std::optional<Expr<SomeType>> &,
parser::ContextualMessages &, const semantics::Scope &, parser::ContextualMessages &, const semantics::Scope &,
const IntrinsicProcTable &, SpecificationExprContext); const IntrinsicProcTable &);
template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &, template void CheckSpecificationExpr(const std::optional<Expr<SomeInteger>> &,
parser::ContextualMessages &, const semantics::Scope &, parser::ContextualMessages &, const semantics::Scope &,
const IntrinsicProcTable &, SpecificationExprContext); const IntrinsicProcTable &);
template void CheckSpecificationExpr( template void CheckSpecificationExpr(
const std::optional<Expr<SubscriptInteger>> &, parser::ContextualMessages &, const std::optional<Expr<SubscriptInteger>> &, parser::ContextualMessages &,
const semantics::Scope &, const IntrinsicProcTable &, const semantics::Scope &, const IntrinsicProcTable &);
SpecificationExprContext);
// IsSimplyContiguous() -- 9.5.4 // IsSimplyContiguous() -- 9.5.4
class IsSimplyContiguousHelper class IsSimplyContiguousHelper

43
flang/lib/Semantics/check-declarations.cpp
View File

@ -33,10 +33,7 @@ public:
void Check() { Check(context_.globalScope()); } void Check() { Check(context_.globalScope()); }
void Check(const ParamValue &, bool canBeAssumed); void Check(const ParamValue &, bool canBeAssumed);
void Check(const Bound &bound) { void Check(const Bound &bound) { CheckSpecExpr(bound.GetExplicit()); }
CheckSpecExpr(
bound.GetExplicit(), evaluate::SpecificationExprContext::BOUND);
}
void Check(const ShapeSpec &spec) { void Check(const ShapeSpec &spec) {
Check(spec.lbound()); Check(spec.lbound());
Check(spec.ubound()); Check(spec.ubound());
@ -47,9 +44,7 @@ public:
void Check(const Scope &); void Check(const Scope &);
private: private:
template <typename A> template <typename A> void CheckSpecExpr(const A &x) {
void CheckSpecExpr(
const A &x, const evaluate::SpecificationExprContext specExprContext) {
if (symbolBeingChecked_ && IsSaved(*symbolBeingChecked_)) { if (symbolBeingChecked_ && IsSaved(*symbolBeingChecked_)) {
if (!evaluate::IsConstantExpr(x)) { if (!evaluate::IsConstantExpr(x)) {
messages_.Say( messages_.Say(
@ -58,22 +53,18 @@ private:
} }
} else { } else {
evaluate::CheckSpecificationExpr( evaluate::CheckSpecificationExpr(
x, messages_, DEREF(scope_), context_.intrinsics(), specExprContext); x, messages_, DEREF(scope_), context_.intrinsics());
} }
} }
template <typename A> template <typename A> void CheckSpecExpr(const std::optional<A> &x) {
void CheckSpecExpr(const std::optional<A> &x,
const evaluate::SpecificationExprContext specExprContext) {
if (x) { if (x) {
CheckSpecExpr(*x, specExprContext); CheckSpecExpr(*x);
} }
} }
template <typename A> template <typename A> void CheckSpecExpr(A &x) {
void CheckSpecExpr(
A &x, const evaluate::SpecificationExprContext specExprContext) {
x = Fold(foldingContext_, std::move(x)); x = Fold(foldingContext_, std::move(x));
const A &constx{x}; const A &constx{x};
CheckSpecExpr(constx, specExprContext); CheckSpecExpr(constx);
} }
void CheckValue(const Symbol &, const DerivedTypeSpec *); void CheckValue(const Symbol &, const DerivedTypeSpec *);
void CheckVolatile( void CheckVolatile(
@ -141,8 +132,7 @@ void CheckHelper::Check(const ParamValue &value, bool canBeAssumed) {
" external function result"_err_en_US); " external function result"_err_en_US);
} }
} else { } else {
CheckSpecExpr( CheckSpecExpr(value.GetExplicit());
value.GetExplicit(), evaluate::SpecificationExprContext::TYPE_PARAM);
} }
} }
@ -294,6 +284,12 @@ void CheckHelper::Check(const Symbol &symbol) {
"A dummy argument may not have the SAVE attribute"_err_en_US); "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( void CheckHelper::CheckValue(
@ -584,6 +580,12 @@ void CheckHelper::CheckProcEntity(
messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US); messages_.Say("A dummy procedure may not be ELEMENTAL"_err_en_US);
} }
} else if (symbol.owner().IsDerivedType()) { } 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); CheckPassArg(symbol, details.interface().symbol(), details);
} }
if (symbol.attrs().test(Attr::POINTER)) { 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 void CheckHelper::CheckPointer(const Symbol &symbol) { // C852
CheckConflicting(symbol, Attr::POINTER, Attr::TARGET); 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); CheckConflicting(symbol, Attr::POINTER, Attr::INTRINSIC);
if (symbol.Corank() > 0) { if (symbol.Corank() > 0) {
messages_.Say( messages_.Say(
@ -1076,6 +1078,7 @@ void CheckHelper::CheckPointer(const Symbol &symbol) { // C852
} }
// C760 constraints on the passed-object dummy argument // C760 constraints on the passed-object dummy argument
// C757 constraints on procedure pointer components
void CheckHelper::CheckPassArg( void CheckHelper::CheckPassArg(
const Symbol &proc, const Symbol *interface, const WithPassArg &details) { const Symbol &proc, const Symbol *interface, const WithPassArg &details) {
if (proc.attrs().test(Attr::NOPASS)) { if (proc.attrs().test(Attr::NOPASS)) {
@ -1117,7 +1120,7 @@ void CheckHelper::CheckPassArg(
break; break;
} }
} }
if (!passArgIndex) { if (!passArgIndex) { // C758
messages_.Say(*passName, messages_.Say(*passName,
"'%s' is not a dummy argument of procedure interface '%s'"_err_en_US, "'%s' is not a dummy argument of procedure interface '%s'"_err_en_US,
*passName, interface->name()); *passName, interface->name());

41
flang/lib/Semantics/resolve-names.cpp
View File

@ -3671,6 +3671,13 @@ bool DeclarationVisitor::Pre(const parser::DerivedTypeDef &x) {
if (!symbol) { if (!symbol) {
Say(paramName, Say(paramName,
"No definition found for type parameter '%s'"_err_en_US); // C742 "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>()) { } else if (!symbol->has<TypeParamDetails>()) {
Say2(paramName, "'%s' is not defined as a type parameter"_err_en_US, Say2(paramName, "'%s' is not defined as a type parameter"_err_en_US,
*symbol, "Definition of '%s'"_en_US); // C741 *symbol, "Definition of '%s'"_en_US); // C741
@ -3906,7 +3913,7 @@ bool DeclarationVisitor::Pre(const parser::ProcComponentDefStmt &) {
CHECK(!interfaceName_); CHECK(!interfaceName_);
return true; return true;
} }
void DeclarationVisitor::Post(const parser::ProcComponentDefStmt &) { void DeclarationVisitor::Post(const parser::ProcComponentDefStmt &stmt) {
interfaceName_ = nullptr; interfaceName_ = nullptr;
} }
bool DeclarationVisitor::Pre(const parser::ProcPointerInit &x) { bool DeclarationVisitor::Pre(const parser::ProcPointerInit &x) {
@ -4682,7 +4689,7 @@ void DeclarationVisitor::SetType(
SetType(name, SetType(name,
currScope().MakeCharacterType(std::move(length), std::move(kind))); currScope().MakeCharacterType(std::move(length), std::move(kind)));
return; return;
} else { } else { // C753
Say(name, Say(name,
"A length specifier cannot be used to declare the non-character entity '%s'"_err_en_US); "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;) { for (const Scope *scope{&currScope()}; scope;) {
CHECK(scope->IsDerivedType()); CHECK(scope->IsDerivedType());
if (auto *prev{FindInScope(*scope, name)}) { if (auto *prev{FindInScope(*scope, name)}) {
auto msg{""_en_US}; if (!prev->test(Symbol::Flag::Error)) {
if (extends) { auto msg{""_en_US};
msg = "Type cannot be extended as it has a component named" if (extends) {
" '%s'"_err_en_US; msg = "Type cannot be extended as it has a component named"
} else if (prev->test(Symbol::Flag::ParentComp)) { " '%s'"_err_en_US;
msg = "'%s' is a parent type of this type and so cannot be" } else if (prev->test(Symbol::Flag::ParentComp)) {
" a component"_err_en_US; msg = "'%s' is a parent type of this type and so cannot be"
} else if (scope != &currScope()) { " a component"_err_en_US;
msg = "Component '%s' is already declared in a parent of this" } else if (scope != &currScope()) {
" derived type"_err_en_US; msg = "Component '%s' is already declared in a parent of this"
} else { " derived type"_err_en_US;
msg = "Component '%s' is already declared in this" } else {
" derived type"_err_en_US; 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; return false;
} }
if (scope == &currScope() && extends) { if (scope == &currScope() && extends) {

11
flang/lib/Semantics/type.cpp
View File

@ -123,9 +123,12 @@ void DerivedTypeSpec::EvaluateParameters(
continue; continue;
} }
} }
evaluate::SayWithDeclaration(messages, symbol, if (!symbol.test(Symbol::Flag::Error)) {
"Value of type parameter '%s' (%s) is not convertible to its type"_err_en_US, evaluate::SayWithDeclaration(messages, symbol,
name, expr->AsFortran()); "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{ auto expr{
evaluate::Fold(foldingContext, common::Clone(details.init()))}; evaluate::Fold(foldingContext, common::Clone(details.init()))};
AddParamValue(name, ParamValue{std::move(*expr), details.attr()}); AddParamValue(name, ParamValue{std::move(*expr), details.attr()});
} else { } else if (!symbol.test(Symbol::Flag::Error)) {
messages.Say(name_, messages.Say(name_,
"Type parameter '%s' lacks a value and has no default"_err_en_US, "Type parameter '%s' lacks a value and has no default"_err_en_US,
name); name);

2
flang/test/Semantics/assign02.f90
View File

@ -11,7 +11,7 @@ module m1
end type end type
contains contains
! C853 ! C852
subroutine s0 subroutine s0
!ERROR: 'p1' may not have both the POINTER and TARGET attributes !ERROR: 'p1' may not have both the POINTER and TARGET attributes
real, pointer :: p1, p3 real, pointer :: p1, p3

2
flang/test/Semantics/resolve31.f90
View File

@ -84,7 +84,7 @@ module m4
!ERROR: A sequence type data component must either be of an intrinsic type or a derived sequence type !ERROR: A sequence type data component must either be of an intrinsic type or a derived sequence type
type(plainType) :: testField1 type(plainType) :: testField1
type(sequenceType) :: testField2 type(sequenceType) :: testField2
procedure(real), nopass :: procField procedure(real), pointer, nopass :: procField
end type testType end type testType
!ERROR: A sequence type may not have type parameters !ERROR: A sequence type may not have type parameters
type :: paramType(param) type :: paramType(param)

1
flang/test/Semantics/resolve33.f90
View File

@ -39,7 +39,6 @@ module m
!ERROR: No definition found for type parameter 'k' !ERROR: No definition found for type parameter 'k'
!ERROR: No definition found for type parameter 'l' !ERROR: No definition found for type parameter 'l'
type :: t6(k, l) type :: t6(k, l)
!ERROR: Must be a constant value
character(kind=k, len=l) :: d3 character(kind=k, len=l) :: d3
end type end type
type(t6(2, 10)) :: x3 type(t6(2, 10)) :: x3

10
flang/test/Semantics/resolve34.f90
View File

@ -27,9 +27,13 @@ module m3
!ERROR: 't1' is a parent type of this type and so cannot be a component !ERROR: 't1' is a parent type of this type and so cannot be a component
real :: t1 real :: t1
end type end type
type, extends(t2) :: t3 type :: t3
!ERROR: 't1' is a parent type of this type and so cannot be a component end type
real :: t1 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 type
end end

7
flang/test/Semantics/resolve52.f90
View File

@ -5,6 +5,13 @@
! all of its length type parameters shall be assumed; it shall be polymorphic ! 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). ! (7.3.2.3) if and only if the type being defined is extensible (7.5.7).
! It shall not have the VALUE attribute. ! 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 module m1
type :: t type :: t

2
flang/test/Semantics/resolve79.f90
View File

@ -24,6 +24,8 @@ module m
procedure(passNopassProc), pass, pointer, nopass :: passNopassField procedure(passNopassProc), pass, pointer, nopass :: passNopassField
!WARNING: Attribute 'POINTER' cannot be used more than once !WARNING: Attribute 'POINTER' cannot be used more than once
procedure(pointerProc), pointer, public, pointer :: pointerField procedure(pointerProc), pointer, public, pointer :: pointerField
!ERROR: Procedure component 'nonpointerfield' must have POINTER attribute
procedure(publicProc), public :: nonpointerField
contains contains
procedure :: noPassProc procedure :: noPassProc
procedure :: passProc procedure :: passProc

64
flang/test/Semantics/resolve89.f90
View File

@ -1,9 +1,15 @@
! RUN: %S/test_errors.sh %s %t %f18 ! RUN: %S/test_errors.sh %s %t %f18
! C750 Each bound in the explicit-shape-spec shall be a specification ! C750 Each bound in the explicit-shape-spec shall be a specification
! expression in which there are no references to specification functions or ! 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 ! or SAME_TYPE_AS, every specification inquiry reference is a constant
! expression, and the value does not depend on the value of a variable. ! 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() impure function impureFunc()
integer :: impureFunc integer :: impureFunc
@ -21,6 +27,7 @@ module m
end module m end module m
subroutine s(iArg, allocArg, pointerArg, arrayArg, ioArg, optionalArg) subroutine s(iArg, allocArg, pointerArg, arrayArg, ioArg, optionalArg)
! C750
use m use m
implicit logical(l) implicit logical(l)
integer, intent(in) :: iArg integer, intent(in) :: iArg
@ -58,7 +65,7 @@ subroutine s(iArg, allocArg, pointerArg, arrayArg, ioArg, optionalArg)
real, dimension(iabs(iArg)) :: arrayVarWithIntrinsic real, dimension(iabs(iArg)) :: arrayVarWithIntrinsic
type arrayType 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 real, dimension(var) :: varField
!ERROR: Invalid specification expression: reference to impure function 'ivolatilestmtfunc' !ERROR: Invalid specification expression: reference to impure function 'ivolatilestmtfunc'
real, dimension(iVolatileStmtFunc()) :: arrayFieldWithVolatile real, dimension(iVolatileStmtFunc()) :: arrayFieldWithVolatile
@ -66,17 +73,17 @@ subroutine s(iArg, allocArg, pointerArg, arrayArg, ioArg, optionalArg)
real, dimension(iImpureStmtFunc()) :: arrayFieldWithImpureFunction real, dimension(iImpureStmtFunc()) :: arrayFieldWithImpureFunction
!ERROR: Invalid specification expression: reference to statement function 'ipurestmtfunc' !ERROR: Invalid specification expression: reference to statement function 'ipurestmtfunc'
real, dimension(iPureStmtFunc()) :: arrayFieldWithPureFunction 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 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 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 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 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 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 real, dimension(merge(1, 2, present(optionalArg))) :: realField5
end type arrayType end type arrayType
@ -100,7 +107,7 @@ subroutine s1()
type localDerivedType type localDerivedType
! OK because the specification inquiry is a constant ! OK because the specification inquiry is a constant
integer, dimension(localDerived%kindParam) :: goodField 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 integer, dimension(derivedArg%lenParam) :: badField
end type localDerivedType end type localDerivedType
@ -108,3 +115,42 @@ subroutine s1()
integer, dimension(derivedArg%kindParam) :: localVar integer, dimension(derivedArg%kindParam) :: localVar
end subroutine inner end subroutine inner
end subroutine s1 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

18
flang/test/Semantics/resolve90.f90 Normal file
View File

@ -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