[flang-commits] [flang] 3332dc3 - [flang] CUDA Fortran - part 3/5: declarations checking
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Wed May 31 10:42:31 PDT 2023
Author: Peter Klausler
Date: 2023-05-31T10:42:26-07:00
New Revision: 3332dc32580751885eef797f6657d363091f69f3
URL: https://github.com/llvm/llvm-project/commit/3332dc32580751885eef797f6657d363091f69f3
DIFF: https://github.com/llvm/llvm-project/commit/3332dc32580751885eef797f6657d363091f69f3.diff
LOG: [flang] CUDA Fortran - part 3/5: declarations checking
Implements checks for CUDA Fortran attributes on objects, types, and
subprograms. Includes a couple downgrades of existing errors into
warnings that were exposed during testing.
Depends on https://reviews.llvm.org/D150159 &
https://reviews.llvm.org/D150161.
Differential Revision: https://reviews.llvm.org/D150162
Added:
flang/module/__cuda_builtins.f90
flang/test/Semantics/cuf02.cuf
flang/test/Semantics/cuf03.cuf
flang/test/Semantics/cuf08.cuf
Modified:
flang/include/flang/Evaluate/type.h
flang/include/flang/Semantics/type.h
flang/lib/Evaluate/type.cpp
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/type.cpp
flang/test/Semantics/bind-c06.f90
flang/test/Semantics/resolve65.f90
flang/test/Semantics/resolve67.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h
index 2183b0dad5d1a..eb4050970c138 100644
--- a/flang/include/flang/Evaluate/type.h
+++ b/flang/include/flang/Evaluate/type.h
@@ -22,6 +22,7 @@
#include "integer.h"
#include "logical.h"
#include "real.h"
+#include "flang/Common/Fortran-features.h"
#include "flang/Common/Fortran.h"
#include "flang/Common/idioms.h"
#include "flang/Common/real.h"
@@ -472,8 +473,10 @@ int SelectedCharKind(const std::string &, int defaultKind);
std::optional<DynamicType> ComparisonType(
const DynamicType &, const DynamicType &);
-bool IsInteroperableIntrinsicType(
- const DynamicType &, bool checkCharLength = true);
+bool IsInteroperableIntrinsicType(const DynamicType &,
+ const common::LanguageFeatureControl * = nullptr,
+ bool checkCharLength = true);
+bool IsCUDAIntrinsicType(const DynamicType &);
// Determine whether two derived type specs are sufficiently identical
// to be considered the "same" type even if declared separately.
diff --git a/flang/include/flang/Semantics/type.h b/flang/include/flang/Semantics/type.h
index e30ec2dd61205..7de436a676a56 100644
--- a/flang/include/flang/Semantics/type.h
+++ b/flang/include/flang/Semantics/type.h
@@ -456,7 +456,8 @@ inline const DerivedTypeSpec *DeclTypeSpec::AsDerived() const {
return const_cast<DeclTypeSpec *>(this)->AsDerived();
}
-bool IsInteroperableIntrinsicType(const DeclTypeSpec &);
+bool IsInteroperableIntrinsicType(
+ const DeclTypeSpec &, const common::LanguageFeatureControl &);
} // namespace Fortran::semantics
#endif // FORTRAN_SEMANTICS_TYPE_H_
diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 8311299fbb78d..9c9daafcce3a4 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -747,14 +747,15 @@ std::optional<DynamicType> ComparisonType(
}
}
-bool IsInteroperableIntrinsicType(
- const DynamicType &type, bool checkCharLength) {
+bool IsInteroperableIntrinsicType(const DynamicType &type,
+ const common::LanguageFeatureControl *features, bool checkCharLength) {
switch (type.category()) {
case TypeCategory::Integer:
return true;
case TypeCategory::Real:
case TypeCategory::Complex:
- return type.kind() >= 4; // no short or half floats
+ return (features && features->IsEnabled(common::LanguageFeature::CUDA)) ||
+ type.kind() >= 4; // no short or half floats
case TypeCategory::Logical:
return type.kind() == 1; // C_BOOL
case TypeCategory::Character:
@@ -768,4 +769,21 @@ bool IsInteroperableIntrinsicType(
}
}
+bool IsCUDAIntrinsicType(const DynamicType &type) {
+ switch (type.category()) {
+ case TypeCategory::Integer:
+ case TypeCategory::Logical:
+ return type.kind() <= 8;
+ case TypeCategory::Real:
+ return type.kind() >= 2 && type.kind() <= 8;
+ case TypeCategory::Complex:
+ return type.kind() == 2 || type.kind() == 4 || type.kind() == 8;
+ case TypeCategory::Character:
+ return type.kind() == 1;
+ default:
+ // Derived types are tested in Semantics/check-declarations.cpp
+ return false;
+ }
+}
+
} // namespace Fortran::evaluate
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 1202ccfc4e3bb..4b70fb19c551a 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -115,6 +115,19 @@ class CheckHelper {
}
return msg;
}
+ template <typename... A> parser::Message *WarnIfNotInModuleFile(A &&...x) {
+ if (FindModuleFileContaining(context_.FindScope(messages_.at()))) {
+ return nullptr;
+ }
+ return messages_.Say(std::forward<A>(x)...);
+ }
+ template <typename... A>
+ parser::Message *WarnIfNotInModuleFile(parser::CharBlock source, A &&...x) {
+ if (FindModuleFileContaining(context_.FindScope(source))) {
+ return nullptr;
+ }
+ return messages_.Say(source, std::forward<A>(x)...);
+ }
bool IsResultOkToDiffer(const FunctionResult &);
void CheckGlobalName(const Symbol &);
void CheckExplicitSave(const Symbol &);
@@ -217,9 +230,8 @@ void CheckHelper::Check(
void CheckHelper::Check(const Symbol &symbol) {
if (symbol.name().size() > common::maxNameLen &&
- &symbol == &symbol.GetUltimate() &&
- !FindModuleFileContaining(symbol.owner())) {
- messages_.Say(symbol.name(),
+ &symbol == &symbol.GetUltimate()) {
+ WarnIfNotInModuleFile(symbol.name(),
"%s has length %d, which is greater than the maximum name length "
"%d"_port_en_US,
symbol.name(), symbol.name().size(), common::maxNameLen);
@@ -606,6 +618,7 @@ void CheckHelper::CheckObjectEntity(
WarnMissingFinal(symbol);
const DeclTypeSpec *type{details.type()};
const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
+ bool isComponent{symbol.owner().IsDerivedType()};
if (!details.coshape().empty()) {
bool isDeferredCoshape{details.coshape().CanBeDeferredShape()};
if (IsAllocatable(symbol)) {
@@ -614,7 +627,7 @@ void CheckHelper::CheckObjectEntity(
" coshape"_err_en_US,
symbol.name());
}
- } else if (symbol.owner().IsDerivedType()) { // C746
+ } else if (isComponent) { // C746
std::string deferredMsg{
isDeferredCoshape ? "" : " and have a deferred coshape"};
messages_.Say("Component '%s' is a coarray and must have the ALLOCATABLE"
@@ -718,7 +731,7 @@ void CheckHelper::CheckObjectEntity(
if (IsPassedViaDescriptor(symbol)) {
if (IsAllocatableOrPointer(symbol)) {
if (inExplicitInterface) {
- messages_.Say(
+ WarnIfNotInModuleFile(
"!DIR$ IGNORE_TKR should not apply to an allocatable or pointer"_warn_en_US);
} else {
messages_.Say(
@@ -726,10 +739,10 @@ void CheckHelper::CheckObjectEntity(
}
} else if (ignoreTKR.test(common::IgnoreTKR::Rank)) {
if (ignoreTKR.count() == 1 && evaluate::IsAssumedRank(symbol)) {
- messages_.Say(
+ WarnIfNotInModuleFile(
"!DIR$ IGNORE_TKR(R) is not meaningful for an assumed-rank array"_warn_en_US);
} else if (inExplicitInterface) {
- messages_.Say(
+ WarnIfNotInModuleFile(
"!DIR$ IGNORE_TKR(R) should not apply to a dummy argument passed via descriptor"_warn_en_US);
} else {
messages_.Say(
@@ -797,9 +810,8 @@ void CheckHelper::CheckObjectEntity(
messages_.Say("A dummy argument must not be initialized"_err_en_US);
} else if (IsFunctionResult(symbol)) {
messages_.Say("A function result must not be initialized"_err_en_US);
- } else if (IsInBlankCommon(symbol) &&
- !FindModuleFileContaining(symbol.owner())) {
- messages_.Say(
+ } else if (IsInBlankCommon(symbol)) {
+ WarnIfNotInModuleFile(
"A variable in blank COMMON should not be initialized"_port_en_US);
}
}
@@ -839,6 +851,156 @@ void CheckHelper::CheckObjectEntity(
"'%s' is a data object and may not be EXTERNAL"_err_en_US,
symbol.name());
}
+
+ // Check CUDA attributes and special circumstances of being in device
+ // subprograms
+ const Scope &progUnit{GetProgramUnitContaining(symbol)};
+ const auto *subpDetails{!isComponent && progUnit.symbol()
+ ? progUnit.symbol()->detailsIf<SubprogramDetails>()
+ : nullptr};
+ bool inDeviceSubprogram{IsCUDADeviceContext(&symbol.owner())};
+ if (inDeviceSubprogram) {
+ if (IsSaved(symbol)) {
+ WarnIfNotInModuleFile(
+ "'%s' should not have the SAVE attribute or initialization in a device subprogram"_warn_en_US,
+ symbol.name());
+ }
+ if (IsPointer(symbol)) {
+ WarnIfNotInModuleFile(
+ "Pointer '%s' may not be associated in a device subprogram"_warn_en_US,
+ symbol.name());
+ }
+ if (details.isDummy() &&
+ details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=
+ common::CUDADataAttr::Device &&
+ details.cudaDataAttr().value_or(common::CUDADataAttr::Device) !=
+ common::CUDADataAttr::Managed) {
+ WarnIfNotInModuleFile(
+ "Dummy argument '%s' may not have ATTRIBUTES(%s) in a device subprogram"_warn_en_US,
+ symbol.name(),
+ parser::ToUpperCaseLetters(
+ common::EnumToString(*details.cudaDataAttr())));
+ }
+ }
+ if (details.cudaDataAttr()) {
+ if (auto dyType{evaluate::DynamicType::From(symbol)}) {
+ if (dyType->category() != TypeCategory::Derived) {
+ if (!IsCUDAIntrinsicType(*dyType)) {
+ messages_.Say(
+ "'%s' has intrinsic type '%s' that is not available on the device"_err_en_US,
+ symbol.name(), dyType->AsFortran());
+ }
+ }
+ }
+ auto attr{*details.cudaDataAttr()};
+ switch (attr) {
+ case common::CUDADataAttr::Constant:
+ if (IsAllocatableOrPointer(symbol) || symbol.attrs().test(Attr::TARGET)) {
+ messages_.Say(
+ "Object '%s' with ATTRIBUTES(CONSTANT) may not be allocatable, pointer, or target"_err_en_US,
+ symbol.name());
+ } else if (auto shape{evaluate::GetShape(foldingContext_, symbol)};
+ !shape ||
+ !evaluate::AsConstantExtents(foldingContext_, *shape)) {
+ messages_.Say(
+ "Object '%s' with ATTRIBUTES(CONSTANT) must have constant array bounds"_err_en_US,
+ symbol.name());
+ }
+ break;
+ case common::CUDADataAttr::Device:
+ if (isComponent && !IsAllocatable(symbol)) {
+ messages_.Say(
+ "Component '%s' with ATTRIBUTES(DEVICE) must also be allocatable"_err_en_US,
+ symbol.name());
+ }
+ break;
+ case common::CUDADataAttr::Managed:
+ if (!IsAutomatic(symbol) && !IsAllocatable(symbol) &&
+ !details.isDummy()) {
+ messages_.Say(
+ "Object '%s' with ATTRIBUTES(MANAGED) must also be allocatable, automatic, or a dummy argument"_err_en_US,
+ symbol.name());
+ }
+ break;
+ case common::CUDADataAttr::Pinned:
+ if (inDeviceSubprogram) {
+ WarnIfNotInModuleFile(
+ "Object '%s' with ATTRIBUTES(PINNED) may not be declared in a device subprogram"_warn_en_US,
+ symbol.name());
+ } else if (IsPointer(symbol)) {
+ WarnIfNotInModuleFile(
+ "Object '%s' with ATTRIBUTES(PINNED) may not be a pointer"_warn_en_US,
+ symbol.name());
+ } else if (!IsAllocatable(symbol)) {
+ WarnIfNotInModuleFile(
+ "Object '%s' with ATTRIBUTES(PINNED) should also be allocatable"_warn_en_US,
+ symbol.name());
+ }
+ break;
+ case common::CUDADataAttr::Shared:
+ if (IsAllocatableOrPointer(symbol) || symbol.attrs().test(Attr::TARGET)) {
+ messages_.Say(
+ "Object '%s' with ATTRIBUTES(SHARED) may not be allocatable, pointer, or target"_err_en_US,
+ symbol.name());
+ } else if (!inDeviceSubprogram) {
+ messages_.Say(
+ "Object '%s' with ATTRIBUTES(SHARED) must be declared in a device subprogram"_err_en_US,
+ symbol.name());
+ }
+ break;
+ case common::CUDADataAttr::Texture:
+ messages_.Say(
+ "ATTRIBUTES(TEXTURE) is obsolete and no longer supported"_err_en_US);
+ break;
+ }
+ if (attr != common::CUDADataAttr::Pinned) {
+ if (details.commonBlock()) {
+ messages_.Say(
+ "Object '%s' with ATTRIBUTES(%s) may not be in COMMON"_err_en_US,
+ symbol.name(),
+ parser::ToUpperCaseLetters(common::EnumToString(attr)));
+ } else if (FindEquivalenceSet(symbol)) {
+ messages_.Say(
+ "Object '%s' with ATTRIBUTES(%s) may not be in an equivalence group"_err_en_US,
+ symbol.name(),
+ parser::ToUpperCaseLetters(common::EnumToString(attr)));
+ }
+ }
+ if (subpDetails /* not a module variable */ && IsSaved(symbol) &&
+ !inDeviceSubprogram && !IsAllocatable(symbol) &&
+ attr == common::CUDADataAttr::Device) {
+ messages_.Say(
+ "Saved object '%s' in host code may not have ATTRIBUTES(DEVICE) unless allocatable"_err_en_US,
+ symbol.name(),
+ parser::ToUpperCaseLetters(common::EnumToString(attr)));
+ }
+ if (isComponent) {
+ if (attr == common::CUDADataAttr::Device) {
+ const DeclTypeSpec *type{symbol.GetType()};
+ if (const DerivedTypeSpec *
+ derived{type ? type->AsDerived() : nullptr}) {
+ DirectComponentIterator directs{*derived};
+ if (auto iter{std::find_if(directs.begin(), directs.end(),
+ [](const Symbol &) { return false; })}) {
+ messages_.Say(
+ "Derived type component '%s' may not have ATTRIBUTES(DEVICE) as it has a direct device component '%s'"_err_en_US,
+ symbol.name(), iter.BuildResultDesignatorName());
+ }
+ }
+ } else if (attr == common::CUDADataAttr::Constant ||
+ attr == common::CUDADataAttr::Shared) {
+ messages_.Say(
+ "Derived type component '%s' may not have ATTRIBUTES(%s)"_err_en_US,
+ symbol.name(),
+ parser::ToUpperCaseLetters(common::EnumToString(attr)));
+ }
+ } else if (!subpDetails && symbol.owner().kind() != Scope::Kind::Module &&
+ symbol.owner().kind() != Scope::Kind::MainProgram) {
+ messages_.Say(
+ "ATTRIBUTES(%s) may apply only to module, host subprogram, or device subprogram data"_err_en_US,
+ parser::ToUpperCaseLetters(common::EnumToString(attr)));
+ }
+ }
}
void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
@@ -910,6 +1072,9 @@ void CheckHelper::CheckArraySpec(
bool canBeAssumedShape{arraySpec.CanBeAssumedShape()};
bool canBeAssumedSize{arraySpec.CanBeAssumedSize()};
bool isAssumedRank{arraySpec.IsAssumedRank()};
+ bool isCUDAShared{
+ GetCUDADataAttr(&symbol).value_or(common::CUDADataAttr::Device) ==
+ common::CUDADataAttr::Shared};
std::optional<parser::MessageFixedText> msg;
if (symbol.test(Symbol::Flag::CrayPointee) && !isExplicit &&
!canBeAssumedSize) {
@@ -939,12 +1104,12 @@ void CheckHelper::CheckArraySpec(
}
} else if (canBeAssumedShape && !canBeDeferred) {
msg = "Assumed-shape array '%s' must be a dummy argument"_err_en_US;
- } else if (canBeAssumedSize && !canBeImplied) { // C833
+ } else if (canBeAssumedSize && !canBeImplied && !isCUDAShared) { // C833
msg = "Assumed-size array '%s' must be a dummy argument"_err_en_US;
} else if (isAssumedRank) { // C837
msg = "Assumed-rank array '%s' must be a dummy argument"_err_en_US;
} else if (canBeImplied) {
- if (!IsNamedConstant(symbol)) { // C835, C836
+ if (!IsNamedConstant(symbol) && !isCUDAShared) { // C835, C836
msg = "Implied-shape array '%s' must be a named constant or a "
"dummy argument"_err_en_US;
}
@@ -1178,6 +1343,50 @@ void CheckHelper::CheckSubprogram(
}
CheckExternal(symbol);
CheckModuleProcedureDef(symbol);
+ auto cudaAttrs{details.cudaSubprogramAttrs()};
+ if (cudaAttrs &&
+ (*cudaAttrs == common::CUDASubprogramAttrs::Global ||
+ *cudaAttrs == common::CUDASubprogramAttrs::Grid_Global) &&
+ details.isFunction()) {
+ messages_.Say(symbol.name(),
+ "A function may not have ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)"_err_en_US);
+ }
+ if (cudaAttrs && *cudaAttrs != common::CUDASubprogramAttrs::Host) {
+ // CUDA device subprogram checks
+ if (symbol.attrs().HasAny({Attr::RECURSIVE, Attr::PURE, Attr::ELEMENTAL})) {
+ messages_.Say(symbol.name(),
+ "A device subprogram may not be RECURSIVE, PURE, or ELEMENTAL"_err_en_US);
+ }
+ if (ClassifyProcedure(symbol) == ProcedureDefinitionClass::Internal) {
+ messages_.Say(symbol.name(),
+ "A device subprogram may not be an internal subprogram"_err_en_US);
+ } else if ((*cudaAttrs == common::CUDASubprogramAttrs::Device ||
+ *cudaAttrs == common::CUDASubprogramAttrs::HostDevice) &&
+ (symbol.owner().kind() != Scope::Kind::Module ||
+ details.isInterface())) {
+ messages_.Say(symbol.name(),
+ "An ATTRIBUTES(DEVICE) subprogram must be a top-level module procedure"_err_en_US);
+ }
+ }
+ if ((!details.cudaLaunchBounds().empty() ||
+ !details.cudaClusterDims().empty()) &&
+ !(cudaAttrs &&
+ (*cudaAttrs == common::CUDASubprogramAttrs::Global ||
+ *cudaAttrs == common::CUDASubprogramAttrs::Grid_Global))) {
+ messages_.Say(symbol.name(),
+ "A subroutine may not have LAUNCH_BOUNDS() or CLUSTER_DIMS() unless it has ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)"_err_en_US);
+ }
+ if (!IsStmtFunction(symbol)) {
+ if (const Scope * outerDevice{FindCUDADeviceContext(&symbol.owner())};
+ outerDevice && outerDevice->symbol()) {
+ if (auto *msg{messages_.Say(symbol.name(),
+ "'%s' may not be an internal procedure of CUDA device subprogram '%s'"_err_en_US,
+ symbol.name(), outerDevice->symbol()->name())}) {
+ msg->Attach(outerDevice->symbol()->name(),
+ "Containing CUDA device subprogram"_en_US);
+ }
+ }
+ }
}
void CheckHelper::CheckExternal(const Symbol &symbol) {
@@ -1206,7 +1415,7 @@ void CheckHelper::CheckExternal(const Symbol &symbol) {
if (chars->HasExplicitInterface()) {
std::string whyNot;
if (!chars->IsCompatibleWith(*globalChars, &whyNot)) {
- msg = messages_.Say(
+ msg = WarnIfNotInModuleFile(
"The global subprogram '%s' is not compatible with its local procedure declaration (%s)"_warn_en_US,
global->name(), whyNot);
}
@@ -1232,7 +1441,7 @@ void CheckHelper::CheckExternal(const Symbol &symbol) {
if (auto previousChars{Characterize(previous)}) {
std::string whyNot;
if (!chars->IsCompatibleWith(*previousChars, &whyNot)) {
- if (auto *msg{messages_.Say(
+ if (auto *msg{WarnIfNotInModuleFile(
"The external interface '%s' is not compatible with an earlier definition (%s)"_warn_en_US,
symbol.name(), whyNot)}) {
evaluate::AttachDeclaration(msg, previous);
@@ -1619,12 +1828,14 @@ bool CheckHelper::CheckDefinedOperator(SourceName opName, GenericKind kind,
return true; // OK
}
bool isFatal{msg->IsFatal()};
- SayWithDeclaration(
- specific, std::move(*msg), MakeOpName(opName), specific.name());
+ if (isFatal || !FindModuleFileContaining(specific.owner())) {
+ SayWithDeclaration(
+ specific, std::move(*msg), MakeOpName(opName), specific.name());
+ }
if (isFatal) {
context_.SetError(specific);
}
- return false;
+ return !isFatal;
}
// If the number of arguments is wrong for this intrinsic operator, return
@@ -1685,15 +1896,24 @@ bool CheckHelper::CheckDefinedOperatorArg(const SourceName &opName,
dataObject == nullptr) {
msg = "In %s function '%s', dummy argument '%s' must be a"
" data object"_err_en_US;
+ } else if (dataObject->intent == common::Intent::Out) {
+ msg =
+ "In %s function '%s', dummy argument '%s' may not be INTENT(OUT)"_err_en_US;
} else if (dataObject->intent != common::Intent::In &&
!dataObject->attrs.test(DummyDataObject::Attr::Value)) {
- msg = "In %s function '%s', dummy argument '%s' must have INTENT(IN)"
- " or VALUE attribute"_err_en_US;
+ msg =
+ "In %s function '%s', dummy argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US;
}
if (msg) {
- SayWithDeclaration(symbol, std::move(*msg),
- parser::ToUpperCaseLetters(opName.ToString()), symbol.name(), arg.name);
- return false;
+ bool isFatal{msg->IsFatal()};
+ if (isFatal || !FindModuleFileContaining(symbol.owner())) {
+ SayWithDeclaration(symbol, std::move(*msg),
+ parser::ToUpperCaseLetters(opName.ToString()), symbol.name(),
+ arg.name);
+ }
+ if (isFatal) {
+ return false;
+ }
}
return true;
}
@@ -1739,17 +1959,23 @@ bool CheckHelper::CheckDefinedAssignmentArg(
" may not be OPTIONAL"_err_en_US;
} else if (const auto *dataObject{std::get_if<DummyDataObject>(&arg.u)}) {
if (pos == 0) {
- if (dataObject->intent != common::Intent::Out &&
+ if (dataObject->intent == common::Intent::In) {
+ msg = "In defined assignment subroutine '%s', first dummy argument '%s'"
+ " may not have INTENT(IN)"_err_en_US;
+ } else if (dataObject->intent != common::Intent::Out &&
dataObject->intent != common::Intent::InOut) {
msg = "In defined assignment subroutine '%s', first dummy argument '%s'"
- " must have INTENT(OUT) or INTENT(INOUT)"_err_en_US;
+ " should have INTENT(OUT) or INTENT(INOUT)"_warn_en_US;
}
} else if (pos == 1) {
- if (dataObject->intent != common::Intent::In &&
+ if (dataObject->intent == common::Intent::Out) {
+ msg = "In defined assignment subroutine '%s', second dummy"
+ " argument '%s' may not have INTENT(OUT)"_err_en_US;
+ } else if (dataObject->intent != common::Intent::In &&
!dataObject->attrs.test(DummyDataObject::Attr::Value)) {
msg =
"In defined assignment subroutine '%s', second dummy"
- " argument '%s' must have INTENT(IN) or VALUE attribute"_err_en_US;
+ " argument '%s' should have INTENT(IN) or VALUE attribute"_warn_en_US;
} else if (dataObject->attrs.test(DummyDataObject::Attr::Pointer)) {
msg =
"In defined assignment subroutine '%s', second dummy argument '%s' must not be a pointer"_err_en_US;
@@ -1765,9 +1991,14 @@ bool CheckHelper::CheckDefinedAssignmentArg(
" must be a data object"_err_en_US;
}
if (msg) {
- SayWithDeclaration(symbol, std::move(*msg), symbol.name(), arg.name);
- context_.SetError(symbol);
- return false;
+ bool isFatal{msg->IsFatal()};
+ if (isFatal || !FindModuleFileContaining(symbol.owner())) {
+ SayWithDeclaration(symbol, std::move(*msg), symbol.name(), arg.name);
+ }
+ if (isFatal) {
+ context_.SetError(symbol);
+ return false;
+ }
}
return true;
}
@@ -1800,10 +2031,10 @@ void CheckHelper::WarnMissingFinal(const Symbol &symbol) {
if (!derivedDetails->finals().empty() &&
!derivedDetails->GetFinalForRank(rank)) {
if (auto *msg{derivedSym == initialDerivedSym
- ? messages_.Say(symbol.name(),
+ ? WarnIfNotInModuleFile(symbol.name(),
"'%s' of derived type '%s' does not have a FINAL subroutine for its rank (%d)"_warn_en_US,
symbol.name(), derivedSym->name(), rank)
- : messages_.Say(symbol.name(),
+ : WarnIfNotInModuleFile(symbol.name(),
"'%s' of derived type '%s' extended from '%s' does not have a FINAL subroutine for its rank (%d)"_warn_en_US,
symbol.name(), initialDerivedSym->name(),
derivedSym->name(), rank)}) {
@@ -2437,15 +2668,17 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
type->category() == DeclTypeSpec::Character &&
type->characterTypeSpec().length().isDeferred()) {
// ok; F'2018 18.3.6 p2(6)
- } else if (derived || IsInteroperableIntrinsicType(*type)) {
+ } else if (derived ||
+ IsInteroperableIntrinsicType(*type, context_.languageFeatures())) {
// F'2018 18.3.6 p2(4,5)
- } else if (type->category() == DeclTypeSpec::Logical && IsDummy(symbol) &&
- evaluate::GetRank(*shape) == 0) {
- // Special exception: LOGICAL scalar dummy arguments can be converted
- // before a call -- & after if not INTENT(IN) -- without loss of
- // information, and are accepted by some older compilers.
- messages_.Say(symbol.name(),
- "A BIND(C) LOGICAL dummy argument should have the interoperable KIND=C_BOOL"_port_en_US);
+ } else if (type->category() == DeclTypeSpec::Logical) {
+ if (IsDummy(symbol)) {
+ WarnIfNotInModuleFile(symbol.name(),
+ "A BIND(C) LOGICAL dummy argument should have the interoperable KIND=C_BOOL"_port_en_US);
+ } else {
+ WarnIfNotInModuleFile(symbol.name(),
+ "A BIND(C) LOGICAL object should have the interoperable KIND=C_BOOL"_port_en_US);
+ }
} else if (symbol.attrs().test(Attr::VALUE)) {
messages_.Say(symbol.name(),
"A BIND(C) VALUE dummy argument must have an interoperable type"_err_en_US);
@@ -2457,12 +2690,13 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
}
}
if (IsOptional(symbol) && !symbol.attrs().test(Attr::VALUE)) {
- messages_.Say(symbol.name(),
+ WarnIfNotInModuleFile(symbol.name(),
"An interoperable procedure with an OPTIONAL dummy argument might not be portable"_port_en_US);
}
} else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
- if (!proc->procInterface() ||
- !proc->procInterface()->attrs().test(Attr::BIND_C)) {
+ if (!proc->isDummy() &&
+ (!proc->procInterface() ||
+ !proc->procInterface()->attrs().test(Attr::BIND_C))) {
messages_.Say(symbol.name(),
"An interface name with BIND attribute must be specified if the BIND attribute is specified in a procedure declaration statement"_err_en_US);
context_.SetError(symbol);
@@ -2514,10 +2748,21 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
}
context_.SetError(symbol);
}
- } else if (!IsInteroperableIntrinsicType(*type)) {
- messages_.Say(component->name(),
- "Each component of an interoperable derived type must have an interoperable type"_err_en_US);
- context_.SetError(symbol);
+ } else if (!IsInteroperableIntrinsicType(
+ *type, context_.languageFeatures())) {
+ auto maybeDyType{evaluate::DynamicType::From(*type)};
+ if (type->category() == DeclTypeSpec::Logical) {
+ WarnIfNotInModuleFile(component->name(),
+ "A LOGICAL component of a BIND(C) type should have the interoperable KIND=C_BOOL"_port_en_US);
+ } else if (type->category() == DeclTypeSpec::Character &&
+ maybeDyType && maybeDyType->kind() == 1) {
+ WarnIfNotInModuleFile(component->name(),
+ "A CHARACTER component of a BIND(C) type should have length 1"_port_en_US);
+ } else {
+ messages_.Say(component->name(),
+ "Each component of an interoperable derived type must have an interoperable type"_err_en_US);
+ context_.SetError(symbol);
+ }
}
}
if (auto extents{
@@ -2529,9 +2774,8 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
}
}
}
- if (derived->componentNames().empty() &&
- !FindModuleFileContaining(symbol.owner())) { // C1805
- messages_.Say(symbol.name(),
+ if (derived->componentNames().empty()) { // C1805
+ WarnIfNotInModuleFile(symbol.name(),
"A derived type with the BIND attribute is empty"_port_en_US);
}
}
diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp
index 667fdc453687a..cf04f24737980 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -797,9 +797,10 @@ llvm::raw_ostream &operator<<(llvm::raw_ostream &o, const DeclTypeSpec &x) {
return o << x.AsFortran();
}
-bool IsInteroperableIntrinsicType(const DeclTypeSpec &type) {
+bool IsInteroperableIntrinsicType(
+ const DeclTypeSpec &type, const common::LanguageFeatureControl &features) {
auto dyType{evaluate::DynamicType::From(type)};
- return dyType && IsInteroperableIntrinsicType(*dyType);
+ return dyType && IsInteroperableIntrinsicType(*dyType, &features);
}
} // namespace Fortran::semantics
diff --git a/flang/module/__cuda_builtins.f90 b/flang/module/__cuda_builtins.f90
new file mode 100644
index 0000000000000..64cb21abe0c57
--- /dev/null
+++ b/flang/module/__cuda_builtins.f90
@@ -0,0 +1,19 @@
+!===-- module/__cuda_builtins.f90 ------------------------------------------===!
+!
+! 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
+!
+!===------------------------------------------------------------------------===!
+
+! These CUDA predefined variables are automatically available in device
+! subprograms.
+
+module __CUDA_builtins
+ use __Fortran_builtins, only: &
+ threadIdx => __builtin_threadIdx, &
+ blockDim => __builtin_blockDim, &
+ blockIdx => __builtin_blockIdx, &
+ gridDim => __builtin_gridDim, &
+ warpsize => __builtin_warpsize
+end module
diff --git a/flang/test/Semantics/bind-c06.f90 b/flang/test/Semantics/bind-c06.f90
index ad36afb4e834b..183eb9e6f1c11 100644
--- a/flang/test/Semantics/bind-c06.f90
+++ b/flang/test/Semantics/bind-c06.f90
@@ -65,7 +65,7 @@ program main
end type
type, bind(c) :: t10
- !ERROR: Each component of an interoperable derived type must have an interoperable type
+ !WARNING: A CHARACTER component of a BIND(C) type should have length 1
character(len=2) x
end type
type, bind(c) :: t11
@@ -73,7 +73,7 @@ program main
character(kind=2) x
end type
type, bind(c) :: t12
- !ERROR: Each component of an interoperable derived type must have an interoperable type
+ !PORTABILITY: A LOGICAL component of a BIND(C) type should have the interoperable KIND=C_BOOL
logical(kind=8) x
end type
type, bind(c) :: t13
diff --git a/flang/test/Semantics/cuf02.cuf b/flang/test/Semantics/cuf02.cuf
new file mode 100644
index 0000000000000..38b3e783d86b3
--- /dev/null
+++ b/flang/test/Semantics/cuf02.cuf
@@ -0,0 +1,49 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+ interface
+ !ERROR: An ATTRIBUTES(DEVICE) subprogram must be a top-level module procedure
+ attributes(device) subroutine exts1
+ end
+ end interface
+ contains
+ !ERROR: A device subprogram may not be RECURSIVE, PURE, or ELEMENTAL
+ recursive attributes(device) subroutine s1
+ end
+ !ERROR: A device subprogram may not be RECURSIVE, PURE, or ELEMENTAL
+ pure attributes(device) subroutine s2
+ end
+ !ERROR: A device subprogram may not be RECURSIVE, PURE, or ELEMENTAL
+ elemental attributes(device) subroutine s3
+ end
+ subroutine s4
+ contains
+ !ERROR: A device subprogram may not be an internal subprogram
+ attributes(device) subroutine inner
+ end
+ end
+ attributes(device) subroutine s5 ! nvfortran crashes on this one
+ contains
+ !ERROR: 'inner' may not be an internal procedure of CUDA device subprogram 's5'
+ subroutine inner
+ end
+ end
+ attributes(device) subroutine s6
+ stmtfunc(x) = x + 1. ! ok
+ end
+ !ERROR: A function may not have ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)
+ attributes(global) real function f1
+ end
+ !ERROR: A device subprogram may not be RECURSIVE, PURE, or ELEMENTAL
+ recursive attributes(global) subroutine s7
+ end
+ !ERROR: A device subprogram may not be RECURSIVE, PURE, or ELEMENTAL
+ pure attributes(global) subroutine s8
+ end
+ !ERROR: A device subprogram may not be RECURSIVE, PURE, or ELEMENTAL
+ elemental attributes(global) subroutine s9
+ end
+end
+
+!ERROR: An ATTRIBUTES(DEVICE) subprogram must be a top-level module procedure
+attributes(device) subroutine exts1
+end
diff --git a/flang/test/Semantics/cuf03.cuf b/flang/test/Semantics/cuf03.cuf
new file mode 100644
index 0000000000000..bebfdadbdbb16
--- /dev/null
+++ b/flang/test/Semantics/cuf03.cuf
@@ -0,0 +1,59 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Exercise CUDA data attribute checks
+module m
+ real, constant :: mc ! ok
+ real, constant :: mci = 1. ! ok
+ !ERROR: Object 'mcl' with ATTRIBUTES(CONSTANT) may not be allocatable, pointer, or target
+ real, constant, allocatable :: mcl
+ !ERROR: Object 'mcp' with ATTRIBUTES(CONSTANT) may not be allocatable, pointer, or target
+ real, constant, pointer :: mcp
+ !ERROR: Object 'mct' with ATTRIBUTES(CONSTANT) may not be allocatable, pointer, or target
+ real, constant, target :: mct
+ real, device :: md ! ok
+ real, device :: mdi = 1.
+ real, device, allocatable :: mdl ! ok
+ real, device, pointer :: mdp ! ok at module level
+ real, device, target :: mdt ! ok
+ !ERROR: Object 'ms' with ATTRIBUTES(SHARED) must be declared in a device subprogram
+ real, shared :: ms
+ !ERROR: Object 'msi' with ATTRIBUTES(SHARED) must be declared in a device subprogram
+ real, shared :: msi = 1.
+ !ERROR: Object 'msl' with ATTRIBUTES(SHARED) may not be allocatable, pointer, or target
+ real, shared, allocatable :: msl
+ !ERROR: Object 'msp' with ATTRIBUTES(SHARED) may not be allocatable, pointer, or target
+ real, shared, pointer :: msp
+ !ERROR: Object 'mst' with ATTRIBUTES(SHARED) may not be allocatable, pointer, or target
+ real, shared, target :: mst
+ !ERROR: Object 'msa' with ATTRIBUTES(SHARED) must be declared in a device subprogram
+ real, shared :: msa(*)
+ !ERROR: Object 'mm' with ATTRIBUTES(MANAGED) must also be allocatable, automatic, or a dummy argument
+ real, managed :: mm
+ !ERROR: Object 'mmi' with ATTRIBUTES(MANAGED) must also be allocatable, automatic, or a dummy argument
+ real, managed :: mmi = 1.
+ real, managed, allocatable :: mml ! ok
+ !ERROR: Object 'mmp' with ATTRIBUTES(MANAGED) must also be allocatable, automatic, or a dummy argument
+ real, managed, pointer :: mmp ! ok
+ !ERROR: Object 'mmt' with ATTRIBUTES(MANAGED) must also be allocatable, automatic, or a dummy argument
+ real, managed, target :: mmt
+ !WARNING: Object 'mp' with ATTRIBUTES(PINNED) should also be allocatable
+ real, pinned :: mp
+ !WARNING: Object 'mpi' with ATTRIBUTES(PINNED) should also be allocatable
+ real, pinned :: mpi = 1.
+ real, pinned, allocatable :: mpl ! ok
+ !ERROR: Object 'mpp' with ATTRIBUTES(PINNED) may not be a pointer
+ real, pinned, pointer :: mpp
+ !WARNING: Object 'mpt' with ATTRIBUTES(PINNED) should also be allocatable
+ real, pinned, target :: mpt ! ok
+ !ERROR: ATTRIBUTES(TEXTURE) is obsolete and no longer supported
+ real, texture, pointer :: mt
+ !ERROR: 'bigint' has intrinsic type 'INTEGER(16)' that is not available on the device
+ integer(16), device :: bigint
+ contains
+ attributes(device) subroutine devsubr(n,da)
+ integer, intent(in) :: n
+ real, device :: da(*) ! ok
+ real, managed :: ma(n) ! ok
+ !WARNING: Pointer 'dp' may not be associated in a device subprogram
+ real, device, pointer :: dp
+ end subroutine
+end module
diff --git a/flang/test/Semantics/cuf08.cuf b/flang/test/Semantics/cuf08.cuf
new file mode 100644
index 0000000000000..4adb4605bb207
--- /dev/null
+++ b/flang/test/Semantics/cuf08.cuf
@@ -0,0 +1,23 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+ contains
+ !ERROR: A subroutine may not have LAUNCH_BOUNDS() or CLUSTER_DIMS() unless it has ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)
+ launch_bounds(1,2) subroutine bad1; end
+ !ERROR: A subroutine may not have LAUNCH_BOUNDS() or CLUSTER_DIMS() unless it has ATTRIBUTES(GLOBAL) or ATTRIBUTES(GRID_GLOBAL)
+ cluster_dims(1,2,3) subroutine bad2; end
+ attributes(global) launch_bounds(1,2) subroutine good1; end
+ attributes(global) launch_bounds(1,2,3) subroutine good2; end
+ !ERROR: LAUNCH_BOUNDS() may only appear once
+ attributes(global) launch_bounds(1,2) launch_bounds(3,4) subroutine bad3; end
+ !ERROR: Operands of LAUNCH_BOUNDS() must be 2 or 3 integer constants
+ attributes(global) launch_bounds(1) subroutine bad4; end
+ !ERROR: Operands of LAUNCH_BOUNDS() must be 2 or 3 integer constants
+ attributes(global) launch_bounds(1,2,3,4) subroutine bad5; end
+ attributes(global) cluster_dims(1,2,3) subroutine good3; end
+ !ERROR: CLUSTER_DIMS() may only appear once
+ attributes(global) cluster_dims(1,2,3) cluster_dims(4,5,6) subroutine bad6; end
+ !ERROR: Operands of CLUSTER_DIMS() must be three integer constants
+ attributes(global) cluster_dims(1) subroutine bad7; end
+ !ERROR: Operands of CLUSTER_DIMS() must be three integer constants
+ attributes(global) cluster_dims(1,2,3,4) subroutine bad8; end
+end module
diff --git a/flang/test/Semantics/resolve65.f90 b/flang/test/Semantics/resolve65.f90
index 00070b8ca8fb7..583c5bca4b34e 100644
--- a/flang/test/Semantics/resolve65.f90
+++ b/flang/test/Semantics/resolve65.f90
@@ -5,6 +5,9 @@ module m1
implicit none
type :: t
contains
+ !ERROR: Generic 'assignment(=)' may not have specific procedures 't%assign_t4' and 't%assign_t5' as their interfaces are not distinguishable
+ !ERROR: Generic 'assignment(=)' may not have specific procedures 't%assign_t4' and 't%assign_t6' as their interfaces are not distinguishable
+ !ERROR: Generic 'assignment(=)' may not have specific procedures 't%assign_t5' and 't%assign_t6' as their interfaces are not distinguishable
!ERROR: Defined assignment procedure 'binding' must be a subroutine
generic :: assignment(=) => binding
procedure :: binding => assign_t1
@@ -12,10 +15,14 @@ module m1
procedure :: assign_t2
procedure :: assign_t3
!ERROR: Defined assignment subroutine 'assign_t2' must have two dummy arguments
- !ERROR: In defined assignment subroutine 'assign_t3', second dummy argument 'y' must have INTENT(IN) or VALUE attribute
- !ERROR: In defined assignment subroutine 'assign_t4', first dummy argument 'x' must have INTENT(OUT) or INTENT(INOUT)
- generic :: assignment(=) => assign_t, assign_t2, assign_t3, assign_t4
+ !WARNING: In defined assignment subroutine 'assign_t3', second dummy argument 'y' should have INTENT(IN) or VALUE attribute
+ !WARNING: In defined assignment subroutine 'assign_t4', first dummy argument 'x' should have INTENT(OUT) or INTENT(INOUT)
+ !ERROR: In defined assignment subroutine 'assign_t5', first dummy argument 'x' may not have INTENT(IN)
+ !ERROR: In defined assignment subroutine 'assign_t6', second dummy argument 'y' may not have INTENT(OUT)
+ generic :: assignment(=) => assign_t, assign_t2, assign_t3, assign_t4, assign_t5, assign_t6
procedure :: assign_t4
+ procedure :: assign_t5
+ procedure :: assign_t6
end type
type :: t2
contains
@@ -41,7 +48,15 @@ subroutine assign_t3(x, y)
end
subroutine assign_t4(x, y)
class(t) :: x
- integer, intent(in) :: y
+ integer, intent(in) :: y
+ end
+ subroutine assign_t5(x, y)
+ class(t), intent(in) :: x
+ integer, intent(in) :: y
+ end
+ subroutine assign_t6(x, y)
+ class(t), intent(out) :: x
+ integer, intent(out) :: y
end
end
diff --git a/flang/test/Semantics/resolve67.f90 b/flang/test/Semantics/resolve67.f90
index 4d5fea8054a99..677eef21d0a8f 100644
--- a/flang/test/Semantics/resolve67.f90
+++ b/flang/test/Semantics/resolve67.f90
@@ -41,15 +41,16 @@ character(*) function divide(x, y)
end
end interface
interface operator(<)
- !ERROR: In OPERATOR(<) function 'lt1', dummy argument 'x' must have INTENT(IN) or VALUE attribute
+ !WARNING: In OPERATOR(<) function 'lt1', dummy argument 'x' should have INTENT(IN) or VALUE attribute
!ERROR: In OPERATOR(<) function 'lt1', dummy argument 'y' may not be OPTIONAL
logical function lt1(x, y)
logical :: x
real, value, optional :: y
end
+ !ERROR: In OPERATOR(<) function 'lt2', dummy argument 'x' may not be INTENT(OUT)
!ERROR: In OPERATOR(<) function 'lt2', dummy argument 'y' must be a data object
logical function lt2(x, y)
- logical, intent(in) :: x
+ logical, intent(out) :: x
intent(in) :: y
interface
subroutine y()
More information about the flang-commits
mailing list