[flang-commits] [flang] [flang] Add semantics support for Fortran 2023 conditional arguments (F2023 R1526-R1528) (PR #195345)
Vineet Kumar via flang-commits
flang-commits at lists.llvm.org
Thu Jun 25 07:01:18 PDT 2026
https://github.com/vntkmr updated https://github.com/llvm/llvm-project/pull/195345
>From dc55b2f58326ae13a7c2335462b35213fa1a829c Mon Sep 17 00:00:00 2001
From: Vineet Kumar <vineetk at hpe.com>
Date: Thu, 30 Apr 2026 10:15:03 -0500
Subject: [PATCH 1/4] [flang] Implement F2023 conditional argument semantics
(F2023 C1538-C1545)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Add semantic analysis for F2023 conditional arguments (F2023
R1526-R1528),
enforcing constraints F2023 C1538-C1545.
Add recursive ConditionalArg representation to ActualArgument with
VisitTail() dispatch helper
Enforce C1538 (type/kind), C1539 (rank), C1540 (.NIL./optional),
C1541 (INTENT(OUT/INOUT)), C1542 (coarray), C1543 (assumed-rank),
C1545 (corank/allocatable/pointer consistency among consequent-args)
C1544 (consequent-arg expr shall not be a variable) is a grammar
disambiguation rule, automatically satisfied by parsing both
alternatives
as a single Expr production — no semantic check needed.
Reject conditional arguments with implicit interfaces
Extend traverse.h, formatting.cpp, and characteristics.cpp for
ConditionalArg
Add positive and negative semantic test cases
AI use disclaimer: The changes in this commit were substantially
generated
with the assistance of AI (claude opus 4.6 via Github CoPilot). In
accordance
with the LLVM project's AI use policy, I have reviewed and tested the
code to
the best of my ability.
---
flang/include/flang/Evaluate/call.h | 92 +++-
flang/include/flang/Evaluate/traverse.h | 26 +-
flang/lib/Evaluate/call.cpp | 56 ++-
flang/lib/Evaluate/characteristics.cpp | 24 +-
flang/lib/Evaluate/formatting.cpp | 33 ++
flang/lib/Parser/program-parsers.cpp | 8 +
flang/lib/Semantics/check-call.cpp | 131 ++++-
flang/lib/Semantics/expression.cpp | 246 ++++++++-
flang/test/Semantics/conditional-arg.f90 | 610 ++++++++++++++++++++++-
9 files changed, 1169 insertions(+), 57 deletions(-)
diff --git a/flang/include/flang/Evaluate/call.h b/flang/include/flang/Evaluate/call.h
index 01b41f36b9977..9eb8103a5ff7d 100644
--- a/flang/include/flang/Evaluate/call.h
+++ b/flang/include/flang/Evaluate/call.h
@@ -73,11 +73,88 @@ class ActualArgument {
SymbolRef symbol_;
};
+ // F2023 R1526 conditional-arg: runtime selection of actual arguments.
+ // Recursive structure mirroring the parser: each ConditionalArg holds
+ // a condition, a consequent, and a tail that is either another
+ // ConditionalArg (continuing the chain) or a terminal Consequent.
+ // std::nullopt represents .NIL. (absent optional argument).
+ class ConditionalArg {
+ public:
+ using Consequent =
+ std::optional<common::CopyableIndirection<Expr<SomeType>>>;
+ using ConditionalArgPartOrConsequent =
+ std::variant<common::CopyableIndirection<ConditionalArg>, Consequent>;
+
+ ConditionalArg(Expr<SomeLogical> &&condition, Consequent &&consequent,
+ ConditionalArgPartOrConsequent &&tail);
+ DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(ConditionalArg)
+
+ const Expr<SomeLogical> &condition() const { return condition_.value(); }
+ const Consequent &consequent() const { return consequent_; }
+ Consequent &consequent() { return consequent_; }
+ const ConditionalArgPartOrConsequent &tail() const { return tail_; }
+
+ // Dispatch on the tail: calls onConditionalArg(const ConditionalArg &)
+ // if the tail continues the chain, or onConsequent(const Consequent &)
+ // if the tail is the terminal consequent.
+ template <typename F, typename G>
+ auto VisitTail(F onConditionalArg, G onConsequent) const {
+ return common::visit(
+ common::visitors{
+ [&](const common::CopyableIndirection<ConditionalArg> &inner) {
+ return onConditionalArg(inner.value());
+ },
+ [&](const Consequent &cons) { return onConsequent(cons); },
+ },
+ tail_);
+ }
+
+ template <typename F, typename G>
+ auto VisitTail(F onConditionalArg, G onConsequent) {
+ return common::visit(
+ common::visitors{
+ [&](common::CopyableIndirection<ConditionalArg> &inner) {
+ return onConditionalArg(inner.value());
+ },
+ [&](Consequent &cons) { return onConsequent(cons); },
+ },
+ tail_);
+ }
+
+ // Apply a callback to every Consequent in the chain (including .NIL.
+ // entries). This encapsulates the recurring "process consequent, then
+ // VisitTail with recursion" pattern.
+ template <typename F> void ForEachConsequent(F f) const {
+ f(consequent_);
+ VisitTail(
+ [&](const ConditionalArg &inner) { inner.ForEachConsequent(f); },
+ [&](const Consequent &cons) { f(cons); });
+ }
+ template <typename F> void ForEachConsequent(F f) {
+ f(consequent_);
+ VisitTail([&](ConditionalArg &inner) { inner.ForEachConsequent(f); },
+ [&](Consequent &cons) { f(cons); });
+ }
+
+ // Returns the first non-.NIL. consequent expression, or nullptr.
+ const Expr<SomeType> *FirstNonNilConsequent() const;
+ bool HasNilConsequent() const;
+
+ bool operator==(const ConditionalArg &) const;
+ llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const;
+
+ private:
+ common::CopyableIndirection<Expr<SomeLogical>> condition_;
+ Consequent consequent_;
+ ConditionalArgPartOrConsequent tail_;
+ };
+
DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(ActualArgument)
explicit ActualArgument(Expr<SomeType> &&);
explicit ActualArgument(common::CopyableIndirection<Expr<SomeType>> &&);
explicit ActualArgument(AssumedType);
explicit ActualArgument(common::Label);
+ explicit ActualArgument(ConditionalArg &&);
~ActualArgument();
ActualArgument &operator=(Expr<SomeType> &&);
@@ -122,6 +199,19 @@ class ActualArgument {
bool isAlternateReturn() const {
return std::holds_alternative<common::Label>(u_);
}
+ bool isConditionalArg() const {
+ return std::holds_alternative<ConditionalArg>(u_);
+ }
+ const ConditionalArg *GetConditionalArg() const {
+ return std::get_if<ConditionalArg>(&u_);
+ }
+ ConditionalArg *GetConditionalArg() {
+ return std::get_if<ConditionalArg>(&u_);
+ }
+ const Expr<SomeType> *GetConditionalArgExpr() const {
+ const auto *condArg{GetConditionalArg()};
+ return condArg ? condArg->FirstNonNilConsequent() : nullptr;
+ }
bool isPassedObject() const { return attrs_.test(Attr::PassedObject); }
ActualArgument &set_isPassedObject(bool yes = true) {
if (yes) {
@@ -169,7 +259,7 @@ class ActualArgument {
// first as a variable, then as an expression, and the distinction appears
// in the parse tree.
std::variant<common::CopyableIndirection<Expr<SomeType>>, AssumedType,
- common::Label>
+ common::Label, ConditionalArg>
u_;
std::optional<parser::CharBlock> keyword_;
Attrs attrs_;
diff --git a/flang/include/flang/Evaluate/traverse.h b/flang/include/flang/Evaluate/traverse.h
index 44cfaa2a7073d..3c51666486b59 100644
--- a/flang/include/flang/Evaluate/traverse.h
+++ b/flang/include/flang/Evaluate/traverse.h
@@ -178,9 +178,31 @@ class Traverse {
Result operator()(const ActualArgument &x) const {
if (const auto *symbol{x.GetAssumedTypeDummy()}) {
return visitor_(*symbol);
- } else {
- return visitor_(x.UnwrapExpr());
}
+ if (const auto *condArg{x.GetConditionalArg()}) {
+ return TraverseConditionalArg(*condArg);
+ }
+ return visitor_(x.UnwrapExpr());
+ }
+ Result TraverseConditionalArg(
+ const ActualArgument::ConditionalArg &ca) const {
+ Result result{visitor_.Default()};
+ result = visitor_.Combine(std::move(result), visitor_(ca.condition()));
+ if (ca.consequent()) {
+ result = visitor_.Combine(
+ std::move(result), visitor_(ca.consequent()->value()));
+ }
+ return ca.VisitTail(
+ [&](const ActualArgument::ConditionalArg &inner) {
+ return visitor_.Combine(
+ std::move(result), TraverseConditionalArg(inner));
+ },
+ [&](const ActualArgument::ConditionalArg::Consequent &cons) -> Result {
+ if (cons) {
+ return visitor_.Combine(std::move(result), visitor_(cons->value()));
+ }
+ return result;
+ });
}
Result operator()(const ProcedureRef &x) const {
return Combine(x.proc(), x.arguments());
diff --git a/flang/lib/Evaluate/call.cpp b/flang/lib/Evaluate/call.cpp
index b179fd7a4a4f5..57afa80a03209 100644
--- a/flang/lib/Evaluate/call.cpp
+++ b/flang/lib/Evaluate/call.cpp
@@ -23,6 +23,12 @@ ActualArgument::ActualArgument(common::CopyableIndirection<Expr<SomeType>> &&v)
: u_{std::move(v)} {}
ActualArgument::ActualArgument(AssumedType x) : u_{x} {}
ActualArgument::ActualArgument(common::Label x) : u_{x} {}
+ActualArgument::ActualArgument(ConditionalArg &&x) : u_{std::move(x)} {}
+
+ActualArgument::ConditionalArg::ConditionalArg(Expr<SomeLogical> &&condition,
+ Consequent &&consequent, ConditionalArgPartOrConsequent &&tail)
+ : condition_{std::move(condition)}, consequent_{std::move(consequent)},
+ tail_{std::move(tail)} {}
ActualArgument::~ActualArgument() {}
ActualArgument::AssumedType::AssumedType(const Symbol &symbol)
@@ -41,19 +47,30 @@ ActualArgument &ActualArgument::operator=(Expr<SomeType> &&expr) {
std::optional<DynamicType> ActualArgument::GetType() const {
if (const Expr<SomeType> *expr{UnwrapExpr()}) {
return expr->GetType();
- } else if (std::holds_alternative<AssumedType>(u_)) {
+ }
+ if (std::holds_alternative<AssumedType>(u_)) {
return DynamicType::AssumedType();
- } else {
- return std::nullopt;
}
+ if (const auto *condArg{std::get_if<ConditionalArg>(&u_)}) {
+ if (const auto *expr{condArg->FirstNonNilConsequent()}) {
+ return expr->GetType();
+ }
+ }
+ return std::nullopt;
}
int ActualArgument::Rank() const {
if (const Expr<SomeType> *expr{UnwrapExpr()}) {
return expr->Rank();
- } else {
- return std::get<AssumedType>(u_).Rank();
}
+ if (const auto *condArg{std::get_if<ConditionalArg>(&u_)}) {
+ if (const auto *expr{condArg->FirstNonNilConsequent()}) {
+ return expr->Rank();
+ }
+ // all-.NIL. error caught earlier by F2023 C1540 check
+ DIE("all-.NIL. conditional arg should have been rejected");
+ }
+ return std::get<AssumedType>(u_).Rank();
}
bool ActualArgument::operator==(const ActualArgument &that) const {
@@ -64,6 +81,35 @@ void ActualArgument::Parenthesize() {
u_ = evaluate::Parenthesize(std::move(DEREF(UnwrapExpr())));
}
+bool ActualArgument::ConditionalArg::operator==(
+ const ConditionalArg &that) const {
+ return condition_ == that.condition_ && consequent_ == that.consequent_ &&
+ tail_ == that.tail_;
+}
+
+const Expr<SomeType> *
+ActualArgument::ConditionalArg::FirstNonNilConsequent() const {
+ if (consequent_) {
+ return &consequent_->value();
+ }
+ return VisitTail(
+ [](const ConditionalArg &inner) -> const Expr<SomeType> * {
+ return inner.FirstNonNilConsequent();
+ },
+ [](const Consequent &cons) -> const Expr<SomeType> * {
+ return cons ? &cons->value() : nullptr;
+ });
+}
+
+bool ActualArgument::ConditionalArg::HasNilConsequent() const {
+ if (!consequent_) {
+ return true;
+ }
+ return VisitTail(
+ [](const ConditionalArg &inner) { return inner.HasNilConsequent(); },
+ [](const Consequent &cons) { return !cons.has_value(); });
+}
+
SpecificIntrinsic::SpecificIntrinsic(
IntrinsicProcedure n, characteristics::Procedure &&chars)
: name{n}, characteristics{
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 63d4c74d553e3..20304844e7438 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -165,11 +165,14 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
const ActualArgument &arg, FoldingContext &context, bool invariantOnly) {
if (const auto *expr{arg.UnwrapExpr()}) {
return Characterize(*expr, context, invariantOnly);
- } else if (const Symbol * assumed{arg.GetAssumedTypeDummy()}) {
+ }
+ if (const Symbol *assumed{arg.GetAssumedTypeDummy()}) {
return Characterize(*assumed, context, invariantOnly);
- } else {
- return std::nullopt;
}
+ if (const auto *expr{arg.GetConditionalArgExpr()}) {
+ return Characterize(*expr, context, invariantOnly);
+ }
+ return std::nullopt;
}
bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages,
@@ -959,11 +962,20 @@ std::optional<DummyArgument> DummyArgument::FromActual(std::string &&name,
bool forImplicitInterface) {
if (const auto *expr{arg.UnwrapExpr()}) {
return FromActual(std::move(name), *expr, context, forImplicitInterface);
- } else if (arg.GetAssumedTypeDummy()) {
+ }
+ if (arg.GetAssumedTypeDummy()) {
return std::nullopt;
- } else {
- return DummyArgument{AlternateReturn{}};
}
+ if (const auto *expr{arg.GetConditionalArgExpr()}) {
+ return FromActual(std::move(name), *expr, context, forImplicitInterface);
+ }
+ // Guard: GetArgExpr() returns the first non-NIL consequent for a
+ // ConditionalArg, so normal conditional args are handled above. An
+ // all-.NIL. ConditionalArg would reach here (GetArgExpr() returns nullptr),
+ // but that case is rejected earlier by the F2023 C1540 check. Only a true
+ // alternate-return label should reach this point.
+ CHECK(arg.isAlternateReturn());
+ return DummyArgument{AlternateReturn{}};
}
bool DummyArgument::IsOptional() const {
diff --git a/flang/lib/Evaluate/formatting.cpp b/flang/lib/Evaluate/formatting.cpp
index 3604484254196..c331e461b8640 100644
--- a/flang/lib/Evaluate/formatting.cpp
+++ b/flang/lib/Evaluate/formatting.cpp
@@ -247,6 +247,7 @@ llvm::raw_ostream &ActualArgument::AsFortran(llvm::raw_ostream &o) const {
},
[&](const AssumedType &assumedType) { assumedType.AsFortran(o); },
[&](const common::Label &label) { o << '*' << label; },
+ [&](const ConditionalArg &condArg) { condArg.AsFortran(o); },
},
u_);
if (isPercentVal() || isPercentRef()) {
@@ -262,6 +263,38 @@ std::string ActualArgument::AsFortran() const {
return result;
}
+// Helper: emit the inner part of a conditional arg without outer parens
+static void EmitConditionalArgInner(
+ llvm::raw_ostream &o, const ActualArgument::ConditionalArg &ca) {
+ auto emitConsequent{
+ [&](const ActualArgument::ConditionalArg::Consequent &cons) {
+ if (cons) {
+ cons->value().AsFortran(o);
+ } else {
+ o << ".NIL.";
+ }
+ }};
+ ca.condition().AsFortran(o);
+ o << " ? ";
+ emitConsequent(ca.consequent());
+ o << " : ";
+ ca.VisitTail(
+ [&](const ActualArgument::ConditionalArg &inner) {
+ EmitConditionalArgInner(o, inner);
+ },
+ [&](const ActualArgument::ConditionalArg::Consequent &cons) {
+ emitConsequent(cons);
+ });
+}
+
+llvm::raw_ostream &ActualArgument::ConditionalArg::AsFortran(
+ llvm::raw_ostream &o) const {
+ o << "( ";
+ EmitConditionalArgInner(o, *this);
+ o << " )";
+ return o;
+}
+
llvm::raw_ostream &SpecificIntrinsic::AsFortran(llvm::raw_ostream &o) const {
return o << name;
}
diff --git a/flang/lib/Parser/program-parsers.cpp b/flang/lib/Parser/program-parsers.cpp
index da8cd6fa27b65..ed6c6fd4325ff 100644
--- a/flang/lib/Parser/program-parsers.cpp
+++ b/flang/lib/Parser/program-parsers.cpp
@@ -518,6 +518,14 @@ TYPE_PARSER(construct<ActualArgSpec>(
// F2023 R1528 consequent-arg -> expr | variable
// N.B. "variable" is subsumed by "expr" in the parser;
// semantics determines the distinction.
+// C1544: "A consequent-arg that is an expr shall not be a variable."
+// This is a grammar disambiguation rule making the two alternatives of
+// R1528 mutually exclusive. It is automatically satisfied here because
+// "variable" is subsumed by "expr" in the parser — there is only one
+// production, so no consequent-arg can accidentally match the wrong
+// alternative. Semantics uses IsVariable() to distinguish the two
+// cases when it matters (e.g. C1541 requires variables for INTENT(OUT/
+// INOUT) dummies).
constexpr auto consequent{construct<ConditionalArg::Consequent>(
".NIL." >> construct<ConditionalArgNil>()) ||
construct<ConditionalArg::Consequent>(indirect(expr))};
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index f91b9b1d0b67d..23f961583b0a0 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -41,6 +41,11 @@ void CheckImplicitInterfaceArgKeywords(
void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
parser::ContextualMessages &messages, SemanticsContext &context) {
CheckImplicitInterfaceArgKeywords(arg, messages);
+ if (arg.isConditionalArg()) {
+ messages.Say(
+ "Conditional argument requires an explicit interface"_err_en_US);
+ return;
+ }
auto type{arg.GetType()};
if (type) {
if (type->IsAssumedType()) {
@@ -1406,6 +1411,88 @@ static void CheckProcedureArg(evaluate::ActualArgument &arg,
}
}
+// F2023 C1540-C1543, C1545: Check conditional argument against dummy data
+// object
+static void CheckConditionalArg(
+ const evaluate::ActualArgument::ConditionalArg &condArg,
+ const characteristics::DummyDataObject &object,
+ const std::string &dummyName, parser::ContextualMessages &messages) {
+ // C1540: .NIL. shall not appear if dummy is not optional
+ if (condArg.HasNilConsequent() &&
+ !object.attrs.test(characteristics::DummyDataObject::Attr::Optional)) {
+ messages.Say(
+ ".NIL. in conditional argument associated with non-optional %s"_err_en_US,
+ dummyName);
+ }
+ // Check a single consequent for C1541, C1543, C1542
+ auto checkOneConsequent{[&](const evaluate::ActualArgument::ConditionalArg::
+ Consequent &cons) {
+ if (!cons) {
+ return;
+ }
+ const auto &consExpr{cons->value()};
+ // C1541: INTENT(OUT/INOUT) requires variable
+ if ((object.intent == common::Intent::Out ||
+ object.intent == common::Intent::InOut) &&
+ !evaluate::IsVariable(consExpr)) {
+ messages.Say(
+ "Each consequent-arg in conditional argument associated with INTENT(%s) %s must be a variable"_err_en_US,
+ object.intent == common::Intent::Out ? "OUT" : "IN OUT", dummyName);
+ }
+ // C1543: assumed-rank consequent-arg requires assumed-rank dummy
+ if (semantics::IsAssumedRank(consExpr) &&
+ !object.type.attrs().test(
+ characteristics::TypeAndShape::Attr::AssumedRank)) {
+ messages.Say(
+ "Assumed-rank consequent-arg in conditional argument may only be associated with assumed-rank %s"_err_en_US,
+ dummyName);
+ }
+ // C1542: coarray attribute
+ if (object.type.corank() > 0 && !evaluate::IsCoarray(consExpr)) {
+ messages.Say(
+ "Each consequent-arg in conditional argument associated with a coarray %s must be a coarray"_err_en_US,
+ dummyName);
+ }
+ }};
+ condArg.ForEachConsequent(checkOneConsequent);
+ // C1545: each consequent-arg shall have the same corank, and if any
+ // has the ALLOCATABLE or POINTER attribute, each shall have it.
+ // (Strictly applies only to generic procedure references, but enforced
+ // unconditionally for consistency.)
+ std::optional<int> firstCorank;
+ std::optional<bool> firstIsAllocatable;
+ std::optional<bool> firstIsPointer;
+ auto checkConsistency{[&](const evaluate::ActualArgument::ConditionalArg::
+ Consequent &cons) {
+ if (!cons) {
+ return;
+ }
+ auto &consExpr{cons->value()};
+ int corank{evaluate::GetCorank(consExpr)};
+ bool isAlloc{evaluate::IsAllocatableDesignator(consExpr)};
+ bool isPtr{evaluate::IsObjectPointer(consExpr)};
+ if (!firstCorank) {
+ firstCorank = corank;
+ firstIsAllocatable = isAlloc;
+ firstIsPointer = isPtr;
+ } else {
+ if (corank != *firstCorank) {
+ messages.Say(
+ "All consequent-args in a conditional argument must have the same corank"_err_en_US);
+ }
+ if (isAlloc != *firstIsAllocatable) {
+ messages.Say(
+ "If any consequent-arg in a conditional argument has the ALLOCATABLE attribute, each must have it"_err_en_US);
+ }
+ if (isPtr != *firstIsPointer) {
+ messages.Say(
+ "If any consequent-arg in a conditional argument has the POINTER attribute, each must have it"_err_en_US);
+ }
+ }
+ }};
+ condArg.ForEachConsequent(checkConsistency);
+}
+
// Allow BOZ literal actual arguments when they can be converted to a known
// dummy argument type
static void ConvertBOZLiteralArg(
@@ -1439,34 +1526,34 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
"Alternate return label '%d' cannot be associated with %s"_err_en_US,
arg.GetLabel(), dummyName);
return false;
- } else {
- return true;
}
+ return true;
};
common::visit(
common::visitors{
[&](const characteristics::DummyDataObject &object) {
if (CheckActualArgForLabel(arg)) {
ConvertBOZLiteralArg(arg, object.type.type());
- if (auto *expr{arg.UnwrapExpr()}) {
+ // Check a single actual expression against the dummy object.
+ auto checkOneExpr{[&](evaluate::Expr<evaluate::SomeType> &expr) {
if (auto type{characteristics::TypeAndShape::Characterize(
- *expr, foldingContext)}) {
+ expr, foldingContext)}) {
arg.set_dummyIntent(object.intent);
bool isElemental{
object.type.Rank() == 0 && proc.IsElemental()};
- CheckExplicitDataArg(object, dummyName, *expr, *type,
+ CheckExplicitDataArg(object, dummyName, expr, *type,
isElemental, context, foldingContext, scope, intrinsic,
allowActualArgumentConversions, extentErrors, proc, arg,
dummy);
} else if (object.type.type().IsTypelessIntrinsicArgument() &&
- IsBOZLiteral(*expr)) {
+ IsBOZLiteral(expr)) {
// ok
} else if (object.type.type().IsTypelessIntrinsicArgument() &&
- evaluate::IsNullObjectPointer(expr)) {
+ evaluate::IsNullObjectPointer(&expr)) {
// ok, ASSOCIATED(NULL(without MOLD=))
} else if (object.type.attrs().test(characteristics::
TypeAndShape::Attr::AssumedRank) &&
- evaluate::IsNullObjectPointer(expr) &&
+ evaluate::IsNullObjectPointer(&expr) &&
(object.attrs.test(
characteristics::DummyDataObject::Attr::Allocatable) ||
object.attrs.test(
@@ -1479,7 +1566,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
Attr::Pointer) ||
object.attrs.test(characteristics::
DummyDataObject::Attr::Optional)) &&
- evaluate::IsNullObjectPointer(expr)) {
+ evaluate::IsNullObjectPointer(&expr)) {
// FOO(NULL(without MOLD=))
if (object.type.type().IsAssumedLengthCharacter()) {
messages.Say(
@@ -1498,30 +1585,44 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
}
} else if (object.attrs.test(characteristics::DummyDataObject::
Attr::Allocatable) &&
- (evaluate::IsNullAllocatable(expr) ||
- evaluate::IsBareNullPointer(expr))) {
+ (evaluate::IsNullAllocatable(&expr) ||
+ evaluate::IsBareNullPointer(&expr))) {
if (object.intent == common::Intent::Out ||
object.intent == common::Intent::InOut) {
messages.Say(
"NULL() actual argument '%s' may not be associated with allocatable dummy argument %s that is INTENT(OUT) or INTENT(IN OUT)"_err_en_US,
- expr->AsFortran(), dummyName);
+ expr.AsFortran(), dummyName);
} else if (object.intent == common::Intent::Default) {
foldingContext.Warn(
common::UsageWarning::
NullActualForDefaultIntentAllocatable,
"NULL() actual argument '%s' should not be associated with allocatable dummy argument %s without INTENT(IN)"_warn_en_US,
- expr->AsFortran(), dummyName);
+ expr.AsFortran(), dummyName);
} else {
foldingContext.Warn(
common::LanguageFeature::NullActualForAllocatable,
"Allocatable %s is associated with %s"_port_en_US,
- dummyName, expr->AsFortran());
+ dummyName, expr.AsFortran());
}
} else {
messages.Say(
"Actual argument '%s' associated with %s is not a variable or typed expression"_err_en_US,
- expr->AsFortran(), dummyName);
+ expr.AsFortran(), dummyName);
}
+ }};
+ if (auto *condArg{arg.GetConditionalArg()}) {
+ CheckConditionalArg(*condArg, object, dummyName, messages);
+ // Also run standard explicit-interface checks on each
+ // non-.NIL. consequent expression (recursive).
+ condArg->ForEachConsequent(
+ [&](evaluate::ActualArgument::ConditionalArg::Consequent
+ &cons) {
+ if (cons) {
+ checkOneExpr(cons->value());
+ }
+ });
+ } else if (auto *expr{arg.UnwrapExpr()}) {
+ checkOneExpr(*expr);
} else {
const Symbol &assumed{DEREF(arg.GetAssumedTypeDummy())};
if (!object.type.type().IsAssumedType()) {
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index aea685e575754..073c5f97a8aa2 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -162,6 +162,8 @@ class ArgumentAnalyzer {
bool CheckConformance();
bool CheckAssignmentConformance();
+ bool CheckConsequentTypesAndRanks(
+ const ActualArgument::ConditionalArg &condArg);
bool CheckForNullPointer(const char *where = "as an operand here");
bool CheckForAssumedRank(const char *where = "as an operand here");
@@ -4868,9 +4870,121 @@ void ArgumentAnalyzer::Analyze(
actual->set_isPercentVal();
}
},
- [&](const parser::ConditionalArg &) {
- context_.Say(
- "Fortran 2023 conditional arguments are not yet supported"_todo_en_US);
+ [&](const parser::ConditionalArg &condArg) {
+ // F2023 R1526 conditional-arg analysis (recursive)
+ using EvalConsequent = ActualArgument::ConditionalArg::Consequent;
+ using EvalConditionalArg = ActualArgument::ConditionalArg;
+ using EvalTail =
+ ActualArgument::ConditionalArg::ConditionalArgPartOrConsequent;
+
+ // Analyze a single parser::Consequent into an evaluate Consequent
+ auto analyzeConsequent{[&](const parser::ConditionalArg::Consequent
+ &consequent) -> EvalConsequent {
+ EvalConsequent result;
+ common::visit(
+ common::visitors{
+ [&](const common::Indirection<parser::Expr> &expr) {
+ if (MaybeExpr valExpr{context_.Analyze(expr.value())}) {
+ if (!valExpr->GetType()) {
+ context_.Say(
+ "Typeless expression is not allowed as a consequent in a conditional argument"_err_en_US);
+ fatalErrors_ = true;
+ } else {
+ result =
+ common::CopyableIndirection<Expr<SomeType>>{
+ std::move(*valExpr)};
+ }
+ } else {
+ fatalErrors_ = true;
+ }
+ },
+ [&](const parser::ConditionalArgNil &) {
+ // .NIL. -> std::nullopt (the default)
+ },
+ },
+ consequent.u);
+ return result;
+ }};
+
+ // Recursively analyze a parser::ConditionalArg into an evaluate
+ // ConditionalArg
+ auto analyzeCondArg{[&](const parser::ConditionalArg &ca,
+ auto &self)
+ -> std::optional<EvalConditionalArg> {
+ // Analyze the condition
+ const auto &condition{std::get<parser::ScalarLogicalExpr>(ca.t)};
+ MaybeExpr condExpr{
+ context_.Analyze(condition.thing.thing.value())};
+ if (!condExpr) {
+ fatalErrors_ = true;
+ return std::nullopt;
+ }
+ auto *logicalExpr{std::get_if<Expr<SomeLogical>>(&condExpr->u)};
+ if (!logicalExpr) {
+ context_.Say(
+ "Condition in conditional argument must be logical"_err_en_US);
+ fatalErrors_ = true;
+ return std::nullopt;
+ }
+
+ // Analyze the consequent
+ EvalConsequent consequent{analyzeConsequent(
+ std::get<parser::ConditionalArg::Consequent>(ca.t))};
+ if (fatalErrors_) {
+ return std::nullopt;
+ }
+
+ // Analyze the tail (recursive)
+ const auto &tailNode{
+ std::get<common::Indirection<parser::ConditionalArgTail>>(
+ ca.t)
+ .value()};
+ EvalTail tail{EvalConsequent{}}; // default: terminal NIL
+ common::visit(
+ common::visitors{
+ [&](const parser::ConditionalArg &innerCA) {
+ auto innerResult{self(innerCA, self)};
+ if (innerResult) {
+ tail =
+ common::CopyableIndirection<EvalConditionalArg>{
+ std::move(*innerResult)};
+ } else {
+ fatalErrors_ = true;
+ }
+ },
+ [&](const parser::ConditionalArg::Consequent &cons) {
+ tail = analyzeConsequent(cons);
+ },
+ },
+ tailNode.u);
+ if (fatalErrors_) {
+ return std::nullopt;
+ }
+
+ return EvalConditionalArg{std::move(*logicalExpr),
+ std::move(consequent), std::move(tail)};
+ }};
+
+ auto result{analyzeCondArg(condArg, analyzeCondArg)};
+ if (!result) {
+ return;
+ }
+
+ // C1540: At least one consequent shall be a consequent-arg
+ if (!result->FirstNonNilConsequent()) {
+ context_.Say(
+ "At least one consequent in a conditional argument must not be .NIL."_err_en_US);
+ fatalErrors_ = true;
+ return;
+ }
+
+ // C1538: same type and kind; C1539: same rank or assumed-rank
+ if (!CheckConsequentTypesAndRanks(*result)) {
+ fatalErrors_ = true;
+ return;
+ }
+
+ actual = ActualArgument{std::move(*result)};
},
},
std::get<parser::ActualArg>(arg.t).u);
@@ -4884,6 +4998,126 @@ void ArgumentAnalyzer::Analyze(
}
}
+// C1538: Each consequent-arg shall have the same declared type and kind
+// C1539: Each consequent-arg shall have the same rank or be assumed-rank
+bool ArgumentAnalyzer::CheckConsequentTypesAndRanks(
+ const ActualArgument::ConditionalArg &condArg) {
+ const Expr<SomeType> *refExpr{condArg.FirstNonNilConsequent()};
+ if (!refExpr) {
+ return true; // all .NIL.; caller checks separately
+ }
+ auto refType{refExpr->GetType()};
+ if (!refType) {
+ return true; // typeless; should have been caught earlier
+ }
+ int refRank{-1};
+ bool allSameRank{true};
+ bool hasAssumedRank{false};
+ bool hasNonAssumedRank{false};
+
+ // Check a single consequent against the reference type and rank
+ auto checkOne{[&](const ActualArgument::ConditionalArg::Consequent &cons)
+ -> bool {
+ if (!cons) {
+ return true; // .NIL. is ok
+ }
+ auto thisType{cons->value().GetType()};
+ if (thisType) {
+ if (refType->category() != thisType->category() ||
+ (refType->category() != TypeCategory::Derived &&
+ refType->kind() != thisType->kind())) {
+ context_.Say(
+ "All consequent-args in a conditional argument must have the same type and kind; have %s and %s"_err_en_US,
+ refType->AsFortran(), thisType->AsFortran());
+ return false;
+ }
+ if (refType->category() == TypeCategory::Derived) {
+ // C1538: same declared type required. Unlimited polymorphic
+ // (CLASS(*)) and assumed type (TYPE(*)) have no declared type,
+ // so mixing them with other types is invalid.
+ if (refType->IsUnlimitedPolymorphic() !=
+ thisType->IsUnlimitedPolymorphic()) {
+ context_.Say(
+ "All consequent-args in a conditional argument must have the same type and kind; have %s and %s"_err_en_US,
+ refType->AsFortran(), thisType->AsFortran());
+ return false;
+ }
+ if (refType->IsAssumedType() != thisType->IsAssumedType()) {
+ context_.Say(
+ "All consequent-args in a conditional argument must have the same type and kind; have %s and %s"_err_en_US,
+ refType->AsFortran(), thisType->AsFortran());
+ return false;
+ }
+ if (!refType->IsUnlimitedPolymorphic() && !refType->IsAssumedType()) {
+ const auto &resSpec{refType->GetDerivedTypeSpec()};
+ const auto &thisSpec{thisType->GetDerivedTypeSpec()};
+ if (&resSpec.typeSymbol() != &thisSpec.typeSymbol()) {
+ context_.Say(
+ "All consequent-args in a conditional argument must be the same derived type; have %s and %s"_err_en_US,
+ refType->AsFortran(), thisType->AsFortran());
+ return false;
+ }
+ for (const auto &[pName, pValue] : resSpec.parameters()) {
+ if (pValue.isKind()) {
+ auto it{thisSpec.parameters().find(pName)};
+ if (it == thisSpec.parameters().end() || pValue != it->second) {
+ context_.Say(
+ "All consequent-args in a conditional argument must have the same kind type parameters; have %s and %s"_err_en_US,
+ refType->AsFortran(), thisType->AsFortran());
+ return false;
+ }
+ }
+ }
+ }
+ }
+ }
+ if (semantics::IsAssumedRank(cons->value())) {
+ hasAssumedRank = true;
+ } else {
+ hasNonAssumedRank = true;
+ int thisRank{cons->value().Rank()};
+ if (refRank < 0) {
+ refRank = thisRank;
+ } else if (thisRank != refRank) {
+ allSameRank = false;
+ }
+ }
+ return true;
+ }};
+
+ // Recursively check all consequents in the tree
+ auto checkAll{
+ [&](const ActualArgument::ConditionalArg &ca, auto &self) -> bool {
+ if (!checkOne(ca.consequent())) {
+ return false;
+ }
+ return ca.VisitTail(
+ [&](const ActualArgument::ConditionalArg &inner) {
+ return self(inner, self);
+ },
+ [&](const ActualArgument::ConditionalArg::Consequent &cons) {
+ return checkOne(cons);
+ });
+ }};
+
+ if (!checkAll(condArg, checkAll)) {
+ return false;
+ }
+
+ // C1539: final rank consistency check
+ if (hasAssumedRank && hasNonAssumedRank) {
+ context_.Say(
+ "All consequent-args in a conditional argument must have the same rank or all must be assumed-rank"_err_en_US);
+ return false;
+ }
+ if (hasNonAssumedRank && !allSameRank) {
+ context_.Say(
+ "All consequent-args in a conditional argument must have the same rank"_err_en_US);
+ return false;
+ }
+ return true;
+}
+
bool ArgumentAnalyzer::IsIntrinsicRelational(RelationalOperator opr,
const DynamicType &leftType, const DynamicType &rightType) const {
CHECK(actuals_.size() == 2);
@@ -5377,12 +5611,6 @@ std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeExpr(
}
context_.SayAt(expr.source,
"TYPE(*) dummy argument may only be used as an actual argument"_err_en_US);
- } else if (isProcedureCall_ &&
- std::holds_alternative<parser::ConditionalExpr>(expr.u)) {
- // Check parse tree before analysis to avoid wasted work
- context_.SayAt(expr.source,
- "Conditional expressions are not yet supported as actual arguments"_todo_en_US);
- return std::nullopt;
} else if (MaybeExpr argExpr{AnalyzeExprOrWholeAssumedSizeArray(expr)}) {
if (isProcedureCall_ || !IsProcedureDesignator(*argExpr)) {
// Pad Hollerith actual argument with spaces up to a multiple of 8
diff --git a/flang/test/Semantics/conditional-arg.f90 b/flang/test/Semantics/conditional-arg.f90
index 552e74a3d58e4..57cd9a797b1dc 100644
--- a/flang/test/Semantics/conditional-arg.f90
+++ b/flang/test/Semantics/conditional-arg.f90
@@ -1,29 +1,601 @@
! RUN: %python %S/test_errors.py %s %flang_fc1
-! Test semantic analysis of conditional arguments (F2023 R1526-R1528)
+! Test semantic analysis of conditional arguments (F2023:R1526-R1528)
+! Constraints F2023:C1538-C1545
-subroutine test_conditional_arg
+module m_conditional_arg
implicit none
- integer :: a, b, c
- logical :: flag, flag2
- ! Simple conditional arg
- !ERROR: not yet implemented: Fortran 2023 conditional arguments are not yet supported
- call sub((flag ? a : b))
+ interface
+ subroutine sub_int(x)
+ integer, intent(in) :: x
+ end subroutine
+ subroutine sub_real(x)
+ real, intent(in) :: x
+ end subroutine
+ subroutine sub_int_out(x)
+ integer, intent(out) :: x
+ end subroutine
+ subroutine sub_int_inout(x)
+ integer, intent(inout) :: x
+ end subroutine
+ subroutine sub_optional(x)
+ integer, intent(in), optional :: x
+ end subroutine
+ subroutine sub_not_optional(x)
+ integer, intent(in) :: x
+ end subroutine
+ subroutine sub_alloc(x)
+ integer, intent(inout), allocatable :: x
+ end subroutine
+ subroutine sub_pointer(x)
+ integer, intent(inout), pointer :: x
+ end subroutine
+ subroutine sub_array(x)
+ integer, intent(in) :: x(:)
+ end subroutine
+ subroutine sub_assumed_rank(x)
+ integer, intent(in) :: x(..)
+ end subroutine
+ subroutine sub_coarray(x)
+ integer, intent(inout) :: x[*]
+ end subroutine
+ subroutine sub_two(x, y)
+ integer, intent(in) :: x, y
+ end subroutine
+ end interface
- ! Multi-branch conditional arg
- !ERROR: not yet implemented: Fortran 2023 conditional arguments are not yet supported
- call sub((flag ? a : flag2 ? b : c))
+contains
- ! .NIL. in else position
- !ERROR: not yet implemented: Fortran 2023 conditional arguments are not yet supported
- call sub((flag ? a : .NIL.))
+ ! =========================================================================
+ ! Positive tests: valid conditional arguments
+ ! =========================================================================
- ! Keyword argument with conditional arg
- !ERROR: not yet implemented: Fortran 2023 conditional arguments are not yet supported
- call sub(arg = (flag ? a : b))
+ subroutine test_valid_simple
+ integer :: a, b
+ logical :: flag
+ ! Simple two-branch conditional arg with explicit interface
+ call sub_int((flag ? a : b))
+ end subroutine
- ! .NIL. in both branches
- !ERROR: not yet implemented: Fortran 2023 conditional arguments are not yet supported
- call sub((flag ? .NIL. : .NIL.))
+ subroutine test_valid_multi_branch
+ integer :: a, b, c
+ logical :: flag, flag2
+ ! Multi-branch conditional arg
+ call sub_int((flag ? a : flag2 ? b : c))
+ end subroutine
+ subroutine test_valid_nil_optional
+ integer :: a
+ logical :: flag
+ ! .NIL. is allowed with optional dummy
+ call sub_optional((flag ? a : .NIL.))
+ end subroutine
+
+ subroutine test_valid_nil_middle
+ integer :: a, b
+ logical :: flag, flag2
+ ! .NIL. in middle branch with optional dummy
+ call sub_optional((flag ? .NIL. : flag2 ? a : b))
+ end subroutine
+
+ subroutine test_valid_expressions
+ integer :: a, b
+ logical :: flag
+ ! Expression consequent-args with INTENT(IN)
+ call sub_int((flag ? a + 1 : b * 2))
+ end subroutine
+
+ subroutine test_valid_intent_out
+ integer :: a, b
+ logical :: flag
+ ! Variable consequent-args with INTENT(OUT)
+ call sub_int_out((flag ? a : b))
+ end subroutine
+
+ subroutine test_valid_intent_inout
+ integer :: a, b
+ logical :: flag
+ ! Variable consequent-args with INTENT(INOUT)
+ call sub_int_inout((flag ? a : b))
+ end subroutine
+
+ subroutine test_valid_two_args
+ integer :: a, b, c, d
+ logical :: flag, flag2
+ ! Multiple arguments, one conditional
+ call sub_two(a, (flag ? b : c))
+ end subroutine
+
+ ! =========================================================================
+ ! F2023:R1526: The condition in a conditional argument must be a
+ ! scalar-logical-expr.
+ ! =========================================================================
+
+ subroutine test_nonlogical_condition
+ integer :: a, b, icond
+ real :: rcond
+ character :: ccond
+ logical :: flag
+ !ERROR: Condition in conditional argument must be logical
+ call sub_int((icond ? a : b))
+ !ERROR: Condition in conditional argument must be logical
+ call sub_int((rcond ? a : b))
+ !ERROR: Condition in conditional argument must be logical
+ call sub_int((ccond ? a : b))
+ ! Valid: logical condition
+ call sub_int((flag ? a : b))
+ end subroutine
+
+ ! =========================================================================
+ ! F2023:C1538: Each consequent-arg shall have the same declared type and
+ ! kind type parameters.
+ ! =========================================================================
+
+ subroutine test_f2023_c1538_different_type
+ integer :: a
+ real :: r
+ logical :: flag
+ !ERROR: All consequent-args in a conditional argument must have the same type and kind; have INTEGER(4) and REAL(4)
+ call sub_int((flag ? a : r))
+ end subroutine
+
+ subroutine test_f2023_c1538_different_kind
+ integer(4) :: a
+ integer(8) :: b
+ logical :: flag
+ !ERROR: All consequent-args in a conditional argument must have the same type and kind; have INTEGER(4) and INTEGER(8)
+ call sub_int((flag ? a : b))
+ end subroutine
+
+ subroutine test_f2023_c1538_three_branch_mismatch
+ integer :: a, b
+ real :: r
+ logical :: flag, flag2
+ !ERROR: All consequent-args in a conditional argument must have the same type and kind; have INTEGER(4) and REAL(4)
+ call sub_int((flag ? a : flag2 ? b : r))
+ end subroutine
+
+ ! =========================================================================
+ ! F2023:C1539: Either all consequent-args shall have the same rank, or be
+ ! assumed-rank.
+ ! =========================================================================
+
+ subroutine test_f2023_c1539_rank_mismatch
+ integer :: a
+ integer :: arr(5)
+ logical :: flag
+ !ERROR: All consequent-args in a conditional argument must have the same rank
+ call sub_int((flag ? a : arr))
+ end subroutine
+
+ subroutine test_f2023_c1539_mixed_assumed_rank_and_fixed_rank(x)
+ integer, intent(in) :: x(..)
+ logical :: flag
+ integer :: a
+ ! Mixing assumed-rank and non-assumed-rank violates F2023:C1539
+ !ERROR: All consequent-args in a conditional argument must have the same rank or all must be assumed-rank
+ call sub_int((flag ? x : a))
+ end subroutine
+
+ ! =========================================================================
+ ! F2023:C1540: At least one consequent shall be a consequent-arg.
+ ! If the corresponding dummy argument is not optional, .NIL.
+ ! shall not appear.
+ ! =========================================================================
+
+ subroutine test_f2023_c1540_all_nil
+ logical :: flag
+ !ERROR: At least one consequent in a conditional argument must not be .NIL.
+ call sub_optional((flag ? .NIL. : .NIL.))
+ end subroutine
+
+ subroutine test_f2023_c1540_nil_non_optional
+ integer :: a
+ logical :: flag
+ !ERROR: .NIL. in conditional argument associated with non-optional dummy argument 'x='
+ call sub_not_optional((flag ? a : .NIL.))
+ end subroutine
+
+ ! =========================================================================
+ ! F2023:C1541: If its corresponding dummy argument is INTENT(OUT) or
+ ! INTENT(INOUT), each consequent-arg shall be a variable.
+ ! =========================================================================
+
+ subroutine test_f2023_c1541_intent_out_expr
+ integer :: a
+ logical :: flag
+ !ERROR: Each consequent-arg in conditional argument associated with INTENT(OUT) dummy argument 'x=' must be a variable
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable
+ !ERROR: 'a+1_4' is not a variable or pointer
+ call sub_int_out((flag ? a + 1 : a))
+ end subroutine
+
+ subroutine test_f2023_c1541_intent_inout_expr
+ integer :: a
+ logical :: flag
+ !ERROR: Each consequent-arg in conditional argument associated with INTENT(IN OUT) dummy argument 'x=' must be a variable
+ !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' is not definable
+ !ERROR: 'a+1_4' is not a variable or pointer
+ call sub_int_inout((flag ? a + 1 : a))
+ end subroutine
+
+ ! =========================================================================
+ ! F2023:C1542: If its corresponding dummy argument is allocatable, a
+ ! pointer, or a coarray, the attributes of each
+ ! consequent-arg shall satisfy the requirements of that dummy
+ ! argument.
+ ! =========================================================================
+
+ subroutine test_f2023_c1542_non_allocatable
+ integer :: a, b
+ logical :: flag
+ !ERROR: ALLOCATABLE dummy argument 'x=' must be associated with an ALLOCATABLE actual argument
+ call sub_alloc((flag ? a : b))
+ end subroutine
+
+ subroutine test_f2023_c1542_non_pointer
+ integer :: a, b
+ logical :: flag
+ !ERROR: Actual argument associated with POINTER dummy argument 'x=' must also be POINTER unless INTENT(IN)
+ call sub_pointer((flag ? a : b))
+ end subroutine
+
+ subroutine test_f2023_c1542_non_coarray
+ integer :: a, b
+ logical :: flag
+ ! Non-coarray consequent-args passed to a coarray dummy violates F2023:C1542
+ !ERROR: Each consequent-arg in conditional argument associated with a coarray dummy argument 'x=' must be a coarray
+ !ERROR: Actual argument associated with coarray dummy argument 'x=' must be a coarray
+ call sub_coarray((flag ? a : b))
+ end subroutine
+
+ ! =========================================================================
+ ! F2023:C1543: A consequent-arg shall not be assumed-rank unless its
+ ! corresponding dummy argument is also assumed-rank.
+ ! =========================================================================
+
+ subroutine test_f2023_c1543_assumed_rank_to_non_assumed_rank_dummy(x, y)
+ integer, intent(in) :: x(..), y(..)
+ logical :: flag
+ ! Both consequents are assumed-rank (satisfies F2023:C1539) but the
+ ! dummy is not assumed-rank — violates F2023:C1543.
+ !ERROR: Assumed-rank consequent-arg in conditional argument may only be associated with assumed-rank dummy argument 'x='
+ !ERROR: Assumed-rank actual argument may not be associated with a dummy argument 'x=' that is not also assumed-rank
+ call sub_int((flag ? x : y))
+ end subroutine
+
+ ! =========================================================================
+ ! F2023:C1544: A consequent-arg that is an expr shall not be a variable.
+ !
+ ! This is a grammar disambiguation rule making the "expr" and "variable"
+ ! alternatives of R1528 mutually exclusive. It is automatically satisfied
+ ! because the parser collapses both alternatives into a single Expr
+ ! production; IsVariable() determines the distinction at the semantic
+ ! level. The tests below demonstrate that the distinction works correctly:
+ ! variables are accepted where variables are required (C1541), expressions
+ ! are accepted where expressions suffice (INTENT(IN)), and non-variable
+ ! expressions are rejected where variables are required.
+ ! =========================================================================
+
+ subroutine test_f2023_c1544_variable_with_intent_in
+ integer :: a, b
+ logical :: flag
+ ! A variable consequent-arg is valid with INTENT(IN): it matched the
+ ! "variable" alternative of R1528, satisfying C1544.
+ call sub_int((flag ? a : b))
+ end subroutine
+
+ subroutine test_f2023_c1544_expr_with_intent_in
+ integer :: a, b
+ logical :: flag
+ ! A non-variable expression is valid with INTENT(IN): it matched the
+ ! "expr" alternative of R1528 and is not a variable, satisfying C1544.
+ call sub_int((flag ? a + 1 : b * 2))
+ end subroutine
+
+ subroutine test_f2023_c1544_variable_with_intent_out
+ integer :: a, b
+ logical :: flag
+ ! A variable consequent-arg is valid with INTENT(OUT): it matched the
+ ! "variable" alternative, satisfying both C1544 and C1541.
+ call sub_int_out((flag ? a : b))
+ end subroutine
+
+ subroutine test_f2023_c1544_expr_with_intent_out
+ integer :: a
+ logical :: flag
+ ! A non-variable expression with INTENT(OUT) satisfies C1544 (it is an
+ ! expr and not a variable) but violates C1541 (INTENT(OUT) requires a
+ ! variable). The C1541 error demonstrates the disambiguation works.
+ !ERROR: Each consequent-arg in conditional argument associated with INTENT(OUT) dummy argument 'x=' must be a variable
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable
+ !ERROR: 'a+1_4' is not a variable or pointer
+ call sub_int_out((flag ? a + 1 : a))
+ end subroutine
+
+ subroutine test_f2023_c1544_mixed_variable_and_expr
+ integer :: a
+ logical :: flag
+ ! One consequent-arg is a variable, the other is an expression.
+ ! Both are valid with INTENT(IN): each independently satisfies C1544
+ ! (variable matched "variable", expression matched "expr").
+ call sub_int((flag ? a : a + 1))
+ end subroutine
+
+ ! =========================================================================
+ ! Typeless consequent-args: BOZ literals and NULL() without MOLD=
+ ! are not allowed as consequent-args because they have no type.
+ ! =========================================================================
+
+ subroutine test_typeless_boz_consequent
+ integer :: a
+ logical :: flag
+ !ERROR: Typeless expression is not allowed as a consequent in a conditional argument
+ call sub_int((flag ? a : z'FF'))
+ end subroutine
+
+ subroutine test_typeless_boz_first_consequent
+ integer :: a
+ logical :: flag
+ !ERROR: Typeless expression is not allowed as a consequent in a conditional argument
+ call sub_int((flag ? z'FF' : a))
+ end subroutine
+
+ subroutine test_typeless_boz_both_consequents
+ logical :: flag
+ !ERROR: Typeless expression is not allowed as a consequent in a conditional argument
+ call sub_int((flag ? z'FF' : z'00'))
+ end subroutine
+
+ subroutine test_typeless_boz_multi_branch
+ integer :: a, b
+ logical :: flag, flag2
+ !ERROR: Typeless expression is not allowed as a consequent in a conditional argument
+ call sub_int((flag ? a : flag2 ? b'101' : b))
+ end subroutine
+
+ subroutine test_typeless_null_consequent
+ integer :: a
+ logical :: flag
+ !ERROR: Typeless expression is not allowed as a consequent in a conditional argument
+ !ERROR: NULL() may not be used as an expression in this context
+ call sub_int((flag ? a : null()))
+ end subroutine
+
+ subroutine test_typeless_null_first_consequent
+ integer :: a
+ logical :: flag
+ !ERROR: Typeless expression is not allowed as a consequent in a conditional argument
+ !ERROR: NULL() may not be used as an expression in this context
+ call sub_int((flag ? null() : a))
+ end subroutine
+
+ subroutine test_typeless_null_both_consequents
+ logical :: flag
+ !ERROR: Typeless expression is not allowed as a consequent in a conditional argument
+ !ERROR: NULL() may not be used as an expression in this context
+ call sub_optional((flag ? null() : null()))
+ end subroutine
+
+ ! =========================================================================
+ ! F2023:C1545: In a reference to a generic procedure, each consequent-arg
+ ! shall have the same corank, and if any consequent-arg has the
+ ! ALLOCATABLE or POINTER attribute, each consequent-arg shall
+ ! have that attribute.
+ ! =========================================================================
+
+ subroutine test_f2023_c1545_allocatable_inconsistency
+ integer, allocatable :: a
+ integer :: b
+ logical :: flag
+ !ERROR: If any consequent-arg in a conditional argument has the ALLOCATABLE attribute, each must have it
+ !ERROR: ALLOCATABLE dummy argument 'x=' must be associated with an ALLOCATABLE actual argument
+ call sub_alloc((flag ? a : b))
+ end subroutine
+
+ subroutine test_f2023_c1545_pointer_inconsistency
+ integer, pointer :: p
+ integer :: b
+ logical :: flag
+ !ERROR: If any consequent-arg in a conditional argument has the POINTER attribute, each must have it
+ !ERROR: Actual argument associated with POINTER dummy argument 'x=' must also be POINTER unless INTENT(IN)
+ call sub_pointer((flag ? p : b))
+ end subroutine
+
+ subroutine test_f2023_c1545_allocatable_consistent_valid
+ integer, allocatable :: a, b
+ logical :: flag
+ ! Both consequent-args are allocatable -- no C1545 error
+ call sub_alloc((flag ? a : b))
+ end subroutine
+
+ subroutine test_f2023_c1545_pointer_consistent_valid
+ integer, pointer :: p, q
+ logical :: flag
+ ! Both consequent-args are pointer -- no C1545 error
+ call sub_pointer((flag ? p : q))
+ end subroutine
+
+end module
+
+! ===========================================================================
+! Test conditional arguments used across module boundaries via USE
+! ===========================================================================
+
+module m_cond_arg_provider
+ implicit none
+
+ interface
+ subroutine ext_sub_int(x)
+ integer, intent(in) :: x
+ end subroutine
+ subroutine ext_sub_optional(x)
+ integer, intent(in), optional :: x
+ end subroutine
+ subroutine ext_sub_real(x)
+ real, intent(in) :: x
+ end subroutine
+ subroutine ext_sub_int_out(x)
+ integer, intent(out) :: x
+ end subroutine
+ end interface
+
+contains
+
+ subroutine provider_valid(a, b, flag)
+ integer, intent(in) :: a, b
+ logical, intent(in) :: flag
+ call ext_sub_int((flag ? a : b))
+ end subroutine
+
+ subroutine provider_valid_optional(a, flag)
+ integer, intent(in) :: a
+ logical, intent(in) :: flag
+ call ext_sub_optional((flag ? a : .NIL.))
+ end subroutine
+
+end module
+
+subroutine test_use_module_conditional_arg
+ use m_cond_arg_provider
+ implicit none
+ integer :: x, y
+ logical :: cond
+ ! Valid: use procedures from a module with conditional args
+ call provider_valid(x, y, cond)
+ call provider_valid_optional(x, cond)
+ ! Valid: use module interfaces directly with conditional args
+ call ext_sub_int((cond ? x : y))
+ call ext_sub_optional((cond ? x : .NIL.))
+end subroutine
+
+subroutine test_use_module_type_mismatch
+ use m_cond_arg_provider
+ implicit none
+ integer :: a
+ real :: r
+ logical :: flag
+ !ERROR: All consequent-args in a conditional argument must have the same type and kind; have INTEGER(4) and REAL(4)
+ call ext_sub_int((flag ? a : r))
+end subroutine
+
+subroutine test_use_module_boz
+ use m_cond_arg_provider
+ implicit none
+ integer :: a
+ logical :: flag
+ !ERROR: Typeless expression is not allowed as a consequent in a conditional argument
+ call ext_sub_int((flag ? a : z'FF'))
+end subroutine
+
+subroutine test_use_module_null
+ use m_cond_arg_provider
+ implicit none
+ integer :: a
+ logical :: flag
+ !ERROR: Typeless expression is not allowed as a consequent in a conditional argument
+ !ERROR: NULL() may not be used as an expression in this context
+ call ext_sub_int((flag ? null() : a))
+end subroutine
+
+subroutine test_use_module_nil_non_optional
+ use m_cond_arg_provider
+ implicit none
+ integer :: a
+ logical :: flag
+ !ERROR: .NIL. in conditional argument associated with non-optional dummy argument 'x='
+ call ext_sub_int((flag ? a : .NIL.))
+end subroutine
+
+subroutine test_use_module_intent_out_expr
+ use m_cond_arg_provider
+ implicit none
+ integer :: a
+ logical :: flag
+ !ERROR: Each consequent-arg in conditional argument associated with INTENT(OUT) dummy argument 'x=' must be a variable
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable
+ !ERROR: 'a+1_4' is not a variable or pointer
+ call ext_sub_int_out((flag ? a + 1 : a))
+end subroutine
+
+! =========================================================================
+! Derived type tests
+! =========================================================================
+
+module m_derived_types
+ implicit none
+ type :: t1
+ integer :: x
+ end type
+ type :: t2
+ integer :: x
+ end type
+ type, extends(t1) :: t1_ext
+ integer :: y
+ end type
+ interface
+ subroutine sub_t1(x)
+ import :: t1
+ type(t1), intent(in) :: x
+ end subroutine
+ subroutine sub_class_t1(x)
+ import :: t1
+ class(t1), intent(in) :: x
+ end subroutine
+ subroutine sub_class_star(x)
+ class(*), intent(in) :: x
+ end subroutine
+ end interface
+end module
+
+subroutine test_derived_same_type
+ use m_derived_types
+ implicit none
+ type(t1) :: a, b
+ logical :: flag
+ ! Valid: same declared type
+ call sub_t1((flag ? a : b))
+end subroutine
+
+subroutine test_derived_mismatched_type
+ use m_derived_types
+ implicit none
+ type(t1) :: a
+ type(t2) :: b
+ logical :: flag
+ !ERROR: All consequent-args in a conditional argument must be the same derived type; have t1 and t2
+ call sub_t1((flag ? a : b))
+end subroutine
+
+! Per F2023 15.5.2.3p4, mixing CLASS(t) and TYPE(t) with the same t is valid —
+! the conditional arg becomes polymorphic.
+subroutine test_polymorphic_class_and_type
+ use m_derived_types
+ implicit none
+ type(t1), allocatable :: a
+ class(t1), allocatable :: b
+ logical :: flag
+ ! Valid: CLASS(t1) mixed with TYPE(t1), same declared type per C1538
+ call sub_class_t1((flag ? b : a))
+end subroutine
+
+! CLASS(*) mixed with non-CLASS(*) is invalid — no declared type to compare.
+subroutine test_unlimited_poly_mismatch
+ use m_derived_types
+ implicit none
+ type(t1) :: a
+ class(*), allocatable :: b
+ logical :: flag
+ !ERROR: All consequent-args in a conditional argument must have the same type and kind; have CLASS(*) and t1
+ call sub_class_star((flag ? b : a))
+end subroutine
+
+! Both CLASS(*) is valid.
+subroutine test_unlimited_poly_both
+ use m_derived_types
+ implicit none
+ class(*), allocatable :: a, b
+ logical :: flag
+ ! Valid: both unlimited polymorphic
+ call sub_class_star((flag ? a : b))
end subroutine
>From 6f61ee4fa7453cc70b6c266cf98a44d3e95ed646 Mon Sep 17 00:00:00 2001
From: Vineet Kumar <vineetk at hpe.com>
Date: Thu, 30 Apr 2026 15:07:54 -0500
Subject: [PATCH 2/4] [flang] Folding and shape analysis for conditional
arguments
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
- Add FoldConditionalArg to fold conditional arguments with constant
conditions, resolving to the selected consequent or .NIL. as appropriate.
- Update folding logic for function/intrinsic calls to invoke
FoldConditionalArg and skip intrinsic folding if any argument remains
conditional.
- Add GetArgExpr to ActualArgument to consistently extract the
expression for shape/corank queries.
- Update shape and corank helpers to handle conditional arguments.
- Add tests for folding conditional arguments with constant and
runtime conditions, including chain-peeling and multi-branch cases.
AI use disclaimer: The changes in this commit were substantially
generated with the assistance of AI (claude opus 4.6 via Github
CoPilot). In accordance with the LLVM project’s AI use policy, I have
reviewed and tested the code to the best of my ability.
---
flang/include/flang/Evaluate/call.h | 10 +
flang/include/flang/Evaluate/fold.h | 8 +
flang/include/flang/Evaluate/shape.h | 1 +
flang/lib/Evaluate/characteristics.cpp | 10 +-
flang/lib/Evaluate/fold-implementation.h | 26 +-
flang/lib/Evaluate/fold.cpp | 89 +++++++
flang/lib/Evaluate/intrinsics.cpp | 2 +-
flang/lib/Evaluate/shape.cpp | 40 +++
flang/lib/Evaluate/tools.cpp | 6 +-
flang/lib/Lower/ConvertCall.cpp | 4 +
flang/test/Evaluate/fold-conditional-arg.f90 | 248 +++++++++++++++++
flang/test/Semantics/conditional-arg.f90 | 263 ++++++++++++++++++-
12 files changed, 694 insertions(+), 13 deletions(-)
create mode 100644 flang/test/Evaluate/fold-conditional-arg.f90
diff --git a/flang/include/flang/Evaluate/call.h b/flang/include/flang/Evaluate/call.h
index 9eb8103a5ff7d..f04ec6c373c88 100644
--- a/flang/include/flang/Evaluate/call.h
+++ b/flang/include/flang/Evaluate/call.h
@@ -89,9 +89,11 @@ class ActualArgument {
ConditionalArgPartOrConsequent &&tail);
DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(ConditionalArg)
+ Expr<SomeLogical> &condition() { return condition_.value(); }
const Expr<SomeLogical> &condition() const { return condition_.value(); }
const Consequent &consequent() const { return consequent_; }
Consequent &consequent() { return consequent_; }
+ ConditionalArgPartOrConsequent &tail() { return tail_; }
const ConditionalArgPartOrConsequent &tail() const { return tail_; }
// Dispatch on the tail: calls onConditionalArg(const ConditionalArg &)
@@ -212,6 +214,14 @@ class ActualArgument {
const auto *condArg{GetConditionalArg()};
return condArg ? condArg->FirstNonNilConsequent() : nullptr;
}
+ // Returns the expression from a direct Expr argument or, failing that,
+ // the first non-NIL consequent from a ConditionalArg.
+ const Expr<SomeType> *GetArgExpr() const {
+ if (const auto *expr{UnwrapExpr()}) {
+ return expr;
+ }
+ return GetConditionalArgExpr();
+ }
bool isPassedObject() const { return attrs_.test(Attr::PassedObject); }
ActualArgument &set_isPassedObject(bool yes = true) {
if (yes) {
diff --git a/flang/include/flang/Evaluate/fold.h b/flang/include/flang/Evaluate/fold.h
index df43489aa679c..dafa004479ded 100644
--- a/flang/include/flang/Evaluate/fold.h
+++ b/flang/include/flang/Evaluate/fold.h
@@ -131,5 +131,13 @@ template <typename A> std::optional<std::int64_t> ToInt64(A *p) {
}
}
+// Fold a conditional argument (F2023 R1526). Folds all sub-expressions
+// and simplifies constant conditions: .TRUE. selects the consequent,
+// .FALSE. skips to the tail. If fully resolved, replaces the
+// ActualArgument with a plain expression or sets it to std::nullopt
+// for .NIL.
+void FoldConditionalArg(
+ FoldingContext &context, std::optional<ActualArgument> &arg);
+
} // namespace Fortran::evaluate
#endif // FORTRAN_EVALUATE_FOLD_H_
diff --git a/flang/include/flang/Evaluate/shape.h b/flang/include/flang/Evaluate/shape.h
index e5c2d6e8cb63d..861ca64928079 100644
--- a/flang/include/flang/Evaluate/shape.h
+++ b/flang/include/flang/Evaluate/shape.h
@@ -184,6 +184,7 @@ class GetShapeHelper
Result operator()(const CoarrayRef &) const;
Result operator()(const Substring &) const;
Result operator()(const ProcedureRef &) const;
+ Result operator()(const ActualArgument &) const;
template <typename T>
Result operator()(const ArrayConstructor<T> &aconst) const {
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 20304844e7438..b679914f429c4 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -163,15 +163,12 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
std::optional<TypeAndShape> TypeAndShape::Characterize(
const ActualArgument &arg, FoldingContext &context, bool invariantOnly) {
- if (const auto *expr{arg.UnwrapExpr()}) {
+ if (const auto *expr{arg.GetArgExpr()}) {
return Characterize(*expr, context, invariantOnly);
}
if (const Symbol *assumed{arg.GetAssumedTypeDummy()}) {
return Characterize(*assumed, context, invariantOnly);
}
- if (const auto *expr{arg.GetConditionalArgExpr()}) {
- return Characterize(*expr, context, invariantOnly);
- }
return std::nullopt;
}
@@ -960,15 +957,12 @@ std::optional<DummyArgument> DummyArgument::FromActual(std::string &&name,
std::optional<DummyArgument> DummyArgument::FromActual(std::string &&name,
const ActualArgument &arg, FoldingContext &context,
bool forImplicitInterface) {
- if (const auto *expr{arg.UnwrapExpr()}) {
+ if (const auto *expr{arg.GetArgExpr()}) {
return FromActual(std::move(name), *expr, context, forImplicitInterface);
}
if (arg.GetAssumedTypeDummy()) {
return std::nullopt;
}
- if (const auto *expr{arg.GetConditionalArgExpr()}) {
- return FromActual(std::move(name), *expr, context, forImplicitInterface);
- }
// Guard: GetArgExpr() returns the first non-NIL consequent for a
// ConditionalArg, so normal conditional args are handled above. An
// all-.NIL. ConditionalArg would reach here (GetArgExpr() returns nullptr),
diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h
index 2df2b9e5a300b..5e4fe0b5fa5ff 100644
--- a/flang/lib/Evaluate/fold-implementation.h
+++ b/flang/lib/Evaluate/fold-implementation.h
@@ -1263,12 +1263,36 @@ Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
// Don't fold the argument to KIND(); it might be a TypeParamInquiry
// with a forced result type that doesn't match the parameter.
for (std::optional<ActualArgument> &arg : args) {
- if (auto *expr{UnwrapExpr<Expr<SomeType>>(arg)}) {
+ if (arg && arg->GetConditionalArg()) {
+ FoldConditionalArg(context, arg);
+ } else if (auto *expr{UnwrapExpr<Expr<SomeType>>(arg)}) {
*expr = Fold(context, std::move(*expr));
}
}
}
if (intrinsic) {
+ // Skip intrinsic folding if any argument is still a conditional arg
+ // (i.e. its condition was not a compile-time constant). When the
+ // condition is a compile-time constant, FoldConditionalArg already resolved
+ // it to a plain Expr above, and intrinsic folding proceeds normally.
+ //
+ // TODO:
+ // For elemental/pure intrinsics, distribute the call over each
+ // consequent of the conditional arg and fold each branch independently:
+ // abs((c1 ? a : c2 ? b : c))
+ // → (c1 ? abs(a) : c2 ? abs(b) : abs(c))
+ // Use ForEachConsequent to walk the chain, clone the call per
+ // consequent, fold each clone, and reassemble into a new ConditionalArg.
+ // When multiple arguments are conditional args, distribute one at a
+ // time to avoid a combinatorial cross-product expansion.
+ // This is NOT valid for non-elemental intrinsics like RESHAPE or
+ // TRANSFER whose results depend on seeing all arguments together.
+ //
+ for (const std::optional<ActualArgument> &arg : args) {
+ if (arg && arg->isConditionalArg()) {
+ return Expr<T>{std::move(funcRef)};
+ }
+ }
const std::string name{intrinsic->name};
if (name == "cshift") {
return Folder<T>{context}.CSHIFT(std::move(funcRef));
diff --git a/flang/lib/Evaluate/fold.cpp b/flang/lib/Evaluate/fold.cpp
index a2f6bc0f2ae51..f20d32077602d 100644
--- a/flang/lib/Evaluate/fold.cpp
+++ b/flang/lib/Evaluate/fold.cpp
@@ -298,6 +298,95 @@ std::optional<Expr<SomeType>> FoldTransfer(
return std::nullopt;
}
+// Fold a Consequent expression in place.
+static void FoldConsequent(
+ FoldingContext &context, ActualArgument::ConditionalArg::Consequent &cons) {
+ if (cons) {
+ cons->value() = Fold(context, std::move(cons->value()));
+ }
+}
+
+// Returned by FoldConditionalArgImpl when the entire ConditionalArg chain
+// resolves to a single consequent. Wraps Consequent in a named type so
+// callers can distinguish "fully resolved" from std::nullopt, which means
+// "chain still has at least one non-constant condition".
+// Note: a ResolvedConsequent whose value is std::nullopt represents .NIL.
+// (an absent optional argument), which is a valid resolved outcome.
+namespace {
+struct ResolvedConsequent {
+ ActualArgument::ConditionalArg::Consequent value;
+};
+} // namespace
+
+// Recursively fold a ConditionalArg chain.
+// Returns ResolvedConsequent — entire chain resolved to one consequent.
+// Returns std::nullopt — chain still has non-constant conditions;
+// all reachable sub-expressions folded in
+// place.
+static std::optional<ResolvedConsequent> FoldConditionalArgImpl(
+ FoldingContext &context, ActualArgument::ConditionalArg &condArg) {
+ using ConditionalArg = ActualArgument::ConditionalArg;
+ using Consequent = ConditionalArg::Consequent;
+
+ condArg.condition() = Fold(context, std::move(condArg.condition()));
+
+ // Condition is constant - select appropriate branch and recursively fold it.
+ if (auto constCond{
+ GetScalarConstantValue<LogicalResult>(condArg.condition())}) {
+ if (constCond->IsTrue()) {
+ // .TRUE. — select this consequent.
+ FoldConsequent(context, condArg.consequent());
+ return ResolvedConsequent{std::move(condArg.consequent())};
+ }
+ // .FALSE. — skip to the tail.
+ return condArg.VisitTail(
+ [&](ConditionalArg &inner) -> std::optional<ResolvedConsequent> {
+ auto folded{FoldConditionalArgImpl(context, inner)};
+ if (!folded) {
+ // Inner chain not fully resolved — promote it to replace
+ // the current condArg (peeling off the .FALSE. prefix).
+ // Move to a local first to avoid self-referential assignment.
+ auto promoted{std::move(inner)};
+ condArg = std::move(promoted);
+ }
+ return folded;
+ },
+ [&](Consequent &cons) -> std::optional<ResolvedConsequent> {
+ FoldConsequent(context, cons);
+ return ResolvedConsequent{std::move(cons)};
+ });
+ }
+
+ // Condition is not constant — fold all sub-expressions in place.
+ FoldConsequent(context, condArg.consequent());
+ condArg.VisitTail(
+ [&](ConditionalArg &inner) {
+ if (auto resolved{FoldConditionalArgImpl(context, inner)}) {
+ // Inner chain fully resolved — replace tail with its consequent.
+ condArg.tail() = std::move(resolved->value);
+ }
+ },
+ [&](Consequent &cons) { FoldConsequent(context, cons); });
+
+ // The condition was not a compile-time constant, so the chain could not be
+ // collapsed. All reachable sub-expressions have been folded in place above.
+ return std::nullopt;
+}
+
+void FoldConditionalArg(
+ FoldingContext &context, std::optional<ActualArgument> &arg) {
+ auto *condArg{arg ? arg->GetConditionalArg() : nullptr};
+ if (!condArg) {
+ return;
+ }
+ if (auto resolved{FoldConditionalArgImpl(context, *condArg)}) {
+ // Fully resolved to a single consequent.
+ // operator=(Expr&&) preserves keyword_, attrs_, and dummyIntent_.
+ resolved->value ? void(*arg = std::move(resolved->value->value()))
+ : void(arg = std::nullopt); // .NIL. — absent argument
+ }
+}
+
template class ExpressionBase<SomeDerived>;
template class ExpressionBase<SomeType>;
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index bc0026746c05c..b3a51cf66950d 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2799,7 +2799,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
for (std::size_t j{0}; j < dummies; ++j) {
const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
if (const auto &arg{rearranged[j]}) {
- if (const Expr<SomeType> *expr{arg->UnwrapExpr()}) {
+ if (const auto *expr{arg->GetArgExpr()}) {
std::string kw{d.keyword};
if (arg->keyword()) {
kw = arg->keyword()->ToString();
diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp
index 27913c3559c71..924b6cbdddd5e 100644
--- a/flang/lib/Evaluate/shape.cpp
+++ b/flang/lib/Evaluate/shape.cpp
@@ -900,6 +900,46 @@ auto GetShapeHelper::operator()(const Substring &substring) const -> Result {
return (*this)(substring.parent());
}
+auto GetShapeHelper::operator()(const ActualArgument &arg) const -> Result {
+ // For ConditionalArg, compare shapes of all non-.NIL. consequent-args.
+ // C1539 requires the same rank. If all branches also have the same
+ // static extents, return the common concrete shape; this preserves
+ // useful compile-time checks (e.g. elemental cross-argument conformance,
+ // intrinsic result derivation). Otherwise return Shape(rank, nullopt) —
+ // correct rank, deferred extents. Per-consequent checking in
+ // CheckExplicitDataArg handles the primary dummy-vs-actual conformance
+ // regardless.
+ if (const auto *condArg{arg.GetConditionalArg()}) {
+ const auto *firstExpr{condArg->FirstNonNilConsequent()};
+ if (!firstExpr) {
+ return std::nullopt;
+ }
+ Result commonShape{(*this)(*firstExpr)};
+ bool allMatch{true};
+ condArg->ForEachConsequent(
+ [&](const ActualArgument::ConditionalArg::Consequent &cons) {
+ if (!cons || !allMatch) {
+ return;
+ }
+ Result thisShape{(*this)(cons->value())};
+ if (commonShape != thisShape) {
+ allMatch = false;
+ }
+ });
+ if (allMatch && commonShape) {
+ return commonShape;
+ }
+ return Shape(firstExpr->Rank(), std::nullopt);
+ }
+ if (const auto *expr{arg.UnwrapExpr()}) {
+ return (*this)(*expr);
+ }
+ if (const auto *assumed{arg.GetAssumedTypeDummy()}) {
+ return (*this)(*assumed);
+ }
+ return std::nullopt;
+}
+
auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
if (call.Rank() == 0) {
return ScalarShape();
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 82dcd1e795f49..c6f080dea8b34 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -887,8 +887,10 @@ std::optional<Expr<SomeType>> ConvertToType(
}
int GetCorank(const ActualArgument &arg) {
- const auto *expr{arg.UnwrapExpr()};
- return GetCorank(*expr);
+ if (const auto *expr{arg.GetArgExpr()}) {
+ return GetCorank(*expr);
+ }
+ return 0;
}
bool IsProcedureDesignator(const Expr<SomeType> &expr) {
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index de552e6c943b0..96850da105308 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -3014,6 +3014,8 @@ genIntrinsicRef(const Fortran::evaluate::SpecificIntrinsic *intrinsic,
loweredActuals.push_back(std::nullopt);
continue;
}
+ if (arg.value()->isConditionalArg())
+ TODO(loc, "lowering conditional arguments to HLFIR");
auto *expr =
Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
if (!expr) {
@@ -3139,6 +3141,8 @@ genProcedureRef(CallContext &callContext) {
Fortran::lower::CallerInterface>::PassedEntity &arg :
caller.getPassedArguments())
if (const auto *actual = arg.entity) {
+ if (actual->isConditionalArg())
+ TODO(loc, "lowering conditional arguments to HLFIR");
const auto *expr = actual->UnwrapExpr();
if (!expr) {
// TYPE(*) actual argument.
diff --git a/flang/test/Evaluate/fold-conditional-arg.f90 b/flang/test/Evaluate/fold-conditional-arg.f90
new file mode 100644
index 0000000000000..b34d332b4dee3
--- /dev/null
+++ b/flang/test/Evaluate/fold-conditional-arg.f90
@@ -0,0 +1,248 @@
+! RUN: %python %S/test_folding.py %s %flang_fc1
+! Tests folding of conditional arguments (F2023 R1526-R1528)
+! When a condition in a conditional-arg is a compile-time constant,
+! the conditional-arg should be folded to the selected consequent,
+! enabling further constant folding of the enclosing expression.
+
+module m_funcs
+ implicit none
+ interface
+ pure integer function func_int(x)
+ integer, intent(in) :: x
+ end function
+ pure real function func_real(x)
+ real, intent(in) :: x
+ end function
+ pure integer function func_two(x, y)
+ integer, intent(in) :: x, y
+ end function
+ subroutine sub_optional(x)
+ integer, intent(in), optional :: x
+ end subroutine
+ end interface
+end module
+
+module m
+ use m_funcs
+ implicit none
+
+ ! Basic: .TRUE. selects the first consequent.
+ logical, parameter :: test_true_int = abs((.true. ? -5 : -3)) == 5
+ logical, parameter :: test_true_real = abs((.true. ? -2.0 : -4.0)) == 2.0
+
+ ! Basic: .FALSE. selects the second consequent (tail).
+ logical, parameter :: test_false_int = abs((.false. ? -5 : -3)) == 3
+ logical, parameter :: test_false_real = abs((.false. ? -2.0 : -4.0)) == 4.0
+
+ ! Multi-branch: first condition .TRUE. selects first consequent.
+ logical, parameter :: test_multi_first = &
+ abs((.true. ? -10 : .false. ? -20 : -30)) == 10
+
+ ! Multi-branch: first .FALSE., second .TRUE. selects second consequent.
+ logical, parameter :: test_multi_second = &
+ abs((.false. ? -10 : .true. ? -20 : -30)) == 20
+
+ ! Multi-branch: all conditions .FALSE. selects final consequent.
+ logical, parameter :: test_multi_third = &
+ abs((.false. ? -10 : .false. ? -20 : -30)) == 30
+
+ ! Named constant as condition.
+ logical, parameter :: cond_t = .true.
+ logical, parameter :: cond_f = .false.
+ logical, parameter :: test_named_cond_true = abs((cond_t ? -7 : -9)) == 7
+ logical, parameter :: test_named_cond_false = abs((cond_f ? -7 : -9)) == 9
+
+ ! Consequent expressions themselves are folded.
+ integer, parameter :: k = 3
+ logical, parameter :: test_consequent_fold = abs((.true. ? -(k*k) : -1)) == 9
+
+ ! .TRUE. selecting a simple arithmetic consequent.
+ logical, parameter :: test_true_arith = abs((.true. ? -(1+2) : -99)) == 3
+
+ ! .FALSE. selecting a foldable tail expression.
+ logical, parameter :: test_false_arith = abs((.false. ? -99 : -(2*3))) == 6
+
+ ! Both consequents are foldable; .TRUE. picks the first.
+ logical, parameter :: test_both_foldable_true = &
+ abs((.true. ? -(1+2) : -(4+5))) == 3
+
+ ! Both consequents are foldable; .FALSE. picks the second.
+ logical, parameter :: test_both_foldable_false = &
+ abs((.false. ? -(1+2) : -(4+5))) == 9
+
+ ! Multi-branch with foldable consequent expressions.
+ logical, parameter :: test_multi_foldable = &
+ abs((.false. ? -(1+1) : .true. ? -(2+2) : -(3+3))) == 4
+
+ ! Character consequent folding.
+ logical, parameter :: test_char_true = len_trim((.true. ? 'hello' : 'world')) == 5
+ logical, parameter :: test_char_false = len_trim((.false. ? 'hi ' : 'world')) == 5
+
+ ! Named constants as both conditions and consequents.
+ integer, parameter :: val_a = -11, val_b = -22
+ logical, parameter :: test_named_cons_true = abs((cond_t ? val_a : val_b)) == 11
+ logical, parameter :: test_named_cons_false = abs((cond_f ? val_a : val_b)) == 22
+ logical, parameter :: test_named_all = abs((cond_t ? val_a : val_b)) /= 22
+
+ ! Condition is a constant expression (not a literal .TRUE./.FALSE.).
+ integer, parameter :: n = 5
+ logical, parameter :: test_expr_cond_true = abs((n > 3 ? -10 : -20)) == 10
+ logical, parameter :: test_expr_cond_false = abs((n < 3 ? -10 : -20)) == 20
+ logical, parameter :: test_expr_cond_eq = abs((n == 5 ? -42 : -99)) == 42
+ logical, parameter :: test_expr_cond_multi = &
+ abs((n > 10 ? -1 : n > 3 ? -2 : -3)) == 2
+
+ ! Negative cases: verify the WRONG branch is NOT selected.
+ logical, parameter :: test_neg_true_not_tail = abs((.true. ? -5 : -3)) /= 3
+ logical, parameter :: test_neg_false_not_first = abs((.false. ? -5 : -3)) /= 5
+ logical, parameter :: test_neg_multi_not_third = &
+ abs((.true. ? -10 : .false. ? -20 : -30)) /= 30
+ logical, parameter :: test_neg_multi_not_first = &
+ abs((.false. ? -10 : .true. ? -20 : -30)) /= 10
+ logical, parameter :: test_neg_expr_cond = abs((n > 3 ? -10 : -20)) /= 20
+
+ ! Double-parenthesized conditional: parsed as a ConditionalExpr (not a
+ ! ConditionalArg), so intrinsic folding works through the expression tree.
+ logical, parameter :: test_double_paren_true = abs(((.true. ? -7 : -3))) == 7
+ logical, parameter :: test_double_paren_false = abs(((.false. ? -7 : -3))) == 3
+ logical, parameter :: test_double_paren_multi = &
+ abs(((.false. ? -10 : .true. ? -20 : -30))) == 20
+
+contains
+
+ ! Non-intrinsic (user-defined) function calls with conditional args.
+ ! The conditional arg is folded when the condition is constant, and the
+ ! resolved consequent is passed to the function. The function call itself
+ ! is not folded (only intrinsics are), but the conditional arg folding
+ ! must not crash.
+
+ subroutine test_user_func_const_cond
+ integer :: r
+ ! Constant condition: conditional arg folds to -5, passed to func_int.
+ r = func_int((.true. ? -5 : -3))
+ r = func_int((.false. ? -5 : -3))
+ end subroutine
+
+ subroutine test_user_func_real_const_cond
+ real :: r
+ r = func_real((.true. ? -2.0 : -4.0))
+ r = func_real((.false. ? -2.0 : -4.0))
+ end subroutine
+
+ subroutine test_user_func_multi_branch
+ integer :: r
+ ! Multi-branch with constant conditions.
+ r = func_int((.false. ? -10 : .true. ? -20 : -30))
+ end subroutine
+
+ subroutine test_user_func_named_const
+ integer :: r
+ logical, parameter :: flag = .true.
+ integer, parameter :: a = -11, b = -22
+ r = func_int((flag ? a : b))
+ end subroutine
+
+ subroutine test_user_func_two_args
+ integer :: r
+ ! One conditional arg and one plain arg.
+ r = func_two((.true. ? -5 : -3), 10)
+ end subroutine
+
+ subroutine test_user_func_runtime_cond
+ integer :: r, a, b
+ logical :: flag
+ ! Runtime condition: conditional arg is NOT folded, passed through as-is.
+ r = func_int((flag ? a : b))
+ r = func_two((flag ? a : b), a)
+ end subroutine
+
+ ! Chain-peeling: leading constant-.FALSE. conditions are peeled off,
+ ! and constant conditions after the runtime one are folded.
+ ! FoldConditionalArgImpl promotes the inner chain to replace the
+ ! peeled-off prefix, so the runtime condition becomes the first.
+
+ subroutine test_chain_peel_false_then_runtime(flag)
+ logical, intent(in) :: flag
+ integer :: a, b, c, d, r
+ ! (.false. ? a : .false. ? b : flag ? c : d)
+ ! → peels two .FALSE. prefixes → (flag ? c : d)
+ r = func_int((.false. ? a : .false. ? b : flag ? c : d))
+ end subroutine
+
+ subroutine test_chain_peel_false_runtime_true(flag)
+ logical, intent(in) :: flag
+ integer :: a, b, c, d, e, r
+ ! (.false. ? a : .false. ? b : flag ? c : .true. ? d : e)
+ ! → peels two .FALSE. prefixes, folds trailing .TRUE. → (flag ? c : d)
+ r = func_int((.false. ? a : .false. ? b : flag ? c : .true. ? d : e))
+ end subroutine
+
+ subroutine test_chain_peel_single_false(flag)
+ logical, intent(in) :: flag
+ integer :: a, b, c, r
+ ! (.false. ? a : flag ? b : c)
+ ! → peels one .FALSE. prefix → (flag ? b : c)
+ r = func_int((.false. ? a : flag ? b : c))
+ end subroutine
+
+ subroutine test_chain_peel_deep(flag)
+ logical, intent(in) :: flag
+ integer :: a, b, c, d, e, f, g, r
+ ! (.false. ? a : .false. ? b : .false. ? c : .false. ? d : flag ? e : .true. ? f : g)
+ ! → peels four .FALSE. prefixes, folds trailing .TRUE. → (flag ? e : f)
+ r = func_int(( &
+ .false. ? a : .false. ? b : .false. ? c : .false. ? d : &
+ flag ? e : .true. ? f : g))
+ end subroutine
+
+ subroutine test_chain_peel_false_then_true
+ integer :: a, b, c, r
+ ! All conditions constant — fully resolved (no runtime condition).
+ ! (.false. ? a : .false. ? b : .true. ? c : a)
+ ! → peels two .FALSE., then .TRUE. selects c → fully folded.
+ ! This must not crash and the call receives a plain expression.
+ r = func_int((.false. ? a : .false. ? b : .true. ? c : a))
+ end subroutine
+
+ ! .NIL. folding tests: conditional args with .NIL. and optional dummies.
+ ! When the condition is constant, .NIL. branches fold to absent arguments
+ ! and non-.NIL. branches fold to plain expressions.
+
+ subroutine test_nil_false_selects_nil
+ integer :: a
+ ! (.FALSE. ? a : .NIL.) → folds to .NIL. (absent)
+ call sub_optional((.false. ? a : .nil.))
+ end subroutine
+
+ subroutine test_nil_false_selects_value
+ integer :: a
+ ! (.FALSE. ? .NIL. : a) → folds to a
+ call sub_optional((.false. ? .nil. : a))
+ end subroutine
+
+ subroutine test_nil_true_selects_nil
+ integer :: a
+ ! (.TRUE. ? .NIL. : a) → folds to .NIL. (absent)
+ call sub_optional((.true. ? .nil. : a))
+ end subroutine
+
+ subroutine test_nil_true_selects_value
+ integer :: a
+ ! (.TRUE. ? a : .NIL.) → folds to a
+ call sub_optional((.true. ? a : .nil.))
+ end subroutine
+
+ subroutine test_nil_runtime_no_fold(flag)
+ logical, intent(in) :: flag
+ integer :: a
+ ! (flag ? a : .NIL.) → no fold (runtime condition)
+ call sub_optional((flag ? a : .nil.))
+ end subroutine
+
+ subroutine test_nil_chain_folds_to_nil
+ integer :: a, b
+ ! (.FALSE. ? a : .TRUE. ? .NIL. : b) → chain folds to .NIL. (absent)
+ call sub_optional((.false. ? a : .true. ? .nil. : b))
+ end subroutine
+
+end module
\ No newline at end of file
diff --git a/flang/test/Semantics/conditional-arg.f90 b/flang/test/Semantics/conditional-arg.f90
index 57cd9a797b1dc..aaa109b05ec98 100644
--- a/flang/test/Semantics/conditional-arg.f90
+++ b/flang/test/Semantics/conditional-arg.f90
@@ -42,6 +42,30 @@ subroutine sub_coarray(x)
subroutine sub_two(x, y)
integer, intent(in) :: x, y
end subroutine
+ subroutine sub_array_fixed(x)
+ integer, intent(in) :: x(5)
+ end subroutine
+ subroutine sub_array_two(x, y)
+ integer, intent(in) :: x(:), y(:)
+ end subroutine
+ subroutine sub_matrix(x)
+ integer, intent(in) :: x(:,:)
+ end subroutine
+ subroutine sub_array_optional(x)
+ integer, intent(in), optional :: x(:)
+ end subroutine
+ subroutine sub_matrix_optional(x)
+ integer, intent(in), optional :: x(:,:)
+ end subroutine
+ pure integer function func_int(x)
+ integer, intent(in) :: x
+ end function
+ pure real function func_real(x)
+ real, intent(in) :: x
+ end function
+ pure integer function func_two(x, y)
+ integer, intent(in) :: x, y
+ end function
end interface
contains
@@ -416,6 +440,244 @@ subroutine test_f2023_c1545_pointer_consistent_valid
call sub_pointer((flag ? p : q))
end subroutine
+ ! =========================================================================
+ ! Shape analysis: verify that conditional args with array consequent-args
+ ! get their shape from the consequents, not from the scalar condition.
+ ! Without the GetShapeHelper(ActualArgument) override, the Traverse base
+ ! class would return the scalar shape of the condition via CombineAnyOf,
+ ! causing spurious shape mismatches.
+ ! =========================================================================
+
+ subroutine test_shape_array_conditional_arg
+ integer :: a(5), b(5)
+ logical :: flag
+ ! Array conditional arg passed to assumed-shape dummy — shape comes
+ ! from the consequent-args (rank 1), not the scalar condition.
+ call sub_array((flag ? a : b))
+ end subroutine
+
+ subroutine test_shape_array_fixed_extent
+ integer :: a(5), b(5)
+ logical :: flag
+ ! Array conditional arg with fixed-extent dummy.
+ call sub_array_fixed((flag ? a : b))
+ end subroutine
+
+ subroutine test_shape_matrix_conditional_arg
+ integer :: m1(3,4), m2(3,4)
+ logical :: flag
+ ! Rank-2 array conditional arg.
+ call sub_matrix((flag ? m1 : m2))
+ end subroutine
+
+ subroutine test_shape_two_array_args
+ integer :: a(5), b(5), c(5), d(5)
+ logical :: f1, f2
+ ! Two independent array conditional args in the same call.
+ call sub_array_two((f1 ? a : b), (f2 ? c : d))
+ end subroutine
+
+ subroutine test_shape_nil_with_array
+ integer :: a(5), b(5)
+ logical :: flag, flag2
+ ! .NIL. mixed with rank-1 array consequent-args passed to an optional
+ ! array dummy. If the shape analysis fails to extract rank from the
+ ! first non-.NIL. consequent, this will produce a rank mismatch error.
+ call sub_array_optional((flag ? .NIL. : flag2 ? a : b))
+ end subroutine
+
+ subroutine test_shape_nil_scalar_to_array_dummy
+ integer :: a, b
+ logical :: flag, flag2
+ ! .NIL. with scalar consequent-args passed to an optional array dummy.
+ ! Shape analysis extracts rank 0 from the first non-.NIL. consequent,
+ ! which mismatches the assumed-shape array dummy.
+ !ERROR: Scalar actual argument may not be associated with assumed-shape dummy argument 'x='
+ call sub_array_optional((flag ? .NIL. : flag2 ? a : b))
+ end subroutine
+
+ subroutine test_shape_nil_skipped_rank_mismatch
+ integer :: a(5), b(5)
+ logical :: flag, flag2
+ ! .NIL. is the first consequent; non-.NIL. consequents are rank-1 arrays.
+ ! Dummy is a rank-2 matrix. If shape were extracted from .NIL. (no shape),
+ ! this might silently pass. Instead, shape comes from the rank-1 array,
+ ! producing a rank mismatch — proving .NIL. was correctly skipped.
+ !ERROR: Rank of dummy argument is 2, but actual argument has rank 1
+ call sub_matrix_optional((flag ? .NIL. : flag2 ? a : b))
+ end subroutine
+
+ subroutine test_shape_nil_forced_rank_match
+ integer :: a(5)
+ ! .TRUE. forces .NIL. to be selected — after folding, the arg becomes
+ ! absent. But shape analysis runs on the unfolded conditional arg and
+ ! still checks the rank of the non-.NIL. consequent (a, rank 1) against
+ ! the dummy (rank 1). No error because ranks match.
+ call sub_array_optional((.true. ? .NIL. : a))
+ end subroutine
+
+ subroutine test_shape_nil_forced_rank_mismatch
+ integer :: a(5)
+ ! .TRUE. forces .NIL. to be selected, but shape analysis still extracts
+ ! rank from the non-.NIL. consequent (a, rank 1). The dummy is rank 2,
+ ! so this errors — proving shape is NOT extracted from .NIL. even when
+ ! .NIL. is the branch that will be selected at compile time.
+ !ERROR: Rank of dummy argument is 2, but actual argument has rank 1
+ call sub_matrix_optional((.true. ? .NIL. : a))
+ end subroutine
+
+ subroutine test_shape_nil_with_array_optional
+ integer :: a(5), b(5)
+ logical :: flag, flag2
+ ! .NIL. with array consequent-args and an optional scalar dummy.
+ ! Shape comes from the first non-.NIL. consequent (a(1), scalar).
+ call sub_optional((flag ? .NIL. : flag2 ? a(1) : b(1)))
+ end subroutine
+
+ subroutine test_shape_multi_branch_array
+ integer :: a(5), b(5), c(5)
+ logical :: f1, f2
+ ! Multi-branch conditional arg with arrays — all same rank.
+ call sub_array((f1 ? a : f2 ? b : c))
+ end subroutine
+
+ ! =========================================================================
+ ! Intrinsic characterization: conditional args with intrinsic procedures.
+ ! Verifies that intrinsic argument matching correctly extracts the type
+ ! and kind from a conditional arg via GetArgExpr().
+ ! =========================================================================
+
+ subroutine test_intrinsic_abs_int
+ integer :: a, b, r
+ logical :: flag
+ ! ABS with integer conditional arg — runtime condition exercises
+ ! the GetArgExpr() path in intrinsic characterization.
+ r = abs((flag ? a : b))
+ end subroutine
+
+ subroutine test_intrinsic_abs_real
+ real :: a, b, r
+ logical :: flag
+ r = abs((flag ? a : b))
+ end subroutine
+
+ subroutine test_intrinsic_max_conditional
+ integer :: a, b, c, r
+ logical :: flag
+ ! MAX with a mix of conditional and plain args.
+ r = max((flag ? a : b), c)
+ end subroutine
+
+ subroutine test_intrinsic_min_multi_conditional
+ integer :: a, b, c, d, r
+ logical :: f1, f2
+ ! MIN with multiple conditional args.
+ r = min((f1 ? a : b), (f2 ? c : d))
+ end subroutine
+
+ subroutine test_intrinsic_len_trim_char
+ character(10) :: s1, s2
+ logical :: flag
+ integer :: r
+ r = len_trim((flag ? s1 : s2))
+ end subroutine
+
+ subroutine test_intrinsic_multi_branch
+ integer :: a, b, c, r
+ logical :: f1, f2
+ ! Multi-branch conditional arg in intrinsic call.
+ r = abs((f1 ? a : f2 ? b : c))
+ end subroutine
+
+ ! =========================================================================
+ ! Coarray: conditional args with coarray consequent-args.
+ ! Verifies that GetCorank (via GetArgExpr()) correctly extracts the
+ ! corank from a conditional arg's consequent.
+ ! =========================================================================
+
+ subroutine test_valid_coarray_conditional(a, b, flag)
+ integer, intent(inout) :: a[*], b[*]
+ logical, intent(in) :: flag
+ ! Both consequent-args are coarrays — matches coarray dummy.
+ call sub_coarray((flag ? a : b))
+ end subroutine
+
+ subroutine test_valid_coarray_multi_branch(a, b, c, f1, f2)
+ integer, intent(inout) :: a[*], b[*], c[*]
+ logical, intent(in) :: f1, f2
+ ! Multi-branch with all coarray consequent-args.
+ call sub_coarray((f1 ? a : f2 ? b : c))
+ end subroutine
+
+ ! =========================================================================
+ ! Double-parenthesized conditional: the extra parens cause the parser to
+ ! treat it as a ConditionalExpr (expression-level) rather than a
+ ! ConditionalArg (argument-level). This exercises the expression folding
+ ! path for intrinsics instead of the ConditionalArg path.
+ ! =========================================================================
+
+ subroutine test_double_paren_abs_int
+ integer :: a, b, r
+ logical :: flag
+ r = abs(((flag ? a : b)))
+ end subroutine
+
+ subroutine test_double_paren_abs_real
+ real :: a, b, r
+ logical :: flag
+ r = abs(((flag ? a : b)))
+ end subroutine
+
+ subroutine test_double_paren_max
+ integer :: a, b, c, r
+ logical :: flag
+ r = max(((flag ? a : b)), c)
+ end subroutine
+
+ subroutine test_double_paren_multi_branch
+ integer :: a, b, c, r
+ logical :: f1, f2
+ r = abs(((f1 ? a : f2 ? b : c)))
+ end subroutine
+
+ ! =========================================================================
+ ! Non-intrinsic (user-defined) function calls with conditional args.
+ ! Unlike intrinsics, these skip the intrinsic folding path entirely,
+ ! so the ConditionalArg in ActualArgument::u_ is passed through as-is.
+ ! =========================================================================
+
+ subroutine test_user_func_int
+ integer :: a, b, r
+ logical :: flag
+ r = func_int((flag ? a : b))
+ end subroutine
+
+ subroutine test_user_func_real
+ real :: a, b, r
+ logical :: flag
+ r = func_real((flag ? a : b))
+ end subroutine
+
+ subroutine test_user_func_multi_branch
+ integer :: a, b, c, r
+ logical :: f1, f2
+ r = func_int((f1 ? a : f2 ? b : c))
+ end subroutine
+
+ subroutine test_user_func_two_args
+ integer :: a, b, c, d, r
+ logical :: f1, f2
+ ! One conditional arg and one plain arg.
+ r = func_two((f1 ? a : b), c)
+ end subroutine
+
+ subroutine test_user_func_two_conditional
+ integer :: a, b, c, d, r
+ logical :: f1, f2
+ ! Both arguments are conditional args.
+ r = func_two((f1 ? a : b), (f2 ? c : d))
+ end subroutine
+
end module
! ===========================================================================
@@ -517,7 +779,6 @@ subroutine test_use_module_intent_out_expr
!ERROR: 'a+1_4' is not a variable or pointer
call ext_sub_int_out((flag ? a + 1 : a))
end subroutine
-
! =========================================================================
! Derived type tests
! =========================================================================
>From c487b3e027fb0bb08326c32157476c8d34942727 Mon Sep 17 00:00:00 2001
From: Vineet Kumar <vineetk at hpe.com>
Date: Tue, 19 May 2026 14:05:24 -0500
Subject: [PATCH 3/4] [flang] Enhance support for Fortran 2023 conditional
arguments and add related tests
- Treat consequent args as actual arguments for assumed types.
- Analyze the condition directly with Analyze().
- Add more tests.
---
flang/include/flang/Semantics/expression.h | 10 +++
flang/lib/Semantics/expression.cpp | 27 ++++----
flang/test/Evaluate/fold-conditional-arg.f90 | 21 +++++-
flang/test/Semantics/conditional-arg.f90 | 70 +++++++++++++++++++-
4 files changed, 111 insertions(+), 17 deletions(-)
diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h
index 75468d683af48..7346de4efac8d 100644
--- a/flang/include/flang/Semantics/expression.h
+++ b/flang/include/flang/Semantics/expression.h
@@ -268,6 +268,15 @@ class ExpressionAnalyzer {
common::Restorer<bool> AllowWholeAssumedSizeArray(bool yes = true) {
return common::ScopedSet(isWholeAssumedSizeArrayOk_, yes);
}
+ // Allows a TYPE(*) assumed-type dummy to appear as an expression
+ // (F2023 15.5.2.3-2: If the chosen consequent is a consequent-arg, its expr
+ // or variable is the actual argument for the corres-
+ // ponding dummy argument, and if it is an expr, it is evaluated. If the
+ // chosen consequent is .NIL., the actual argument for that dummy argument is
+ // not present.).
+ common::Restorer<bool> AllowAssumedTypeDummy() {
+ return common::ScopedSet(isAssumedTypeDummyOk_, true);
+ }
protected:
int IntegerTypeSpecKind(const parser::IntegerTypeSpec &);
@@ -425,6 +434,7 @@ class ExpressionAnalyzer {
implicitInterfaces_;
bool isWholeAssumedSizeArrayOk_{false};
bool isNullPointerOk_{false};
+ bool isAssumedTypeDummyOk_{false};
bool useSavedTypedExprs_{true};
bool inWhereBody_{false};
bool inDataStmtObject_{false};
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 073c5f97a8aa2..35ac825ba68c4 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -4416,7 +4416,8 @@ MaybeExpr ExpressionAnalyzer::ExprOrVariable(
std::is_same_v<PARSED, parser::Variable>) {
FixMisparsedFunctionReference(context_, x.u);
}
- if (AssumedTypeDummy(x)) { // C710
+ // F2018 C710 (F2023 C715)
+ if (AssumedTypeDummy(x) && !isAssumedTypeDummyOk_) {
Say("TYPE(*) dummy argument may only be used as an actual argument"_err_en_US);
ResetExpr(x);
return std::nullopt;
@@ -4884,6 +4885,10 @@ void ArgumentAnalyzer::Analyze(
common::visit(
common::visitors{
[&](const common::Indirection<parser::Expr> &expr) {
+ // F2023 15.5.2.3-2: consequent-args are actual
+ // arguments, so TYPE(*) dummies are permitted here
+ // (F2018 C710 (F2023 C715) waived).
+ auto restorer{context_.AllowAssumedTypeDummy()};
if (MaybeExpr valExpr{context_.Analyze(expr.value())}) {
if (!valExpr->GetType()) {
context_.Say(
@@ -4911,21 +4916,17 @@ void ArgumentAnalyzer::Analyze(
auto analyzeCondArg{[&](const parser::ConditionalArg &ca,
auto &self)
-> std::optional<EvalConditionalArg> {
- // Analyze the condition
+ // Analyze the condition — passing ScalarLogicalExpr directly
+ // enforces both scalar (rank-0) and logical type constraints
+ // via the Analyze(Scalar<A>) and Analyze(Logical<A>) templates.
const auto &condition{std::get<parser::ScalarLogicalExpr>(ca.t)};
- MaybeExpr condExpr{
- context_.Analyze(condition.thing.thing.value())};
- if (!condExpr) {
- fatalErrors_ = true;
- return std::nullopt;
- }
- auto *logicalExpr{std::get_if<Expr<SomeLogical>>(&condExpr->u)};
- if (!logicalExpr) {
- context_.Say(
- "Condition in conditional argument must be logical"_err_en_US);
+ MaybeExpr conditionExpr{context_.Analyze(condition)};
+ if (!conditionExpr) {
fatalErrors_ = true;
return std::nullopt;
}
+ auto &conditionValue{
+ std::get<Expr<SomeLogical>>(conditionExpr->u)};
// Analyze the consequent
EvalConsequent consequent{analyzeConsequent(
@@ -4961,7 +4962,7 @@ void ArgumentAnalyzer::Analyze(
return std::nullopt;
}
- return EvalConditionalArg{std::move(*logicalExpr),
+ return EvalConditionalArg{std::move(conditionValue),
std::move(consequent), std::move(tail)};
}};
diff --git a/flang/test/Evaluate/fold-conditional-arg.f90 b/flang/test/Evaluate/fold-conditional-arg.f90
index b34d332b4dee3..27c79e500110f 100644
--- a/flang/test/Evaluate/fold-conditional-arg.f90
+++ b/flang/test/Evaluate/fold-conditional-arg.f90
@@ -245,4 +245,23 @@ subroutine test_nil_chain_folds_to_nil
call sub_optional((.false. ? a : .true. ? .nil. : b))
end subroutine
-end module
\ No newline at end of file
+ ! Logical-type consequents: conditional args whose consequent expressions
+ ! are logical values. Tests folding through the conditional arg path.
+
+ subroutine test_logical_consequent_true
+ logical :: a, b, r
+ ! Constant condition with logical consequents.
+ ! (.TRUE. ? a : b) folds to 'a', passed to a function.
+ a = .true.
+ b = .false.
+ r = (.true. ? a : b)
+ end subroutine
+
+ subroutine test_logical_consequent_false
+ logical :: a, b, r
+ a = .true.
+ b = .false.
+ r = (.false. ? a : b)
+ end subroutine
+
+end module
diff --git a/flang/test/Semantics/conditional-arg.f90 b/flang/test/Semantics/conditional-arg.f90
index aaa109b05ec98..4c70ac0fcc49f 100644
--- a/flang/test/Semantics/conditional-arg.f90
+++ b/flang/test/Semantics/conditional-arg.f90
@@ -130,6 +130,17 @@ subroutine test_valid_two_args
call sub_two(a, (flag ? b : c))
end subroutine
+ ! =========================================================================
+ ! Implicit interface: conditional arguments require an explicit interface.
+ ! =========================================================================
+
+ subroutine test_implicit_interface
+ integer :: a, b
+ logical :: flag
+ !ERROR: Conditional argument requires an explicit interface
+ call external_sub_no_interface((flag ? a : b))
+ end subroutine
+
! =========================================================================
! F2023:R1526: The condition in a conditional argument must be a
! scalar-logical-expr.
@@ -140,16 +151,23 @@ subroutine test_nonlogical_condition
real :: rcond
character :: ccond
logical :: flag
- !ERROR: Condition in conditional argument must be logical
+ !ERROR: Must have LOGICAL type, but is INTEGER(4)
call sub_int((icond ? a : b))
- !ERROR: Condition in conditional argument must be logical
+ !ERROR: Must have LOGICAL type, but is REAL(4)
call sub_int((rcond ? a : b))
- !ERROR: Condition in conditional argument must be logical
+ !ERROR: Must have LOGICAL type, but is CHARACTER(KIND=1,LEN=1_8)
call sub_int((ccond ? a : b))
! Valid: logical condition
call sub_int((flag ? a : b))
end subroutine
+ subroutine test_nonscalar_condition
+ integer :: a, b
+ logical :: arr_flag(5)
+ !ERROR: Must be a scalar value, but is a rank-1 array
+ call sub_int((arr_flag ? a : b))
+ end subroutine
+
! =========================================================================
! F2023:C1538: Each consequent-arg shall have the same declared type and
! kind type parameters.
@@ -806,6 +824,9 @@ subroutine sub_class_t1(x)
subroutine sub_class_star(x)
class(*), intent(in) :: x
end subroutine
+ subroutine sub_type_star(x)
+ type(*), intent(in) :: x
+ end subroutine
end interface
end module
@@ -860,3 +881,46 @@ subroutine test_unlimited_poly_both
! Valid: both unlimited polymorphic
call sub_class_star((flag ? a : b))
end subroutine
+
+! TYPE(*) with TYPE(*) — both assumed type, should be valid.
+! F2023 15.5.2.3-2: consequent-args are actual arguments, so TYPE(*) is permitted.
+subroutine test_assumed_type_both(a, b)
+ use m_derived_types
+ implicit none
+ type(*), intent(in) :: a, b
+ logical :: flag
+ ! Valid: both assumed type
+ call sub_type_star((flag ? a : b))
+end subroutine
+
+! TYPE(*) with TYPE(t1) — one assumed type, one concrete type, should error.
+subroutine test_assumed_type_mismatch(a)
+ use m_derived_types
+ implicit none
+ type(*), intent(in) :: a
+ type(t1) :: b
+ logical :: flag
+ !ERROR: All consequent-args in a conditional argument must have the same type and kind; have TYPE(*) and t1
+ call sub_type_star((flag ? a : b))
+end subroutine
+
+! CLASS(t1) with CLASS(t1) — both polymorphic same declared type, should be valid.
+subroutine test_class_same_type
+ use m_derived_types
+ implicit none
+ class(t1), allocatable :: a, b
+ logical :: flag
+ ! Valid: both CLASS(t1), same declared type
+ call sub_class_t1((flag ? a : b))
+end subroutine
+
+! CLASS(t1) with CLASS(t2) — both polymorphic different declared types, should error.
+subroutine test_class_different_types
+ use m_derived_types
+ implicit none
+ class(t1), allocatable :: a
+ class(t2), allocatable :: b
+ logical :: flag
+ !ERROR: All consequent-args in a conditional argument must be the same derived type; have CLASS(t1) and CLASS(t2)
+ call sub_class_star((flag ? a : b))
+end subroutine
>From 566e9a9ab585cd803557350675c796ddf51a7f21 Mon Sep 17 00:00:00 2001
From: Vineet Kumar <vineetk at hpe.com>
Date: Wed, 24 Jun 2026 14:28:21 -0500
Subject: [PATCH 4/4] [flang] Address review feedback on F2023 conditional
argument semantics
- Restrict the TYPE(*) assumed-type waiver for a conditional-argument
consequent to the consequent expression itself (via a bool parameter on
AllowAssumedTypeDummy), so nested uses like (cond ? (a) : b) and
(cond ? a+1 : b) are correctly illegal again.
- Use a shared helper, AreSameDerivedTypeIgnoringLengthParameters(), for the
C1538 derived-type check: resolves symbol aliases (GetUltimate) and honors
SEQUENCE/BIND(C) structure equivalence (F2023 7.5.2.4), while requiring
equal kind parameters and allowing length parameters to differ.
- Assert (CHECK) rather than silently skip the invariant that a non-.NIL.
consequent always has a type, and drop a redundant !IsAssumedType() test.
- Clean up comments: AllowAssumedTypeDummy() doc, C1544 per-consequent
enforcement, and C1545 applying only to generic references (with a TODO),
plus restore the explicit Expr<SomeType> type name in intrinsics.cpp.
- Note a TODO that type-inquiry intrinsics (KIND, BIT_SIZE, ...) of a
conditional argument should fold to a constant.
Add tests for assumed-type misuse in consequent sub-expressions and for
derived-type identity via SEQUENCE equivalence and kind/length parameters.
AI use disclaimer: The changes in this commit were substantially
generated with the assistance of AI (claude opus 4.8 via Github
CoPilot). In accordance with the LLVM project's AI use policy, I have
reviewed and tested the code to the best of my ability.
---
flang/include/flang/Evaluate/type.h | 4 +
flang/include/flang/Semantics/expression.h | 12 +-
flang/lib/Evaluate/fold-implementation.h | 18 +++
flang/lib/Evaluate/intrinsics.cpp | 2 +-
flang/lib/Evaluate/type.cpp | 6 +
flang/lib/Semantics/check-call.cpp | 18 ++-
flang/lib/Semantics/expression.cpp | 94 +++++++-------
flang/test/Semantics/conditional-arg.f90 | 144 +++++++++++++++++++++
8 files changed, 240 insertions(+), 58 deletions(-)
diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h
index e25122d873f2c..66b47cedd116f 100644
--- a/flang/include/flang/Evaluate/type.h
+++ b/flang/include/flang/Evaluate/type.h
@@ -508,6 +508,10 @@ bool AreSameDerivedType(
const semantics::DerivedTypeSpec &, const semantics::DerivedTypeSpec &);
bool AreSameDerivedTypeIgnoringTypeParameters(
const semantics::DerivedTypeSpec &, const semantics::DerivedTypeSpec &);
+// Like AreSameDerivedType, but length type parameters may differ; kind type
+// parameters must still match.
+bool AreSameDerivedTypeIgnoringLengthParameters(
+ const semantics::DerivedTypeSpec &, const semantics::DerivedTypeSpec &);
bool AreSameDerivedTypeIgnoringSequence(
const semantics::DerivedTypeSpec &, const semantics::DerivedTypeSpec &);
diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h
index 7346de4efac8d..9fd77a45d1afd 100644
--- a/flang/include/flang/Semantics/expression.h
+++ b/flang/include/flang/Semantics/expression.h
@@ -268,14 +268,10 @@ class ExpressionAnalyzer {
common::Restorer<bool> AllowWholeAssumedSizeArray(bool yes = true) {
return common::ScopedSet(isWholeAssumedSizeArrayOk_, yes);
}
- // Allows a TYPE(*) assumed-type dummy to appear as an expression
- // (F2023 15.5.2.3-2: If the chosen consequent is a consequent-arg, its expr
- // or variable is the actual argument for the corres-
- // ponding dummy argument, and if it is an expr, it is evaluated. If the
- // chosen consequent is .NIL., the actual argument for that dummy argument is
- // not present.).
- common::Restorer<bool> AllowAssumedTypeDummy() {
- return common::ScopedSet(isAssumedTypeDummyOk_, true);
+ // Allows a TYPE(*) assumed-type dummy to appear as an expression for the
+ // lifetime of the returned restorer.
+ common::Restorer<bool> AllowAssumedTypeDummy(bool yes = true) {
+ return common::ScopedSet(isAssumedTypeDummyOk_, yes);
}
protected:
diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h
index 5e4fe0b5fa5ff..9189de58f78f7 100644
--- a/flang/lib/Evaluate/fold-implementation.h
+++ b/flang/lib/Evaluate/fold-implementation.h
@@ -1288,6 +1288,24 @@ Expr<T> FoldOperation(FoldingContext &context, FunctionRef<T> &&funcRef) {
// This is NOT valid for non-elemental intrinsics like RESHAPE or
// TRANSFER whose results depend on seeing all arguments together.
//
+ // TODO (conformance):
+ // Type-inquiry intrinsics whose result depends only on the argument's
+ // declared type/rank (e.g. KIND, BIT_SIZE, DIGITS, HUGE, TINY, EPSILON,
+ // PRECISION, RANGE, RADIX, MAXEXPONENT, MINEXPONENT, STORAGE_SIZE, RANK)
+ // are foldable even when the condition is not constant, because C1538/C1539
+ // guarantee every consequent has the same type and rank. Because they are
+ // not folded here, a reference such as
+ // integer, parameter :: k = kind((flag ? a : b))
+ // is wrongly rejected ("cannot be computed as a constant value") even
+ // though it is a valid F2023 constant expression.
+ // Fix:
+ // For such a curated allow-list of type-only inquiries, before the bailout
+ // below, a curated allow-list of type-only inquiries, before the bailout
+ // below, replace the conditional-arg argument with its first non-.NIL.
+ // consequent (a representative) and fold normally. This must NOT be
+ // applied to shape/value inquiries (SIZE, SHAPE, LBOUND/UBOUND, LEN of
+ // deferred length, ALLOCATED, ASSOCIATED, PRESENT, IS_CONTIGUOUS), whose
+ // results can differ between consequents.
for (const std::optional<ActualArgument> &arg : args) {
if (arg && arg->isConditionalArg()) {
return Expr<T>{std::move(funcRef)};
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index b3a51cf66950d..4603109d8f141 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2799,7 +2799,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
for (std::size_t j{0}; j < dummies; ++j) {
const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
if (const auto &arg{rearranged[j]}) {
- if (const auto *expr{arg->GetArgExpr()}) {
+ if (const Expr<SomeType> *expr{arg->GetArgExpr()}) {
std::string kw{d.keyword};
if (arg->keyword()) {
kw = arg->keyword()->ToString();
diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 3f8acd7b89cd3..3913bd394fde0 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -563,6 +563,12 @@ bool AreSameDerivedTypeIgnoringTypeParameters(
return AreSameDerivedType(x, y, true, true, false, inProgress);
}
+bool AreSameDerivedTypeIgnoringLengthParameters(
+ const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
+ SetOfDerivedTypePairs inProgress;
+ return AreSameDerivedType(x, y, false, true, false, inProgress);
+}
+
bool AreSameDerivedTypeIgnoringSequence(
const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
SetOfDerivedTypePairs inProgress;
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 23f961583b0a0..071db685a5225 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -1453,12 +1453,22 @@ static void CheckConditionalArg(
"Each consequent-arg in conditional argument associated with a coarray %s must be a coarray"_err_en_US,
dummyName);
}
+ // C1544: the requirement that each consequent-arg match the dummy's
+ // ALLOCATABLE/POINTER attribute is enforced by the standard
+ // explicit-interface check (checkOneExpr) run on each non-.NIL.
+ // consequent below.
}};
condArg.ForEachConsequent(checkOneConsequent);
- // C1545: each consequent-arg shall have the same corank, and if any
- // has the ALLOCATABLE or POINTER attribute, each shall have it.
- // (Strictly applies only to generic procedure references, but enforced
- // unconditionally for consistency.)
+ // C1545: in a reference to a generic procedure, each consequent-arg shall
+ // have the same corank, and if any has the ALLOCATABLE or POINTER attribute,
+ // each shall have it. Strictly, this requirement applies only to references
+ // to generic procedures, where it avoids ambiguity when resolving the generic
+ // to a specific procedure; for a specific procedure reference these
+ // combinations are otherwise allowed. For now it is enforced unconditionally
+ // here.
+ // TODO: move this check into generic resolution (ResolveGeneric) and enforce
+ // it precisely, i.e. only for references to generic procedures, where the
+ // ambiguity it guards against can actually arise.
std::optional<int> firstCorank;
std::optional<bool> firstIsAllocatable;
std::optional<bool> firstIsPointer;
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 35ac825ba68c4..e18876be05e7e 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -4885,10 +4885,16 @@ void ArgumentAnalyzer::Analyze(
common::visit(
common::visitors{
[&](const common::Indirection<parser::Expr> &expr) {
- // F2023 15.5.2.3-2: consequent-args are actual
- // arguments, so TYPE(*) dummies are permitted here
- // (F2018 C710 (F2023 C715) waived).
- auto restorer{context_.AllowAssumedTypeDummy()};
+ // F2023 15.5.2.3-2: a consequent-arg is an actual
+ // argument, so a bare TYPE(*) assumed-type dummy is
+ // permitted as the whole consequent (F2018 C710 /
+ // F2023 C715 waived). The waiver applies only to the
+ // consequent expression itself; an assumed-type entity
+ // nested in a larger expression (e.g. (a) or a + 1)
+ // remains illegal, so the allowance is not extended to
+ // sub-expressions.
+ auto restorer{context_.AllowAssumedTypeDummy(
+ AssumedTypeDummy(expr.value()) != nullptr)};
if (MaybeExpr valExpr{context_.Analyze(expr.value())}) {
if (!valExpr->GetType()) {
context_.Say(
@@ -5008,9 +5014,10 @@ bool ArgumentAnalyzer::CheckConsequentTypesAndRanks(
return true; // all .NIL.; caller checks separately
}
auto refType{refExpr->GetType()};
- if (!refType) {
- return true; // typeless; should have been caught earlier
- }
+ // A non-.NIL. consequent always has a type: typeless consequents are
+ // rejected during analysis (analyzeConsequent), which aborts before this
+ // check runs, so refType is never null here.
+ CHECK(refType);
int refRank{-1};
bool allSameRank{true};
bool hasAssumedRank{false};
@@ -5023,53 +5030,50 @@ bool ArgumentAnalyzer::CheckConsequentTypesAndRanks(
return true; // .NIL. is ok
}
auto thisType{cons->value().GetType()};
- if (thisType) {
- if (refType->category() != thisType->category() ||
- (refType->category() != TypeCategory::Derived &&
- refType->kind() != thisType->kind())) {
+ // As with refType above, a non-.NIL. consequent always has a type.
+ CHECK(thisType);
+ if (refType->category() != thisType->category() ||
+ (refType->category() != TypeCategory::Derived &&
+ refType->kind() != thisType->kind())) {
+ context_.Say(
+ "All consequent-args in a conditional argument must have the same type and kind; have %s and %s"_err_en_US,
+ refType->AsFortran(), thisType->AsFortran());
+ return false;
+ }
+ if (refType->category() == TypeCategory::Derived) {
+ // C1538: same declared type required. Unlimited polymorphic
+ // (CLASS(*)) and assumed type (TYPE(*)) have no declared type,
+ // so mixing them with other types is invalid.
+ if (refType->IsUnlimitedPolymorphic() !=
+ thisType->IsUnlimitedPolymorphic()) {
context_.Say(
"All consequent-args in a conditional argument must have the same type and kind; have %s and %s"_err_en_US,
refType->AsFortran(), thisType->AsFortran());
return false;
}
- if (refType->category() == TypeCategory::Derived) {
- // C1538: same declared type required. Unlimited polymorphic
- // (CLASS(*)) and assumed type (TYPE(*)) have no declared type,
- // so mixing them with other types is invalid.
- if (refType->IsUnlimitedPolymorphic() !=
- thisType->IsUnlimitedPolymorphic()) {
- context_.Say(
- "All consequent-args in a conditional argument must have the same type and kind; have %s and %s"_err_en_US,
- refType->AsFortran(), thisType->AsFortran());
- return false;
- }
- if (refType->IsAssumedType() != thisType->IsAssumedType()) {
+ if (refType->IsAssumedType() != thisType->IsAssumedType()) {
+ context_.Say(
+ "All consequent-args in a conditional argument must have the same type and kind; have %s and %s"_err_en_US,
+ refType->AsFortran(), thisType->AsFortran());
+ return false;
+ }
+ // AssumedType (TYPE(*)) implies IsUnlimitedPolymorphic, so checking
+ // !IsUnlimitedPolymorphic() alone excludes both CLASS(*) and TYPE(*).
+ if (!refType->IsUnlimitedPolymorphic()) {
+ const auto &resSpec{refType->GetDerivedTypeSpec()};
+ const auto &thisSpec{thisType->GetDerivedTypeSpec()};
+ // C1538: same declared type and kind type parameters. Length type
+ // parameters may differ. AreSameDerivedTypeIgnoringLengthParameters
+ // resolves symbol aliases (GetUltimate) and honors the structure
+ // equivalence of separately-declared SEQUENCE/BIND(C) types
+ // (F2023 7.5.2.4).
+ if (!evaluate::AreSameDerivedTypeIgnoringLengthParameters(
+ resSpec, thisSpec)) {
context_.Say(
- "All consequent-args in a conditional argument must have the same type and kind; have %s and %s"_err_en_US,
+ "All consequent-args in a conditional argument must be the same derived type; have %s and %s"_err_en_US,
refType->AsFortran(), thisType->AsFortran());
return false;
}
- if (!refType->IsUnlimitedPolymorphic() && !refType->IsAssumedType()) {
- const auto &resSpec{refType->GetDerivedTypeSpec()};
- const auto &thisSpec{thisType->GetDerivedTypeSpec()};
- if (&resSpec.typeSymbol() != &thisSpec.typeSymbol()) {
- context_.Say(
- "All consequent-args in a conditional argument must be the same derived type; have %s and %s"_err_en_US,
- refType->AsFortran(), thisType->AsFortran());
- return false;
- }
- for (const auto &[pName, pValue] : resSpec.parameters()) {
- if (pValue.isKind()) {
- auto it{thisSpec.parameters().find(pName)};
- if (it == thisSpec.parameters().end() || pValue != it->second) {
- context_.Say(
- "All consequent-args in a conditional argument must have the same kind type parameters; have %s and %s"_err_en_US,
- refType->AsFortran(), thisType->AsFortran());
- return false;
- }
- }
- }
- }
}
}
if (semantics::IsAssumedRank(cons->value())) {
diff --git a/flang/test/Semantics/conditional-arg.f90 b/flang/test/Semantics/conditional-arg.f90
index 4c70ac0fcc49f..fac95dd6dc4ed 100644
--- a/flang/test/Semantics/conditional-arg.f90
+++ b/flang/test/Semantics/conditional-arg.f90
@@ -924,3 +924,147 @@ subroutine test_class_different_types
!ERROR: All consequent-args in a conditional argument must be the same derived type; have CLASS(t1) and CLASS(t2)
call sub_class_star((flag ? a : b))
end subroutine
+
+! =========================================================================
+! Assumed-type (TYPE(*)) usage in a consequent (F2018 C710 / F2023 C715).
+! A consequent-arg is an actual argument, so a *bare* TYPE(*) dummy is
+! permitted as a whole consequent. But an assumed-type entity nested inside
+! a larger consequent expression remains illegal: the waiver must apply only
+! to the consequent expression itself, not to its sub-expressions.
+! =========================================================================
+
+! Valid: a bare TYPE(*) consequent is an actual argument.
+subroutine test_assumed_type_bare_ok(a, b)
+ implicit none
+ type(*), intent(in) :: a, b
+ logical :: flag
+ interface
+ subroutine sub_star(x)
+ type(*), intent(in) :: x
+ end subroutine
+ end interface
+ call sub_star((flag ? a : b))
+end subroutine
+
+! A parenthesized assumed-type consequent is an expression, not a bare actual
+! argument, so it is illegal. This is the case that escaped diagnosis when the
+! TYPE(*) waiver leaked into the whole consequent sub-expression tree.
+subroutine test_assumed_type_parenthesized(a, b)
+ implicit none
+ type(*), intent(in) :: a, b
+ logical :: flag
+ interface
+ subroutine sub_star(x)
+ type(*), intent(in) :: x
+ end subroutine
+ end interface
+ !ERROR: TYPE(*) dummy argument may only be used as an actual argument
+ call sub_star((flag ? (a) : b))
+ !ERROR: TYPE(*) dummy argument may only be used as an actual argument
+ call sub_star((flag ? ((a)) : b))
+end subroutine
+
+! Assumed-type nested in a larger consequent expression is illegal. These cases
+! are also independently diagnosed when each operand/argument is analyzed, but
+! they must remain errors regardless of the conditional-argument waiver.
+subroutine test_assumed_type_in_subexpr(a, b)
+ implicit none
+ type(*), intent(in) :: a, b
+ integer :: other, arr(3)
+ logical :: flag, flag2
+ interface
+ subroutine sub_int(x)
+ integer, intent(in) :: x
+ end subroutine
+ end interface
+ !ERROR: TYPE(*) dummy argument may only be used as an actual argument
+ call sub_int((flag ? a + 1 : other))
+ !ERROR: TYPE(*) dummy argument may only be used as an actual argument
+ call sub_int((flag ? other : b + 1))
+ !ERROR: TYPE(*) dummy argument may only be used as an actual argument
+ call sub_int((flag ? -a : other))
+ !ERROR: Assumed type TYPE(*) dummy argument not allowed for 'a=' intrinsic argument
+ call sub_int((flag ? iabs(a) : other))
+ !ERROR: TYPE(*) dummy argument may only be used as an actual argument
+ call sub_int((flag ? other : flag2 ? a + 1 : other))
+ !ERROR: TYPE(*) dummy argument may only be used as an actual argument
+ call sub_int((flag ? arr(a) : other))
+end subroutine
+
+! =========================================================================
+! C1538 derived-type identity via structure equivalence and type parameters.
+! The consequent-arg type check uses AreSameDerivedTypeIgnoringLengthParameters,
+! which (a) resolves symbol aliases, (b) treats separately-declared SEQUENCE /
+! BIND(C) types as the same type when structurally equivalent (F2023 7.5.2.4),
+! and (c) requires equal kind type parameters while allowing length type
+! parameters to differ.
+! =========================================================================
+
+module m_seq_cond
+contains
+ function f1()
+ type :: point
+ sequence
+ integer :: x, y, z
+ end type
+ type(point) :: f1
+ end function
+ function f2()
+ type :: point
+ sequence
+ integer :: x, y, z
+ end type
+ type(point) :: f2
+ end function
+ subroutine foo(p)
+ type :: point
+ sequence
+ integer :: x, y, z
+ end type
+ type(point), intent(in) :: p
+ end subroutine
+ ! Valid: f1() and f2() return separately-declared but structurally identical
+ ! SEQUENCE types, which are the same type per F2023 7.5.2.4.
+ subroutine test_seq_equiv(cdt)
+ logical :: cdt
+ call foo((cdt ? f1() : f2()))
+ end subroutine
+end module
+
+module m_param_cond
+ type :: tlen(l)
+ integer, len :: l
+ integer :: a(l)
+ end type
+ type :: tkind(k)
+ integer, kind :: k
+ integer(k) :: a
+ end type
+ interface
+ subroutine sub_tlen(x)
+ import :: tlen
+ type(tlen(*)), intent(in) :: x
+ end subroutine
+ subroutine sub_tkind4(x)
+ import :: tkind
+ type(tkind(4)), intent(in) :: x
+ end subroutine
+ end interface
+contains
+ ! Valid: length type parameters may differ between consequent-args (C1538
+ ! constrains only the declared type and kind type parameters).
+ subroutine test_len_param_differ(cdt)
+ logical :: cdt
+ type(tlen(3)) :: a
+ type(tlen(5)) :: b
+ call sub_tlen((cdt ? a : b))
+ end subroutine
+ ! Error: kind type parameters must match.
+ subroutine test_kind_param_differ(cdt)
+ logical :: cdt
+ type(tkind(4)) :: a
+ type(tkind(8)) :: b
+ !ERROR: All consequent-args in a conditional argument must be the same derived type; have tkind(k=4_4) and tkind(k=8_4)
+ call sub_tkind4((cdt ? a : b))
+ end subroutine
+end module
More information about the flang-commits
mailing list