Skip to content

Commit 7c3a45a

Browse files
FreddyLeafFreddyLeaf
committed
Merge from 'main' to 'sycl-web' (8 commits)
 CONFLICT (content): Merge conflict in CONTRIBUTING.md
2 parents 10d0a02 + de7639d commit 7c3a45a

36 files changed

+498
-256
lines changed

‎flang/docs/Extensions.md

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -269,6 +269,9 @@ end
269269
* A scalar logical dummy argument to a `BIND(C)` procedure does
270270
not have to have `KIND=C_BOOL` since it can be converted to/from
271271
`_Bool` without loss of information.
272+
* The character length of the `SOURCE=` or `MOLD=` in `ALLOCATE`
273+
may be distinct from the constant character length, if any,
274+
of an allocated object.
272275

273276
### Extensions supported when enabled by options
274277

‎flang/lib/Semantics/assignment.cpp

Lines changed: 15 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -44,8 +44,7 @@ class AssignmentContext {
4444
void Analyze(const parser::ConcurrentControl &);
4545

4646
private:
47-
bool CheckForPureContext(const SomeExpr &rhs, parser::CharBlock rhsSource,
48-
bool isPointerAssignment, bool isDefinedAssignment);
47+
bool CheckForPureContext(const SomeExpr &rhs, parser::CharBlock rhsSource);
4948
void CheckShape(parser::CharBlock, const SomeExpr *);
5049
template <typename... A>
5150
parser::Message *Say(parser::CharBlock at, A &&...args) {
@@ -75,8 +74,11 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
7574
}
7675
}
7776
auto rhsLoc{std::get<parser::Expr>(stmt.t).source};
78-
CheckForPureContext(rhs, rhsLoc, false /*not a pointer assignment*/,
79-
std::holds_alternative<evaluate::ProcedureRef>(assignment->u));
77+
if (std::holds_alternative<evaluate::ProcedureRef>(assignment->u)) {
78+
// it's a defined ASSIGNMENT(=)
79+
} else {
80+
CheckForPureContext(rhs, rhsLoc);
81+
}
8082
if (whereDepth_ > 0) {
8183
CheckShape(lhsLoc, &lhs);
8284
}
@@ -86,14 +88,10 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
8688
void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &stmt) {
8789
CHECK(whereDepth_ == 0);
8890
if (const evaluate::Assignment * assignment{GetAssignment(stmt)}) {
89-
const SomeExpr &rhs{assignment->rhs};
90-
CheckForPureContext(rhs, std::get<parser::Expr>(stmt.t).source,
91-
true /*this is a pointer assignment*/,
92-
false /*not a defined assignment*/);
9391
parser::CharBlock at{context_.location().value()};
9492
auto restorer{foldingContext().messages().SetLocation(at)};
95-
const Scope &scope{context_.FindScope(at)};
96-
CheckPointerAssignment(foldingContext(), *assignment, scope);
93+
CheckPointerAssignment(
94+
foldingContext(), *assignment, context_.FindScope(at));
9795
}
9896
}
9997

@@ -128,29 +126,16 @@ bool CheckCopyabilityInPureScope(parser::ContextualMessages &messages,
128126
return true;
129127
}
130128

