aboutsummaryrefslogtreecommitdiff
path: root/flang/lib
diff options
context:
space:
mode:
Diffstat (limited to 'flang/lib')
-rw-r--r--flang/lib/Evaluate/common.cpp18
-rw-r--r--flang/lib/Evaluate/fold-implementation.h14
-rw-r--r--flang/lib/Evaluate/host.cpp4
-rw-r--r--flang/lib/Evaluate/intrinsics-library.cpp4
-rw-r--r--flang/lib/Optimizer/Builder/TemporaryStorage.cpp8
-rw-r--r--flang/lib/Optimizer/OpenACC/Support/CMakeLists.txt1
-rw-r--r--flang/lib/Optimizer/OpenACC/Support/FIROpenACCOpsInterfaces.cpp62
-rw-r--r--flang/lib/Optimizer/OpenACC/Support/RegisterOpenACCExtensions.cpp22
-rw-r--r--flang/lib/Parser/prescan.cpp24
-rw-r--r--flang/lib/Semantics/check-allocate.cpp33
-rw-r--r--flang/lib/Semantics/check-allocate.h1
-rw-r--r--flang/lib/Semantics/check-deallocate.cpp111
-rw-r--r--flang/lib/Semantics/expression.cpp2
-rw-r--r--flang/lib/Semantics/resolve-names.cpp19
14 files changed, 243 insertions, 80 deletions
diff --git a/flang/lib/Evaluate/common.cpp b/flang/lib/Evaluate/common.cpp
index 46c75a5..ed6a0ef 100644
--- a/flang/lib/Evaluate/common.cpp
+++ b/flang/lib/Evaluate/common.cpp
@@ -13,24 +13,28 @@ using namespace Fortran::parser::literals;
namespace Fortran::evaluate {
-void RealFlagWarnings(
- FoldingContext &context, const RealFlags &flags, const char *operation) {
+void FoldingContext::RealFlagWarnings(
+ const RealFlags &flags, const char *operation) {
static constexpr auto warning{common::UsageWarning::FoldingException};
if (flags.test(RealFlag::Overflow)) {
- context.Warn(warning, "overflow on %s"_warn_en_US, operation);
+ Warn(warning, "overflow on %s%s"_warn_en_US, operation,
+ realFlagWarningContext_);
}
if (flags.test(RealFlag::DivideByZero)) {
if (std::strcmp(operation, "division") == 0) {
- context.Warn(warning, "division by zero"_warn_en_US);
+ Warn(warning, "division by zero%s"_warn_en_US, realFlagWarningContext_);
} else {
- context.Warn(warning, "division by zero on %s"_warn_en_US, operation);
+ Warn(warning, "division by zero on %s%s"_warn_en_US, operation,
+ realFlagWarningContext_);
}
}
if (flags.test(RealFlag::InvalidArgument)) {
- context.Warn(warning, "invalid argument on %s"_warn_en_US, operation);
+ Warn(warning, "invalid argument on %s%s"_warn_en_US, operation,
+ realFlagWarningContext_);
}
if (flags.test(RealFlag::Underflow)) {
- context.Warn(warning, "underflow on %s"_warn_en_US, operation);
+ Warn(warning, "underflow on %s%s"_warn_en_US, operation,
+ realFlagWarningContext_);
}
}
diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h
index 3fdf3a6..52ea627 100644
--- a/flang/lib/Evaluate/fold-implementation.h
+++ b/flang/lib/Evaluate/fold-implementation.h
@@ -1862,7 +1862,7 @@ Expr<TO> FoldOperation(
std::snprintf(buffer, sizeof buffer,
"INTEGER(%d) to REAL(%d) conversion", Operand::kind,
TO::kind);
- RealFlagWarnings(ctx, converted.flags, buffer);
+ ctx.RealFlagWarnings(converted.flags, buffer);
}
return ScalarConstantToExpr(std::move(converted.value));
} else if constexpr (FromCat == TypeCategory::Real) {
@@ -1871,7 +1871,7 @@ Expr<TO> FoldOperation(
if (!converted.flags.empty()) {
std::snprintf(buffer, sizeof buffer,
"REAL(%d) to REAL(%d) conversion", Operand::kind, TO::kind);
- RealFlagWarnings(ctx, converted.flags, buffer);
+ ctx.RealFlagWarnings(converted.flags, buffer);
}
if (ctx.targetCharacteristics().areSubnormalsFlushedToZero()) {
converted.value = converted.value.FlushSubnormalToZero();
@@ -2012,7 +2012,7 @@ Expr<T> FoldOperation(FoldingContext &context, Add<T> &&x) {
} else {
auto sum{folded->first.Add(
folded->second, context.targetCharacteristics().roundingMode())};
- RealFlagWarnings(context, sum.flags, "addition");
+ context.RealFlagWarnings(sum.flags, "addition");
if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
sum.value = sum.value.FlushSubnormalToZero();
}
@@ -2041,7 +2041,7 @@ Expr<T> FoldOperation(FoldingContext &context, Subtract<T> &&x) {
} else {
auto difference{folded->first.Subtract(
folded->second, context.targetCharacteristics().roundingMode())};
- RealFlagWarnings(context, difference.flags, "subtraction");
+ context.RealFlagWarnings(difference.flags, "subtraction");
if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
difference.value = difference.value.FlushSubnormalToZero();
}
@@ -2070,7 +2070,7 @@ Expr<T> FoldOperation(FoldingContext &context, Multiply<T> &&x) {
} else {
auto product{folded->first.Multiply(
folded->second, context.targetCharacteristics().roundingMode())};
- RealFlagWarnings(context, product.flags, "multiplication");
+ context.RealFlagWarnings(product.flags, "multiplication");
if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
product.value = product.value.FlushSubnormalToZero();
}
@@ -2141,7 +2141,7 @@ Expr<T> FoldOperation(FoldingContext &context, Divide<T> &&x) {
}
}
if (!isCanonicalNaNOrInf) {
- RealFlagWarnings(context, quotient.flags, "division");
+ context.RealFlagWarnings(quotient.flags, "division");
}
if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
quotient.value = quotient.value.FlushSubnormalToZero();
@@ -2201,7 +2201,7 @@ Expr<T> FoldOperation(FoldingContext &context, RealToIntPower<T> &&x) {
[&](auto &y) -> Expr<T> {
if (auto folded{OperandsAreConstants(x.left(), y)}) {
auto power{evaluate::IntPower(folded->first, folded->second)};
- RealFlagWarnings(context, power.flags, "power with INTEGER exponent");
+ context.RealFlagWarnings(power.flags, "power with INTEGER exponent");
if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
power.value = power.value.FlushSubnormalToZero();
}
diff --git a/flang/lib/Evaluate/host.cpp b/flang/lib/Evaluate/host.cpp
index 25409ac..bf02496 100644
--- a/flang/lib/Evaluate/host.cpp
+++ b/flang/lib/Evaluate/host.cpp
@@ -140,8 +140,8 @@ void HostFloatingPointEnvironment::CheckAndRestoreFloatingPointEnvironment(
}
if (!flags_.empty()) {
- RealFlagWarnings(
- context, flags_, "evaluation of intrinsic function or operation");
+ context.RealFlagWarnings(
+ flags_, "evaluation of intrinsic function or operation");
}
errno = 0;
if (fesetenv(&originalFenv_) != 0) {
diff --git a/flang/lib/Evaluate/intrinsics-library.cpp b/flang/lib/Evaluate/intrinsics-library.cpp
index 9820aa3..d8af524 100644
--- a/flang/lib/Evaluate/intrinsics-library.cpp
+++ b/flang/lib/Evaluate/intrinsics-library.cpp
@@ -1043,7 +1043,7 @@ std::optional<HostRuntimeWrapper> GetHostRuntimeWrapper(const std::string &name,
if (const auto *hostFunction{
SearchHostRuntime(name, biggerResultType, biggerArgTypes)}) {
auto hostFolderWithChecks{AddArgumentVerifierIfAny(name, *hostFunction)};
- return [hostFunction, resultType, hostFolderWithChecks](
+ return [hostFunction, resultType, hostFolderWithChecks, name](
FoldingContext &context, std::vector<Expr<SomeType>> &&args) {
auto nArgs{args.size()};
for (size_t i{0}; i < nArgs; ++i) {
@@ -1051,6 +1051,8 @@ std::optional<HostRuntimeWrapper> GetHostRuntimeWrapper(const std::string &name,
ConvertToType(hostFunction->argumentTypes[i], std::move(args[i]))
.value());
}
+ auto restorer{context.SetRealFlagWarningContext(
+ " after folding a call to '"s + name + "'"s)};
return Fold(context,
ConvertToType(
resultType, hostFolderWithChecks(context, std::move(args)))
diff --git a/flang/lib/Optimizer/Builder/TemporaryStorage.cpp b/flang/lib/Optimizer/Builder/TemporaryStorage.cpp
index 7e329e3..5db40af 100644
--- a/flang/lib/Optimizer/Builder/TemporaryStorage.cpp
+++ b/flang/lib/Optimizer/Builder/TemporaryStorage.cpp
@@ -258,13 +258,9 @@ void fir::factory::AnyVariableStack::pushValue(mlir::Location loc,
fir::FirOpBuilder &builder,
mlir::Value variable) {
hlfir::Entity entity{variable};
- mlir::Type storageElementType =
- hlfir::getFortranElementType(retValueBox.getType());
- auto [box, maybeCleanUp] =
- hlfir::convertToBox(loc, builder, entity, storageElementType);
+ mlir::Value box =
+ hlfir::genVariableBox(loc, builder, entity, entity.getBoxType());
fir::runtime::genPushDescriptor(loc, builder, opaquePtr, fir::getBase(box));
- if (maybeCleanUp)
- (*maybeCleanUp)();
}
void fir::factory::AnyVariableStack::resetFetchPosition(
diff --git a/flang/lib/Optimizer/OpenACC/Support/CMakeLists.txt b/flang/lib/Optimizer/OpenACC/Support/CMakeLists.txt
index ef67ab1..898fb00 100644
--- a/flang/lib/Optimizer/OpenACC/Support/CMakeLists.txt
+++ b/flang/lib/Optimizer/OpenACC/Support/CMakeLists.txt
@@ -2,6 +2,7 @@ get_property(dialect_libs GLOBAL PROPERTY MLIR_DIALECT_LIBS)
add_flang_library(FIROpenACCSupport
FIROpenACCAttributes.cpp
+ FIROpenACCOpsInterfaces.cpp
FIROpenACCTypeInterfaces.cpp
RegisterOpenACCExtensions.cpp
diff --git a/flang/lib/Optimizer/OpenACC/Support/FIROpenACCOpsInterfaces.cpp b/flang/lib/Optimizer/OpenACC/Support/FIROpenACCOpsInterfaces.cpp
new file mode 100644
index 0000000..c1734be
--- /dev/null
+++ b/flang/lib/Optimizer/OpenACC/Support/FIROpenACCOpsInterfaces.cpp
@@ -0,0 +1,62 @@
+//===-- FIROpenACCOpsInterfaces.cpp ---------------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+//
+// Implementation of external operation interfaces for FIR.
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Optimizer/OpenACC/Support/FIROpenACCOpsInterfaces.h"
+
+#include "flang/Optimizer/Dialect/FIROps.h"
+#include "flang/Optimizer/HLFIR/HLFIROps.h"
+
+namespace fir::acc {
+
+template <>
+mlir::Value PartialEntityAccessModel<fir::ArrayCoorOp>::getBaseEntity(
+ mlir::Operation *op) const {
+ return mlir::cast<fir::ArrayCoorOp>(op).getMemref();
+}
+
+template <>
+mlir::Value PartialEntityAccessModel<fir::CoordinateOp>::getBaseEntity(
+ mlir::Operation *op) const {
+ return mlir::cast<fir::CoordinateOp>(op).getRef();
+}
+
+template <>
+mlir::Value PartialEntityAccessModel<hlfir::DesignateOp>::getBaseEntity(
+ mlir::Operation *op) const {
+ return mlir::cast<hlfir::DesignateOp>(op).getMemref();
+}
+
+mlir::Value PartialEntityAccessModel<fir::DeclareOp>::getBaseEntity(
+ mlir::Operation *op) const {
+ return mlir::cast<fir::DeclareOp>(op).getStorage();
+}
+
+bool PartialEntityAccessModel<fir::DeclareOp>::isCompleteView(
+ mlir::Operation *op) const {
+ // Return false (partial view) only if storage is present
+ // Return true (complete view) if storage is absent
+ return !getBaseEntity(op);
+}
+
+mlir::Value PartialEntityAccessModel<hlfir::DeclareOp>::getBaseEntity(
+ mlir::Operation *op) const {
+ return mlir::cast<hlfir::DeclareOp>(op).getStorage();
+}
+
+bool PartialEntityAccessModel<hlfir::DeclareOp>::isCompleteView(
+ mlir::Operation *op) const {
+ // Return false (partial view) only if storage is present
+ // Return true (complete view) if storage is absent
+ return !getBaseEntity(op);
+}
+
+} // namespace fir::acc
diff --git a/flang/lib/Optimizer/OpenACC/Support/RegisterOpenACCExtensions.cpp b/flang/lib/Optimizer/OpenACC/Support/RegisterOpenACCExtensions.cpp
index 717bf34..d71c40d 100644
--- a/flang/lib/Optimizer/OpenACC/Support/RegisterOpenACCExtensions.cpp
+++ b/flang/lib/Optimizer/OpenACC/Support/RegisterOpenACCExtensions.cpp
@@ -11,8 +11,13 @@
//===----------------------------------------------------------------------===//
#include "flang/Optimizer/OpenACC/Support/RegisterOpenACCExtensions.h"
+
#include "flang/Optimizer/Dialect/FIRDialect.h"
+#include "flang/Optimizer/Dialect/FIROps.h"
#include "flang/Optimizer/Dialect/FIRType.h"
+#include "flang/Optimizer/HLFIR/HLFIRDialect.h"
+#include "flang/Optimizer/HLFIR/HLFIROps.h"
+#include "flang/Optimizer/OpenACC/Support/FIROpenACCOpsInterfaces.h"
#include "flang/Optimizer/OpenACC/Support/FIROpenACCTypeInterfaces.h"
namespace fir::acc {
@@ -37,7 +42,24 @@ void registerOpenACCExtensions(mlir::DialectRegistry &registry) {
fir::LLVMPointerType::attachInterface<
OpenACCPointerLikeModel<fir::LLVMPointerType>>(*ctx);
+
+ fir::ArrayCoorOp::attachInterface<
+ PartialEntityAccessModel<fir::ArrayCoorOp>>(*ctx);
+ fir::CoordinateOp::attachInterface<
+ PartialEntityAccessModel<fir::CoordinateOp>>(*ctx);
+ fir::DeclareOp::attachInterface<PartialEntityAccessModel<fir::DeclareOp>>(
+ *ctx);
});
+
+ // Register HLFIR operation interfaces
+ registry.addExtension(
+ +[](mlir::MLIRContext *ctx, hlfir::hlfirDialect *dialect) {
+ hlfir::DesignateOp::attachInterface<
+ PartialEntityAccessModel<hlfir::DesignateOp>>(*ctx);
+ hlfir::DeclareOp::attachInterface<
+ PartialEntityAccessModel<hlfir::DeclareOp>>(*ctx);
+ });
+
registerAttrsExtensions(registry);
}
diff --git a/flang/lib/Parser/prescan.cpp b/flang/lib/Parser/prescan.cpp
index fd69404..efce8fc 100644
--- a/flang/lib/Parser/prescan.cpp
+++ b/flang/lib/Parser/prescan.cpp
@@ -1642,6 +1642,17 @@ Prescanner::IsFixedFormCompilerDirectiveLine(const char *start) const {
// This is a Continuation line, not an initial directive line.
return std::nullopt;
}
+ ++column, ++p;
+ }
+ if (isOpenMPConditional) {
+ for (; column <= fixedFormColumnLimit_; ++column, ++p) {
+ if (IsSpaceOrTab(p)) {
+ } else if (*p == '!') {
+ return std::nullopt; // !$ ! is a comment, not a directive
+ } else {
+ break;
+ }
+ }
}
if (const char *ss{IsCompilerDirectiveSentinel(
sentinel, static_cast<std::size_t>(sp - sentinel))}) {
@@ -1657,8 +1668,17 @@ Prescanner::IsFreeFormCompilerDirectiveLine(const char *start) const {
p && *p++ == '!') {
if (auto maybePair{IsCompilerDirectiveSentinel(p)}) {
auto offset{static_cast<std::size_t>(p - start - 1)};
- return {LineClassification{LineClassification::Kind::CompilerDirective,
- offset, maybePair->first}};
+ const char *sentinel{maybePair->first};
+ if ((sentinel[0] == '$' && sentinel[1] == '\0') || sentinel[1] == '@') {
+ if (const char *comment{IsFreeFormComment(maybePair->second)}) {
+ if (*comment == '!') {
+ // Conditional line comment - treat as comment
+ return std::nullopt;
+ }
+ }
+ }
+ return {LineClassification{
+ LineClassification::Kind::CompilerDirective, offset, sentinel}};
}
}
return std::nullopt;
diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp
index e019bbd..a411e20 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -26,6 +26,10 @@ struct AllocateCheckerInfo {
std::optional<evaluate::DynamicType> sourceExprType;
std::optional<parser::CharBlock> sourceExprLoc;
std::optional<parser::CharBlock> typeSpecLoc;
+ std::optional<parser::CharBlock> statSource;
+ std::optional<parser::CharBlock> msgSource;
+ const SomeExpr *statVar{nullptr};
+ const SomeExpr *msgVar{nullptr};
int sourceExprRank{0}; // only valid if gotMold || gotSource
bool gotStat{false};
bool gotMsg{false};
@@ -141,12 +145,15 @@ static std::optional<AllocateCheckerInfo> CheckAllocateOptions(
[&](const parser::StatOrErrmsg &statOrErr) {
common::visit(
common::visitors{
- [&](const parser::StatVariable &) {
+ [&](const parser::StatVariable &var) {
if (info.gotStat) { // C943
context.Say(
"STAT may not be duplicated in a ALLOCATE statement"_err_en_US);
}
info.gotStat = true;
+ info.statVar = GetExpr(context, var);
+ info.statSource =
+ parser::Unwrap<parser::Variable>(var)->GetSource();
},
[&](const parser::MsgVariable &var) {
WarnOnDeferredLengthCharacterScalar(context,
@@ -159,6 +166,9 @@ static std::optional<AllocateCheckerInfo> CheckAllocateOptions(
"ERRMSG may not be duplicated in a ALLOCATE statement"_err_en_US);
}
info.gotMsg = true;
+ info.msgVar = GetExpr(context, var);
+ info.msgSource =
+ parser::Unwrap<parser::Variable>(var)->GetSource();
},
},
statOrErr.u);
@@ -460,6 +470,16 @@ static bool HaveCompatibleLengths(
}
}
+bool AreSameAllocation(const SomeExpr *root, const SomeExpr *path) {
+ if (root && path) {
+ // For now we just use equality of expressions. If we implement a more
+ // sophisticated alias analysis we should use it here.
+ return *root == *path;
+ } else {
+ return false;
+ }
+}
+
bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
if (!ultimate_) {
CHECK(context.AnyFatalError());
@@ -690,6 +710,17 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
"Object in ALLOCATE must have DEVICE attribute when STREAM option is specified"_err_en_US);
}
}
+
+ if (const SomeExpr *allocObj{GetExpr(context, allocateObject_)}) {
+ if (AreSameAllocation(allocObj, allocateInfo_.statVar)) {
+ context.Say(allocateInfo_.statSource.value_or(name_.source),
+ "STAT variable in ALLOCATE must not be the variable being allocated"_err_en_US);
+ }
+ if (AreSameAllocation(allocObj, allocateInfo_.msgVar)) {
+ context.Say(allocateInfo_.msgSource.value_or(name_.source),
+ "ERRMSG variable in ALLOCATE must not be the variable being allocated"_err_en_US);
+ }
+ }
return RunCoarrayRelatedChecks(context);
}
diff --git a/flang/lib/Semantics/check-allocate.h b/flang/lib/Semantics/check-allocate.h
index e3f7f07..54f7380 100644
--- a/flang/lib/Semantics/check-allocate.h
+++ b/flang/lib/Semantics/check-allocate.h
@@ -24,5 +24,6 @@ public:
private:
SemanticsContext &context_;
};
+bool AreSameAllocation(const SomeExpr *root, const SomeExpr *path);
} // namespace Fortran::semantics
#endif // FORTRAN_SEMANTICS_CHECK_ALLOCATE_H_
diff --git a/flang/lib/Semantics/check-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp
index c1ebc5f..e6ce1b3 100644
--- a/flang/lib/Semantics/check-deallocate.cpp
+++ b/flang/lib/Semantics/check-deallocate.cpp
@@ -7,51 +7,87 @@
//===----------------------------------------------------------------------===//
#include "check-deallocate.h"
+#include "check-allocate.h"
#include "definable.h"
#include "flang/Evaluate/type.h"
#include "flang/Parser/message.h"
#include "flang/Parser/parse-tree.h"
#include "flang/Semantics/expression.h"
#include "flang/Semantics/tools.h"
+#include <optional>
namespace Fortran::semantics {
void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
+ bool gotStat{false}, gotMsg{false};
+ const SomeExpr *statVar{nullptr}, *msgVar{nullptr};
+ std::optional<parser::CharBlock> statSource;
+ std::optional<parser::CharBlock> msgSource;
+ for (const parser::StatOrErrmsg &deallocOpt :
+ std::get<std::list<parser::StatOrErrmsg>>(deallocateStmt.t)) {
+ common::visit(
+ common::visitors{
+ [&](const parser::StatVariable &var) {
+ if (gotStat) {
+ context_.Say(
+ "STAT may not be duplicated in a DEALLOCATE statement"_err_en_US);
+ }
+ gotStat = true;
+ statVar = GetExpr(context_, var);
+ statSource = parser::Unwrap<parser::Variable>(var)->GetSource();
+ },
+ [&](const parser::MsgVariable &var) {
+ WarnOnDeferredLengthCharacterScalar(context_,
+ GetExpr(context_, var),
+ parser::UnwrapRef<parser::Variable>(var).GetSource(),
+ "ERRMSG=");
+ if (gotMsg) {
+ context_.Say(
+ "ERRMSG may not be duplicated in a DEALLOCATE statement"_err_en_US);
+ }
+ gotMsg = true;
+ msgVar = GetExpr(context_, var);
+ msgSource = parser::Unwrap<parser::Variable>(var)->GetSource();
+ },
+ },
+ deallocOpt.u);
+ }
for (const parser::AllocateObject &allocateObject :
std::get<std::list<parser::AllocateObject>>(deallocateStmt.t)) {
+ parser::CharBlock source;
common::visit(
common::visitors{
[&](const parser::Name &name) {
const Symbol *symbol{
name.symbol ? &name.symbol->GetUltimate() : nullptr};
- ;
+ source = name.source;
if (context_.HasError(symbol)) {
// already reported an error
} else if (!IsVariableName(*symbol)) {
- context_.Say(name.source,
+ context_.Say(source,
"Name in DEALLOCATE statement must be a variable name"_err_en_US);
} else if (!IsAllocatableOrObjectPointer(symbol)) { // C936
- context_.Say(name.source,
+ context_.Say(source,
"Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
- } else if (auto whyNot{WhyNotDefinable(name.source,
- context_.FindScope(name.source),
- {DefinabilityFlag::PointerDefinition,
- DefinabilityFlag::AcceptAllocatable,
- DefinabilityFlag::PotentialDeallocation},
- *symbol)}) {
+ } else if (auto whyNot{
+ WhyNotDefinable(source, context_.FindScope(source),
+ {DefinabilityFlag::PointerDefinition,
+ DefinabilityFlag::AcceptAllocatable,
+ DefinabilityFlag::PotentialDeallocation},
+ *symbol)}) {
// Catch problems with non-definability of the
// pointer/allocatable
context_
- .Say(name.source,
+ .Say(source,
"Name in DEALLOCATE statement is not definable"_err_en_US)
.Attach(std::move(
whyNot->set_severity(parser::Severity::Because)));
- } else if (auto whyNot{WhyNotDefinable(name.source,
- context_.FindScope(name.source),
- DefinabilityFlags{}, *symbol)}) {
+ } else if (auto whyNot{
+ WhyNotDefinable(source, context_.FindScope(source),
+ DefinabilityFlags{}, *symbol)}) {
// Catch problems with non-definability of the dynamic object
context_
- .Say(name.source,
+ .Say(source,
"Object in DEALLOCATE statement is not deallocatable"_err_en_US)
.Attach(std::move(
whyNot->set_severity(parser::Severity::Because)));
@@ -62,13 +98,12 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
[&](const parser::StructureComponent &structureComponent) {
// Only perform structureComponent checks if it was successfully
// analyzed by expression analysis.
- auto source{structureComponent.component.source};
+ source = structureComponent.component.source;
if (const auto *expr{GetExpr(context_, allocateObject)}) {
- if (const Symbol *
- symbol{structureComponent.component.symbol
- ? &structureComponent.component.symbol
- ->GetUltimate()
- : nullptr};
+ if (const Symbol *symbol{structureComponent.component.symbol
+ ? &structureComponent.component.symbol
+ ->GetUltimate()
+ : nullptr};
!IsAllocatableOrObjectPointer(symbol)) { // F'2023 C936
context_.Say(source,
"Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
@@ -99,32 +134,16 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
},
},
allocateObject.u);
- }
- bool gotStat{false}, gotMsg{false};
- for (const parser::StatOrErrmsg &deallocOpt :
- std::get<std::list<parser::StatOrErrmsg>>(deallocateStmt.t)) {
- common::visit(
- common::visitors{
- [&](const parser::StatVariable &) {
- if (gotStat) {
- context_.Say(
- "STAT may not be duplicated in a DEALLOCATE statement"_err_en_US);
- }
- gotStat = true;
- },
- [&](const parser::MsgVariable &var) {
- WarnOnDeferredLengthCharacterScalar(context_,
- GetExpr(context_, var),
- parser::UnwrapRef<parser::Variable>(var).GetSource(),
- "ERRMSG=");
- if (gotMsg) {
- context_.Say(
- "ERRMSG may not be duplicated in a DEALLOCATE statement"_err_en_US);
- }
- gotMsg = true;
- },
- },
- deallocOpt.u);
+ if (const SomeExpr *allocObj{GetExpr(context_, allocateObject)}) {
+ if (AreSameAllocation(allocObj, statVar)) {
+ context_.Say(statSource.value_or(source),
+ "STAT variable in DEALLOCATE must not be the variable being deallocated"_err_en_US);
+ }
+ if (AreSameAllocation(allocObj, msgVar)) {
+ context_.Say(msgSource.value_or(source),
+ "ERRMSG variable in DEALLOCATE must not be the variable being deallocated"_err_en_US);
+ }
+ }
}
}
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 32aa6b1..c8167fd 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -834,7 +834,7 @@ Constant<TYPE> ReadRealLiteral(
auto valWithFlags{
Scalar<TYPE>::Read(p, context.targetCharacteristics().roundingMode())};
CHECK(p == source.end());
- RealFlagWarnings(context, valWithFlags.flags, "conversion of REAL literal");
+ context.RealFlagWarnings(valWithFlags.flags, "conversion of REAL literal");
auto value{valWithFlags.value};
if (context.targetCharacteristics().areSubnormalsFlushedToZero()) {
value = value.FlushSubnormalToZero();
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index f88af5f..220f1c9 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -9435,13 +9435,18 @@ bool ResolveNamesVisitor::SetProcFlag(
SayWithDecl(name, symbol,
"Implicit declaration of function '%s' has a different result type than in previous declaration"_err_en_US);
return false;
- } else if (symbol.has<ProcEntityDetails>()) {
- symbol.set(flag); // in case it hasn't been set yet
- if (flag == Symbol::Flag::Function) {
- ApplyImplicitRules(symbol);
- }
- if (symbol.attrs().test(Attr::INTRINSIC)) {
- AcquireIntrinsicProcedureFlags(symbol);
+ } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
+ if (IsPointer(symbol) && !proc->type() && !proc->procInterface()) {
+ // PROCEDURE(), POINTER -- errors will be emitted later about a lack
+ // of known characteristics if used as a function
+ } else {
+ symbol.set(flag); // in case it hasn't been set yet
+ if (flag == Symbol::Flag::Function) {
+ ApplyImplicitRules(symbol);
+ }
+ if (symbol.attrs().test(Attr::INTRINSIC)) {
+ AcquireIntrinsicProcedureFlags(symbol);
+ }
}
} else if (symbol.GetType() && flag == Symbol::Flag::Subroutine) {
SayWithDecl(
generated by cgit v1.1 at 2025-11-01 13:53:00 +0000