[flang-commits] [flang] 8f01eca - [flang] Special-case handling of INTRINSIC in type-decl-stmt (#86518)
via flang-commits
flang-commits at lists.llvm.org
Tue Mar 26 09:50:41 PDT 2024
Author: Peter Klausler
Date: 2024-03-26T09:50:37-07:00
New Revision: 8f01ecaeb8e537511718c4df123fb92633d9f73d
URL: https://github.com/llvm/llvm-project/commit/8f01ecaeb8e537511718c4df123fb92633d9f73d
DIFF: https://github.com/llvm/llvm-project/commit/8f01ecaeb8e537511718c4df123fb92633d9f73d.diff
LOG: [flang] Special-case handling of INTRINSIC in type-decl-stmt (#86518)
Fortran allows the INTRINSIC attribute to be specified with a distinct
attribute statement, and also as part of the attribute list of a
type-declaration-stmt. This is an odd case (especially as the declared
type is mandated to be ignored if it doesn't match the type of the
intrinsic function) that can lead to odd error messages and crashes,
since the rest of name resolution expects that intrinsics with explicit
declarations will have been declared with INTRINSIC attribute
statements. Resolve by handling an "inline" INTRINSIC attribute as a
special case while processing a type-declaration-stmt, so that
real, intrinsic :: acos, asin, atan
is processed exactly as if it had been
intrinsic acos, asin, atan; real acos, asin, atan
Fixes https://github.com/llvm/llvm-project/issues/86382.
Added:
Modified:
flang/include/flang/Parser/tools.h
flang/lib/Parser/tools.cpp
flang/lib/Semantics/resolve-names.cpp
flang/test/Semantics/init01.f90
flang/test/Semantics/resolve81.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Parser/tools.h b/flang/include/flang/Parser/tools.h
index 1e347fab6461a3..f1ead11734fa0d 100644
--- a/flang/include/flang/Parser/tools.h
+++ b/flang/include/flang/Parser/tools.h
@@ -40,6 +40,7 @@ const Name &GetFirstName(const ProcedureDesignator &);
const Name &GetFirstName(const Call &);
const Name &GetFirstName(const FunctionReference &);
const Name &GetFirstName(const Variable &);
+const Name &GetFirstName(const EntityDecl &);
// When a parse tree node is an instance of a specific type wrapped in
// layers of packaging, return a pointer to that object.
diff --git a/flang/lib/Parser/tools.cpp b/flang/lib/Parser/tools.cpp
index 899fb0f069a935..6e5f1ed2fc66f0 100644
--- a/flang/lib/Parser/tools.cpp
+++ b/flang/lib/Parser/tools.cpp
@@ -123,6 +123,10 @@ const Name &GetFirstName(const Variable &x) {
x.u);
}
+const Name &GetFirstName(const EntityDecl &x) {
+ return std::get<ObjectName>(x.t);
+}
+
const CoindexedNamedObject *GetCoindexedNamedObject(const DataRef &base) {
return common::visit(
common::visitors{
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 73450c49d5fe29..2e88a2daff2c08 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -955,7 +955,7 @@ class DeclarationVisitor : public ArraySpecVisitor,
void Post(const parser::TargetStmt &) { objectDeclAttr_ = std::nullopt; }
void Post(const parser::DimensionStmt::Declaration &);
void Post(const parser::CodimensionDecl &);
- bool Pre(const parser::TypeDeclarationStmt &) { return BeginDecl(); }
+ bool Pre(const parser::TypeDeclarationStmt &);
void Post(const parser::TypeDeclarationStmt &);
void Post(const parser::IntegerTypeSpec &);
void Post(const parser::IntrinsicTypeSpec::Real &);
@@ -1202,6 +1202,7 @@ class DeclarationVisitor : public ArraySpecVisitor,
bool MustBeScalar(const Symbol &symbol) const {
return mustBeScalar_.find(symbol) != mustBeScalar_.end();
}
+ void DeclareIntrinsic(const parser::Name &);
};
// Resolve construct entities and statement entities.
@@ -4550,6 +4551,20 @@ void DeclarationVisitor::CheckAccessibility(
}
}
+bool DeclarationVisitor::Pre(const parser::TypeDeclarationStmt &x) {
+ BeginDecl();
+ // If INTRINSIC appears as an attr-spec, handle it now as if the
+ // names had appeared on an INTRINSIC attribute statement beforehand.
+ for (const auto &attr : std::get<std::list<parser::AttrSpec>>(x.t)) {
+ if (std::holds_alternative<parser::Intrinsic>(attr.u)) {
+ for (const auto &decl : std::get<std::list<parser::EntityDecl>>(x.t)) {
+ DeclareIntrinsic(parser::GetFirstName(decl));
+ }
+ break;
+ }
+ }
+ return true;
+}
void DeclarationVisitor::Post(const parser::TypeDeclarationStmt &) {
EndDecl();
}
@@ -4571,6 +4586,7 @@ bool DeclarationVisitor::Pre(const parser::Initialization &) {
void DeclarationVisitor::Post(const parser::EntityDecl &x) {
const auto &name{std::get<parser::ObjectName>(x.t)};
Attrs attrs{attrs_ ? HandleSaveName(name.source, *attrs_) : Attrs{}};
+ attrs.set(Attr::INTRINSIC, false); // dealt with in Pre(TypeDeclarationStmt)
Symbol &symbol{DeclareUnknownEntity(name, attrs)};
symbol.ReplaceName(name.source);
SetCUDADataAttr(name.source, symbol, cudaDataAttr());
@@ -4811,45 +4827,47 @@ bool DeclarationVisitor::Pre(const parser::IntentStmt &x) {
HandleAttributeStmt(IntentSpecToAttr(intentSpec), names);
}
bool DeclarationVisitor::Pre(const parser::IntrinsicStmt &x) {
- HandleAttributeStmt(Attr::INTRINSIC, x.v);
for (const auto &name : x.v) {
- if (!IsIntrinsic(name.source, std::nullopt)) {
- Say(name.source, "'%s' is not a known intrinsic procedure"_err_en_US);
- }
- auto &symbol{DEREF(FindSymbol(name))};
- if (symbol.has<GenericDetails>()) {
- // Generic interface is extending intrinsic; ok
- } else if (!ConvertToProcEntity(symbol)) {
- SayWithDecl(
- name, symbol, "INTRINSIC attribute not allowed on '%s'"_err_en_US);
- } else if (symbol.attrs().test(Attr::EXTERNAL)) { // C840
+ DeclareIntrinsic(name);
+ }
+ return false;
+}
+void DeclarationVisitor::DeclareIntrinsic(const parser::Name &name) {
+ HandleAttributeStmt(Attr::INTRINSIC, name);
+ if (!IsIntrinsic(name.source, std::nullopt)) {
+ Say(name.source, "'%s' is not a known intrinsic procedure"_err_en_US);
+ }
+ auto &symbol{DEREF(FindSymbol(name))};
+ if (symbol.has<GenericDetails>()) {
+ // Generic interface is extending intrinsic; ok
+ } else if (!ConvertToProcEntity(symbol)) {
+ SayWithDecl(
+ name, symbol, "INTRINSIC attribute not allowed on '%s'"_err_en_US);
+ } else if (symbol.attrs().test(Attr::EXTERNAL)) { // C840
+ Say(symbol.name(),
+ "Symbol '%s' cannot have both EXTERNAL and INTRINSIC attributes"_err_en_US,
+ symbol.name());
+ } else {
+ if (symbol.GetType()) {
+ // These warnings are worded so that they should make sense in either
+ // order.
Say(symbol.name(),
- "Symbol '%s' cannot have both EXTERNAL and INTRINSIC attributes"_err_en_US,
- symbol.name());
- } else {
- if (symbol.GetType()) {
- // These warnings are worded so that they should make sense in either
- // order.
- Say(symbol.name(),
- "Explicit type declaration ignored for intrinsic function '%s'"_warn_en_US,
- symbol.name())
- .Attach(name.source,
- "INTRINSIC statement for explicitly-typed '%s'"_en_US,
- name.source);
- }
- if (!symbol.test(Symbol::Flag::Function) &&
- !symbol.test(Symbol::Flag::Subroutine)) {
- if (context().intrinsics().IsIntrinsicFunction(
- name.source.ToString())) {
- symbol.set(Symbol::Flag::Function);
- } else if (context().intrinsics().IsIntrinsicSubroutine(
- name.source.ToString())) {
- symbol.set(Symbol::Flag::Subroutine);
- }
+ "Explicit type declaration ignored for intrinsic function '%s'"_warn_en_US,
+ symbol.name())
+ .Attach(name.source,
+ "INTRINSIC statement for explicitly-typed '%s'"_en_US,
+ name.source);
+ }
+ if (!symbol.test(Symbol::Flag::Function) &&
+ !symbol.test(Symbol::Flag::Subroutine)) {
+ if (context().intrinsics().IsIntrinsicFunction(name.source.ToString())) {
+ symbol.set(Symbol::Flag::Function);
+ } else if (context().intrinsics().IsIntrinsicSubroutine(
+ name.source.ToString())) {
+ symbol.set(Symbol::Flag::Subroutine);
}
}
}
- return false;
}
bool DeclarationVisitor::Pre(const parser::OptionalStmt &x) {
return CheckNotInBlock("OPTIONAL") && // C1107
diff --git a/flang/test/Semantics/init01.f90 b/flang/test/Semantics/init01.f90
index f85feef097cdca..65d524b16a23a2 100644
--- a/flang/test/Semantics/init01.f90
+++ b/flang/test/Semantics/init01.f90
@@ -158,8 +158,10 @@ subroutine notObjects
real, external :: x1 = 1.
!ERROR: 'x2' is not a pointer but is initialized like one
real, external :: x2 => sin
+!ERROR: 'x3' is not a known intrinsic procedure
!ERROR: 'x3' is not an object that can be initialized
real, intrinsic :: x3 = 1.
+!ERROR: 'x4' is not a known intrinsic procedure
!ERROR: 'x4' is not a pointer but is initialized like one
real, intrinsic :: x4 => cos
end subroutine
diff --git a/flang/test/Semantics/resolve81.f90 b/flang/test/Semantics/resolve81.f90
index 2a0b961d48e5c3..87901fd7d2efcb 100644
--- a/flang/test/Semantics/resolve81.f90
+++ b/flang/test/Semantics/resolve81.f90
@@ -28,6 +28,7 @@ module m
!WARNING: Attribute 'EXTERNAL' cannot be used more than once
real, external, external :: externFunc
!WARNING: Attribute 'INTRINSIC' cannot be used more than once
+ !ERROR: An interface name with BIND attribute must be specified if the BIND attribute is specified in a procedure declaration statement
real, intrinsic, bind(c), intrinsic :: cos
!WARNING: Attribute 'BIND(C)' cannot be used more than once
integer, bind(c), volatile, bind(c) :: bindVar
More information about the flang-commits
mailing list