131-
bool AssignmentContext::CheckForPureContext(const SomeExpr &rhs,
132-
parser::CharBlock rhsSource, bool isPointerAssignment,
133-
bool isDefinedAssignment) {
129+
bool AssignmentContext::CheckForPureContext(
130+
const SomeExpr &rhs, parser::CharBlock rhsSource) {
134131
const Scope &scope{context_.FindScope(rhsSource)};
135-
if (!FindPureProcedureContaining(scope)) {
136-
return true;
137-
}
138-
parser::ContextualMessages messages{
139-
context_.location().value(), &context_.messages()};
140-
if (isPointerAssignment) {
141-
if (const Symbol * base{GetFirstSymbol(rhs)}) {
142-
if (const char *why{WhyBaseObjectIsSuspicious(
143-
base->GetUltimate(), scope)}) { // C1594(3)
144-
evaluate::SayWithDeclaration(messages, *base,
145-
"A pure subprogram may not use '%s' as the target of pointer assignment because it is %s"_err_en_US,
146-
base->name(), why);
147-
return false;
148-
}
149-
}
150-
} else if (!isDefinedAssignment) {
132+
if (FindPureProcedureContaining(scope)) {
133+
parser::ContextualMessages messages{
134+
context_.location().value(), &context_.messages()};
151135
return CheckCopyabilityInPureScope(messages, rhs, scope);
136+
} else {
137+
return true;
152138
}
153-
return true;
154139
}
155140

156141
// 10.2.3.1(2) The masks and LHS of assignments must be arrays of the same shape

‎flang/lib/Semantics/check-allocate.cpp

Lines changed: 58 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -350,30 +350,24 @@ static std::optional<std::int64_t> GetTypeParameterInt64Value(
350350
if (const ParamValue *
351351
paramValue{derivedType.FindParameter(parameterSymbol.name())}) {
352352
return evaluate::ToInt64(paramValue->GetExplicit());
353-
} else {
354-
return std::nullopt;
355353
}
354+
return std::nullopt;
356355
}
357356

358-
// HaveCompatibleKindParameters functions assume type1 is type compatible with
359-
// type2 (except for kind type parameters)
360-
static bool HaveCompatibleKindParameters(
357+
static bool HaveCompatibleTypeParameters(
361358
const DerivedTypeSpec &derivedType1, const DerivedTypeSpec &derivedType2) {
362359
for (const Symbol &symbol :
363360
OrderParameterDeclarations(derivedType1.typeSymbol())) {
364-
if (symbol.get<TypeParamDetails>().attr() == common::TypeParamAttr::Kind) {
365-
// At this point, it should have been ensured that these contain integer
366-
// constants, so die if this is not the case.
367-
if (GetTypeParameterInt64Value(symbol, derivedType1).value() !=
368-
GetTypeParameterInt64Value(symbol, derivedType2).value()) {
369-
return false;
370-
}
361+
auto v1{GetTypeParameterInt64Value(symbol, derivedType1)};
362+
auto v2{GetTypeParameterInt64Value(symbol, derivedType2)};
363+
if (v1 && v2 && *v1 != *v2) {
364+
return false;
371365
}
372366
}
373367
return true;
374368
}
375369

376-
static bool HaveCompatibleKindParameters(
370+
static bool HaveCompatibleTypeParameters(
377371
const DeclTypeSpec &type1, const evaluate::DynamicType &type2) {
378372
if (type1.category() == DeclTypeSpec::Category::ClassStar) {
379373
return true;
@@ -383,28 +377,56 @@ static bool HaveCompatibleKindParameters(
383377
} else if (type2.IsUnlimitedPolymorphic()) {
384378
return false;
385379
} else if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
386-
return HaveCompatibleKindParameters(
380+
return HaveCompatibleTypeParameters(
387381
*derivedType1, type2.GetDerivedTypeSpec());
388382
} else {
389383
common::die("unexpected type1 category");
390384
}
391385
}
392386

393-
static bool HaveCompatibleKindParameters(
387+
static bool HaveCompatibleTypeParameters(
394388
const DeclTypeSpec &type1, const DeclTypeSpec &type2) {
395389
if (type1.category() == DeclTypeSpec::Category::ClassStar) {
396390
return true;
397-
}
398-
if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
399-
return intrinsicType1->kind() == DEREF(type2.AsIntrinsic()).kind();
391+
} else if (const IntrinsicTypeSpec * intrinsicType1{type1.AsIntrinsic()}) {
392+
const IntrinsicTypeSpec *intrinsicType2{type2.AsIntrinsic()};
393+
return !intrinsicType2 || intrinsicType1->kind() == intrinsicType2->kind();
400394
} else if (const DerivedTypeSpec * derivedType1{type1.AsDerived()}) {
401-
return HaveCompatibleKindParameters(
402-
*derivedType1, DEREF(type2.AsDerived()));
395+
const DerivedTypeSpec *derivedType2{type2.AsDerived()};
396+
return !derivedType2 ||
397+
HaveCompatibleTypeParameters(*derivedType1, *derivedType2);
403398
} else {
404399
common::die("unexpected type1 category");
405400
}
406401
}
407402

403+
static bool HaveCompatibleLengths(
404+
const DeclTypeSpec &type1, const DeclTypeSpec &type2) {
405+
if (type1.category() == DeclTypeSpec::Character &&
406+
type2.category() == DeclTypeSpec::Character) {
407+
auto v1{
408+
evaluate::ToInt64(type1.characterTypeSpec().length().GetExplicit())};
409+
auto v2{
410+
evaluate::ToInt64(type2.characterTypeSpec().length().GetExplicit())};
411+
return !v1 || !v2 || *v1 == *v2;
412+
} else {
413+
return true;
414+
}
415+
}
416+
417+
static bool HaveCompatibleLengths(
418+
const DeclTypeSpec &type1, const evaluate::DynamicType &type2) {
419+
if (type1.category() == DeclTypeSpec::Character &&
420+
type2.category() == TypeCategory::Character) {
421+
auto v1{
422+
evaluate::ToInt64(type1.characterTypeSpec().length().GetExplicit())};
423+
auto v2{type2.knownLength()};
424+
return !v1 || !v2 || *v1 == *v2;
425+
} else {
426+
return true;
427+
}
428+
}
429+
408430
bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
409431
if (!symbol_) {
410432
CHECK(context.AnyFatalError());
@@ -455,10 +477,15 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
455477
"Allocatable object in ALLOCATE must be type compatible with type-spec"_err_en_US);
456478
return false;
457479
}
458-
if (!HaveCompatibleKindParameters(*type_, *allocateInfo_.typeSpec)) {
480+
if (!HaveCompatibleTypeParameters(*type_, *allocateInfo_.typeSpec)) {
459481
context.Say(name_.source,
460482
// C936
461-
"Kind type parameters of allocatable object in ALLOCATE must be the same as the corresponding ones in type-spec"_err_en_US);
483+
"Type parameters of allocatable object in ALLOCATE must be the same as the corresponding ones in type-spec"_err_en_US);
484+
return false;
485+
}
486+
if (!HaveCompatibleLengths(*type_, *allocateInfo_.typeSpec)) { // C934
487+
context.Say(name_.source,
488+
"Character length of allocatable object in ALLOCATE must be the same as the type-spec"_err_en_US);
462489
return false;
463490
}
464491
if (!HaveSameAssumedTypeParameters(*type_, *allocateInfo_.typeSpec)) {
@@ -474,11 +501,18 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
474501
"Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE"_err_en_US);
475502
return false;
476503
}
477-
if (!HaveCompatibleKindParameters(
504+
if (!HaveCompatibleTypeParameters(
478505
*type_, allocateInfo_.sourceExprType.value())) {
479506
// C946
480507
context.Say(name_.source,
481-
"Kind type parameters of allocatable object must be the same as the corresponding ones of SOURCE or MOLD expression"_err_en_US);
508+
"Derived type parameters of allocatable object must be the same as the corresponding ones of SOURCE or MOLD expression"_err_en_US);
509+
return false;
510+
}
511+
// Character length distinction is allowed, with a warning
512+
if (!HaveCompatibleLengths(
513+
*type_, allocateInfo_.sourceExprType.value())) { // C945
514+
context.Say(name_.source,
515+
"Character length of allocatable object in ALLOCATE should be the same as the SOURCE or MOLD"_port_en_US);
482516
return false;
483517
}
484518
}

‎flang/lib/Semantics/check-call.cpp

Lines changed: 7 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -494,23 +494,16 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
494494

495495
// 15.5.2.7 -- dummy is POINTER
496496
if (dummyIsPointer) {
497-
if (dummyIsContiguous && !actualIsContiguous) {
497+
if (actualIsPointer || dummy.intent == common::Intent::In) {
498+
if (scope) {
499+
semantics::CheckPointerAssignment(
500+
context, messages.at(), dummyName, dummy, actual, *scope);
501+
}
502+
} else if (!actualIsPointer) {
498503
messages.Say(
499-
"Actual argument associated with CONTIGUOUS POINTER %s must be simply contiguous"_err_en_US,
504+
"Actual argument associated with POINTER %s must also be POINTER unless INTENT(IN)"_err_en_US,
500505
dummyName);
501506
}
502-
if (!actualIsPointer) {
503-
if (dummy.intent == common::Intent::In) {
504-
if (scope) {
505-
semantics::CheckPointerAssignment(
506-
context, messages.at(), dummyName, dummy, actual, *scope);
507-
}
508-
} else {
509-
messages.Say(
510-
"Actual argument associated with POINTER %s must also be POINTER unless INTENT(IN)"_err_en_US,
511-
dummyName);
512-
}
513-
}
514507
}
515508

516509
// 15.5.2.5 -- actual & dummy are both POINTER or both ALLOCATABLE

‎flang/lib/Semantics/check-data.cpp

Lines changed: 21 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -179,24 +179,27 @@ class DataVarChecker : public evaluate::AllTraverse<DataVarChecker, true> {
179179
bool isFirstSymbol_{true};
180180
};
181181

182+
static bool IsValidDataObject(const SomeExpr &expr) { // C878, C879
183+
return !evaluate::IsConstantExpr(expr) &&
184+
(evaluate::IsVariable(expr) || evaluate::IsProcedurePointer(expr));
185+
}
186+
182187
void DataChecker::Leave(const parser::DataIDoObject &object) {
183188
if (const auto *designator{
184189
std::get_if<parser::Scalar<common::Indirection<parser::Designator>>>(
185190
&object.u)}) {
186191
if (MaybeExpr expr{exprAnalyzer_.Analyze(*designator)}) {
187192
auto source{designator->thing.value().source};
188-
if (evaluate::IsConstantExpr(*expr)) { // C878,C879
189-
exprAnalyzer_.context().Say(
190-
source, "Data implied do object must be a variable"_err_en_US);
191-
} else {
192-
DataVarChecker checker{exprAnalyzer_.context(), source};
193-
if (checker(*expr)) {
194-
if (checker.HasComponentWithoutSubscripts()) { // C880
195-
exprAnalyzer_.context().Say(source,
196-
"Data implied do structure component must be subscripted"_err_en_US);
197-
} else {
198-
return;
199-
}
193+
DataVarChecker checker{exprAnalyzer_.context(), source};
194+
if (checker(*expr)) {
195+
if (checker.HasComponentWithoutSubscripts()) { // C880
196+
exprAnalyzer_.context().Say(source,
197+
"Data implied do structure component must be subscripted"_err_en_US);
198+
} else if (!IsValidDataObject(*expr)) {
199+
exprAnalyzer_.context().Say(
200+
source, "Data implied do object must be a variable"_err_en_US);
201+
} else {
202+
return;
200203
}
201204
}
202205
}
@@ -211,9 +214,13 @@ void DataChecker::Leave(const parser::DataStmtObject &dataObject) {
211214
},
212215
[&](const auto &var) {
213216
auto expr{exprAnalyzer_.Analyze(var)};
217+
auto source{parser::FindSourceLocation(dataObject)};
214218
if (!expr ||
215-
!DataVarChecker{exprAnalyzer_.context(),
216-
parser::FindSourceLocation(dataObject)}(*expr)) {
219+
!DataVarChecker{exprAnalyzer_.context(), source}(*expr)) {
220+
currentSetHasFatalErrors_ = true;
221+
} else if (!IsValidDataObject(*expr)) {
222+
exprAnalyzer_.context().Say(
223+
source, "Data statement object must be a variable"_err_en_US);
217224
currentSetHasFatalErrors_ = true;
218225
}
219226
},

‎flang/lib/Semantics/expression.cpp

Lines changed: 19 additions & 31 deletions
Original file line numberDiff line numberDiff line change
@@ -1814,6 +1814,8 @@ MaybeExpr ExpressionAnalyzer::Analyze(
18141814
if (!spec.scope() || !typeSymbol.has<semantics::DerivedTypeDetails>()) {
18151815
return std::nullopt; // error recovery
18161816
}
1817+
const semantics::Scope &scope{context_.FindScope(typeName)};
1818+
const semantics::Scope *pureContext{FindPureProcedureContaining(scope)};
18171819
const auto &typeDetails{typeSymbol.get<semantics::DerivedTypeDetails>()};
18181820
const Symbol *parentComponent{typeDetails.GetParentComponent(*spec.scope())};
18191821

@@ -1939,41 +1941,18 @@ MaybeExpr ExpressionAnalyzer::Analyze(
19391941
}
19401942
unavailable.insert(symbol->name());
19411943
if (value) {
1942-
if (symbol->has<semantics::ProcEntityDetails>()) {
1943-
CHECK(IsPointer(*symbol));
1944-
} else if (symbol->has<semantics::ObjectEntityDetails>()) {
1945-
// C1594(4)
1946-
if (const auto *pureProc{FindPureProcedureContaining(innermost)}) {
1947-
if (const Symbol *pointer{FindPointerComponent(*symbol)}) {
1948-
if (const Symbol *object{
1949-
FindExternallyVisibleObject(*value, *pureProc)}) {
1950-
if (auto *msg{Say(expr.source,
1951-
"Externally visible object '%s' may not be "
1952-
"associated with pointer component '%s' in a "
1953-
"pure procedure"_err_en_US,
1954-
object->name(), pointer->name())}) {
1955-
msg->Attach(object->name(), "Object declaration"_en_US)
1956-
.Attach(pointer->name(), "Pointer declaration"_en_US);
1957-
}
1958-
}
1959-
}
1960-
}
1961-
} else if (symbol->has<semantics::TypeParamDetails>()) {
1944+
if (symbol->has<semantics::TypeParamDetails>()) {
19621945
Say(expr.source,
1963-
"Type parameter '%s' may not appear as a component "
1964-
"of a structure constructor"_err_en_US,
1946+
"Type parameter '%s' may not appear as a component of a structure constructor"_err_en_US,
19651947
symbol->name());
1966-
continue;
1967-
} else {
1968-
Say(expr.source,
1969-
"Component '%s' is neither a procedure pointer "
1970-
"nor a data object"_err_en_US,
1971-
symbol->name());
1972-
continue;
19731948
}
1974-
if (IsPointer(*symbol)) {
1949+
if (!(symbol->has<semantics::ProcEntityDetails>() ||
1950+
symbol->has<semantics::ObjectEntityDetails>())) {
1951+
continue; // recovery
1952+
}
1953+
if (IsPointer(*symbol)) { // C7104, C7105, C1594(4)
19751954
semantics::CheckStructConstructorPointerComponent(
1976-
GetFoldingContext(), *symbol, *value, innermost); // C7104, C7105
1955+
GetFoldingContext(), *symbol, *value, innermost);
19771956
result.Add(*symbol, Fold(std::move(*value)));
19781957
continue;
19791958
}
@@ -2008,6 +1987,15 @@ MaybeExpr ExpressionAnalyzer::Analyze(
20081987
*symbol);
20091988
continue;
20101989
}
1990+
} else if (const Symbol * pointer{FindPointerComponent(*symbol)};
1991+
pointer && pureContext) { // C1594(4)
1992+
if (const Symbol *
1993+
visible{semantics::FindExternallyVisibleObject(
1994+
*value, *pureContext)}) {
1995+
Say(expr.source,
1996+
"The externally visible object '%s' may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US,
1997+
visible->name(), symbol->name(), pointer->name());
1998+
}
20111999
}
20122000
if (MaybeExpr converted{ConvertToType(*symbol, std::move(*value))}) {
20132001
if (auto componentShape{GetShape(GetFoldingContext(), *symbol)}) {

0 commit comments

Comments
 (0)