[flang] Ensure that intrinsic procedures are PURE &/or ELEMENTAL

The intrinsic procedure table properly classify the various
intrinsics, but the PURE and ELEMENTAL attributes that these
classifications imply don't always make it to the utility
predicates that test symbols for them, leading to spurious
error messages in some contexts.  So set those attribute flags
as appropriate in name resolution, using a new function to
isolate the tests.

An alternate solution, in which the predicates would query
the intrinsic procedure table for these attributes on demand,
was something I also tried, so that this information could
come directly from an authoritative source; but it would have
required references to the intrinsic table to be passed along
on too many seemingly unrelated APIs and ended up looking messy.

Several symbol table tests needed to have their expected outputs
augmented with the PURE and ELEMENTAL flags.  Some bogus messages
that were flagged as such in test/Semantics/doconcurrent01.f90 were
removed, since they are now correctly not emitted.

Differential Revision: https://reviews.llvm.org/D96878

diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 7e122db..b87916d 100644 (file)
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -584,6 +584,7 @@ public:
 protected:
   // Apply the implicit type rules to this symbol.
   void ApplyImplicitRules(Symbol &);
+  void AcquireIntrinsicProcedureFlags(Symbol &);
   const DeclTypeSpec *GetImplicitType(Symbol &, const Scope &);
   bool ConvertToObjectEntity(Symbol &);
   bool ConvertToProcEntity(Symbol &);
@@ -2146,7 +2147,7 @@ void ScopeHandler::ApplyImplicitRules(Symbol &symbol) {
       }
       if (IsIntrinsic(symbol.name(), functionOrSubroutineFlag)) {
         // type will be determined in expression semantics
-        symbol.attrs().set(Attr::INTRINSIC);
+        AcquireIntrinsicProcedureFlags(symbol);
         return;
       }
     }
@@ -2157,6 +2158,24 @@ void ScopeHandler::ApplyImplicitRules(Symbol &symbol) {
   }
 }
 
