diff --git a/flang/include/flang/Evaluate/intrinsics.h b/flang/include/flang/Evaluate/intrinsics.h index dbe1ba7fe7ec1..fc1c8b2ba6ab7 100644 --- a/flang/include/flang/Evaluate/intrinsics.h +++ b/flang/include/flang/Evaluate/intrinsics.h @@ -86,6 +86,7 @@ class IntrinsicProcTable { bool IsIntrinsic(const std::string &) const; bool IsIntrinsicFunction(const std::string &) const; bool IsIntrinsicSubroutine(const std::string &) const; + bool IsDualIntrinsic(const std::string &) const; // Inquiry intrinsics are defined in section 16.7, table 16.1 IntrinsicClass GetIntrinsicClass(const std::string &) const; diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp index c7f174f7989dd..fe679da4ff98b 100644 --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -1674,7 +1674,7 @@ static const IntrinsicInterface intrinsicSubroutine[]{ {"to", SameIntOrUnsigned, Rank::elemental, Optionality::required, common::Intent::Out}, {"topos", AnyInt}}, - {}, Rank::elemental, IntrinsicClass::elementalSubroutine}, // elemental + {}, Rank::elemental, IntrinsicClass::elementalSubroutine}, {"random_init", {{"repeatable", AnyLogical, Rank::scalar}, {"image_distinct", AnyLogical, Rank::scalar}}, @@ -2903,7 +2903,7 @@ bool IntrinsicProcTable::Implementation::IsDualIntrinsic( // Collection for some intrinsics with function and subroutine form, // in order to pass the semantic check. static const std::string dualIntrinsic[]{{"chdir"}, {"etime"}, {"fseek"}, - {"ftell"}, {"getcwd"}, {"hostnm"}, {"putenv"s}, {"rename"}, {"second"}, + {"ftell"}, {"getcwd"}, {"hostnm"}, {"putenv"}, {"rename"}, {"second"}, {"system"}, {"unlink"}}; return llvm::is_contained(dualIntrinsic, name); } @@ -3766,6 +3766,9 @@ bool IntrinsicProcTable::IsIntrinsicFunction(const std::string &name) const { bool IntrinsicProcTable::IsIntrinsicSubroutine(const std::string &name) const { return DEREF(impl_.get()).IsIntrinsicSubroutine(name); } +bool IntrinsicProcTable::IsDualIntrinsic(const std::string &name) const { + return DEREF(impl_.get()).IsDualIntrinsic(name); +} IntrinsicClass IntrinsicProcTable::GetIntrinsicClass( const std::string &name) const { diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index 3f048ab6f7a4d..836500145e4a2 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -3644,19 +3644,24 @@ std::optional ExpressionAnalyzer::CheckCall( Say(callSite, "Assumed-length character function must be defined with a length to be called"_err_en_US); } + if (!chars->IsPure()) { + if (const semantics::Scope *pure{semantics::FindPureProcedureContaining( + context_.FindScope(callSite))}) { + std::string name; + if (procSymbol) { + name = "'"s + procSymbol->name().ToString() + "'"; + } else if (const auto *intrinsic{proc.GetSpecificIntrinsic()}) { + name = "'"s + intrinsic->name + "'"; + } + Say(callSite, + "Procedure %s referenced in pure subprogram '%s' must be pure too"_err_en_US, + name, DEREF(pure->symbol()).name()); + } + } ok &= semantics::CheckArguments(*chars, arguments, context_, context_.FindScope(callSite), treatExternalAsImplicit, /*ignoreImplicitVsExplicit=*/false, specificIntrinsic); } - if (procSymbol && !IsPureProcedure(*procSymbol)) { - if (const semantics::Scope * - pure{semantics::FindPureProcedureContaining( - context_.FindScope(callSite))}) { - Say(callSite, - "Procedure '%s' referenced in pure subprogram '%s' must be pure too"_err_en_US, - procSymbol->name(), DEREF(pure->symbol()).name()); - } - } if (ok && !treatExternalAsImplicit && procSymbol && !(chars && chars->HasExplicitInterface())) { if (const Symbol *global{FindGlobal(*procSymbol)}; diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp index 43b49e01c89c7..543edcdb6d8d3 100644 --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -5733,7 +5733,8 @@ void DeclarationVisitor::DeclareIntrinsic(const parser::Name &name) { } } if (!symbol.test(Symbol::Flag::Function) && - !symbol.test(Symbol::Flag::Subroutine)) { + !symbol.test(Symbol::Flag::Subroutine) && + !context().intrinsics().IsDualIntrinsic(name.source.ToString())) { if (context().intrinsics().IsIntrinsicFunction(name.source.ToString())) { symbol.set(Symbol::Flag::Function); } else if (context().intrinsics().IsIntrinsicSubroutine( diff --git a/flang/test/Semantics/bug157124.f90 b/flang/test/Semantics/bug157124.f90 new file mode 100644 index 0000000000000..92326dc9e7b69 --- /dev/null +++ b/flang/test/Semantics/bug157124.f90 @@ -0,0 +1,11 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +pure subroutine puresub + intrinsic sleep, chdir, get_command + character(80) str + !ERROR: Procedure 'impureexternal' referenced in pure subprogram 'puresub' must be pure too + call impureExternal ! implicit interface + !ERROR: Procedure 'sleep' referenced in pure subprogram 'puresub' must be pure too + call sleep(1) ! intrinsic subroutine, debatably impure + !ERROR: Procedure 'chdir' referenced in pure subprogram 'puresub' must be pure too + call chdir('.') ! "dual" function/subroutine, impure +end