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

[klausler]

Summary

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.

[PeteSteinfeld]

All builds, tests, and looks good.

flang/lib/Semantics/resolve-names.cpp

common::IfNoLvalue<Symbol &, D> MakeSymbol(
     }
   }
 
   void MakeExternal(Symbol &);
 
 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 &);
 
   const DeclTypeSpec &MakeNumericType(
       TypeCategory, const std::optional<parser::KindSelector> &);
   const DeclTypeSpec &MakeLogicalType(
       const std::optional<parser::KindSelector> &);
if (symbol.has<ProcEntityDetails>() &&
       std::optional<Symbol::Flag> functionOrSubroutineFlag;
       if (symbol.test(Symbol::Flag::Function)) {
         functionOrSubroutineFlag = Symbol::Flag::Function;
       } else if (symbol.test(Symbol::Flag::Subroutine)) {
         functionOrSubroutineFlag = Symbol::Flag::Subroutine;
       }
       if (IsIntrinsic(symbol.name(), functionOrSubroutineFlag)) {
         // type will be determined in expression semantics
-        symbol.attrs().set(Attr::INTRINSIC);
+        AcquireIntrinsicProcedureFlags(symbol);
         return;
       }
     }
     if (!context().HasError(symbol)) {
       Say(symbol.name(), "No explicit type declared for '%s'"_err_en_US);
       context().SetError(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())};
   if (type) {
     if (const DerivedTypeSpec * derived{type->AsDerived()}) {
       // Resolve any forward-referenced derived type; a quick no-op else.
       auto &instantiatable{*const_cast<DerivedTypeSpec *>(derived)};
       instantiatable.Instantiate(currScope(), context());
bool DeclarationVisitor::Pre(const parser::IntentStmt &x) {
   auto &intentSpec{std::get<parser::IntentSpec>(x.t)};
   auto &names{std::get<std::list<parser::Name>>(x.t)};
   return CheckNotInBlock("INTENT") && // C1107
       HandleAttributeStmt(IntentSpecToAttr(intentSpec), names);
 }
 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;
 }
 bool DeclarationVisitor::Pre(const parser::OptionalStmt &x) {
   return CheckNotInBlock("OPTIONAL") && // C1107
       HandleAttributeStmt(Attr::OPTIONAL, x.v);
 }

 bool DeclarationVisitor::HandleUnrestrictedSpecificIntrinsicFunction(
     const parser::Name &name) {
   if (auto interface{context().intrinsics().IsSpecificIntrinsicFunction(
           name.source.ToString())}) {
     // Unrestricted specific intrinsic function names (e.g., "cos")
     // 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 {
     return false;
   }
 }
 
 // Checks for all locality-specs: LOCAL, LOCAL_INIT, and SHARED
if (!symbol) {
     SetProcFlag(name, *symbol, flag);
   } else if (CheckUseError(name)) {
     // error was reported
   } else {
     symbol = &Resolve(name, symbol)->GetUltimate();
     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
     }
     CheckImplicitNoneExternal(name.source, *symbol);
     if (symbol->has<SubprogramDetails>() &&
         symbol->attrs().test(Attr::ABSTRACT)) {
       Say(name, "Abstract interface '%s' may not be called"_err_en_US);
if (symbol.test(Symbol::Flag::Function) && flag == Symbol::Flag::Subroutine) {
     SayWithDecl(
         name, symbol, "Cannot call subroutine '%s' like a function"_err_en_US);
     return false;
   } else if (symbol.has<ProcEntityDetails>()) {
     symbol.set(flag); // in case it hasn't been set yet
     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;
 }
 
 bool ModuleVisitor::Pre(const parser::AccessStmt &x) {
   Attr accessAttr{AccessSpecToAttr(std::get<parser::AccessSpec>(x.t))};
   if (!currScope().IsModule()) { // C869
     Say(currStmtSource().value(),

flang/test/Semantics/call11.f90

forall (i=1:10)
       a(i) = t(pure(i))  ! OK
     end forall
     forall (i=1:10)
       !ERROR: Impure procedure 'impure' may not be referenced in a FORALL
       a(i) = t(impure(i))  ! C1037
     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

flang/test/Semantics/doconcurrent01.f90

!ERROR: An image control statement is not allowed in DO CONCURRENT
   end do
 
   do concurrent (i = 1:10)
 !ERROR: An image control statement is not allowed in DO CONCURRENT
     deallocate(ca, pvar%type1_field%coarray_type0_field)
   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 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
 end subroutine s6
 
 subroutine s7()
   interface
     pure integer function pf()

flang/test/Semantics/omp-symbol08.f90

 !$omp distribute
  !DEF: /dotprod/Block1/Block1/Block1/i0 (OmpPrivate, OmpPreDetermined) HostAssoc INTEGER(4)
  !REF: /dotprod/n
  !REF: /dotprod/block_size
  do i0=1,n,block_size
 !$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)
    !REF: /dotprod/sum
    !REF: /dotprod/b
    !REF: /dotprod/Block1/Block1/Block1/Block1/i
    !REF: /dotprod/c
    sum = sum+b(i)*c(i)

flang/test/Semantics/procinterface01.f90

type :: derived1
   !DEF: /module1/nested2 PUBLIC (Function) Subprogram LOGICAL(4)
   procedure(logical), pointer, nopass :: p3 => nested2
   !DEF: /module1/derived1/p4 NOPASS, POINTER (Function) ProcEntity LOGICAL(4)
   !DEF: /module1/nested3 PUBLIC (Function) Subprogram LOGICAL(4)
   procedure(logical(kind=4)), pointer, nopass :: p4 => nested3
   !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)
   !DEF: /module1/nested5 PUBLIC (Function) Subprogram CHARACTER(1_8,1)
   procedure(tan), pointer, nopass :: p8 => nested5
  end type derived1
 
 contains

  end function nested3
 
  !REF: /module1/nested4
  !DEF: /module1/nested4/x INTENT(IN) ObjectEntity REAL(4)
  complex function nested4(x)
   !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
 
  !REF: /module1/nested5
  !DEF: /module1/nested5/x INTENT(IN) ObjectEntity REAL(4)
  character function nested5(x)
   !REF: /module1/nested5/x

flang/test/Semantics/symbol13.f90

 ! RUN: %S/test_symbols.sh %s %t %f18
 ! Old-style "*length" specifiers (R723)
 
 !DEF: /f1 (Function) Subprogram CHARACTER(1_8,1)
 !DEF: /f1/x1 INTENT(IN) ObjectEntity CHARACTER(2_4,1)
 !DEF: /f1/x2 INTENT(IN) ObjectEntity CHARACTER(3_4,1)
 character*1 function f1(x1, x2)
  !DEF: /f1/n PARAMETER ObjectEntity INTEGER(4)
  integer, parameter :: n = 2
  !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
   !REF: /f1/len
   !REF: /f1/x2
   !DEF: /f1/t/c1 ObjectEntity CHARACTER(4_4,1)
   !DEF: /f1/t/c2 ObjectEntity CHARACTER(6_8,1)
   character*(len(x2)+1) :: c1, c2*6
  end type t
 end function f1

flang/test/Semantics/symbol14.f90

  end type t1
  !REF: /MainProgram1/t1
  !DEF: /MainProgram1/t2 DerivedType
  type, extends(t1) :: t2
   !DEF: /MainProgram1/t2/b ObjectEntity REAL(4)
   !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
   !DEF: /MainProgram1/t2/x ObjectEntity TYPE(t1(k=666_4))
   type(t1) :: x
  end type t2
 end program

flang/test/Semantics/symbol15.f90

 ! RUN: %S/test_symbols.sh %s %t %f18
 ! Forward references in pointer initializers and TBP bindings.
 
 !DEF: /m Module
 module m
  implicit none
  abstract interface
   !DEF: /m/iface ABSTRACT, PUBLIC (Subroutine) Subprogram
   subroutine iface
   end subroutine
  end interface
  !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)
  real, pointer :: op3 => x
  !DEF: /m/op4 POINTER, PUBLIC ObjectEntity REAL(4)
  !DEF: /m/y PUBLIC, TARGET ObjectEntity REAL(4)
  real, pointer :: op4 => y(1)
  !REF: /m/iface

flang/test/Semantics/symbol17.f90

type :: fwd
   !DEF: /s1/fwd/n ObjectEntity INTEGER(4)
   integer :: n
  end type
  !REF: /s1/q1
  !REF: /s1/fwd/n
  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)
  !REF: /f2/fwdpdt
  !DEF: /f2/fwdpdt/k TypeParam INTEGER(4)
  type :: fwdpdt(k)
   !REF: /f2/fwdpdt/k
   integer, kind :: k
   !REF: /f2/fwdpdt/k
   !DEF: /f2/fwdpdt/n ObjectEntity INTEGER(int(int(k,kind=4),kind=8))
   integer(kind=k) :: n
  end type
  !DEF: /f2/f2 ObjectEntity TYPE(fwdpdt(k=4_4))
  !DEF: /f2/DerivedType2/n ObjectEntity INTEGER(4)
  !REF: /f2/n
  f2%n = n
 end function
 !DEF: /s2 (Subroutine) Subprogram
 !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)
  type :: fwdpdt(k)
   !REF: /s2/fwdpdt/k
   integer, kind :: k
   !REF: /s2/fwdpdt/k
   !DEF: /s2/fwdpdt/n ObjectEntity INTEGER(int(int(k,kind=4),kind=8))

flang/test/Semantics/symbol18.f90

 ! RUN: %S/test_symbols.sh %s %t %f18
 
 ! Intrinsic function in type declaration statement: type is ignored
 
 !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
  !DEF: /f EXTERNAL (Function, Implicit) ProcEntity REAL(4)
  !REF: /p1/x
  y = f(x)
 end program
 

flang/test/Semantics/symbol19.f90

  !DEF: /system_clock EXTERNAL (Function, Implicit) ProcEntity REAL(4)
  !DEF: /expect_external/icount (Implicit) ObjectEntity INTEGER(4)
  i = system_clock(icount)
 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
  !DEF: /expect_intrinsic/icount (Implicit) ObjectEntity INTEGER(4)
  call system_clock(icount)
 end subroutine
 
 ! Sanity check that the EXTERNAL attribute is not bypassed by