diff options
Diffstat (limited to 'flang/lib')
22 files changed, 303 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/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp index 6e72987..0f4b39a 100644 --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -4876,6 +4876,10 @@ private: mlir::Value shape = builder->genShape(loc, lbounds, extents); rhsBox = fir::ReboxOp::create(*builder, loc, lhsBoxType, rhsBox, shape, /*slice=*/mlir::Value{}); + } else if (fir::isClassStarType(lhsBoxType) && + !fir::ConvertOp::canBeConverted(rhsBoxType, lhsBoxType)) { + rhsBox = fir::ReboxOp::create(*builder, loc, lhsBoxType, rhsBox, + mlir::Value{}, mlir::Value{}); } return rhsBox; } diff --git a/flang/lib/Lower/OpenMP/Clauses.cpp b/flang/lib/Lower/OpenMP/Clauses.cpp index d39f9dd..0f60b47 100644 --- a/flang/lib/Lower/OpenMP/Clauses.cpp +++ b/flang/lib/Lower/OpenMP/Clauses.cpp @@ -1482,6 +1482,21 @@ ThreadLimit make(const parser::OmpClause::ThreadLimit &inp, return ThreadLimit{/*Threadlim=*/makeExpr(inp.v, semaCtx)}; } +Threadset make(const parser::OmpClause::Threadset &inp, + semantics::SemanticsContext &semaCtx) { + // inp.v -> parser::OmpThreadsetClause + using wrapped = parser::OmpThreadsetClause; + + CLAUSET_ENUM_CONVERT( // + convert, wrapped::ThreadsetPolicy, Threadset::ThreadsetPolicy, + // clang-format off + MS(Omp_Pool, Omp_Pool) + MS(Omp_Team, Omp_Team) + // clang-format on + ); + return Threadset{/*ThreadsetPolicy=*/convert(inp.v.v)}; +} + // Threadprivate: empty // Threads: empty diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp index 53fe9c0..15ea845 100644 --- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp +++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp @@ -3359,8 +3359,8 @@ void IntrinsicLibrary::genBarrierInit(llvm::ArrayRef<fir::ExtendedValue> args) { assert(args.size() == 2); mlir::Value barrier = convertPtrToNVVMSpace( builder, loc, fir::getBase(args[0]), mlir::NVVM::NVVMMemorySpace::Shared); - mlir::NVVM::MBarrierInitSharedOp::create(builder, loc, barrier, - fir::getBase(args[1]), {}); + mlir::NVVM::MBarrierInitOp::create(builder, loc, barrier, + fir::getBase(args[1]), {}); auto kind = mlir::NVVM::ProxyKindAttr::get( builder.getContext(), mlir::NVVM::ProxyKind::async_shared); auto space = mlir::NVVM::SharedSpaceAttr::get( @@ -9362,6 +9362,8 @@ static void genTMABulkLoad(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value size = mlir::arith::MulIOp::create(builder, loc, nelem, eleSize); auto llvmPtrTy = mlir::LLVM::LLVMPointerType::get(builder.getContext()); barrier = builder.createConvert(loc, llvmPtrTy, barrier); + dst = builder.createConvert(loc, llvmPtrTy, dst); + src = builder.createConvert(loc, llvmPtrTy, src); mlir::NVVM::InlinePtxOp::create( builder, loc, mlir::TypeRange{}, {dst, src, size, barrier}, {}, "cp.async.bulk.shared::cluster.global.mbarrier::complete_tx::bytes [%0], " 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/FIROpenACCTypeInterfaces.cpp b/flang/lib/Optimizer/OpenACC/Support/FIROpenACCTypeInterfaces.cpp index ed9e41c..ae0f5fb8 100644 --- a/flang/lib/Optimizer/OpenACC/Support/FIROpenACCTypeInterfaces.cpp +++ b/flang/lib/Optimizer/OpenACC/Support/FIROpenACCTypeInterfaces.cpp @@ -193,6 +193,28 @@ OpenACCMappableModel<fir::PointerType>::getOffsetInBytes( mlir::Type type, mlir::Value var, mlir::ValueRange accBounds, const mlir::DataLayout &dataLayout) const; +template <typename Ty> +bool OpenACCMappableModel<Ty>::hasUnknownDimensions(mlir::Type type) const { + assert(fir::isa_ref_type(type) && "expected FIR reference type"); + return fir::hasDynamicSize(fir::unwrapRefType(type)); +} + +template bool OpenACCMappableModel<fir::ReferenceType>::hasUnknownDimensions( + mlir::Type type) const; + +template bool OpenACCMappableModel<fir::HeapType>::hasUnknownDimensions( + mlir::Type type) const; + +template bool OpenACCMappableModel<fir::PointerType>::hasUnknownDimensions( + mlir::Type type) const; + +template <> +bool OpenACCMappableModel<fir::BaseBoxType>::hasUnknownDimensions( + mlir::Type type) const { + // Descriptor-based entities have dimensions encoded. + return false; +} + static llvm::SmallVector<mlir::Value> generateSeqTyAccBounds(fir::SequenceType seqType, mlir::Value var, mlir::OpBuilder &builder) { 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 ®istry) { 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 4739da0..efce8fc 100644 --- a/flang/lib/Parser/prescan.cpp +++ b/flang/lib/Parser/prescan.cpp @@ -557,7 +557,7 @@ bool Prescanner::MustSkipToEndOfLine() const { return true; // skip over ignored columns in right margin (73:80) } else if (*at_ == '!' && !inCharLiteral_ && (!inFixedForm_ || tabInCurrentLine_ || column_ != 6)) { - return !IsCompilerDirectiveSentinel(at_); + return !IsCompilerDirectiveSentinel(at_ + 1); } else { return false; } @@ -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-call.cpp b/flang/lib/Semantics/check-call.cpp index c51d40b..995deaa 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -914,7 +914,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, dummyName); } // INTENT(OUT) and INTENT(IN OUT) cases are caught elsewhere - } else { + } else if (!actualIsAllocatable && + !dummy.ignoreTKR.test(common::IgnoreTKR::Pointer)) { messages.Say( "ALLOCATABLE %s must be associated with an ALLOCATABLE actual argument"_err_en_US, dummyName); @@ -929,7 +930,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, dummy, actual, *scope, /*isAssumedRank=*/dummyIsAssumedRank, actualIsPointer); } - } else if (!actualIsPointer) { + } else if (!actualIsPointer && + !dummy.ignoreTKR.test(common::IgnoreTKR::Pointer)) { messages.Say( "Actual argument associated with POINTER %s must also be POINTER unless INTENT(IN)"_err_en_US, dummyName); 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/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp index 549ee83..de407d3 100644 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -949,7 +949,8 @@ void CheckHelper::CheckObjectEntity( "!DIR$ IGNORE_TKR(R) may not apply in an ELEMENTAL procedure"_err_en_US); } if (IsPassedViaDescriptor(symbol)) { - if (IsAllocatableOrObjectPointer(&symbol)) { + if (IsAllocatableOrObjectPointer(&symbol) && + !ignoreTKR.test(common::IgnoreTKR::Pointer)) { if (inExplicitExternalInterface) { Warn(common::UsageWarning::IgnoreTKRUsage, "!DIR$ IGNORE_TKR should not apply to an allocatable or pointer"_warn_en_US); diff --git a/flang/lib/Semantics/check-omp-structure.cpp b/flang/lib/Semantics/check-omp-structure.cpp index e094458f..aaaf1ec 100644 --- a/flang/lib/Semantics/check-omp-structure.cpp +++ b/flang/lib/Semantics/check-omp-structure.cpp @@ -3390,6 +3390,7 @@ CHECK_SIMPLE_CLAUSE(Read, OMPC_read) CHECK_SIMPLE_CLAUSE(Threadprivate, OMPC_threadprivate) CHECK_SIMPLE_CLAUSE(Groupprivate, OMPC_groupprivate) CHECK_SIMPLE_CLAUSE(Threads, OMPC_threads) +CHECK_SIMPLE_CLAUSE(Threadset, OMPC_threadset) CHECK_SIMPLE_CLAUSE(Inbranch, OMPC_inbranch) CHECK_SIMPLE_CLAUSE(Link, OMPC_link) CHECK_SIMPLE_CLAUSE(Indirect, OMPC_indirect) 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/mod-file.cpp b/flang/lib/Semantics/mod-file.cpp index 556259d..b419864 100644 --- a/flang/lib/Semantics/mod-file.cpp +++ b/flang/lib/Semantics/mod-file.cpp @@ -1021,6 +1021,9 @@ void ModFileWriter::PutObjectEntity( case common::IgnoreTKR::Contiguous: os << 'c'; break; + case common::IgnoreTKR::Pointer: + os << 'p'; + break; } }); os << ") " << symbol.name() << '\n'; diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 0e6d4c7..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( @@ -10109,6 +10114,9 @@ void ResolveNamesVisitor::Post(const parser::CompilerDirective &x) { case 'c': set.set(common::IgnoreTKR::Contiguous); break; + case 'p': + set.set(common::IgnoreTKR::Pointer); + break; case 'a': set = common::ignoreTKRAll; break; diff --git a/flang/lib/Support/Fortran.cpp b/flang/lib/Support/Fortran.cpp index 3a8ebbb..05d6e0e 100644 --- a/flang/lib/Support/Fortran.cpp +++ b/flang/lib/Support/Fortran.cpp @@ -95,6 +95,9 @@ std::string AsFortran(IgnoreTKRSet tkr) { if (tkr.test(IgnoreTKR::Contiguous)) { result += 'C'; } + if (tkr.test(IgnoreTKR::Pointer)) { + result += 'P'; + } return result; } |