[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.

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