aboutsummaryrefslogtreecommitdiff
path: root/flang/lib/Evaluate
diff options
context:
space:
mode:
Diffstat (limited to 'flang/lib/Evaluate')
-rw-r--r--flang/lib/Evaluate/check-expression.cpp96
-rw-r--r--flang/lib/Evaluate/common.cpp19
-rw-r--r--flang/lib/Evaluate/fold-real.cpp10
-rw-r--r--flang/lib/Evaluate/intrinsics-library.cpp2
-rw-r--r--flang/lib/Evaluate/intrinsics.cpp41
-rw-r--r--flang/lib/Evaluate/tools.cpp20
6 files changed, 98 insertions, 90 deletions
diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index 839717d..e07076e 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -379,8 +379,11 @@ bool IsInitialProcedureTarget(const semantics::Symbol &symbol) {
common::visitors{
[&](const semantics::SubprogramDetails &subp) {
return !subp.isDummy() && !subp.stmtFunction() &&
- symbol.owner().kind() != semantics::Scope::Kind::MainProgram &&
- symbol.owner().kind() != semantics::Scope::Kind::Subprogram;
+ ((symbol.owner().kind() !=
+ semantics::Scope::Kind::MainProgram &&
+ symbol.owner().kind() !=
+ semantics::Scope::Kind::Subprogram) ||
+ ultimate.attrs().test(semantics::Attr::EXTERNAL));
},
[](const semantics::SubprogramNameDetails &x) {
return x.kind() != semantics::SubprogramKind::Internal;
@@ -1475,13 +1478,12 @@ public:
const characteristics::DummyDataObject &dummyObj)
: fc_{fc}, actual_{actual}, dummyObj_{dummyObj} {}
- // Returns true, if actual and dummy have different contiguity requirements
- bool HaveContiguityDifferences() const {
- // Check actual contiguity, unless dummy doesn't care
+ // Returns true if dummy arg needs to be contiguous
+ bool DummyNeedsContiguity() const {
+ if (dummyObj_.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {
+ return false;
+ }
bool dummyTreatAsArray{dummyObj_.ignoreTKR.test(common::IgnoreTKR::Rank)};
- bool actualTreatAsContiguous{
- dummyObj_.ignoreTKR.test(common::IgnoreTKR::Contiguous) ||
- IsSimplyContiguous(actual_, fc_)};
bool dummyIsExplicitShape{dummyObj_.type.IsExplicitShape()};
bool dummyIsAssumedSize{dummyObj_.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedSize)};
@@ -1498,32 +1500,17 @@ public:
(dummyTreatAsArray && !dummyIsPolymorphic) || dummyIsVoidStar ||
dummyObj_.attrs.test(
characteristics::DummyDataObject::Attr::Contiguous)};
- return !actualTreatAsContiguous && dummyNeedsContiguity;
+ return dummyNeedsContiguity;
}
- // Returns true, if actual and dummy have polymorphic differences
bool HavePolymorphicDifferences() const {
- bool dummyIsAssumedRank{dummyObj_.type.attrs().test(
- characteristics::TypeAndShape::Attr::AssumedRank)};
- bool actualIsAssumedRank{semantics::IsAssumedRank(actual_)};
- bool dummyIsAssumedShape{dummyObj_.type.attrs().test(
- characteristics::TypeAndShape::Attr::AssumedShape)};
- bool actualIsAssumedShape{semantics::IsAssumedShape(actual_)};
- if ((actualIsAssumedRank && dummyIsAssumedRank) ||
- (actualIsAssumedShape && dummyIsAssumedShape)) {
- // Assumed-rank and assumed-shape arrays are represented by descriptors,
- // so don't need to do polymorphic check.
- } else if (!dummyObj_.ignoreTKR.test(common::IgnoreTKR::Type)) {
- // flang supports limited cases of passing polymorphic to non-polimorphic.
- // These cases require temporary of non-polymorphic type. (For example,
- // the actual argument could be polymorphic array of child type,
- // while the dummy argument could be non-polymorphic array of parent
- // type.)
+ if (dummyObj_.ignoreTKR.test(common::IgnoreTKR::Type)) {
+ return false;
+ }
+ if (auto actualType{
+ characteristics::TypeAndShape::Characterize(actual_, fc_)}) {
+ bool actualIsPolymorphic{actualType->type().IsPolymorphic()};
bool dummyIsPolymorphic{dummyObj_.type.type().IsPolymorphic()};
- auto actualType{
- characteristics::TypeAndShape::Characterize(actual_, fc_)};
- bool actualIsPolymorphic{
- actualType && actualType->type().IsPolymorphic()};
if (actualIsPolymorphic && !dummyIsPolymorphic) {
return true;
}
@@ -1572,28 +1559,32 @@ private:
// procedures with explicit interface, it's expected that "dummy" is not null.
// For procedures with implicit interface dummy may be null.
//
+// Returns std::optional<bool> indicating whether the copy is known to be
+// needed (true) or not needed (false); returns std::nullopt if the necessity
+// of the copy is undetermined.
+//
// Note that these copy-in and copy-out checks are done from the caller's
// perspective, meaning that for copy-in the caller need to do the copy
// before calling the callee. Similarly, for copy-out the caller is expected
// to do the copy after the callee returns.
-bool MayNeedCopy(const ActualArgument *actual,
+std::optional<bool> ActualArgNeedsCopy(const ActualArgument *actual,
const characteristics::DummyArgument *dummy, FoldingContext &fc,
bool forCopyOut) {
if (!actual) {
- return false;
+ return std::nullopt;
}
if (actual->isAlternateReturn()) {
- return false;
+ return std::nullopt;
}
const auto *dummyObj{dummy
? std::get_if<characteristics::DummyDataObject>(&dummy->u)
: nullptr};
- const bool forCopyIn = !forCopyOut;
+ const bool forCopyIn{!forCopyOut};
if (!evaluate::IsVariable(*actual)) {
- // Actual argument expressions that aren’t variables are copy-in, but
- // not copy-out.
+ // Expressions are copy-in, but not copy-out.
return forCopyIn;
}
+ auto maybeContigActual{IsContiguous(*actual, fc)};
if (dummyObj) { // Explict interface
CopyInOutExplicitInterface check{fc, *actual, *dummyObj};
if (forCopyOut && check.HasIntentIn()) {
@@ -1616,28 +1607,25 @@ bool MayNeedCopy(const ActualArgument *actual,
if (!check.HaveArrayOrAssumedRankArgs()) {
return false;
}
- if (check.HaveContiguityDifferences()) {
- return true;
- }
- if (check.HavePolymorphicDifferences()) {
- return true;
+ if (maybeContigActual.has_value()) {
+ // We know whether actual arg is contiguous or not
+ bool isContiguousActual{maybeContigActual.value()};
+ bool actualArgNeedsCopy{
+ (!isContiguousActual || check.HavePolymorphicDifferences()) &&
+ check.DummyNeedsContiguity()};
+ return actualArgNeedsCopy;
+ } else {
+ // We don't know whether actual arg is contiguous or not
+ return check.DummyNeedsContiguity();
}
} else { // Implicit interface
- if (ExtractCoarrayRef(*actual)) {
- // Coindexed actual args may need copy-in and copy-out with implicit
- // interface
- return true;
- }
- if (!IsSimplyContiguous(*actual, fc)) {
- // Copy-in: actual arguments that are variables are copy-in when
- // non-contiguous.
- // Copy-out: vector subscripts could refer to duplicate elements, can't
- // copy out.
- return !(forCopyOut && HasVectorSubscript(*actual));
+ if (maybeContigActual.has_value()) {
+ // If known contiguous, don't copy in/out.
+ // If known non-contiguous, copy in/out.
+ return !*maybeContigActual;
}
}
- // For everything else, no copy-in or copy-out
- return false;
+ return std::nullopt;
}
} // namespace Fortran::evaluate
diff --git a/flang/lib/Evaluate/common.cpp b/flang/lib/Evaluate/common.cpp
index ed6a0ef..119ea3c 100644
--- a/flang/lib/Evaluate/common.cpp
+++ b/flang/lib/Evaluate/common.cpp
@@ -16,25 +16,26 @@ namespace Fortran::evaluate {
void FoldingContext::RealFlagWarnings(
const RealFlags &flags, const char *operation) {
static constexpr auto warning{common::UsageWarning::FoldingException};
+ if (!realFlagWarningContext_.empty()) {
+ // Override 'operation' with a string like
+ // "compilation-time evaluation of a call to '...'"
+ operation = realFlagWarningContext_.c_str();
+ }
if (flags.test(RealFlag::Overflow)) {
- Warn(warning, "overflow on %s%s"_warn_en_US, operation,
- realFlagWarningContext_);
+ Warn(warning, "overflow on %s"_warn_en_US, operation);
}
if (flags.test(RealFlag::DivideByZero)) {
if (std::strcmp(operation, "division") == 0) {
- Warn(warning, "division by zero%s"_warn_en_US, realFlagWarningContext_);
+ Warn(warning, "division by zero"_warn_en_US);
} else {
- Warn(warning, "division by zero on %s%s"_warn_en_US, operation,
- realFlagWarningContext_);
+ Warn(warning, "division by zero on %s"_warn_en_US, operation);
}
}
if (flags.test(RealFlag::InvalidArgument)) {
- Warn(warning, "invalid argument on %s%s"_warn_en_US, operation,
- realFlagWarningContext_);
+ Warn(warning, "invalid argument on %s"_warn_en_US, operation);
}
if (flags.test(RealFlag::Underflow)) {
- Warn(warning, "underflow on %s%s"_warn_en_US, operation,
- realFlagWarningContext_);
+ Warn(warning, "underflow on %s"_warn_en_US, operation);
}
}
diff --git a/flang/lib/Evaluate/fold-real.cpp b/flang/lib/Evaluate/fold-real.cpp
index 225e340..1ff9410 100644
--- a/flang/lib/Evaluate/fold-real.cpp
+++ b/flang/lib/Evaluate/fold-real.cpp
@@ -425,8 +425,14 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
[](const Scalar<T> &x) -> Scalar<T> { return x.SPACING(); }));
} else if (name == "sqrt") {
return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
- ScalarFunc<T, T>(
- [](const Scalar<T> &x) -> Scalar<T> { return x.SQRT().value; }));
+ ScalarFunc<T, T>([&context](const Scalar<T> &x) -> Scalar<T> {
+ ValueWithRealFlags<Scalar<T>> result{x.SQRT()};
+ if (result.flags.test(RealFlag::InvalidArgument)) {
+ context.Warn(common::UsageWarning::FoldingValueChecks,
+ "Invalid argument to SQRT()"_warn_en_US);
+ }
+ return result.value;
+ }));
} else if (name == "sum") {
return FoldSum<T>(context, std::move(funcRef));
} else if (name == "tiny") {
diff --git a/flang/lib/Evaluate/intrinsics-library.cpp b/flang/lib/Evaluate/intrinsics-library.cpp
index d8af524..54726ac5 100644
--- a/flang/lib/Evaluate/intrinsics-library.cpp
+++ b/flang/lib/Evaluate/intrinsics-library.cpp
@@ -1052,7 +1052,7 @@ std::optional<HostRuntimeWrapper> GetHostRuntimeWrapper(const std::string &name,
.value());
}
auto restorer{context.SetRealFlagWarningContext(
- " after folding a call to '"s + name + "'"s)};
+ "compilation-time evaluation of a call to '"s + name + "'"s)};
return Fold(context,
ConvertToType(
resultType, hostFolderWithChecks(context, std::move(args)))
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 1de5e6b..da39f19 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -654,6 +654,11 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
{{"i", OperandUnsigned}, {"j", OperandUnsigned, Rank::elementalOrBOZ}},
OperandUnsigned},
{"ior", {{"i", BOZ}, {"j", SameIntOrUnsigned}}, SameIntOrUnsigned},
+ {"irand",
+ {{"i", TypePattern{IntType, KindCode::exactKind, 4}, Rank::scalar,
+ Optionality::optional}},
+ TypePattern{IntType, KindCode::exactKind, 4}, Rank::scalar,
+ IntrinsicClass::impureFunction},
{"ishft", {{"i", SameIntOrUnsigned}, {"shift", AnyInt}}, SameIntOrUnsigned},
{"ishftc",
{{"i", SameIntOrUnsigned}, {"shift", AnyInt},
@@ -872,6 +877,11 @@ static const IntrinsicInterface genericIntrinsicFunction[]{
common::Intent::In,
{ArgFlag::canBeMoldNull, ArgFlag::onlyConstantInquiry}}},
DefaultInt, Rank::scalar, IntrinsicClass::inquiryFunction},
+ {"rand",
+ {{"i", TypePattern{IntType, KindCode::exactKind, 4}, Rank::scalar,
+ Optionality::optional}},
+ TypePattern{RealType, KindCode::exactKind, 4}, Rank::scalar,
+ IntrinsicClass::impureFunction},
{"range",
{{"x", AnyNumeric, Rank::anyOrAssumedRank, Optionality::required,
common::Intent::In,
@@ -1597,6 +1607,10 @@ static const IntrinsicInterface intrinsicSubroutine[]{
{"exit", {{"status", DefaultInt, Rank::scalar, Optionality::optional}}, {},
Rank::elemental, IntrinsicClass::impureSubroutine},
{"free", {{"ptr", Addressable}}, {}},
+ {"flush",
+ {{"unit", AnyInt, Rank::scalar, Optionality::optional,
+ common::Intent::In}},
+ {}, Rank::elemental, IntrinsicClass::impureSubroutine},
{"fseek",
{{"unit", AnyInt, Rank::scalar}, {"offset", AnyInt, Rank::scalar},
{"whence", AnyInt, Rank::scalar},
@@ -1701,6 +1715,8 @@ static const IntrinsicInterface intrinsicSubroutine[]{
{}, Rank::scalar, IntrinsicClass::impureSubroutine},
{"second", {{"time", DefaultReal, Rank::scalar}}, {}, Rank::scalar,
IntrinsicClass::impureSubroutine},
+ {"__builtin_show_descriptor", {{"d", AnyData, Rank::anyOrAssumedRank}}, {},
+ Rank::elemental, IntrinsicClass::impureSubroutine},
{"system",
{{"command", DefaultChar, Rank::scalar},
{"exitstat", DefaultInt, Rank::scalar, Optionality::optional,
@@ -2822,7 +2838,8 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
name, characteristics::Procedure{std::move(dummyArgs), attrs}},
std::move(rearranged)};
} else {
- attrs.set(characteristics::Procedure::Attr::Pure);
+ if (intrinsicClass != IntrinsicClass::impureFunction /* RAND and IRAND */)
+ attrs.set(characteristics::Procedure::Attr::Pure);
characteristics::TypeAndShape typeAndShape{resultType.value(), resultRank};
characteristics::FunctionResult funcResult{std::move(typeAndShape)};
characteristics::Procedure chars{
@@ -3139,28 +3156,6 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
if (type->HasDeferredTypeParameter()) {
context.messages().Say(at,
"FPTR= argument to C_F_POINTER() may not have a deferred type parameter"_err_en_US);
- } else if (type->category() == TypeCategory::Derived) {
- if (type->IsUnlimitedPolymorphic()) {
- context.Warn(common::UsageWarning::Interoperability, at,
- "FPTR= argument to C_F_POINTER() should not be unlimited polymorphic"_warn_en_US);
- } else if (!type->GetDerivedTypeSpec().typeSymbol().attrs().test(
- semantics::Attr::BIND_C)) {
- context.Warn(common::UsageWarning::Portability, at,
- "FPTR= argument to C_F_POINTER() should not have a derived type that is not BIND(C)"_port_en_US);
- }
- } else if (!IsInteroperableIntrinsicType(
- *type, &context.languageFeatures())
- .value_or(true)) {
- if (type->category() == TypeCategory::Character &&
- type->kind() == 1) {
- context.Warn(common::UsageWarning::CharacterInteroperability, at,
- "FPTR= argument to C_F_POINTER() should not have the non-interoperable character length %s"_warn_en_US,
- type->AsFortran());
- } else {
- context.Warn(common::UsageWarning::Interoperability, at,
- "FPTR= argument to C_F_POINTER() should not have the non-interoperable intrinsic type or kind %s"_warn_en_US,
- type->AsFortran());
- }
}
if (ExtractCoarrayRef(*expr)) {
context.messages().Say(at,
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index bd06acc..a0035ae 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -63,7 +63,11 @@ Expr<SomeType> Parenthesize(Expr<SomeType> &&expr) {
std::optional<DataRef> ExtractDataRef(
const ActualArgument &arg, bool intoSubstring, bool intoComplexPart) {
- return ExtractDataRef(arg.UnwrapExpr(), intoSubstring, intoComplexPart);
+ if (const Symbol *assumedType{arg.GetAssumedTypeDummy()}) {
+ return DataRef{*assumedType};
+ } else {
+ return ExtractDataRef(arg.UnwrapExpr(), intoSubstring, intoComplexPart);
+ }
}
std::optional<DataRef> ExtractSubstringBase(const Substring &substring) {
@@ -1210,6 +1214,20 @@ bool HasConstant(const Expr<SomeType> &expr) {
return HasConstantHelper{}(expr);
}
+// HasStructureComponent()
+struct HasStructureComponentHelper
+ : public AnyTraverse<HasStructureComponentHelper, bool, false> {
+ using Base = AnyTraverse<HasStructureComponentHelper, bool, false>;
+ HasStructureComponentHelper() : Base(*this) {}
+ using Base::operator();
+
+ bool operator()(const Component &) const { return true; }
+};
+
+bool HasStructureComponent(const Expr<SomeType> &expr) {
+ return HasStructureComponentHelper{}(expr);
+}
+
parser::Message *AttachDeclaration(
parser::Message &message, const Symbol &symbol) {
const Symbol *unhosted{&symbol};
generated by cgit v1.1 at 2026-01-06 03:08:48 +0000