[flang] Catch calls to impure intrinsics from PURE subprograms

[klausler]

The code in expression semantics that catches a call to an impure procedure in a PURE context misses calls to impure intrinsics, since their designators have a SpecificIntrinsic rather than a Symbol. Replace the current check with a new one that uses the characteristics of the called procedure, which works for both intrinsic and non-intrinsic cases.

Testing this change revealed that an explicit INTRINSIC statement wasn't doing the right thing for extension "dual" intrinsics that can be called as either a function or as a subroutine; the use of an INTRINSIC statement would disallow its use as a subroutine. I've fixed that here as well.

Fixes #157124.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

Changes

The code in expression semantics that catches a call to an impure procedure in a PURE context misses calls to impure intrinsics, since their designators have a SpecificIntrinsic rather than a Symbol. Replace the current check with a new one that uses the characteristics of the called procedure, which works for both intrinsic and non-intrinsic cases.

Change a few intrinsic subroutines to be pure when they don't modify program state and will always return the same values. (I had earlier mentioned that timing subroutines could be pure, since they don't modify program state, but they can return different values.)

Testing this change revealed that an explicit INTRINSIC statement wasn't doing the right thing for extension "dual" intrinsics that can be called as either a function or as a subroutine; the use of an INTRINSIC statement would disallow its use as a subroutine. I've fixed that here as well.

Fixes #157124.

---

Full diff: https://github.com/llvm/llvm-project/pull/160947.diff

6 Files Affected:

• (modified) flang/docs/Intrinsics.md (+4)
• (modified) flang/include/flang/Evaluate/intrinsics.h (+1)
• (modified) flang/lib/Evaluate/intrinsics.cpp (+9-6)
• (modified) flang/lib/Semantics/expression.cpp (+14-9)
• (modified) flang/lib/Semantics/resolve-names.cpp (+2-1)
• (added) flang/test/Semantics/bug157124.f90 (+16)

diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md
index 34b6559e4345f..aa995c376c454 100644
--- a/flang/docs/Intrinsics.md
+++ b/flang/docs/Intrinsics.md
@@ -639,6 +639,9 @@ CALL RANDOM_SEED([SIZE, PUT, GET])
 CALL SYSTEM_CLOCK([COUNT, COUNT_RATE, COUNT_MAX])
 ```
 
+`GET_COMMAND`, `GET_COMMAND_ARGUMENT`, and `GET_ENVIRONMENT_VARIABLE` are pure
+procedures in this compiler; the others are impure.
+
 ### Atomic intrinsic subroutines
 ```
 CALL ATOMIC_ADD(ATOM, VALUE [, STAT=])
@@ -1018,6 +1021,7 @@ END PROGRAM
 `HOSTNM(C, STATUS)` returns the host name of the system.
 
 This intrinsic is provided in both subroutine and function forms; however, only one form can be used in any given program unit.
+It is a pure procedure.
 
 *C* and *STATUS* are `INTENT(OUT)` and provide the following:
 
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..9c5e798093aa2 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -1615,7 +1615,7 @@ static const IntrinsicInterface intrinsicSubroutine[]{
                 common::Intent::Out},
             {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
                 common::Intent::InOut}},
-        {}, Rank::elemental, IntrinsicClass::impureSubroutine},
+        {}, Rank::elemental, IntrinsicClass::pureSubroutine},
     {"get_command_argument",
         {{"number", AnyInt, Rank::scalar},
             {"value", DefaultChar, Rank::scalar, Optionality::optional,
@@ -1626,7 +1626,7 @@ static const IntrinsicInterface intrinsicSubroutine[]{
                 common::Intent::Out},
             {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
                 common::Intent::InOut}},
-        {}, Rank::elemental, IntrinsicClass::impureSubroutine},
+        {}, Rank::elemental, IntrinsicClass::pureSubroutine},
     {"get_environment_variable",
         {{"name", DefaultChar, Rank::scalar},
             {"value", DefaultChar, Rank::scalar, Optionality::optional,
@@ -1638,7 +1638,7 @@ static const IntrinsicInterface intrinsicSubroutine[]{
             {"trim_name", AnyLogical, Rank::scalar, Optionality::optional},
             {"errmsg", DefaultChar, Rank::scalar, Optionality::optional,
                 common::Intent::InOut}},
-        {}, Rank::elemental, IntrinsicClass::impureSubroutine},
+        {}, Rank::elemental, IntrinsicClass::pureSubroutine},
     {"getcwd",
         {{"c", DefaultChar, Rank::scalar, Optionality::required,
              common::Intent::Out},
@@ -1650,7 +1650,7 @@ static const IntrinsicInterface intrinsicSubroutine[]{
              common::Intent::Out},
             {"status", TypePattern{IntType, KindCode::greaterOrEqualToKind, 4},
                 Rank::scalar, Optionality::optional, common::Intent::Out}},
-        {}, Rank::elemental, IntrinsicClass::impureSubroutine},
+        {}, Rank::elemental, IntrinsicClass::pureSubroutine},
     {"move_alloc",
         {{"from", SameType, Rank::known, Optionality::required,
              common::Intent::InOut},
@@ -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<characteristics::Procedure> 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..ddba97a00f2a0
--- /dev/null
+++ b/flang/test/Semantics/bug157124.f90
@@ -0,0 +1,16 @@
+! 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
+  ! These intrinsic subroutines are pure in this compiler.
+  call get_command(str)
+  call get_command_argument(1, str)
+  call get_environment_variable("PATH", str)
+  call hostnm(str)
+end