diff options
author | Peter Klausler <35819229+klausler@users.noreply.github.com> | 2024-06-24 09:06:32 -0700 |
---|---|---|
committer | GitHub <noreply@github.com> | 2024-06-24 09:06:32 -0700 |
commit | 3602efa78ddc16f82c338358748b3a13b3859e24 (patch) | |
tree | 24236ec62d41b14f187a1dfe197adadac8e8eeb3 | |
parent | b312cbf921422fc30615b1311b235a8cb31453d9 (diff) | |
download | llvm-3602efa78ddc16f82c338358748b3a13b3859e24.zip llvm-3602efa78ddc16f82c338358748b3a13b3859e24.tar.gz llvm-3602efa78ddc16f82c338358748b3a13b3859e24.tar.bz2 |
[flang] Silence errors on C_LOC/C_FUNLOC in specification expressions (#96108)
Transformational functions from the intrinsic module ISO_C_BINDING are
allowed in specification expressions, so tweak some general checks that
would otherwise trigger error messages about inadmissible targets, dummy
procedures in specification expressions, and pure procedures with impure
dummy procedures.
-rw-r--r-- | flang/lib/Evaluate/check-expression.cpp | 3 | ||||
-rw-r--r-- | flang/lib/Evaluate/tools.cpp | 2 | ||||
-rw-r--r-- | flang/lib/Semantics/check-declarations.cpp | 20 | ||||
-rw-r--r-- | flang/lib/Semantics/resolve-names.cpp | 144 | ||||
-rw-r--r-- | flang/module/__fortran_builtins.f90 | 5 | ||||
-rw-r--r-- | flang/test/Semantics/c_loc01.f90 | 13 | ||||
-rw-r--r-- | flang/test/Semantics/call05.f90 | 6 |
7 files changed, 115 insertions, 78 deletions
diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp index f4a50dd..342aac4 100644 --- a/flang/lib/Evaluate/check-expression.cpp +++ b/flang/lib/Evaluate/check-expression.cpp @@ -650,7 +650,8 @@ public: return std::holds_alternative<characteristics::DummyProcedure>( dummy.u); })}; - if (iter != procChars->dummyArguments.end()) { + if (iter != procChars->dummyArguments.end() && + ultimate.name().ToString() != "__builtin_c_funloc") { return "reference to function '"s + ultimate.name().ToString() + "' with dummy procedure argument '" + iter->name + '\''; } diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp index b2a50ab..a5f4faa 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -82,6 +82,8 @@ auto IsVariableHelper::operator()(const Symbol &symbol) const -> Result { const Symbol &ultimate{symbol.GetUltimate()}; return !IsNamedConstant(ultimate) && (ultimate.has<semantics::ObjectEntityDetails>() || + (ultimate.has<semantics::EntityDetails>() && + ultimate.attrs().test(semantics::Attr::TARGET)) || ultimate.has<semantics::AssocEntityDetails>()); } auto IsVariableHelper::operator()(const Component &x) const -> Result { diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp index 2fa2633..60787cc 100644 --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -354,7 +354,10 @@ void CheckHelper::Check(const Symbol &symbol) { messages_.Say( "A pure subprogram may not have a variable with the VOLATILE attribute"_err_en_US); } - if (IsProcedure(symbol) && !IsPureProcedure(symbol) && IsDummy(symbol)) { + if (innermostSymbol_ && innermostSymbol_->name() == "__builtin_c_funloc") { + // The intrinsic procedure C_FUNLOC() gets a pass on this check. + } else if (IsProcedure(symbol) && !IsPureProcedure(symbol) && + IsDummy(symbol)) { messages_.Say( "A dummy procedure of a pure subprogram must be pure"_err_en_US); } @@ -463,16 +466,11 @@ void CheckHelper::Check(const Symbol &symbol) { symbol.name()); } } - if (IsProcedure(symbol) && !symbol.HasExplicitInterface()) { - if (IsAllocatable(symbol)) { - messages_.Say( - "Procedure '%s' may not be ALLOCATABLE without an explicit interface"_err_en_US, - symbol.name()); - } else if (symbol.Rank() > 0) { - messages_.Say( - "Procedure '%s' may not be an array without an explicit interface"_err_en_US, - symbol.name()); - } + if (IsProcedure(symbol) && !symbol.HasExplicitInterface() && + symbol.Rank() > 0) { + messages_.Say( + "Procedure '%s' may not be an array without an explicit interface"_err_en_US, + symbol.name()); } } diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index d4fe668..8882297 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -661,8 +661,8 @@ public: void MakeExternal(Symbol &); // C815 duplicated attribute checking; returns false on error - bool CheckDuplicatedAttr(SourceName, const Symbol &, Attr); - bool CheckDuplicatedAttrs(SourceName, const Symbol &, Attrs); + bool CheckDuplicatedAttr(SourceName, Symbol &, Attr); + bool CheckDuplicatedAttrs(SourceName, Symbol &, Attrs); void SetExplicitAttr(Symbol &symbol, Attr attr) const { symbol.attrs().set(attr); @@ -1087,6 +1087,58 @@ protected: void NoteScalarSpecificationArgument(const Symbol &symbol) { mustBeScalar_.emplace(symbol); } + // Declare an object or procedure entity. + // T is one of: EntityDetails, ObjectEntityDetails, ProcEntityDetails + template <typename T> + Symbol &DeclareEntity(const parser::Name &name, Attrs attrs) { + Symbol &symbol{MakeSymbol(name, attrs)}; + if (context().HasError(symbol) || symbol.has<T>()) { + return symbol; // OK or error already reported + } else if (symbol.has<UnknownDetails>()) { + symbol.set_details(T{}); + return symbol; + } else if (auto *details{symbol.detailsIf<EntityDetails>()}) { + symbol.set_details(T{std::move(*details)}); + return symbol; + } else if (std::is_same_v<EntityDetails, T> && + (symbol.has<ObjectEntityDetails>() || + symbol.has<ProcEntityDetails>())) { + return symbol; // OK + } else if (auto *details{symbol.detailsIf<UseDetails>()}) { + Say(name.source, + "'%s' is use-associated from module '%s' and cannot be re-declared"_err_en_US, + name.source, GetUsedModule(*details).name()); + } else if (auto *details{symbol.detailsIf<SubprogramNameDetails>()}) { + if (details->kind() == SubprogramKind::Module) { + Say2(name, + "Declaration of '%s' conflicts with its use as module procedure"_err_en_US, + symbol, "Module procedure definition"_en_US); + } else if (details->kind() == SubprogramKind::Internal) { + Say2(name, + "Declaration of '%s' conflicts with its use as internal procedure"_err_en_US, + symbol, "Internal procedure definition"_en_US); + } else { + DIE("unexpected kind"); + } + } else if (std::is_same_v<ObjectEntityDetails, T> && + symbol.has<ProcEntityDetails>()) { + SayWithDecl( + name, symbol, "'%s' is already declared as a procedure"_err_en_US); + } else if (std::is_same_v<ProcEntityDetails, T> && + symbol.has<ObjectEntityDetails>()) { + if (FindCommonBlockContaining(symbol)) { + SayWithDecl(name, symbol, + "'%s' may not be a procedure as it is in a COMMON block"_err_en_US); + } else { + SayWithDecl( + name, symbol, "'%s' is already declared as an object"_err_en_US); + } + } else if (!CheckPossibleBadForwardRef(symbol)) { + SayAlreadyDeclared(name, symbol); + } + context().SetError(symbol); + return symbol; + } private: // The attribute corresponding to the statement containing an ObjectDecl @@ -1151,59 +1203,6 @@ private: bool PassesLocalityChecks( const parser::Name &name, Symbol &symbol, Symbol::Flag flag); bool CheckForHostAssociatedImplicit(const parser::Name &); - - // Declare an object or procedure entity. - // T is one of: EntityDetails, ObjectEntityDetails, ProcEntityDetails - template <typename T> - Symbol &DeclareEntity(const parser::Name &name, Attrs attrs) { - Symbol &symbol{MakeSymbol(name, attrs)}; - if (context().HasError(symbol) || symbol.has<T>()) { - return symbol; // OK or error already reported - } else if (symbol.has<UnknownDetails>()) { - symbol.set_details(T{}); - return symbol; - } else if (auto *details{symbol.detailsIf<EntityDetails>()}) { - symbol.set_details(T{std::move(*details)}); - return symbol; - } else if (std::is_same_v<EntityDetails, T> && - (symbol.has<ObjectEntityDetails>() || - symbol.has<ProcEntityDetails>())) { - return symbol; // OK - } else if (auto *details{symbol.detailsIf<UseDetails>()}) { - Say(name.source, - "'%s' is use-associated from module '%s' and cannot be re-declared"_err_en_US, - name.source, GetUsedModule(*details).name()); - } else if (auto *details{symbol.detailsIf<SubprogramNameDetails>()}) { - if (details->kind() == SubprogramKind::Module) { - Say2(name, - "Declaration of '%s' conflicts with its use as module procedure"_err_en_US, - symbol, "Module procedure definition"_en_US); - } else if (details->kind() == SubprogramKind::Internal) { - Say2(name, - "Declaration of '%s' conflicts with its use as internal procedure"_err_en_US, - symbol, "Internal procedure definition"_en_US); - } else { - DIE("unexpected kind"); - } - } else if (std::is_same_v<ObjectEntityDetails, T> && - symbol.has<ProcEntityDetails>()) { - SayWithDecl( - name, symbol, "'%s' is already declared as a procedure"_err_en_US); - } else if (std::is_same_v<ProcEntityDetails, T> && - symbol.has<ObjectEntityDetails>()) { - if (FindCommonBlockContaining(symbol)) { - SayWithDecl(name, symbol, - "'%s' may not be a procedure as it is in a COMMON block"_err_en_US); - } else { - SayWithDecl( - name, symbol, "'%s' is already declared as an object"_err_en_US); - } - } else if (!CheckPossibleBadForwardRef(symbol)) { - SayAlreadyDeclared(name, symbol); - } - context().SetError(symbol); - return symbol; - } bool HasCycle(const Symbol &, const Symbol *interface); bool MustBeScalar(const Symbol &symbol) const { return mustBeScalar_.find(symbol) != mustBeScalar_.end(); @@ -1624,6 +1623,7 @@ private: void PreSpecificationConstruct(const parser::SpecificationConstruct &); void CreateCommonBlockSymbols(const parser::CommonStmt &); + void CreateObjectSymbols(const std::list<parser::ObjectDecl> &, Attr); void CreateGeneric(const parser::GenericSpec &); void FinishSpecificationPart(const std::list<parser::DeclarationConstruct> &); void AnalyzeStmtFunctionStmt(const parser::StmtFunctionStmt &); @@ -2806,12 +2806,13 @@ void ScopeHandler::MakeExternal(Symbol &symbol) { } bool ScopeHandler::CheckDuplicatedAttr( - SourceName name, const Symbol &symbol, Attr attr) { + SourceName name, Symbol &symbol, Attr attr) { if (attr == Attr::SAVE) { // checked elsewhere } else if (symbol.attrs().test(attr)) { // C815 if (symbol.implicitAttrs().test(attr)) { // Implied attribute is now confirmed explicitly + symbol.implicitAttrs().reset(attr); } else { Say(name, "%s attribute was already specified on '%s'"_err_en_US, EnumToString(attr), name); @@ -2822,7 +2823,7 @@ bool ScopeHandler::CheckDuplicatedAttr( } bool ScopeHandler::CheckDuplicatedAttrs( - SourceName name, const Symbol &symbol, Attrs attrs) { + SourceName name, Symbol &symbol, Attrs attrs) { bool ok{true}; attrs.IterateOverMembers( [&](Attr x) { ok &= CheckDuplicatedAttr(name, symbol, x); }); @@ -5032,6 +5033,10 @@ Symbol &DeclarationVisitor::DeclareUnknownEntity( charInfo_.length.reset(); if (symbol.attrs().test(Attr::EXTERNAL)) { ConvertToProcEntity(symbol); + } else if (symbol.attrs().HasAny(Attrs{Attr::ALLOCATABLE, + Attr::ASYNCHRONOUS, Attr::CONTIGUOUS, Attr::PARAMETER, + Attr::SAVE, Attr::TARGET, Attr::VALUE, Attr::VOLATILE})) { + ConvertToObjectEntity(symbol); } if (attrs.test(Attr::BIND_C)) { SetBindNameOn(symbol); @@ -8551,11 +8556,19 @@ void ResolveNamesVisitor::PreSpecificationConstruct( } }, [&](const parser::Statement<parser::OtherSpecificationStmt> &y) { - if (const auto *commonStmt{parser::Unwrap<parser::CommonStmt>(y)}) { - CreateCommonBlockSymbols(*commonStmt); - } + common::visit( + common::visitors{ + [&](const common::Indirection<parser::CommonStmt> &z) { + CreateCommonBlockSymbols(z.value()); + }, + [&](const common::Indirection<parser::TargetStmt> &z) { + CreateObjectSymbols(z.value().v, Attr::TARGET); + }, + [](const auto &) {}, + }, + y.statement.u); }, - [&](const auto &) {}, + [](const auto &) {}, }, spec.u); } @@ -8575,6 +8588,15 @@ void ResolveNamesVisitor::CreateCommonBlockSymbols( } } +void ResolveNamesVisitor::CreateObjectSymbols( + const std::list<parser::ObjectDecl> &decls, Attr attr) { + for (const parser::ObjectDecl &decl : decls) { + SetImplicitAttr(DeclareEntity<ObjectEntityDetails>( + std::get<parser::ObjectName>(decl.t), Attrs{}), + attr); + } +} + void ResolveNamesVisitor::CreateGeneric(const parser::GenericSpec &x) { auto info{GenericSpecInfo{x}}; SourceName symbolName{info.symbolName()}; diff --git a/flang/module/__fortran_builtins.f90 b/flang/module/__fortran_builtins.f90 index b33d843..44b0f17 100644 --- a/flang/module/__fortran_builtins.f90 +++ b/flang/module/__fortran_builtins.f90 @@ -182,7 +182,10 @@ module __fortran_builtins __builtin_c_ptr_ne = x%__address /= y%__address end function - function __builtin_c_funloc(x) + ! Semantics has some special-case code that allows c_funloc() + ! to appear in a specification expression and exempts it + ! from the requirement that "x" be a pure dummy procedure. + pure function __builtin_c_funloc(x) type(__builtin_c_funptr) :: __builtin_c_funloc external :: x __builtin_c_funloc = __builtin_c_funptr(loc(x)) diff --git a/flang/test/Semantics/c_loc01.f90 b/flang/test/Semantics/c_loc01.f90 index 7c9e294..83b88d2 100644 --- a/flang/test/Semantics/c_loc01.f90 +++ b/flang/test/Semantics/c_loc01.f90 @@ -4,7 +4,10 @@ module m type haslen(L) integer, len :: L end type + integer, target :: targ contains + subroutine subr + end subroutine test(assumedType, poly, nclen) type(*), target :: assumedType class(*), target :: poly @@ -17,6 +20,8 @@ module m type(hasLen(1)), target :: clen type(hasLen(*)), target :: nclen character(2), target :: ch + real :: arr1(purefun1(c_loc(targ))) ! ok + real :: arr2(purefun2(c_funloc(subr))) ! ok !ERROR: C_LOC() argument must be a data pointer or target cp = c_loc(notATarget) !ERROR: C_LOC() argument must be a data pointer or target @@ -44,4 +49,12 @@ module m !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(c_funptr) and TYPE(c_ptr) cfp = cp end + pure integer function purefun1(p) + type(c_ptr), intent(in) :: p + purefun1 = 1 + end + pure integer function purefun2(p) + type(c_funptr), intent(in) :: p + purefun2 = 1 + end end module diff --git a/flang/test/Semantics/call05.f90 b/flang/test/Semantics/call05.f90 index 71f2197..8a4386e 100644 --- a/flang/test/Semantics/call05.f90 +++ b/flang/test/Semantics/call05.f90 @@ -123,9 +123,7 @@ end module module m2 - !ERROR: Procedure 't3' may not be ALLOCATABLE without an explicit interface character(len=10), allocatable :: t1, t2, t3, t4 - !ERROR: Procedure 't6' may not be ALLOCATABLE without an explicit interface character(len=:), allocatable :: t5, t6, t7, t8(:) character(len=10), pointer :: p1 @@ -189,7 +187,7 @@ module m2 !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument call sma(t2(:)) - !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument + !ERROR: 't3' is not a callable procedure call sma(t3(1)) !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument @@ -208,7 +206,7 @@ module m2 !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument call sma(t5(:)) - !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument + !ERROR: 't6' is not a callable procedure call sma(t6(1)) !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument |