maxjhandsome
/
llvm-project
forked from OSchip/llvm-project
1
0
Fork 0
Code Issues Pull Requests Packages Releases Wiki Activity

[flang] Fix test for assignment to host-associated object in PURE 

Original-commit: flang-compiler/f18@019e61aa85
Reviewed-on: https://github.com/flang-compiler/f18/pull/893
This commit is contained in:
peter klausler 2019-12-23 17:12:53 -08:00
parent 71f6a80c2b
commit b8a7bad3e0
29 changed files with 293 additions and 194 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
flang/lib/common/default-kinds.cc
View File

@ -23,6 +23,12 @@ IntrinsicTypeDefaultKinds &IntrinsicTypeDefaultKinds::set_defaultIntegerKind(
return *this;
}
IntrinsicTypeDefaultKinds &IntrinsicTypeDefaultKinds::set_subscriptIntegerKind(
int k) {
subscriptIntegerKind_ = k;
return *this;
}
IntrinsicTypeDefaultKinds &IntrinsicTypeDefaultKinds::set_defaultRealKind(
int k) {
defaultRealKind_ = k;

8
flang/lib/common/default-kinds.h
View File

@ -22,17 +22,16 @@ using ConstantSubscript = std::int64_t;
// Represent the default values of the kind parameters of the
// various intrinsic types. Most of these can be configured by
// means of the compiler command line; subscriptIntegerKind,
// however, is fixed at 8 because all address calculations are
// 64-bit safe.
// means of the compiler command line.
class IntrinsicTypeDefaultKinds {
public:
IntrinsicTypeDefaultKinds();
static constexpr int subscriptIntegerKind() { return 8; }
int subscriptIntegerKind() const { return subscriptIntegerKind_; }
int doublePrecisionKind() const { return doublePrecisionKind_; }
int quadPrecisionKind() const { return quadPrecisionKind_; }
IntrinsicTypeDefaultKinds &set_defaultIntegerKind(int);
IntrinsicTypeDefaultKinds &set_subscriptIntegerKind(int);
IntrinsicTypeDefaultKinds &set_defaultRealKind(int);
IntrinsicTypeDefaultKinds &set_doublePrecisionKind(int);
IntrinsicTypeDefaultKinds &set_quadPrecisionKind(int);
@ -48,6 +47,7 @@ private:
// storage unit, so their kinds are also forced. Default COMPLEX must always
// comprise two default REAL components.
int defaultIntegerKind_{4};
int subscriptIntegerKind_{8};
int defaultRealKind_{defaultIntegerKind_};
int doublePrecisionKind_{2 * defaultRealKind_};
int quadPrecisionKind_{2 * doublePrecisionKind_};

1
flang/lib/evaluate/call.cc
View File

@ -15,6 +15,7 @@
namespace Fortran::evaluate {
DEFINE_DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(ActualArgument)
ActualArgument::ActualArgument(Expr<SomeType> &&x) : u_{std::move(x)} {}
ActualArgument::ActualArgument(common::CopyableIndirection<Expr<SomeType>> &&v)
: u_{std::move(v)} {}

1
flang/lib/evaluate/call.h
View File

@ -66,6 +66,7 @@ public:
SymbolRef symbol_;
};
DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(ActualArgument)
explicit ActualArgument(Expr<SomeType> &&);
explicit ActualArgument(common::CopyableIndirection<Expr<SomeType>> &&);
explicit ActualArgument(AssumedType);

14
flang/lib/evaluate/characteristics.cc
View File

@ -509,11 +509,9 @@ bool FunctionResult::CanBeReturnedViaImplicitInterface() const {
const DynamicType &type{typeAndShape->type()};
switch (type.category()) {
case TypeCategory::Character:
if (!type.IsAssumedLengthCharacter()) {
if (const auto *param{type.charLength()}) {
if (const auto &expr{param->GetExplicit()}) {
return IsConstantExpr(*expr); // 15.4.2.2(4)(c)
}
if (const auto *param{type.charLength()}) {
if (const auto &expr{param->GetExplicit()}) {
return IsConstantExpr(*expr); // 15.4.2.2(4)(c)
}
}
return false;
@ -576,7 +574,7 @@ int Procedure::FindPassIndex(std::optional<parser::CharBlock> name) const {
bool Procedure::CanOverride(
const Procedure &that, std::optional<int> passIndex) const {
// A PURE procedure may override an impure one (7.5.7.3(2))
// A pure procedure may override an impure one (7.5.7.3(2))
if ((that.attrs.test(Attr::Pure) && !attrs.test(Attr::Pure)) ||
that.attrs.test(Attr::Elemental) != attrs.test(Attr::Elemental) ||
functionResult != that.functionResult) {
@ -604,6 +602,10 @@ std::optional<Procedure> Procedure::Characterize(
{semantics::Attr::ELEMENTAL, Procedure::Attr::Elemental},
{semantics::Attr::BIND_C, Procedure::Attr::BindC},
});
if (result.attrs.test(Attr::Elemental) &&
!symbol.attrs().test(semantics::Attr::IMPURE)) {
result.attrs.set(Attr::Pure); // explicitly flag pure procedures
}
return std::visit(
common::visitors{
[&](const semantics::SubprogramDetails &subp)

26
flang/lib/evaluate/fold.cc
View File

@ -812,6 +812,30 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
}
} else if (name == "min") {
return FoldMINorMAX(context, std::move(funcRef), Ordering::Less);
} else if (name == "mod") {
return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
ScalarFuncWithContext<T, T, T>(
[](FoldingContext &context, const Scalar<T> &x,
const Scalar<T> &y) -> Scalar<T> {
auto quotRem{x.DivideSigned(y)};
if (quotRem.divisionByZero) {
context.messages().Say("mod() by zero"_en_US);
} else if (quotRem.overflow) {
context.messages().Say("mod() folding overflowed"_en_US);
}
return quotRem.remainder;
}));
} else if (name == "modulo") {
return FoldElementalIntrinsic<T, T, T>(context, std::move(funcRef),
ScalarFuncWithContext<T, T, T>(
[](FoldingContext &context, const Scalar<T> &x,
const Scalar<T> &y) -> Scalar<T> {
auto result{x.MODULO(y)};
if (result.overflow) {
context.messages().Say("modulo() folding overflowed"_en_US);
}
return result.value;
}));
} else if (name == "precision") {
if (const auto *cx{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
return Expr<T>{std::visit(
@ -919,7 +943,7 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
// ceiling, cshift, dot_product, eoshift,
// findloc, floor, iall, iany, iparity, ibits, image_status, index, ishftc,
// len_trim, matmul, maxloc, maxval,
// minloc, minval, mod, modulo, nint, not, pack, product, reduce,
// minloc, minval, nint, not, pack, product, reduce,
// scan, sign, spread, sum, transfer, transpose, unpack, verify
return Expr<T>{std::move(funcRef)};
}

24
flang/lib/evaluate/type.cc
View File

@ -95,11 +95,33 @@ bool DynamicType::operator==(const DynamicType &that) const {
PointeeComparison(derived_, that.derived_);
}
std::optional<common::ConstantSubscript> DynamicType::GetCharLength() const {
if (category_ == TypeCategory::Character && charLength_ &&
charLength_->isExplicit()) {
if (const auto &len{charLength_->GetExplicit()}) {
return ToInt64(len);
}
}
return std::nullopt;
}
bool DynamicType::IsAssumedLengthCharacter() const {
return category_ == TypeCategory::Character && charLength_ &&
charLength_->isAssumed();
}
bool DynamicType::IsUnknownLengthCharacter() const {
if (category_ != TypeCategory::Character) {
return false;
} else if (!charLength_) {
return true;
} else if (const auto &expr{charLength_->GetExplicit()}) {
return !IsConstantExpr(*expr);
} else {
return true;
}
}
bool DynamicType::IsTypelessIntrinsicArgument() const {
return category_ == TypeCategory::Integer && kind_ == TypelessKind;
}
@ -402,7 +424,7 @@ DynamicType DynamicType::ResultTypeForMultiply(const DynamicType &that) const {
}
bool DynamicType::RequiresDescriptor() const {
if (IsPolymorphic() || IsAssumedLengthCharacter()) {
if (IsPolymorphic() || IsUnknownLengthCharacter()) {
return true;
}
if (derived_) {

2
flang/lib/evaluate/type.h
View File

@ -136,12 +136,14 @@ public:
constexpr const semantics::ParamValue *charLength() const {
return charLength_;
}
std::optional<common::ConstantSubscript> GetCharLength() const;
std::string AsFortran() const;
std::string AsFortran(std::string &&charLenExpr) const;
DynamicType ResultTypeForMultiply(const DynamicType &) const;
bool IsAssumedLengthCharacter() const;
bool IsUnknownLengthCharacter() const;
bool IsTypelessIntrinsicArgument() const;
constexpr bool IsAssumedType() const { // TYPE(*)
return kind_ == AssumedTypeKind;

26
flang/lib/semantics/assignment.cc
View File

@ -568,7 +568,7 @@ static const char *WhyBaseObjectIsSuspicious(
} else if (IsUseAssociated(x, scope)) {
return "USE-associated";
} else if (IsPointerDummyOfPureFunction(x)) {
return "a POINTER dummy argument of a PURE function";
return "a POINTER dummy argument of a pure function";
} else if (IsIntentIn(x)) {
return "an INTENT(IN) dummy argument";
} else if (FindCommonBlockContaining(x)) {
@ -584,7 +584,7 @@ void CheckDefinabilityInPureScope(parser::ContextualMessages &messages,
if (pure.symbol()) {
if (const char *why{WhyBaseObjectIsSuspicious(lhs, context)}) {
evaluate::SayWithDeclaration(messages, lhs,
"PURE subprogram '%s' may not define '%s' because it is %s"_err_en_US,
"Pure subprogram '%s' may not define '%s' because it is %s"_err_en_US,
pure.symbol()->name(), lhs.name(), why);
}
}
@ -610,7 +610,7 @@ void CheckCopyabilityInPureScope(parser::ContextualMessages &messages,
if (const char *why{WhyBaseObjectIsSuspicious(*base, scope)}) {
if (auto pointer{GetPointerComponentDesignatorName(expr)}) {
evaluate::SayWithDeclaration(messages, *base,
"A PURE subprogram may not copy the value of '%s' because it is %s and has the POINTER component '%s'"_err_en_US,
"A pure subprogram may not copy the value of '%s' because it is %s and has the POINTER component '%s'"_err_en_US,
base->name(), why, *pointer);
}
}
@ -624,32 +624,40 @@ void AssignmentContext::CheckForPureContext(const SomeExpr &lhs,
parser::ContextualMessages messages{at_, &context_.messages()};
if (evaluate::ExtractCoarrayRef(lhs)) {
messages.Say(
"A PURE subprogram may not define a coindexed object"_err_en_US);
"A pure subprogram may not define a coindexed object"_err_en_US);
} else if (const Symbol * base{GetFirstSymbol(lhs)}) {
CheckDefinabilityInPureScope(messages, *base, scope, *pure);
if (const auto *assoc{base->detailsIf<AssocEntityDetails>()}) {
if (auto dataRef{ExtractDataRef(assoc->expr())}) {
// ASSOCIATE(a=>x) -- check x, not a, for "a=..."
CheckDefinabilityInPureScope(
messages, dataRef->GetFirstSymbol(), scope, *pure);
}
} else {
CheckDefinabilityInPureScope(messages, *base, scope, *pure);
}
}
if (isPointerAssignment) {
if (const Symbol * base{GetFirstSymbol(rhs)}) {
if (const char *why{
WhyBaseObjectIsSuspicious(*base, scope)}) { // C1594(3)
evaluate::SayWithDeclaration(messages, *base,
"A PURE subprogram may not use '%s' as the target of pointer assignment because it is %s"_err_en_US,
"A pure subprogram may not use '%s' as the target of pointer assignment because it is %s"_err_en_US,
base->name(), why);
}
}
} else {
if (auto type{evaluate::DynamicType::From(lhs)}) {
// C1596 checks for polymorphic deallocation in a PURE subprogram
// C1596 checks for polymorphic deallocation in a pure subprogram
// due to automatic reallocation on assignment
if (type->IsPolymorphic()) {
Say(at_,
"Deallocation of polymorphic object is not permitted in a PURE subprogram"_err_en_US);
"Deallocation of polymorphic object is not permitted in a pure subprogram"_err_en_US);
}
if (const DerivedTypeSpec * derived{GetDerivedTypeSpec(type)}) {
if (auto bad{FindPolymorphicAllocatableNonCoarrayUltimateComponent(
*derived)}) {
evaluate::SayWithDeclaration(messages, *bad,
"Deallocation of polymorphic non-coarray component '%s' is not permitted in a PURE subprogram"_err_en_US,
"Deallocation of polymorphic non-coarray component '%s' is not permitted in a pure subprogram"_err_en_US,
bad.BuildResultDesignatorName());
} else {
CheckCopyabilityInPureScope(messages, rhs, scope);

4
flang/lib/semantics/assignment.h
View File

@ -48,10 +48,10 @@ extern template class Fortran::common::Indirection<
Fortran::semantics::AssignmentContext>;
namespace Fortran::semantics {
// Applies checks from C1594(1-2) on definitions in PURE subprograms
// Applies checks from C1594(1-2) on definitions in pure subprograms
void CheckDefinabilityInPureScope(parser::ContextualMessages &, const Symbol &,
const Scope &context, const Scope &pure);
// Applies checks from C1594(5-6) on copying pointers in PURE subprograms
// Applies checks from C1594(5-6) on copying pointers in pure subprograms
void CheckCopyabilityInPureScope(parser::ContextualMessages &,
const evaluate::Expr<evaluate::SomeType> &, const Scope &);

2
flang/lib/semantics/check-allocate.cc
View File

@ -227,7 +227,7 @@ static std::optional<AllocateCheckerInfo> CheckAllocateOptions(
}
}
}
if (info.gotSource) { // C1594(6) - SOURCE= restrictions when PURE
if (info.gotSource) { // C1594(6) - SOURCE= restrictions when pure
const Scope &scope{context.FindScope(at)};
if (FindPureProcedureContaining(scope)) {
parser::ContextualMessages messages{at, &context.messages()};

5
flang/lib/semantics/check-call.cc
View File

@ -267,7 +267,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
? actualLastSymbol->GetUltimate().detailsIf<ObjectEntityDetails>()
: nullptr};
int actualRank{evaluate::GetRank(actualType.shape())};
bool actualIsPointer{actualLastSymbol && IsPointer(*actualLastSymbol)};
bool actualIsPointer{(actualLastSymbol && IsPointer(*actualLastSymbol)) ||
evaluate::IsNullPointer(actual)};
if (dummy.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedShape)) {
// 15.5.2.4(16)
@ -523,7 +524,7 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
}
}
if (!interface.IsPure()) {
// 15.5.2.9(1): if dummy is not PURE, actual need not be.
// 15.5.2.9(1): if dummy is not pure, actual need not be.
argInterface.attrs.reset(characteristics::Procedure::Attr::Pure);
}
if (interface.HasExplicitInterface()) {

31
flang/lib/semantics/check-declarations.cc
View File

@ -151,25 +151,25 @@ void CheckHelper::Check(const Symbol &symbol) {
if (InPure()) {
if (IsSaved(symbol)) {
messages_.Say(
"A PURE subprogram may not have a variable with the SAVE attribute"_err_en_US);
"A pure subprogram may not have a variable with the SAVE attribute"_err_en_US);
}
if (symbol.attrs().test(Attr::VOLATILE)) {
messages_.Say(
"A PURE subprogram may not have a variable with the VOLATILE attribute"_err_en_US);
"A pure subprogram may not have a variable with the VOLATILE attribute"_err_en_US);
}
if (IsProcedure(symbol) && !IsPureProcedure(symbol) && IsDummy(symbol)) {
messages_.Say(
"A dummy procedure of a PURE subprogram must be PURE"_err_en_US);
"A dummy procedure of a pure subprogram must be pure"_err_en_US);
}
if (!IsDummy(symbol) && !IsFunctionResult(symbol)) {
if (IsPolymorphicAllocatable(symbol)) {
SayWithDeclaration(symbol,
"Deallocation of polymorphic object '%s' is not permitted in a PURE subprogram"_err_en_US,
"Deallocation of polymorphic object '%s' is not permitted in a pure subprogram"_err_en_US,
symbol.name());
} else if (derived) {
if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) {
SayWithDeclaration(*bad,
"Deallocation of polymorphic object '%s%s' is not permitted in a PURE subprogram"_err_en_US,
"Deallocation of polymorphic object '%s%s' is not permitted in a pure subprogram"_err_en_US,
symbol.name(), bad.BuildResultDesignatorName());
}
}
@ -190,16 +190,16 @@ void CheckHelper::Check(const Symbol &symbol) {
if (InPure() && InFunction() && IsFunctionResult(symbol)) {
if (derived && HasImpureFinal(*derived)) { // C1584
messages_.Say(
"Result of PURE function may not have an impure FINAL subroutine"_err_en_US);
"Result of pure function may not have an impure FINAL subroutine"_err_en_US);
}
if (type->IsPolymorphic() && IsAllocatable(symbol)) { // C1585
messages_.Say(
"Result of PURE function may not be both polymorphic and ALLOCATABLE"_err_en_US);
"Result of pure function may not be both polymorphic and ALLOCATABLE"_err_en_US);
}
if (derived) {
if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) {
SayWithDeclaration(*bad,
"Result of PURE function may not have polymorphic ALLOCATABLE ultimate component '%s'"_err_en_US,
"Result of pure function may not have polymorphic ALLOCATABLE ultimate component '%s'"_err_en_US,
bad.BuildResultDesignatorName());
}
}
@ -317,29 +317,29 @@ void CheckHelper::CheckObjectEntity(
!symbol.attrs().test(Attr::VALUE)) {
if (InFunction()) { // C1583
messages_.Say(
"non-POINTER dummy argument of PURE function must be INTENT(IN) or VALUE"_err_en_US);
"non-POINTER dummy argument of pure function must be INTENT(IN) or VALUE"_err_en_US);
} else if (IsIntentOut(symbol)) {
if (const DeclTypeSpec * type{details.type()}) {
if (type && type->IsPolymorphic()) { // C1588
messages_.Say(
"An INTENT(OUT) dummy argument of a PURE subroutine may not be polymorphic"_err_en_US);
"An INTENT(OUT) dummy argument of a pure subroutine may not be polymorphic"_err_en_US);
} else if (const DerivedTypeSpec * derived{type->AsDerived()}) {
if (FindUltimateComponent(*derived, [](const Symbol &x) {
const DeclTypeSpec *type{x.GetType()};
return type && type->IsPolymorphic();
})) { // C1588
messages_.Say(
"An INTENT(OUT) dummy argument of a PURE subroutine may not have a polymorphic ultimate component"_err_en_US);
"An INTENT(OUT) dummy argument of a pure subroutine may not have a polymorphic ultimate component"_err_en_US);
}
if (HasImpureFinal(*derived)) { // C1587
messages_.Say(
"An INTENT(OUT) dummy argument of a PURE subroutine may not have an impure FINAL subroutine"_err_en_US);
"An INTENT(OUT) dummy argument of a pure subroutine may not have an impure FINAL subroutine"_err_en_US);
}
}
}
} else if (!IsIntentInOut(symbol)) { // C1586
messages_.Say(
"non-POINTER dummy argument of PURE subroutine must have INTENT() or VALUE attribute"_err_en_US);
"non-POINTER dummy argument of pure subroutine must have INTENT() or VALUE attribute"_err_en_US);
}
}
}
@ -825,10 +825,9 @@ void CheckHelper::CheckProcBinding(
}
if (const auto *overriddenBinding{
overridden->detailsIf<ProcBindingDetails>()}) {
if (!binding.symbol().attrs().test(Attr::PURE) &&
overriddenBinding->symbol().attrs().test(Attr::PURE)) {
if (!IsPureProcedure(symbol) && IsPureProcedure(*overridden)) {
SayWithDeclaration(*overridden,
"An overridden PURE type-bound procedure binding must also be PURE"_err_en_US);
"An overridden pure type-bound procedure binding must also be pure"_err_en_US);
return;
}
if (!binding.symbol().attrs().test(Attr::ELEMENTAL) &&

2
flang/lib/semantics/check-io.cc
View File

@ -758,7 +758,7 @@ void IoChecker::CheckForProhibitedSpecifier(
void IoChecker::CheckForPureSubprogram() const { // C1597
CHECK(context_.location());
if (FindPureProcedureContaining(context_.FindScope(*context_.location()))) {
context_.Say("External I/O is not allowed in a PURE subprogram"_err_en_US);
context_.Say("External I/O is not allowed in a pure subprogram"_err_en_US);
}
}

4
flang/lib/semantics/check-purity.cc
View File

@ -14,7 +14,7 @@ namespace Fortran::semantics {
void PurityChecker::Enter(const parser::ExecutableConstruct &exec) {
if (InPureSubprogram() && IsImageControlStmt(exec)) {
context_.Say(GetImageControlStmtLocation(exec),
"An image control statement may not appear in a PURE subprogram"_err_en_US);
"An image control statement may not appear in a pure subprogram"_err_en_US);
}
}
void PurityChecker::Enter(const parser::SubroutineSubprogram &subr) {
@ -59,7 +59,7 @@ void PurityChecker::Entered(
}
} else if (InPureSubprogram()) {
context_.messages().Say(source,
"An internal subprogram of a PURE subprogram must also be PURE"_err_en_US);
"An internal subprogram of a pure subprogram must also be pure"_err_en_US);
}
++depth_;
}

62
flang/lib/semantics/expression.cc
View File

@ -679,7 +679,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Name &n) {
pure{semantics::FindPureProcedureContaining(
context_.FindScope(n.source))}) {
SayAt(n,
"VOLATILE variable '%s' may not be referenced in PURE subprogram '%s'"_err_en_US,
"VOLATILE variable '%s' may not be referenced in pure subprogram '%s'"_err_en_US,
n.source, DEREF(pure->symbol()).name());
n.symbol->attrs().reset(semantics::Attr::VOLATILE);
}
@ -1432,7 +1432,7 @@ MaybeExpr ExpressionAnalyzer::Analyze(
if (auto *msg{Say(expr.source,
"Externally visible object '%s' may not be "
"associated with pointer component '%s' in a "
"PURE procedure"_err_en_US,
"pure procedure"_err_en_US,
object->name(), pointer->name())}) {
msg->Attach(object->name(), "Object declaration"_en_US)
.Attach(pointer->name(), "Pointer declaration"_en_US);
@ -1545,7 +1545,7 @@ static int GetPassIndex(const Symbol &proc) {
// argument keyword if possible, but not when the passed object goes
// before a positional argument.
// e.g., obj%tbp(x) -> tbp(obj,x).
static void AddPassArg(ActualArguments &actuals, Expr<SomeDerived> &&expr,
static void AddPassArg(ActualArguments &actuals, const Expr<SomeDerived> &expr,
const Symbol &component, bool isPassedObject = true) {
if (component.attrs().test(semantics::Attr::NOPASS)) {
return;
@ -1561,7 +1561,7 @@ static void AddPassArg(ActualArguments &actuals, Expr<SomeDerived> &&expr,
++iter;
++at;
}
ActualArgument passed{AsGenericExpr(std::move(expr))};
ActualArgument passed{AsGenericExpr(common::Clone(expr))};
passed.set_isPassedObject(isPassedObject);
if (iter == actuals.end()) {
if (auto passName{GetPassName(component)}) {
@ -1594,14 +1594,16 @@ auto ExpressionAnalyzer::AnalyzeProcedureComponentRef(
if (const Symbol * sym{sc.component.symbol}) {
if (auto *dtExpr{UnwrapExpr<Expr<SomeDerived>>(*base)}) {
if (sym->has<semantics::GenericDetails>()) {
sym = ResolveGeneric(*sym, arguments,
AdjustActuals adjustment{
[&](const Symbol &proc, ActualArguments &actuals) {
if (!proc.attrs().test(semantics::Attr::NOPASS)) {
AddPassArg(actuals, std::move(*dtExpr), proc);
}
return true;
});
}};
sym = ResolveGeneric(*sym, arguments, adjustment);
if (!sym) {
EmitGenericResolutionError(*sc.component.symbol);
return std::nullopt;
}
}
@ -1679,8 +1681,8 @@ static bool CheckCompatibleArguments(
// Resolve a call to a generic procedure with given actual arguments.
// adjustActuals is called on procedure bindings to handle pass arg.
const Symbol *ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol,
const ActualArguments &actuals, AdjustActuals adjustActuals,
bool mightBeStructureConstructor, bool inParentType) {
const ActualArguments &actuals, const AdjustActuals &adjustActuals,
bool mightBeStructureConstructor) {
const Symbol *elemental{nullptr}; // matching elemental specific proc
const auto &details{symbol.GetUltimate().get<semantics::GenericDetails>()};
for (const Symbol &specific : details.specificProcs()) {
@ -1712,19 +1714,19 @@ const Symbol *ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol,
if (const Symbol * extended{parentScope->FindComponent(symbol.name())}) {
if (extended->GetUltimate().has<semantics::GenericDetails>()) {
if (const Symbol *
result{ResolveGeneric(
*extended, actuals, adjustActuals, false, true)}) {
result{ResolveGeneric(*extended, actuals, adjustActuals, false)}) {
return result;
}
}
}
}
if (inParentType) {
return nullptr; // emit error only at top level
}
if (mightBeStructureConstructor && details.derivedType()) {
return details.derivedType();
}
return nullptr;
}
void ExpressionAnalyzer::EmitGenericResolutionError(const Symbol &symbol) {
if (semantics::IsGenericDefinedOp(symbol)) {
Say("No specific procedure of generic operator '%s' matches the actual arguments"_err_en_US,
symbol.name());
@ -1732,7 +1734,6 @@ const Symbol *ExpressionAnalyzer::ResolveGeneric(const Symbol &symbol,
Say("No specific procedure of generic '%s' matches the actual arguments"_err_en_US,
symbol.name());
}
return nullptr;
}
auto ExpressionAnalyzer::GetCalleeAndArguments(
@ -1771,8 +1772,9 @@ auto ExpressionAnalyzer::GetCalleeAndArguments(const parser::Name &name,
} else {
CheckForBadRecursion(name.source, ultimate);
if (ultimate.has<semantics::GenericDetails>()) {
ExpressionAnalyzer::AdjustActuals noAdjustment;
symbol = ResolveGeneric(
*symbol, arguments, std::nullopt, mightBeStructureConstructor);
*symbol, arguments, noAdjustment, mightBeStructureConstructor);
}
if (symbol) {
if (symbol->GetUltimate().has<semantics::DerivedTypeDetails>()) {
@ -1784,6 +1786,17 @@ auto ExpressionAnalyzer::GetCalleeAndArguments(const parser::Name &name,
return CalleeAndArguments{
ProcedureDesignator{*symbol}, std::move(arguments)};
}
} else if (std::optional<SpecificCall> specificCall{
context_.intrinsics().Probe(
CallCharacteristics{
ultimate.name().ToString(), isSubroutine},
arguments, GetFoldingContext())}) {
// Generics can extend intrinsics
return CalleeAndArguments{
ProcedureDesignator{std::move(specificCall->specificIntrinsic)},
std::move(specificCall->arguments)};
} else {
EmitGenericResolutionError(*name.symbol);
}
}
return std::nullopt;
@ -1933,7 +1946,7 @@ std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
pure{semantics::FindPureProcedureContaining(
context_.FindScope(callSite))}) {
Say(callSite,
"Procedure '%s' referenced in PURE subprogram '%s' must be PURE too"_err_en_US,
"Procedure '%s' referenced in pure subprogram '%s' must be pure too"_err_en_US,
DEREF(proc.GetSymbol()).name(), DEREF(pure->symbol()).name());
}
}
@ -2709,8 +2722,12 @@ std::optional<ProcedureRef> ArgumentAnalyzer::GetDefinedAssignmentProc() {
const Symbol *proc{nullptr};
const auto &scope{context_.context().FindScope(source_)};
if (const Symbol * symbol{scope.FindSymbol(oprName)}) {
if (const Symbol * specific{context_.ResolveGeneric(*symbol, actuals_)}) {
ExpressionAnalyzer::AdjustActuals noAdjustment;
if (const Symbol *
specific{context_.ResolveGeneric(*symbol, actuals_, noAdjustment)}) {
proc = specific;
} else {
context_.EmitGenericResolutionError(*symbol);
}
}
for (std::size_t passIndex{0}; passIndex < actuals_.size(); ++passIndex) {
@ -2756,10 +2773,15 @@ const Symbol *ArgumentAnalyzer::FindBoundOp(
return nullptr;
}
sawDefinedOp_ = symbol;
return context_.ResolveGeneric(
*symbol, actuals_, [&](const Symbol &proc, ActualArguments &) {
ExpressionAnalyzer::AdjustActuals adjustment{
[&](const Symbol &proc, ActualArguments &) {
return passIndex == GetPassIndex(proc);
});
}};
const Symbol *result{context_.ResolveGeneric(*symbol, actuals_, adjustment)};
if (!result) {
context_.EmitGenericResolutionError(*symbol);
}
return result;
}
std::optional<DynamicType> ArgumentAnalyzer::GetType(std::size_t i) const {

4
flang/lib/semantics/expression.h
View File

@ -356,8 +356,8 @@ private:
using AdjustActuals =
std::optional<std::function<bool(const Symbol &, ActualArguments &)>>;
const Symbol *ResolveGeneric(const Symbol &, const ActualArguments &,
AdjustActuals = std::nullopt, bool mightBeStructureConstructor = false,
bool inParentType = false);
const AdjustActuals &, bool mightBeStructureConstructor = false);
void EmitGenericResolutionError(const Symbol &);
std::optional<CalleeAndArguments> GetCalleeAndArguments(const parser::Name &,
ActualArguments &&, bool isSubroutine = false,
bool mightBeStructureConstructor = false);

4
flang/lib/semantics/mod-file.cc
View File

@ -945,8 +945,10 @@ bool SubprogramSymbolCollector::NeedImport(
return false;
} else if (symbol.owner() != scope_.parent()) {
// detect import from parent of use-associated symbol
// can be null in the case of a use-associated derived type's parent type
const auto *found{scope_.FindSymbol(name)};
return DEREF(found).has<UseDetails>() && found->owner() != scope_;
CHECK(found || symbol.has<DerivedTypeDetails>());
return found && found->has<UseDetails>() && found->owner() != scope_;
} else {
return true;
}

5
flang/lib/semantics/resolve-names-utils.cc
View File

@ -103,8 +103,9 @@ std::forward_list<std::string> GenericSpecInfo::GetAllNames(
Symbol *GenericSpecInfo::FindInScope(
SemanticsContext &context, const Scope &scope) const {
for (const auto &name : GetAllNames(context)) {
if (auto *symbol{scope.FindSymbol(SourceName{name})}) {
return symbol;
auto iter{scope.find(SourceName{name})};
if (iter != scope.end()) {
return &*iter->second;
}
}
return nullptr;

16
flang/lib/semantics/tools.cc
View File

@ -66,8 +66,8 @@ const Scope *FindProgramUnitContaining(const Symbol &symbol) {
const Scope *FindPureProcedureContaining(const Scope &start) {
// N.B. We only need to examine the innermost containing program unit
// because an internal subprogram of a PURE subprogram must also
// be PURE (C1592).
// because an internal subprogram of a pure subprogram must also
// be pure (C1592).
if (const Scope * scope{FindProgramUnitContaining(start)}) {
if (IsPureProcedure(*scope)) {
return scope;
@ -184,7 +184,9 @@ bool DoesScopeContain(const Scope *maybeAncestor, const Symbol &symbol) {
}
bool IsHostAssociated(const Symbol &symbol, const Scope &scope) {
return DoesScopeContain(FindProgramUnitContaining(symbol), scope);
const Scope *subprogram{FindProgramUnitContaining(scope)};
return subprogram &&
DoesScopeContain(FindProgramUnitContaining(symbol), *subprogram);
}
bool IsDummy(const Symbol &symbol) {
@ -236,7 +238,7 @@ bool IsFunction(const Symbol &symbol) {
bool IsPureProcedure(const Symbol &symbol) {
if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
if (const Symbol * procInterface{procDetails->interface().symbol()}) {
// procedure component with a PURE interface
// procedure component with a pure interface
return IsPureProcedure(*procInterface);
}
} else if (const auto *details{symbol.detailsIf<ProcBindingDetails>()}) {
@ -244,7 +246,9 @@ bool IsPureProcedure(const Symbol &symbol) {
} else if (!IsProcedure(symbol)) {
return false;
}
return symbol.attrs().test(Attr::PURE);
return symbol.attrs().test(Attr::PURE) ||
(symbol.attrs().test(Attr::ELEMENTAL) &&
!symbol.attrs().test(Attr::IMPURE));
}
bool IsPureProcedure(const Scope &scope) {
@ -701,7 +705,7 @@ std::optional<parser::MessageFixedText> WhyNotModifiable(
} else if (InProtectedContext(*root, scope)) {
return "'%s' is protected in this scope"_en_US;
} else if (IsExternalInPureContext(*root, scope)) {
return "'%s' is externally visible and referenced in a PURE"
return "'%s' is externally visible and referenced in a pure"
" procedure"_en_US;
} else if (IsOrContainsEventOrLockComponent(*root)) {
return "'%s' is an entity with either an EVENT_TYPE or LOCK_TYPE"_en_US;

2
flang/lib/semantics/tools.h
View File

@ -187,7 +187,7 @@ const DeclTypeSpec &FindOrInstantiateDerivedType(Scope &, DerivedTypeSpec &&,
SemanticsContext &, DeclTypeSpec::Category = DeclTypeSpec::TypeDerived);
// Determines whether an object might be visible outside a
// PURE function (C1594); returns a non-null Symbol pointer for
// pure function (C1594); returns a non-null Symbol pointer for
// diagnostic purposes if so.
const Symbol *FindExternallyVisibleObject(const Symbol &, const Scope &);

92
flang/test/semantics/call10.f90
View File

@ -1,5 +1,5 @@
! Test 15.7 (C1583-C1590, C1592-C1599) constraints and restrictions
! for PURE procedures.
! for pure procedures.
! (C1591 is tested in call11.f90; C1594 in call12.f90.)
module m
@ -33,14 +33,14 @@ module m
real, value :: a ! ok
end function
pure real function f03(a) ! C1583
!ERROR: non-POINTER dummy argument of PURE function must be INTENT(IN) or VALUE
!ERROR: non-POINTER dummy argument of pure function must be INTENT(IN) or VALUE
real :: a
end function
pure real function f03a(a)
real, pointer :: a ! ok
end function
pure real function f04(a) ! C1583
!ERROR: non-POINTER dummy argument of PURE function must be INTENT(IN) or VALUE
!ERROR: non-POINTER dummy argument of pure function must be INTENT(IN) or VALUE
real, intent(out) :: a
end function
pure real function f04a(a)
@ -50,65 +50,65 @@ module m
real, value :: a ! weird, but ok (VALUE without INTENT)
end function
pure function f06() ! C1584
!ERROR: Result of PURE function may not have an impure FINAL subroutine
!ERROR: Result of pure function may not have an impure FINAL subroutine
type(impureFinal) :: f06
end function
pure function f07() ! C1585
!ERROR: Result of PURE function may not be both polymorphic and ALLOCATABLE
!ERROR: Result of pure function may not be both polymorphic and ALLOCATABLE
class(t), allocatable :: f07
end function
pure function f08() ! C1585
!ERROR: Result of PURE function may not have polymorphic ALLOCATABLE ultimate component '%a'
!ERROR: Result of pure function may not have polymorphic ALLOCATABLE ultimate component '%a'
type(polyAlloc) :: f08
end function
pure subroutine s01(a) ! C1586
!ERROR: non-POINTER dummy argument of PURE subroutine must have INTENT() or VALUE attribute
!ERROR: non-POINTER dummy argument of pure subroutine must have INTENT() or VALUE attribute
real :: a
end subroutine
pure subroutine s01a(a)
real, pointer :: a
end subroutine
pure subroutine s02(a) ! C1587
!ERROR: An INTENT(OUT) dummy argument of a PURE subroutine may not have an impure FINAL subroutine
!ERROR: An INTENT(OUT) dummy argument of a pure subroutine may not have an impure FINAL subroutine
type(impureFinal), intent(out) :: a
end subroutine
pure subroutine s03(a) ! C1588
!ERROR: An INTENT(OUT) dummy argument of a PURE subroutine may not be polymorphic
!ERROR: An INTENT(OUT) dummy argument of a pure subroutine may not be polymorphic
class(t), intent(out) :: a
end subroutine
pure subroutine s04(a) ! C1588
!ERROR: An INTENT(OUT) dummy argument of a PURE subroutine may not have a polymorphic ultimate component
!ERROR: An INTENT(OUT) dummy argument of a pure subroutine may not have a polymorphic ultimate component
type(polyAlloc), intent(out) :: a
end subroutine
pure subroutine s05 ! C1589
!ERROR: A PURE subprogram may not have a variable with the SAVE attribute
!ERROR: A pure subprogram may not have a variable with the SAVE attribute
real, save :: v1
!ERROR: A PURE subprogram may not have a variable with the SAVE attribute
!ERROR: A pure subprogram may not have a variable with the SAVE attribute
real :: v2 = 0.
!TODO: once we have DATA: !ERROR: A PURE subprogram may not have a variable with the SAVE attribute
!TODO: once we have DATA: !ERROR: A pure subprogram may not have a variable with the SAVE attribute
real :: v3
data v3/0./
!ERROR: A PURE subprogram may not have a variable with the SAVE attribute
!ERROR: A pure subprogram may not have a variable with the SAVE attribute
real :: v4
common /blk/ v4
save /blk/
block
!ERROR: A PURE subprogram may not have a variable with the SAVE attribute
!ERROR: A pure subprogram may not have a variable with the SAVE attribute
real, save :: v5
!ERROR: A PURE subprogram may not have a variable with the SAVE attribute
!ERROR: A pure subprogram may not have a variable with the SAVE attribute
real :: v6 = 0.
end block
end subroutine
pure subroutine s06 ! C1589
!ERROR: A PURE subprogram may not have a variable with the VOLATILE attribute
!ERROR: A pure subprogram may not have a variable with the VOLATILE attribute
real, volatile :: v1
block
!ERROR: A PURE subprogram may not have a variable with the VOLATILE attribute
!ERROR: A pure subprogram may not have a variable with the VOLATILE attribute
real, volatile :: v2
end block
end subroutine
!ERROR: A dummy procedure of a PURE subprogram must be PURE
!ERROR: A dummy procedure of a pure subprogram must be pure
pure subroutine s07(p) ! C1590
procedure(impure) :: p
end subroutine
@ -117,30 +117,30 @@ module m
contains
pure subroutine pure ! ok
end subroutine
!ERROR: An internal subprogram of a PURE subprogram must also be PURE
!ERROR: An internal subprogram of a pure subprogram must also be pure
subroutine impure1
end subroutine
!ERROR: An internal subprogram of a PURE subprogram must also be PURE
!ERROR: An internal subprogram of a pure subprogram must also be pure
impure subroutine impure2
end subroutine
end subroutine
pure subroutine s09 ! C1593
real :: x
!ERROR: VOLATILE variable 'volatile' may not be referenced in PURE subprogram 's09'
!ERROR: VOLATILE variable 'volatile' may not be referenced in pure subprogram 's09'
x = volatile
end subroutine
! C1594 is tested in call12.f90.
pure subroutine s10 ! C1595
integer :: n
!ERROR: Procedure 'notpure' referenced in PURE subprogram 's10' must be PURE too
!ERROR: Procedure 'notpure' referenced in pure subprogram 's10' must be pure too
n = notpure(1)
end subroutine
pure subroutine s11(to) ! C1596
! Implicit deallocation at the end of the subroutine
!ERROR: Deallocation of polymorphic object 'auto%a' is not permitted in a PURE subprogram
!ERROR: Deallocation of polymorphic object 'auto%a' is not permitted in a pure subprogram
type(polyAlloc) :: auto
type(polyAlloc), intent(in out) :: to
!ERROR: Deallocation of polymorphic non-coarray component '%a' is not permitted in a PURE subprogram
!ERROR: Deallocation of polymorphic non-coarray component '%a' is not permitted in a pure subprogram
to = auto
end subroutine
pure subroutine s12
@ -148,64 +148,64 @@ module m
real :: x
write(buff, *) 1.0 ! ok
read(buff, *) x ! ok
!ERROR: External I/O is not allowed in a PURE subprogram
!ERROR: External I/O is not allowed in a pure subprogram
print *, 'hi' ! C1597
!ERROR: External I/O is not allowed in a PURE subprogram
!ERROR: External I/O is not allowed in a pure subprogram
open(1, file='launch-codes') ! C1597
!ERROR: External I/O is not allowed in a PURE subprogram
!ERROR: External I/O is not allowed in a pure subprogram
close(1) ! C1597
!ERROR: External I/O is not allowed in a PURE subprogram
!ERROR: External I/O is not allowed in a pure subprogram
backspace(1) ! C1597
!ERROR: External I/O is not allowed in a PURE subprogram
!ERROR: External I/O is not allowed in a pure subprogram
endfile(1) ! C1597
!ERROR: External I/O is not allowed in a PURE subprogram
!ERROR: External I/O is not allowed in a pure subprogram
rewind(1) ! C1597
!ERROR: External I/O is not allowed in a PURE subprogram
!ERROR: External I/O is not allowed in a pure subprogram
flush(1) ! C1597
!ERROR: External I/O is not allowed in a PURE subprogram
!ERROR: External I/O is not allowed in a pure subprogram
wait(1) ! C1597
!ERROR: External I/O is not allowed in a PURE subprogram
!ERROR: External I/O is not allowed in a pure subprogram
inquire(1, name=buff) ! C1597
!ERROR: External I/O is not allowed in a PURE subprogram
!ERROR: External I/O is not allowed in a pure subprogram
read(5, *) x ! C1598
!ERROR: External I/O is not allowed in a PURE subprogram
!ERROR: External I/O is not allowed in a pure subprogram
read(*, *) x ! C1598
!ERROR: External I/O is not allowed in a PURE subprogram
!ERROR: External I/O is not allowed in a pure subprogram
write(6, *) ! C1598
!ERROR: External I/O is not allowed in a PURE subprogram
!ERROR: External I/O is not allowed in a pure subprogram
write(*, *) ! C1598
end subroutine
pure subroutine s13
!ERROR: An image control statement may not appear in a PURE subprogram
!ERROR: An image control statement may not appear in a pure subprogram
sync all ! C1599
end subroutine
pure subroutine s14
integer :: img, nimgs, i[*], tmp
! implicit sync all
!ERROR: Procedure 'this_image' referenced in PURE subprogram 's14' must be PURE too
!ERROR: Procedure 'this_image' referenced in pure subprogram 's14' must be pure too
img = this_image()
!ERROR: Procedure 'num_images' referenced in PURE subprogram 's14' must be PURE too
!ERROR: Procedure 'num_images' referenced in pure subprogram 's14' must be pure too
nimgs = num_images()
i = img ! i is ready to use
if ( img .eq. 1 ) then
!ERROR: An image control statement may not appear in a PURE subprogram
!ERROR: An image control statement may not appear in a pure subprogram
sync images( nimgs ) ! explicit sync 1 with last img
tmp = i[ nimgs ]
!ERROR: An image control statement may not appear in a PURE subprogram
!ERROR: An image control statement may not appear in a pure subprogram
sync images( nimgs ) ! explicit sync 2 with last img
i = tmp
end if
if ( img .eq. nimgs ) then
!ERROR: An image control statement may not appear in a PURE subprogram
!ERROR: An image control statement may not appear in a pure subprogram
sync images( 1 ) ! explicit sync 1 with img 1
tmp = i[ 1 ]
!ERROR: An image control statement may not appear in a PURE subprogram
!ERROR: An image control statement may not appear in a pure subprogram
sync images( 1 ) ! explicit sync 2 with img 1
i = tmp
end if
!ERROR: External I/O is not allowed in a PURE subprogram
!ERROR: External I/O is not allowed in a pure subprogram
write (*,*) img, i
! all other images wait here
! TODO others from 11.6.1 (many)

4
flang/test/semantics/call11.f90
View File

@ -1,4 +1,4 @@
! Test 15.7 C1591 & others: contexts requiring PURE subprograms
! Test 15.7 C1591 & others: contexts requiring pure subprograms
module m
@ -9,7 +9,7 @@ module m
end type
type, extends(t) :: t2
contains
!ERROR: An overridden PURE type-bound procedure binding must also be PURE
!ERROR: An overridden pure type-bound procedure binding must also be pure
procedure, nopass :: tbp_pure => impure ! 7.5.7.3
end type

40
flang/test/semantics/call12.f90
View File

@ -1,4 +1,4 @@
! Test 15.7 C1594 - prohibited assignments in PURE subprograms
! Test 15.7 C1594 - prohibited assignments in pure subprograms
module used
real :: useassociated
@ -28,46 +28,46 @@ module m
type(hasCoarray), pointer :: hcp
integer :: n
common /block/ y
!ERROR: PURE subprogram 'test' may not define 'x' because it is host-associated
!ERROR: Pure subprogram 'test' may not define 'x' because it is host-associated
x%a = 0.
!ERROR: PURE subprogram 'test' may not define 'y' because it is in a COMMON block
!ERROR: Pure subprogram 'test' may not define 'y' because it is in a COMMON block
y%a = 0. ! C1594(1)
!ERROR: PURE subprogram 'test' may not define 'useassociated' because it is USE-associated
!ERROR: Pure subprogram 'test' may not define 'useassociated' because it is USE-associated
useassociated = 0. ! C1594(1)
!ERROR: PURE subprogram 'test' may not define 'ptr' because it is a POINTER dummy argument of a PURE function
!ERROR: Pure subprogram 'test' may not define 'ptr' because it is a POINTER dummy argument of a pure function
ptr%a = 0. ! C1594(1)
!ERROR: PURE subprogram 'test' may not define 'in' because it is an INTENT(IN) dummy argument
!ERROR: Pure subprogram 'test' may not define 'in' because it is an INTENT(IN) dummy argument
in%a = 0. ! C1594(1)
!ERROR: A PURE subprogram may not define a coindexed object
!ERROR: A pure subprogram may not define a coindexed object
hcp%co[1] = 0. ! C1594(1)
!ERROR: PURE subprogram 'test' may not define 'ptr' because it is a POINTER dummy argument of a PURE function
!ERROR: Pure subprogram 'test' may not define 'ptr' because it is a POINTER dummy argument of a pure function
ptr => z ! C1594(2)
!ERROR: PURE subprogram 'test' may not define 'ptr' because it is a POINTER dummy argument of a PURE function
!ERROR: Pure subprogram 'test' may not define 'ptr' because it is a POINTER dummy argument of a pure function
nullify(ptr) ! C1594(2), 19.6.8
!ERROR: A PURE subprogram may not use 'ptr' as the target of pointer assignment because it is a POINTER dummy argument of a PURE function
!ERROR: A pure subprogram may not use 'ptr' as the target of pointer assignment because it is a POINTER dummy argument of a pure function
ptr2 => ptr ! C1594(3)
!ERROR: A PURE subprogram may not use 'in' as the target of pointer assignment because it is an INTENT(IN) dummy argument
!ERROR: A pure subprogram may not use 'in' as the target of pointer assignment because it is an INTENT(IN) dummy argument
ptr2 => in ! C1594(3)
!ERROR: A PURE subprogram may not use 'y' as the target of pointer assignment because it is in a COMMON block
!ERROR: A pure subprogram may not use 'y' as the target of pointer assignment because it is in a COMMON block
ptr2 => y ! C1594(2)
!ERROR: Externally visible object 'block' may not be associated with pointer component 'p' in a PURE procedure
!ERROR: Externally visible object 'block' may not be associated with pointer component 'p' in a pure procedure
n = size([hasPtr(y%a)]) ! C1594(4)
!ERROR: Externally visible object 'x' may not be associated with pointer component 'p' in a PURE procedure
!ERROR: Externally visible object 'x' may not be associated with pointer component 'p' in a pure procedure
n = size([hasPtr(x%a)]) ! C1594(4)
!ERROR: Externally visible object 'ptr' may not be associated with pointer component 'p' in a PURE procedure
!ERROR: Externally visible object 'ptr' may not be associated with pointer component 'p' in a pure procedure
n = size([hasPtr(ptr%a)]) ! C1594(4)
!ERROR: Externally visible object 'in' may not be associated with pointer component 'p' in a PURE procedure
!ERROR: Externally visible object 'in' may not be associated with pointer component 'p' in a pure procedure
n = size([hasPtr(in%a)]) ! C1594(4)
!ERROR: A PURE subprogram may not copy the value of 'hpd' because it is an INTENT(IN) dummy argument and has the POINTER component '%p'
!ERROR: A pure subprogram may not copy the value of 'hpd' because it is an INTENT(IN) dummy argument and has the POINTER component '%p'
hp = hpd ! C1594(5)
!ERROR: A PURE subprogram may not copy the value of 'hpd' because it is an INTENT(IN) dummy argument and has the POINTER component '%p'
!ERROR: A pure subprogram may not copy the value of 'hpd' because it is an INTENT(IN) dummy argument and has the POINTER component '%p'
allocate(alloc, source=hpd)
contains
pure subroutine internal
type(hasPtr) :: localhp
!ERROR: PURE subprogram 'internal' may not define 'z' because it is host-associated
!ERROR: Pure subprogram 'internal' may not define 'z' because it is host-associated
z%a = 0.
!ERROR: Externally visible object 'z' may not be associated with pointer component 'p' in a PURE procedure
!ERROR: Externally visible object 'z' may not be associated with pointer component 'p' in a pure procedure
localhp = hasPtr(z%a)
end subroutine
end function

5
flang/test/semantics/doconcurrent01.f90
View File

@ -34,6 +34,7 @@ subroutine do_concurrent_test2(i,j,n,flag)
type(ieee_flag_type) :: flag
logical :: flagValue, halting
type(team_type) :: j
type(ieee_status_type) :: status
do concurrent (i = 1:n)
!ERROR: An image control statement is not allowed in DO CONCURRENT
sync team (j)
@ -42,9 +43,7 @@ subroutine do_concurrent_test2(i,j,n,flag)
!ERROR: An image control statement is not allowed in DO CONCURRENT
critical
!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
call ieee_get_flag(flag, flagValue)
!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
call ieee_get_halting_mode(flag, halting)
call ieee_get_status(status)
!ERROR: IEEE_SET_HALTING_MODE is not allowed in DO CONCURRENT
call ieee_set_halting_mode(flag, halting)
end critical

12
flang/test/semantics/resolve66.f90
View File

@ -74,17 +74,17 @@ contains
logical :: l
complex :: z
real :: r, r5(5)
!ERROR: Procedure 'assign_tt' referenced in PURE subprogram 'test3' must be PURE too
!ERROR: Procedure 'assign_tt' referenced in pure subprogram 'test3' must be pure too
a = b
!ERROR: Procedure 'assign_il' referenced in PURE subprogram 'test3' must be PURE too
!ERROR: Procedure 'assign_il' referenced in pure subprogram 'test3' must be pure too
i = l
!ERROR: Procedure 'assign_li' referenced in PURE subprogram 'test3' must be PURE too
!ERROR: Procedure 'assign_li' referenced in pure subprogram 'test3' must be pure too
l = i
!ERROR: Procedure 'assign_il' referenced in PURE subprogram 'test3' must be PURE too
!ERROR: Procedure 'assign_il' referenced in pure subprogram 'test3' must be pure too
i = .true.
!ERROR: Procedure 'assign_tz' referenced in PURE subprogram 'test3' must be PURE too
!ERROR: Procedure 'assign_tz' referenced in pure subprogram 'test3' must be pure too
a = z
!ERROR: Procedure 'assign_01' referenced in PURE subprogram 'test3' must be PURE too
!ERROR: Procedure 'assign_01' referenced in pure subprogram 'test3' must be pure too
r = r5
end

40
flang/test/semantics/structconst03.f90
View File

@ -61,26 +61,26 @@ module module1
real, target :: commonvar1
common /cblock/ commonvar1
x1 = t1(0)(local1)
!ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a pure procedure
x1 = t1(0)(usedfrom1)
!ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'pt1' in a pure procedure
x1 = t1(0)(modulevar1)
!ERROR: Externally visible object 'cblock' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'cblock' may not be associated with pointer component 'pt1' in a pure procedure
x1 = t1(0)(commonvar1)
!ERROR: Externally visible object 'dummy1' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'dummy1' may not be associated with pointer component 'pt1' in a pure procedure
x1 = t1(0)(dummy1)
x1 = t1(0)(dummy2)
!ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure
x1 = t1(0)(dummy3)
! TODO when semantics handles coindexing:
! TODO !ERROR: Externally visible object may not be associated with a pointer in a PURE procedure
! TODO !ERROR: Externally visible object may not be associated with a pointer in a pure procedure
! TODO x1 = t1(0)(dummy4[0])
x1 = t1(0)(dummy4)
!ERROR: Externally visible object 'modulevar2' may not be associated with pointer component 'ptop' in a PURE procedure
!ERROR: Externally visible object 'modulevar2' may not be associated with pointer component 'ptop' in a pure procedure
x2 = t2(0)(modulevar2)
!ERROR: Externally visible object 'modulevar3' may not be associated with pointer component 'ptop' in a PURE procedure
!ERROR: Externally visible object 'modulevar3' may not be associated with pointer component 'ptop' in a pure procedure
x3 = t3(0)(modulevar3)
!ERROR: Externally visible object 'modulevar4' may not be associated with pointer component 'ptop' in a PURE procedure
!ERROR: Externally visible object 'modulevar4' may not be associated with pointer component 'ptop' in a pure procedure
x4 = t4(0)(modulevar4)
contains
pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
@ -94,30 +94,30 @@ module module1
real, pointer :: dummy3a
real, intent(inout), target :: dummy4a[*]
x1a = t1(0)(local1a)
!ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a pure procedure
x1a = t1(0)(usedfrom1)
!ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'pt1' in a pure procedure
x1a = t1(0)(modulevar1)
!ERROR: Externally visible object 'commonvar1' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'commonvar1' may not be associated with pointer component 'pt1' in a pure procedure
x1a = t1(0)(commonvar1)
!ERROR: Externally visible object 'dummy1' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'dummy1' may not be associated with pointer component 'pt1' in a pure procedure
x1a = t1(0)(dummy1)
!ERROR: Externally visible object 'dummy1a' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'dummy1a' may not be associated with pointer component 'pt1' in a pure procedure
x1a = t1(0)(dummy1a)
x1a = t1(0)(dummy2a)
!ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure
x1a = t1(0)(dummy3)
!ERROR: Externally visible object 'dummy3a' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'dummy3a' may not be associated with pointer component 'pt1' in a pure procedure
x1a = t1(0)(dummy3a)
! TODO when semantics handles coindexing:
! TODO !ERROR: Externally visible object may not be associated with a pointer in a PURE procedure
! TODO !ERROR: Externally visible object may not be associated with a pointer in a pure procedure
! TODO x1a = t1(0)(dummy4a[0])
x1a = t1(0)(dummy4a)
!ERROR: Externally visible object 'modulevar2' may not be associated with pointer component 'ptop' in a PURE procedure
!ERROR: Externally visible object 'modulevar2' may not be associated with pointer component 'ptop' in a pure procedure
x2a = t2(0)(modulevar2)
!ERROR: Externally visible object 'modulevar3' may not be associated with pointer component 'ptop' in a PURE procedure
!ERROR: Externally visible object 'modulevar3' may not be associated with pointer component 'ptop' in a pure procedure
x3a = t3(0)(modulevar3)
!ERROR: Externally visible object 'modulevar4' may not be associated with pointer component 'ptop' in a PURE procedure
!ERROR: Externally visible object 'modulevar4' may not be associated with pointer component 'ptop' in a pure procedure
x4a = t4(0)(modulevar4)
end subroutine subr
end subroutine

40
flang/test/semantics/structconst04.f90
View File

@ -56,26 +56,26 @@ module module1
real, target :: commonvar1
common /cblock/ commonvar1
x1 = t1(local1)
!ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a pure procedure
x1 = t1(usedfrom1)
!ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'pt1' in a pure procedure
x1 = t1(modulevar1)
!ERROR: Externally visible object 'cblock' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'cblock' may not be associated with pointer component 'pt1' in a pure procedure
x1 = t1(commonvar1)
!ERROR: Externally visible object 'dummy1' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'dummy1' may not be associated with pointer component 'pt1' in a pure procedure
x1 = t1(dummy1)
x1 = t1(dummy2)
!ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure
x1 = t1(dummy3)
! TODO when semantics handles coindexing:
! TODO !ERROR: Externally visible object may not be associated with a pointer in a PURE procedure
! TODO !ERROR: Externally visible object may not be associated with a pointer in a pure procedure
! TODO x1 = t1(dummy4[0])
x1 = t1(dummy4)
!ERROR: Externally visible object 'modulevar2' may not be associated with pointer component 'ptop' in a PURE procedure
!ERROR: Externally visible object 'modulevar2' may not be associated with pointer component 'ptop' in a pure procedure
x2 = t2(modulevar2)
!ERROR: Externally visible object 'modulevar3' may not be associated with pointer component 'ptop' in a PURE procedure
!ERROR: Externally visible object 'modulevar3' may not be associated with pointer component 'ptop' in a pure procedure
x3 = t3(modulevar3)
!ERROR: Externally visible object 'modulevar4' may not be associated with pointer component 'ptop' in a PURE procedure
!ERROR: Externally visible object 'modulevar4' may not be associated with pointer component 'ptop' in a pure procedure
x4 = t4(modulevar4)
contains
pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
@ -89,30 +89,30 @@ module module1
real, pointer :: dummy3a
real, intent(inout), target :: dummy4a[*]
x1a = t1(local1a)
!ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a pure procedure
x1a = t1(usedfrom1)
!ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'pt1' in a pure procedure
x1a = t1(modulevar1)
!ERROR: Externally visible object 'commonvar1' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'commonvar1' may not be associated with pointer component 'pt1' in a pure procedure
x1a = t1(commonvar1)
!ERROR: Externally visible object 'dummy1' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'dummy1' may not be associated with pointer component 'pt1' in a pure procedure
x1a = t1(dummy1)
!ERROR: Externally visible object 'dummy1a' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'dummy1a' may not be associated with pointer component 'pt1' in a pure procedure
x1a = t1(dummy1a)
x1a = t1(dummy2a)
!ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'dummy3' may not be associated with pointer component 'pt1' in a pure procedure
x1a = t1(dummy3)
!ERROR: Externally visible object 'dummy3a' may not be associated with pointer component 'pt1' in a PURE procedure
!ERROR: Externally visible object 'dummy3a' may not be associated with pointer component 'pt1' in a pure procedure
x1a = t1(dummy3a)
! TODO when semantics handles coindexing:
! TODO !ERROR: Externally visible object may not be associated with a pointer in a PURE procedure
! TODO !ERROR: Externally visible object may not be associated with a pointer in a pure procedure
! TODO x1a = t1(dummy4a[0])
x1a = t1(dummy4a)
!ERROR: Externally visible object 'modulevar2' may not be associated with pointer component 'ptop' in a PURE procedure
!ERROR: Externally visible object 'modulevar2' may not be associated with pointer component 'ptop' in a pure procedure
x2a = t2(modulevar2)
!ERROR: Externally visible object 'modulevar3' may not be associated with pointer component 'ptop' in a PURE procedure
!ERROR: Externally visible object 'modulevar3' may not be associated with pointer component 'ptop' in a pure procedure
x3a = t3(modulevar3)
!ERROR: Externally visible object 'modulevar4' may not be associated with pointer component 'ptop' in a PURE procedure
!ERROR: Externally visible object 'modulevar4' may not be associated with pointer component 'ptop' in a pure procedure
x4a = t4(modulevar4)
end subroutine subr
end subroutine

5
flang/tools/f18/f18.cc
View File

@ -520,6 +520,11 @@ int main(int argc, char *const argv[]) {
defaultKinds.set_defaultRealKind(8);
} else if (arg == "-i8" || arg == "-fdefault-integer-8") {
defaultKinds.set_defaultIntegerKind(8);
defaultKinds.set_subscriptIntegerKind(8);
} else if (arg == "-Mlargearray") {
defaultKinds.set_subscriptIntegerKind(8);
} else if (arg == "-Mnolargearray") {
defaultKinds.set_subscriptIntegerKind(4);
} else if (arg == "-module") {
driver.moduleDirectory = args.front();
args.pop_front();