+// Ensure that the symbol for an intrinsic procedure is marked with
+// the INTRINSIC attribute.  Also set PURE &/or ELEMENTAL as
+// appropriate.
+void ScopeHandler::AcquireIntrinsicProcedureFlags(Symbol &symbol) {
+  symbol.attrs().set(Attr::INTRINSIC);
+  switch (context().intrinsics().GetIntrinsicClass(symbol.name().ToString())) {
+  case evaluate::IntrinsicClass::elementalFunction:
+  case evaluate::IntrinsicClass::elementalSubroutine:
+    symbol.attrs().set(Attr::ELEMENTAL);
+    symbol.attrs().set(Attr::PURE);
+    break;
+  case evaluate::IntrinsicClass::impureSubroutine:
+    break;
+  default:
+    symbol.attrs().set(Attr::PURE);
+  }
+}
+
 const DeclTypeSpec *ScopeHandler::GetImplicitType(
     Symbol &symbol, const Scope &scope) {
   const auto *type{implicitRulesMap_->at(&scope).GetType(symbol.name())};
@@ -3461,14 +3480,14 @@ bool DeclarationVisitor::Pre(const parser::IntentStmt &x) {
 bool DeclarationVisitor::Pre(const parser::IntrinsicStmt &x) {
   HandleAttributeStmt(Attr::INTRINSIC, x.v);
   for (const auto &name : x.v) {
-    auto *symbol{FindSymbol(name)};
-    if (!ConvertToProcEntity(*symbol)) {
+    auto &symbol{DEREF(FindSymbol(name))};
+    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(),
+          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());
+          symbol.name());
     }
   }
   return false;
@@ -4692,10 +4711,14 @@ bool DeclarationVisitor::HandleUnrestrictedSpecificIntrinsicFunction(
     // are acceptable as procedure interfaces.
     Symbol &symbol{
         MakeSymbol(InclusiveScope(), name.source, Attrs{Attr::INTRINSIC})};
+    symbol.set_details(ProcEntityDetails{});
+    symbol.set(Symbol::Flag::Function);
     if (interface->IsElemental()) {
       symbol.attrs().set(Attr::ELEMENTAL);
     }
-    symbol.set_details(ProcEntityDetails{});
+    if (interface->IsPure()) {
+      symbol.attrs().set(Attr::PURE);
+    }
     Resolve(name, symbol);
     return true;
   } else {
@@ -5971,9 +5994,9 @@ void ResolveNamesVisitor::HandleProcedureName(
     bool convertedToProcEntity{ConvertToProcEntity(*symbol)};
     if (convertedToProcEntity && !symbol->attrs().test(Attr::EXTERNAL) &&
         IsIntrinsic(symbol->name(), flag) && !IsDummy(*symbol)) {
-      symbol->attrs().set(Attr::INTRINSIC);
       // 8.2(3): ignore type from intrinsic in type-declaration-stmt
       symbol->get<ProcEntityDetails>().set_interface(ProcInterface{});
+      AcquireIntrinsicProcedureFlags(*symbol);
     }
     if (!SetProcFlag(name, *symbol, flag)) {
       return; // reported error
@@ -6058,9 +6081,14 @@ bool ResolveNamesVisitor::SetProcFlag(
     if (flag == Symbol::Flag::Function) {
       ApplyImplicitRules(symbol);
     }
+    if (symbol.attrs().test(Attr::INTRINSIC)) {
+      AcquireIntrinsicProcedureFlags(symbol);
+    }
   } else if (symbol.GetType() && flag == Symbol::Flag::Subroutine) {
     SayWithDecl(
         name, symbol, "Cannot call function '%s' like a subroutine"_err_en_US);
+  } else if (symbol.attrs().test(Attr::INTRINSIC)) {
+    AcquireIntrinsicProcedureFlags(symbol);
   }
   return true;
 }

diff --git a/flang/test/Semantics/call11.f90 b/flang/test/Semantics/call11.f90
index 47e3df0..7919eec 100644 (file)
--- a/flang/test/Semantics/call11.f90
+++ b/flang/test/Semantics/call11.f90
@@ -80,4 +80,18 @@ module m
     end forall
   end subroutine
 
+  subroutine test4(ch)
+    type :: t
+      real, allocatable :: x
+    end type
+    type(t) :: a(1), b(1)
+    character(*), intent(in) :: ch
+    allocate (b(1)%x)
+    ! Intrinsic functions and a couple subroutines are pure; do not emit errors
+    do concurrent (j=1:1)
+      b(j)%x = cos(1.) + len(ch)
+      call move_alloc(from=b(j)%x, to=a(j)%x)
+    end do
+  end subroutine
+
 end module

diff --git a/flang/test/Semantics/doconcurrent01.f90 b/flang/test/Semantics/doconcurrent01.f90
index c932068..ac1f431 100644 (file)
--- a/flang/test/Semantics/doconcurrent01.f90
+++ b/flang/test/Semantics/doconcurrent01.f90
@@ -164,28 +164,20 @@ subroutine s6()
   end do
 
 ! Call to MOVE_ALLOC of a coarray outside a DO CONCURRENT.  This is OK.
-call move_alloc(ca, cb)
-
-! Note that the errors below relating to MOVE_ALLOC() bing impure are bogus.  
-! They're the result of the fact that access to the move_alloc() instrinsic 
-! is not yet possible.
+  call move_alloc(ca, cb)
 
+! Call to MOVE_ALLOC with non-coarray arguments in a DO CONCURRENT.  This is OK.
   allocate(aa)
   do concurrent (i = 1:10)
-!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
     call move_alloc(aa, ab)
   end do
 
-! Call to MOVE_ALLOC with non-coarray arguments in a DO CONCURRENT.  This is OK.
-
   do concurrent (i = 1:10)
-!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
 !ERROR: An image control statement is not allowed in DO CONCURRENT
     call move_alloc(ca, cb)
   end do
 
   do concurrent (i = 1:10)
-!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
 !ERROR: An image control statement is not allowed in DO CONCURRENT
     call move_alloc(pvar%type1_field%coarray_type0_field, qvar%type1_field%coarray_type0_field)
   end do

diff --git a/flang/test/Semantics/omp-symbol08.f90 b/flang/test/Semantics/omp-symbol08.f90
index 567c056..1fb2a86 100644 (file)
--- a/flang/test/Semantics/omp-symbol08.f90
+++ b/flang/test/Semantics/omp-symbol08.f90
@@ -139,7 +139,7 @@ subroutine dotprod (b, c, n, block_size, num_teams, block_threads)
 !$omp parallel do  reduction(+:sum)
   !DEF: /dotprod/Block1/Block1/Block1/Block1/i (OmpPrivate, OmpPreDetermined) HostAssoc INTEGER(4)
   !REF: /dotprod/Block1/Block1/Block1/i0
-  !DEF: /dotprod/min INTRINSIC (Function) ProcEntity
+  !DEF: /dotprod/min ELEMENTAL, INTRINSIC, PURE (Function) ProcEntity
   !REF: /dotprod/block_size
   !REF: /dotprod/n
   do i=i0,min(i0+block_size, n)

diff --git a/flang/test/Semantics/procinterface01.f90 b/flang/test/Semantics/procinterface01.f90
index dd9fd3b..8f33168 100644 (file)
--- a/flang/test/Semantics/procinterface01.f90
+++ b/flang/test/Semantics/procinterface01.f90
@@ -53,13 +53,13 @@ module module1
   !DEF: /module1/derived1/p5 NOPASS, POINTER (Function) ProcEntity COMPLEX(4)
   !DEF: /module1/nested4 PUBLIC (Function) Subprogram COMPLEX(4)
   procedure(complex), pointer, nopass :: p5 => nested4
-  !DEF: /module1/sin ELEMENTAL, INTRINSIC, PUBLIC ProcEntity
-  !DEF: /module1/derived1/p6 NOPASS, POINTER ProcEntity
+  !DEF: /module1/sin ELEMENTAL, INTRINSIC, PUBLIC, PURE (Function) ProcEntity
+  !DEF: /module1/derived1/p6 NOPASS, POINTER (Function) ProcEntity
   !REF: /module1/nested1
   procedure(sin), pointer, nopass :: p6 => nested1
   !REF: /module1/sin
-  !DEF: /module1/derived1/p7 NOPASS, POINTER ProcEntity
-  !DEF: /module1/cos ELEMENTAL, INTRINSIC, PUBLIC ProcEntity
+  !DEF: /module1/derived1/p7 NOPASS, POINTER (Function) ProcEntity
+  !DEF: /module1/cos ELEMENTAL, INTRINSIC, PUBLIC, PURE (Function) ProcEntity
   procedure(sin), pointer, nopass :: p7 => cos
   !REF: /module1/tan
   !DEF: /module1/derived1/p8 NOPASS, POINTER (Function) ProcEntity CHARACTER(1_4,1)
@@ -105,7 +105,7 @@ contains
   !REF: /module1/nested4/x
   real, intent(in) :: x
   !DEF: /module1/nested4/nested4 ObjectEntity COMPLEX(4)
-  !DEF: /module1/nested4/cmplx INTRINSIC (Function) ProcEntity
+  !DEF: /module1/nested4/cmplx ELEMENTAL, INTRINSIC, PURE (Function) ProcEntity
   !REF: /module1/nested4/x
   nested4 = cmplx(x+4., 6.)
  end function nested4

diff --git a/flang/test/Semantics/symbol13.f90 b/flang/test/Semantics/symbol13.f90
index 47ea86b..6052bfc 100644 (file)
--- a/flang/test/Semantics/symbol13.f90
+++ b/flang/test/Semantics/symbol13.f90
@@ -10,7 +10,7 @@ character*1 function f1(x1, x2)
  !REF: /f1/n
  !REF: /f1/x1
  !REF: /f1/x2
- !DEF: /f1/len INTRINSIC (Function) ProcEntity
+ !DEF: /f1/len ELEMENTAL, INTRINSIC, PURE (Function) ProcEntity
  character*(n), intent(in) :: x1, x2*(len(x1)+1)
  !DEF: /f1/t DerivedType
  type :: t

diff --git a/flang/test/Semantics/symbol14.f90 b/flang/test/Semantics/symbol14.f90
index 5d1af5e..7705bdb 100644 (file)
--- a/flang/test/Semantics/symbol14.f90
+++ b/flang/test/Semantics/symbol14.f90
@@ -17,7 +17,7 @@
   !REF: /MainProgram1/t1/k
   real :: b(k)
   !DEF: /MainProgram1/t2/c ObjectEntity REAL(4)
-  !DEF: /MainProgram1/size INTRINSIC (Function) ProcEntity
+  !DEF: /MainProgram1/size INTRINSIC, PURE (Function) ProcEntity
   !REF: /MainProgram1/t1/a
   real :: c(size(a))
   !REF: /MainProgram1/t1

diff --git a/flang/test/Semantics/symbol15.f90 b/flang/test/Semantics/symbol15.f90
index cc230ff..7f307e7 100644 (file)
--- a/flang/test/Semantics/symbol15.f90
+++ b/flang/test/Semantics/symbol15.f90
@@ -12,7 +12,7 @@ module m
  !DEF: /m/op1 POINTER, PUBLIC ObjectEntity REAL(4)
  real, pointer :: op1
  !DEF: /m/op2 POINTER, PUBLIC ObjectEntity REAL(4)
- !DEF: /m/null INTRINSIC, PUBLIC (Function) ProcEntity
+ !DEF: /m/null INTRINSIC, PUBLIC, PURE (Function) ProcEntity
  real, pointer :: op2 => null()
  !DEF: /m/op3 POINTER, PUBLIC ObjectEntity REAL(4)
  !DEF: /m/x PUBLIC, TARGET ObjectEntity REAL(4)

diff --git a/flang/test/Semantics/symbol17.f90 b/flang/test/Semantics/symbol17.f90
index f453e2e..d5b086b 100644 (file)
--- a/flang/test/Semantics/symbol17.f90
+++ b/flang/test/Semantics/symbol17.f90
@@ -70,7 +70,7 @@ subroutine s1 (q1)
  q1%n = 1
 end subroutine
 !DEF: /f2/fwdpdt DerivedType
-!DEF: /f2/kind INTRINSIC (Function) ProcEntity
+!DEF: /f2/kind INTRINSIC, PURE (Function) ProcEntity
 !DEF: /f2 (Function) Subprogram TYPE(fwdpdt(k=4_4))
 !DEF: /f2/n (Implicit) ObjectEntity INTEGER(4)
 type(fwdpdt(kind(0))) function f2(n)
@@ -92,7 +92,7 @@ end function
 !DEF: /s2/q1 (Implicit) ObjectEntity TYPE(fwdpdt(k=4_4))
 subroutine s2 (q1)
  !DEF: /s2/fwdpdt DerivedType
- !DEF: /s2/kind INTRINSIC (Function) ProcEntity
+ !DEF: /s2/kind INTRINSIC, PURE (Function) ProcEntity
  implicit type(fwdpdt(kind(0)))(q)
  !REF: /s2/fwdpdt
  !DEF: /s2/fwdpdt/k TypeParam INTEGER(4)

diff --git a/flang/test/Semantics/symbol18.f90 b/flang/test/Semantics/symbol18.f90
index 93987f6..a0fa0eb 100644 (file)
--- a/flang/test/Semantics/symbol18.f90
+++ b/flang/test/Semantics/symbol18.f90
@@ -4,14 +4,14 @@
 
 !DEF: /p1 MainProgram
 program p1
- !DEF: /p1/cos INTRINSIC (Function) ProcEntity
+ !DEF: /p1/cos ELEMENTAL, INTRINSIC, PURE (Function) ProcEntity
  integer cos
  !DEF: /p1/y (Implicit) ObjectEntity REAL(4)
  !REF: /p1/cos
  !DEF: /p1/x (Implicit) ObjectEntity REAL(4)
  y = cos(x)
  !REF: /p1/y
- !DEF: /p1/sin INTRINSIC (Function) ProcEntity
+ !DEF: /p1/sin ELEMENTAL, INTRINSIC, PURE (Function) ProcEntity
  !REF: /p1/x
  y = sin(x)
  !REF: /p1/y

diff --git a/flang/test/Semantics/symbol19.f90 b/flang/test/Semantics/symbol19.f90
index 539edd1..94a6b86 100644 (file)
--- a/flang/test/Semantics/symbol19.f90
+++ b/flang/test/Semantics/symbol19.f90
@@ -18,7 +18,7 @@ end subroutine
 !DEF: /expect_intrinsic (Subroutine) Subprogram
 subroutine expect_intrinsic
  !DEF: /expect_intrinsic/y (Implicit) ObjectEntity REAL(4)
- !DEF: /expect_intrinsic/acos INTRINSIC (Function) ProcEntity
+ !DEF: /expect_intrinsic/acos ELEMENTAL, INTRINSIC, PURE (Function) ProcEntity
  !DEF: /expect_intrinsic/x (Implicit) ObjectEntity REAL(4)
  y = acos(x)
  !DEF: /expect_intrinsic/system_clock INTRINSIC (Subroutine) ProcEntity